diff --git a/Lean4Lean/Audit/SorryFrontier.lean b/Lean4Lean/Audit/SorryFrontier.lean index f48b7304..c5be36d3 100644 --- a/Lean4Lean/Audit/SorryFrontier.lean +++ b/Lean4Lean/Audit/SorryFrontier.lean @@ -1,19 +1,72 @@ import Lean4Lean.Theory +import Lean4Lean.Theory.ConstructorValidityFixtures +import Lean4Lean.Theory.Inductive import Lean4Lean.Theory.InductiveFixtures +import Lean4Lean.Theory.Meta +import Lean4Lean.Theory.MutualInductiveFixtures +import Lean4Lean.Theory.Quot +import Lean4Lean.Theory.SingletonParity +import Lean4Lean.Theory.Typing.Basic +import Lean4Lean.Theory.Typing.ChurchRosser +import Lean4Lean.Theory.Typing.Env +import Lean4Lean.Theory.Typing.EnvLemmas +import Lean4Lean.Theory.Typing.HeadReduction +import Lean4Lean.Theory.Typing.InductiveLemmas import Lean4Lean.Theory.Typing.Injectivity +import Lean4Lean.Theory.Typing.Lemmas +import Lean4Lean.Theory.Typing.Meta +import Lean4Lean.Theory.Typing.Pattern +import Lean4Lean.Theory.Typing.QuotLemmas +import Lean4Lean.Theory.Typing.Strong +import Lean4Lean.Theory.Typing.UniqueTyping +import Lean4Lean.Theory.VDecl +import Lean4Lean.Theory.VEnv +import Lean4Lean.Theory.VExpr +import Lean4Lean.Theory.VLevel import Lean4Lean.Verify -import Lean4Lean.Verify.Level +import Lean4Lean.Verify.Axioms import Lean4Lean.Verify.Environment +import Lean4Lean.Verify.Environment.Basic +import Lean4Lean.Verify.Environment.CandidateIdentityReplay +import Lean4Lean.Verify.Environment.ConstructorValidation +import Lean4Lean.Verify.Environment.ConstructorValidityMatrix +import Lean4Lean.Verify.Environment.ConstructorValidityReplay +import Lean4Lean.Verify.Environment.Elimination +import Lean4Lean.Verify.Environment.EliminationFixtures +import Lean4Lean.Verify.Environment.EliminationFixturesCommon +import Lean4Lean.Verify.Environment.EliminationFixturesEdges +import Lean4Lean.Verify.Environment.EliminationFixturesEq +import Lean4Lean.Verify.Environment.EliminationFixturesEqNat +import Lean4Lean.Verify.Environment.EliminationFixturesNat +import Lean4Lean.Verify.Environment.EliminationFixturesOrAnd +import Lean4Lean.Verify.Environment.EliminationFixturesSmall import Lean4Lean.Verify.Environment.IndexedVecCandidate import Lean4Lean.Verify.Environment.IndexedVecConsReplay import Lean4Lean.Verify.Environment.IndexedVecConstructors import Lean4Lean.Verify.Environment.IndexedVecOuterReplay import Lean4Lean.Verify.Environment.IndexedVecSemanticReplay import Lean4Lean.Verify.Environment.InductiveFixtures +import Lean4Lean.Verify.Environment.Lemmas +import Lean4Lean.Verify.Environment.MutualInductiveFixtures import Lean4Lean.Verify.Environment.Normalization +import Lean4Lean.Verify.Environment.NormalizationMatrix +import Lean4Lean.Verify.Environment.SingletonParityMatrix +import Lean4Lean.Verify.Environment.SingletonParityReplay +import Lean4Lean.Verify.EquivManager +import Lean4Lean.Verify.Expr +import Lean4Lean.Verify.Level +import Lean4Lean.Verify.LocalContext +import Lean4Lean.Verify.NameGenerator +import Lean4Lean.Verify.TypeChecker +import Lean4Lean.Verify.TypeChecker.Basic import Lean4Lean.Verify.TypeChecker.InferType -import Lean4Lean.Verify.TypeChecker.WHNF import Lean4Lean.Verify.TypeChecker.IsDefEq +import Lean4Lean.Verify.TypeChecker.Reduce +import Lean4Lean.Verify.TypeChecker.WHNF +import Lean4Lean.Verify.Typing.ConditionallyTyped +import Lean4Lean.Verify.Typing.Expr +import Lean4Lean.Verify.Typing.Lemmas +import Lean4Lean.Verify.VLCtx /-! # Lean4Lean sorry frontier @@ -32,8 +85,15 @@ when it sits in a foreign namespace (e.g. `Lean.Level.isEquiv_wf` lives in 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 -in a proof module not (transitively) imported here is not seen, so when a new -`Theory`/`Verify` file joins the trusted build, add its import below. +in a proof module not (transitively) imported here is not seen, so the import +block above lists the complete `Theory`/`Verify` file tree explicitly (imports +already reachable transitively are harmless). When files are added or renamed, +regenerate it with + + { printf 'import %s\n' Lean4Lean.Theory Lean4Lean.Verify; \ + find Lean4Lean/Theory Lean4Lean/Verify -name '*.lean' \ + | sed 's/\.lean$//; s#/#.#g; s/^/import /'; } | LC_ALL=C sort -u + `Lean4Lean.Experimental.*` is parked proof work outside the trusted surface and is intentionally not imported. @@ -77,8 +137,8 @@ private def allowlist : Array Lean.Name := #[ `Lean4Lean.TrProj.instN, `Lean4Lean.TrProj.instL, -- Tier V — checker verification, blocked on Tiers S/P - `Lean.Level.Normalize.NormLevel.subsumption_eval, - `Lean.Level.isEquiv_wf, + -- (NormLevel.subsumption_eval and Level.isEquiv_wf were proved on the + -- formalization line, 2026-08-05/07, and left the frontier.) `Lean4Lean.addDecl.WF, `Lean4Lean.TypeChecker.Inner.inferProj.WF, `Lean4Lean.TypeChecker.Inner.reduceRecursor.WF, @@ -96,7 +156,14 @@ private def allowlist : Array Lean.Name := #[ -- carries a sorry dependency even though the source has no `sorry` token -- (which is why the old source-token scan never saw these). Not proof debt. `Lean4Lean.InductiveFixtures.KernelDifferential.KernelRejectRecDomain, - `Lean4Lean.InductiveFixtures.KernelDifferential.KernelRejectRecIndex] + `Lean4Lean.InductiveFixtures.KernelDifferential.KernelRejectRecIndex, + -- The L4L-05 nearest-kernel negatives (Theory/ConstructorValidityFixtures.lean) + -- are the same pattern: `#guard_msgs`-pinned rejections whose recovered + -- constants carry `sorryAx`. Not proof debt. + `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05FamilyNonrecursive, + `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05FamilyProof, + `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05NestedNegative, + `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05RecursiveDependency] /-- Declarations in the audited surface that directly reference `sorryAx`. -/ private def observedFrontier (env : Lean.Environment) : Array Lean.Name := Id.run do diff --git a/Lean4Lean/Expr.lean b/Lean4Lean/Expr.lean index e9bf4da3..208eb3dc 100644 --- a/Lean4Lean/Expr.lean +++ b/Lean4Lean/Expr.lean @@ -5,6 +5,33 @@ namespace Expr def prop : Expr := .sort .zero +/-- Transparent structural equality with the non-strict binder behavior used +by kernel expression comparison. Unlike `Expr.eqv`, this definition is +available to the kernel evaluator, so checker branch proofs do not require an +opaque implementation equation. -/ +def structuralEq : Expr → Expr → Bool + | .bvar i, .bvar j + | .fvar i, .fvar j + | .mvar i, .mvar j + | .sort i, .sort j + | .lit i, .lit j => i == j + | .const name levels, .const name' levels' => + name == name' && levels == levels' + | .app fn arg, .app fn' arg' => + structuralEq fn fn' && structuralEq arg arg' + | .lam _ domain body _, .lam _ domain' body' _ + | .forallE _ domain body _, .forallE _ domain' body' _ => + structuralEq domain domain' && structuralEq body body' + | .letE _ type value body nondep, + .letE _ type' value' body' nondep' => + structuralEq type type' && structuralEq value value' && + structuralEq body body' && nondep == nondep' + | .mdata data expr, .mdata data' expr' => + structuralEq expr expr' && data.entries == data'.entries + | .proj typeName index struct, .proj typeName' index' struct' => + structuralEq struct struct' && typeName == typeName' && index == index' + | _, _ => false + def arrow (d b : Expr) : Expr := .forallE `a d b .default def lam0 (ty e : Expr) : Expr := .lam `_ ty e default diff --git a/Lean4Lean/Inductive/Add.lean b/Lean4Lean/Inductive/Add.lean index 1ceb4816..b8f07377 100644 --- a/Lean4Lean/Inductive/Add.lean +++ b/Lean4Lean/Inductive/Add.lean @@ -324,6 +324,65 @@ def declareInductiveTypes (stats : InductiveStats) (numParams : Nat) env.checkName info.name c.allowPrimitive return env.add (.inductInfo info) +/-- The exact kernel family record assembled for a singleton inductive block. +Naming it exposes the value installed by `declareInductiveTypes` without +asking a replay proof to duplicate the producer's record construction. -/ +def singletonDeclaredInfo (stats : InductiveStats) (numParams numIndices : Nat) + (indType : InductiveType) (numNested : Nat) (isUnsafe : Bool) + (context : Context) : InductiveVal := + { indType with + numParams, numIndices, all := [indType.name], numNested, isUnsafe + levelParams := context.lparams + ctors := indType.ctors.map (·.name) + isRec := isRec #[indType] stats.indConsts + isReflexive := isReflexive #[indType] stats.indConsts } + +/-- A successful singleton family declaration installs exactly the family +record assembled by the executable producer. The result equation supplies +the name-check evidence; replay callers provide only the validator's exact +singleton index count. -/ +theorem declareInductiveTypes_singleton_constants + (stats : InductiveStats) (numParams numIndices : Nat) + (indType : InductiveType) (numNested : Nat) (isUnsafe : Bool) + (context : Context) (familyEnv : Environment) + (hnindices : stats.nindices = #[numIndices]) + (hdeclare : + declareInductiveTypes stats numParams #[indType] numNested isUnsafe context = + .ok familyEnv) : + familyEnv.constants = + context.env.constants.insert indType.name + (.inductInfo <| singletonDeclaredInfo stats numParams numIndices + indType numNested isUnsafe context) := by + unfold declareInductiveTypes at hdeclare + rw [hnindices] at hdeclare + cases hcheck : context.env.checkName indType.name context.allowPrimitive with + | error error => + simp [hcheck, Bind.bind, Except.bind, Pure.pure, Except.pure] at hdeclare + | ok _ => + simp [hcheck, Bind.bind, Except.bind, Pure.pure, Except.pure] at hdeclare + exact congrArg Kernel.Environment.constants hdeclare.symm + +/-- A successful singleton family declaration changes only the constant map; +in particular it preserves the kernel's quotient-initialization flag. -/ +theorem declareInductiveTypes_singleton_quotInit + (stats : InductiveStats) (numParams numIndices : Nat) + (indType : InductiveType) (numNested : Nat) (isUnsafe : Bool) + (context : Context) (familyEnv : Environment) + (hnindices : stats.nindices = #[numIndices]) + (hdeclare : + declareInductiveTypes stats numParams #[indType] numNested isUnsafe context = + .ok familyEnv) : + familyEnv.quotInit = context.env.quotInit := by + unfold declareInductiveTypes at hdeclare + rw [hnindices] at hdeclare + cases hcheck : context.env.checkName indType.name context.allowPrimitive with + | error error => + simp [hcheck, Bind.bind, Except.bind, Pure.pure, Except.pure] at hdeclare + | ok _ => + simp [hcheck, Bind.bind, Except.bind, Pure.pure, Except.pure] at hdeclare + subst familyEnv + rfl + /-- Family declaration observes only the environment, universe parameters, and primitive-name policy of its reader context. In particular, the local telescope and fresh-name generator retained by family validation do not alter @@ -392,55 +451,65 @@ def checkPositivity (stats : InductiveStats) (t : Expr) (ctor : Name) (idx : Nat throw <| .other s!"arg #{idx + 1} of '{ctor}' \ has a non valid occurrence of the datatypes being declared" +/-- Validate the parameter/field telescope and terminal family application of +one constructor. This is factored from the outer traversal so successful +executions can be retained without reproducing compiler-expanded `for` loops. -/ +def checkConstructorType (stats : InductiveStats) (isUnsafe : Bool) + (idx : Nat) (n : Name) (t : Expr) : M Unit := do + loop t 0 (← readThe Context).fuel.inductiveFuel +where + loop t i + | 0 => throw .deepRecursion + | fuel+1 => do + if let .forallE name dom body bi := t then + if let some param := stats.params[i]? then + unless ← isDefEq dom (← getType param) do + throw <| .other + s!"arg #{i + 1} of '{n}' does not match inductive datatype parameters" + loop (body.instantiate1 param) (i + 1) fuel + else + let s ← ensureType dom + -- Equal levels are reflexively admissible, so discharge that common + -- case before consulting the full normalization comparison. + if levelStructGe stats.resultLevel s.sortLevel! then + pure () + else + unless stats.resultLevel.isZero || 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 + checkPositivity stats dom n i + withLocalDecl name bi (consumeTypeAnnotations dom) fun arg => do + loop (body.instantiate1 arg) (i + 1) fuel + else if !isValidIndAppIdx stats t idx then + throw <| .other s!"invalid return type for '{n}'" + +/-- Validate constructors in source order while retaining the duplicate-name +accumulator as the fold result. -/ +def checkConstructorFold (env : Environment) (stats : InductiveStats) + (isUnsafe : Bool) (idx : Nat) (seen : NameSet) + (ctors : List Constructor) : M NameSet := match ctors with + | [] => pure seen + | ctor :: ctors => do + let n := ctor.name + if seen.contains n then + throw <| .other s!"duplicate constructor name '{n}'" + let seen := seen.insert n + let t := ctor.type + env.checkNoMVarNoFVar n t + -- Constructor metadata has just been established to contain no free + -- variables. Its full closed-type check does not inherit family locals; + -- parameter matching in `checkConstructorType` deliberately does. + _ ← withEmptyLocalContext do checkType t + checkConstructorType stats isUnsafe idx n t + checkConstructorFold env stats isUnsafe idx seen ctors + 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] - let mut foundCtors : NameSet := {} - for ctor in indType.ctors do - let n := ctor.name - if foundCtors.contains n then - throw <| .other s!"duplicate constructor name '{n}'" - foundCtors := foundCtors.insert n - let t := ctor.type - env.checkNoMVarNoFVar n t - -- Constructor metadata has just been established to contain no free - -- variables. Its full closed-type check must therefore not inherit the - -- parameter/index locals retained by family validation; keeping that - -- check local-context independent also gives candidate replay one stable - -- execution. The telescope loop below deliberately remains in the - -- family context because parameter matching uses `stats.params`. - _ ← withEmptyLocalContext do checkType t - let rec loop t i - | 0 => throw .deepRecursion - | fuel+1 => do - if let .forallE name dom body bi := t then - if let some param := stats.params[i]? then - unless ← isDefEq dom (← getType param) do - throw <| .other - s!"arg #{i + 1} of '{n}' does not match inductive datatype parameters" - loop (body.instantiate1 param) (i + 1) fuel - else - let s ← ensureType dom - -- Equal levels are reflexively admissible, so discharge that - -- common case before consulting the full standard-library - -- normalization comparison. Besides avoiding needless work, this - -- keeps exact checker executions reducible without a separate - -- reflexivity contract axiom. - if levelStructGe stats.resultLevel s.sortLevel! then - pure () - else - unless stats.resultLevel.isZero || 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 - checkPositivity stats dom n i - withLocalDecl name bi (consumeTypeAnnotations dom) fun arg => do - loop (body.instantiate1 arg) (i + 1) fuel - else if !isValidIndAppIdx stats t idx then - throw <| .other s!"invalid return type for '{n}'" - loop t 0 (← readThe Context).fuel.inductiveFuel + _ ← checkConstructorFold env stats isUnsafe idx {} indType.ctors /-- One observed WHNF node in the executable normalization-candidate pass. The complete `AddInductive.Context` is retained because Verify must replay the @@ -858,7 +927,7 @@ def storedSpine : | _, _, .terminal .. => true | _, _, .forallE _ source _ name domain body binderInfo _ _ _ _ _ _ bodyCandidate => - (source == .forallE name domain body binderInfo) && + Expr.structuralEq source (.forallE name domain body binderInfo) && storedSpine bodyCandidate /-- Number of stored Pi binders on the main (body) path of a candidate. -/ @@ -904,6 +973,53 @@ theorem terminalContext_lparams domain_ih body_ih => simpa [terminalContext, Context.pushLocalDecl] using body_ih +/-- Following the main candidate Π spine preserves the kernel environment. -/ +theorem terminalContext_env + (candidate : CandidateExprTrace context source) : + candidate.terminalContext.env = context.env := by + induction candidate with + | terminal => rfl + | forallE context source inferred name domain body binderInfo fresh + annotations annotationsEq checked valid domainCandidate bodyCandidate + domain_ih body_ih => + simpa [terminalContext, Context.pushLocalDecl] using body_ih + +/-- Following the main candidate Π spine preserves the primitive-name +policy used by family declaration. -/ +theorem terminalContext_allowPrimitive + (candidate : CandidateExprTrace context source) : + candidate.terminalContext.allowPrimitive = context.allowPrimitive := by + induction candidate with + | terminal => rfl + | forallE context source inferred name domain body binderInfo fresh + annotations annotationsEq checked valid domainCandidate bodyCandidate + domain_ih body_ih => + simpa [terminalContext, Context.pushLocalDecl] using body_ih + +/-- Following the main candidate Π spine changes only the local context and +name generator; it preserves the checker safety mode. -/ +theorem terminalContext_safety + (candidate : CandidateExprTrace context source) : + candidate.terminalContext.safety = context.safety := by + induction candidate with + | terminal => rfl + | forallE context source inferred name domain body binderInfo fresh + annotations annotationsEq checked valid domainCandidate bodyCandidate + domain_ih body_ih => + simpa [terminalContext, Context.pushLocalDecl] using body_ih + +/-- Following the main candidate Π spine preserves the checker fuel +configuration. -/ +theorem terminalContext_fuel + (candidate : CandidateExprTrace context source) : + candidate.terminalContext.fuel = context.fuel := by + induction candidate with + | terminal => rfl + | forallE context source inferred name domain body binderInfo fresh + annotations annotationsEq checked valid domainCandidate bodyCandidate + domain_ih body_ih => + simpa [terminalContext, Context.pushLocalDecl] using body_ih + /-- Non-Π result reached after following the complete main Π spine. -/ def terminalResult : CandidateExprTrace context source → Expr | .terminal _ _ _ result _ _ => result @@ -1390,6 +1506,65 @@ theorem buildCandidateExpr_loop_of_whnf_forall annotations.consumed hannotationsEq, hdomain, hbody, Pure.pure, Except.pure] +/-- Every annotation choice on a successfully built candidate main spine +comes from the transparent annotation builder used by the ordinary producer. +This recovers validator-replay provenance from the executable traversal +itself; callers do not supply an independent annotation premise. -/ +theorem CandidateExprTrace.validationAnnotations_of_loop + {context : Context} {source : Expr} {fuel : Nat} + {candidate : CandidateExprTrace context source} + (h : buildCandidateExpr.loop context source fuel = .ok candidate) : + candidate.validationAnnotations := by + fun_induction buildCandidateExpr.loop context source fuel <;> + simp_all + case case5 => + simp only [Bind.bind, Except.bind] at h + repeat' split at h + all_goals try simp_all [Functor.map, Except.map] + repeat' split at h + all_goals try simp_all + subst candidate + constructor + · apply CandidateTypeAnnotations.matches_of_build + assumption + · apply_assumption + assumption + case case6 => + simp only [Pure.pure, Except.pure, Except.ok.injEq] at h + subst candidate + trivial + +/-- A successful ordinary candidate-expression call carries the complete +annotation provenance needed to replay family validation. -/ +theorem CandidateExpr.validationAnnotations_of_build + {context : Context} {source : Expr} + {candidate : CandidateExpr source} + (h : buildCandidateExpr source context = .ok candidate) : + candidate.trace.validationAnnotations := by + unfold buildCandidateExpr at h + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, Pure.pure, Except.bind, Except.pure] at h + split at h <;> try simp_all + simp [ReaderT.pure, Pure.pure, Except.pure] at h + subst candidate + apply CandidateExprTrace.validationAnnotations_of_loop + assumption + +/-- The context stored at the root of a successful expression candidate is +the exact reader context in which the ordinary builder was executed. -/ +theorem CandidateExpr.context_eq_of_build + {context : Context} {source : Expr} + {candidate : CandidateExpr source} + (h : buildCandidateExpr source context = .ok candidate) : + candidate.context = context := by + unfold buildCandidateExpr at h + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, Pure.pure, Except.bind, Except.pure] at h + split at h <;> try simp_all + simp [ReaderT.pure, Pure.pure, Except.pure] at h + subst candidate + rfl + /-- Erase the operational trace and retain only the analysis expression. -/ def normalizeCandidateExpr (e : Expr) : M Expr := do return (← buildCandidateExpr e).view @@ -1466,6 +1641,17 @@ def toList (f : (a : α) → F a → β) : def singleton : CandidateList F [source] → F source | .cons head .nil => head +/-- A source-indexed singleton list is completely determined by its total +singleton projection. This eta law lets retained producer witnesses be +reindexed at staged singleton APIs without inspecting or replacing their +candidate payload. -/ +theorem singleton_eta (candidates : CandidateList F [source]) : + candidates = .cons candidates.singleton .nil := by + cases candidates with + | cons head tail => + cases tail + rfl + end CandidateList /-- Candidate for one constructor; its header is always taken from `source`. -/ @@ -1487,6 +1673,16 @@ structure CandidateFamily (source : InductiveType) where constructors : CandidateList CandidateConstructor source.ctors +/-- Project the pre-family candidate spine from a complete dependent family +candidate list without erasing source indices or using a parallel list. -/ +def CandidateList.familyTypes : + {sources : List InductiveType} → + CandidateList CandidateFamily sources → + CandidateList CandidateFamilyType sources + | [], .nil => .nil + | _ :: _, .cons family families => + .cons family.familyType families.familyTypes + def CandidateFamily.view (candidate : CandidateFamily source) : InductiveType := { source with type := candidate.familyType.type.view @@ -1496,10 +1692,61 @@ def normalizeCandidateConstructor (ctor : Constructor) : M (CandidateConstructor ctor) := do return ⟨← buildCandidateExpr ctor.type⟩ +/-- The root context stored by a successful constructor normalization is the +exact post-family reader context used for that traversal. -/ +theorem CandidateConstructor.context_eq_of_normalize + {context : Context} {source : Constructor} + {candidate : CandidateConstructor source} + (h : normalizeCandidateConstructor source context = .ok candidate) : + candidate.type.context = context := by + unfold normalizeCandidateConstructor at h + simp only [ReaderT.bind, Bind.bind] at h + cases hbuild : buildCandidateExpr source.type context with + | error error => + simp [Except.bind, hbuild] at h + | ok type => + simp [Except.bind, ReaderT.pure, Pure.pure, Except.pure, hbuild] at h + subst candidate + exact CandidateExpr.context_eq_of_build hbuild + def normalizeCandidateFamilyType (indType : InductiveType) : M (CandidateFamilyType indType) := do return ⟨← buildCandidateExpr indType.type⟩ +/-- A successful family-type normalization carries the annotation provenance +of its underlying executable expression traversal. -/ +theorem CandidateFamilyType.validationAnnotations_of_normalize + {context : Context} {source : InductiveType} + {candidate : CandidateFamilyType source} + (h : normalizeCandidateFamilyType source context = .ok candidate) : + candidate.type.trace.validationAnnotations := by + unfold normalizeCandidateFamilyType at h + simp only [ReaderT.bind, Bind.bind] at h + cases hbuild : buildCandidateExpr source.type context with + | error error => + simp [Except.bind, hbuild] at h + | ok type => + simp [Except.bind, ReaderT.pure, Pure.pure, Except.pure, hbuild] at h + subst candidate + exact type.validationAnnotations_of_build hbuild + +/-- The root context stored by a successful family-type normalization is the +exact pre-family reader context used for that traversal. -/ +theorem CandidateFamilyType.context_eq_of_normalize + {context : Context} {source : Lean.InductiveType} + {candidate : CandidateFamilyType source} + (h : normalizeCandidateFamilyType source context = .ok candidate) : + candidate.type.context = context := by + unfold normalizeCandidateFamilyType at h + simp only [ReaderT.bind, Bind.bind] at h + cases hbuild : buildCandidateExpr source.type context with + | error error => + simp [Except.bind, hbuild] at h + | ok type => + simp [Except.bind, ReaderT.pure, Pure.pure, Except.pure, hbuild] at h + subst candidate + exact CandidateExpr.context_eq_of_build hbuild + def normalizeCandidateConstructorList : (ctors : List Constructor) → M (CandidateList CandidateConstructor ctors) @@ -1555,6 +1802,30 @@ theorem CandidateFamilyTypeListProduced.normalize rw [head, ih] rfl +/-- A successful singleton family-type traversal retains the annotation +provenance of the exact candidate selected at its sole source position. -/ +theorem CandidateFamilyTypeListProduced.singleton_validationAnnotations + {context : Context} {source : Lean.InductiveType} + {candidates : CandidateList CandidateFamilyType [source]} + (run : CandidateFamilyTypeListProduced context candidates) : + candidates.singleton.type.trace.validationAnnotations := by + cases run with + | cons head tail => + cases tail + exact CandidateFamilyType.validationAnnotations_of_normalize head + +/-- A successful singleton family-type traversal stores its exact traversal +context at the candidate root. -/ +theorem CandidateFamilyTypeListProduced.singleton_context_eq + {context : Context} {source : Lean.InductiveType} + {candidates : CandidateList CandidateFamilyType [source]} + (run : CandidateFamilyTypeListProduced context candidates) : + candidates.singleton.type.context = context := by + cases run with + | cons head tail => + cases tail + exact CandidateFamilyType.context_eq_of_normalize head + /-- Exact successful traversal of an arbitrary source-indexed constructor list in one post-family context. Every candidate remains indexed by its source constructor, so ordering, length, and header provenance are preserved by the @@ -1584,6 +1855,18 @@ theorem CandidateConstructorListProduced.normalize rw [head, ih] rfl +/-- A successful singleton constructor traversal stores its exact traversal +context at the candidate root. -/ +theorem CandidateConstructorListProduced.singleton_context_eq + {context : Context} {source : Constructor} + {candidates : CandidateList CandidateConstructor [source]} + (run : CandidateConstructorListProduced context candidates) : + candidates.singleton.type.context = context := by + cases run with + | cons head tail => + cases tail + exact CandidateConstructor.context_eq_of_normalize head + /-- Exact successful assembly of complete family candidates from an already source-indexed family-type list. Each constructor traversal is tied to the corresponding family source, and the tail remains tied to the remaining family @@ -1617,6 +1900,48 @@ theorem CandidateFamilyListProduced.normalize rw [constructors.normalize, ih] rfl +/-- Singleton family assembly reuses, without replacement, the family-type +candidate produced in the pre-family environment. -/ +theorem CandidateFamilyListProduced.singleton_familyType + {context : Context} {source : Lean.InductiveType} + {familyTypes : CandidateList CandidateFamilyType [source]} + {families : CandidateList CandidateFamily [source]} + (run : CandidateFamilyListProduced context familyTypes families) : + families.singleton.familyType = familyTypes.singleton := by + cases run with + | cons constructors tail => + cases tail + rfl + +/-- Singleton family assembly exposes the exact source-indexed constructor +traversal retained for its sole family. -/ +theorem CandidateFamilyListProduced.singleton_constructors + {context : Context} {source : Lean.InductiveType} + {familyTypes : CandidateList CandidateFamilyType [source]} + {families : CandidateList CandidateFamily [source]} + (run : CandidateFamilyListProduced context familyTypes families) : + CandidateConstructorListProduced context + families.singleton.constructors := by + cases run with + | cons constructors tail => + cases tail + exact constructors + +/-- A successful singleton family assembly can be reindexed directly by the +family-type payload retained in its assembled result. This dependent eta law +avoids rewriting the input list underneath the execution witness. -/ +theorem CandidateFamilyListProduced.singleton_reindex + {context : Context} {source : Lean.InductiveType} + {familyTypes : CandidateList CandidateFamilyType [source]} + {families : CandidateList CandidateFamily [source]} + (run : CandidateFamilyListProduced context familyTypes families) : + CandidateFamilyListProduced context + (.cons families.singleton.familyType .nil) families := by + cases run with + | cons constructors tail => + cases tail + exact .cons constructors .nil + /-- Shape-preserving output of the executable normalization-candidate pass. The dependent family/constructor lists prevent positional provenance from being silently reused for a different inductive request. Names, ordering, and @@ -1629,6 +1954,176 @@ def NormalizationCandidate.view (candidate : NormalizationCandidate source) : List InductiveType := candidate.families.toList fun _ family => family.view +/-- One exact family-type traversal result together with the source-indexed +operational witness that produced it. The witness is provenance for later +Verify staging; it carries no Theory semantics. -/ +structure CandidateFamilyTypeListExecution (context : Context) + (sources : List InductiveType) where + candidates : CandidateList CandidateFamilyType sources + produced : CandidateFamilyTypeListProduced context candidates + +/-- Run the existing family-type normalizer while retaining its exact +source-ordered traversal equations. Errors and candidate data are unchanged. -/ +def executeCandidateFamilyTypeList (context : Context) : + (sources : List InductiveType) → + Except Exception (CandidateFamilyTypeListExecution context sources) + | [] => .ok ⟨.nil, .nil⟩ + | source :: sources => + match hhead : normalizeCandidateFamilyType source context with + | .error error => .error error + | .ok head => + match executeCandidateFamilyTypeList context sources with + | .error error => .error error + | .ok tail => .ok { + candidates := .cons head tail.candidates + produced := .cons (by simpa using hhead) tail.produced } + +/-- One exact constructor traversal result together with its source-indexed +operational witness. -/ +structure CandidateConstructorListExecution (context : Context) + (sources : List Constructor) where + candidates : CandidateList CandidateConstructor sources + produced : CandidateConstructorListProduced context candidates + +/-- Run the existing constructor normalizer while retaining its exact +source-ordered traversal equations. -/ +def executeCandidateConstructorList (context : Context) : + (sources : List Constructor) → + Except Exception (CandidateConstructorListExecution context sources) + | [] => .ok ⟨.nil, .nil⟩ + | source :: sources => + match hhead : normalizeCandidateConstructor source context with + | .error error => .error error + | .ok head => + match executeCandidateConstructorList context sources with + | .error error => .error error + | .ok tail => .ok { + candidates := .cons head tail.candidates + produced := .cons (by simpa using hhead) tail.produced } + +/-- One exact family/constructor assembly result together with both dependent +source lists retained by the ordinary traversal. -/ +structure CandidateFamilyListExecution (context : Context) + {sources : List InductiveType} + (familyTypes : CandidateList CandidateFamilyType sources) where + candidates : CandidateList CandidateFamily sources + produced : CandidateFamilyListProduced context familyTypes candidates + +/-- Run the existing family assembler while retaining each constructor-list +execution. This is an operational refinement of +`normalizeCandidateFamilyList`, not an additional acceptance premise. -/ +def executeCandidateFamilyList (context : Context) : + {sources : List InductiveType} → + (familyTypes : CandidateList CandidateFamilyType sources) → + Except Exception (CandidateFamilyListExecution context familyTypes) + | [], .nil => .ok ⟨.nil, .nil⟩ + | source :: _, .cons familyType familyTypes => + match executeCandidateConstructorList context source.ctors with + | .error error => .error error + | .ok constructors => + match executeCandidateFamilyList context familyTypes with + | .error error => .error error + | .ok tail => + let family : CandidateFamily source := { + familyType + constructors := constructors.candidates } + .ok { + candidates := .cons family tail.candidates + produced := by + change CandidateFamilyListProduced context + (.cons family.familyType familyTypes) + (.cons family tail.candidates) + exact .cons constructors.produced tail.produced } + +/-- Detailed operational result of `buildNormalizationCandidate`. + +The ordinary result erases to `candidate`. The remaining fields retain the +validator-selected statistics, intermediate environment, and exact list +traversals already executed by the same call. Verify uses these equations as +staging provenance; all semantic authority still comes from the D1--D4 +interpreters. -/ +structure NormalizationCandidateExecution + (nparams : Nat) (types : List InductiveType) + (numNested : Nat) (isUnsafe : Bool) (candidateContext : Context) where + validationContext : Context + stats : InductiveStats + familyTypes : CandidateFamilyTypeListExecution + { candidateContext with lctx := {} } types + familyEnv : Environment + declareRun : declareInductiveTypes stats nparams types.toArray + numNested isUnsafe validationContext = .ok familyEnv + constructorRun : checkConstructors types.toArray stats isUnsafe + { validationContext with env := familyEnv } = .ok () + families : CandidateFamilyListExecution + { candidateContext with env := familyEnv, lctx := {} } + familyTypes.candidates + +def NormalizationCandidateExecution.candidate + (execution : NormalizationCandidateExecution nparams types numNested + isUnsafe candidateContext) : NormalizationCandidate types := + ⟨execution.families.candidates⟩ + +/-- The post-family half of the detailed ordinary execution. -/ +def buildNormalizationCandidateExecutionAfterValidation + (nparams : Nat) (types : List InductiveType) + (numNested : Nat) (isUnsafe : Bool) (candidateContext : Context) + (stats : InductiveStats) : + M (NormalizationCandidateExecution nparams types numNested isUnsafe + candidateContext) := + fun validationContext => + match executeCandidateFamilyTypeList + { candidateContext with lctx := {} } types with + | .error error => .error error + | .ok familyTypes => + match hdeclare : declareInductiveTypes stats nparams types.toArray + numNested isUnsafe validationContext with + | .error error => .error error + | .ok familyEnv => + match hconstructors : checkConstructors types.toArray stats isUnsafe + { validationContext with env := familyEnv } with + | .error error => .error error + | .ok () => + match executeCandidateFamilyList + { candidateContext with env := familyEnv, lctx := {} } + familyTypes.candidates with + | .error error => .error error + | .ok families => .ok { + validationContext + stats + familyTypes + familyEnv + declareRun := by simpa using hdeclare + constructorRun := by simpa using hconstructors + families } + +/-- A retained successful post-validation execution exposes exactly the +statistics and reader context supplied by the family validator. -/ +theorem NormalizationCandidateExecution.fields_of_afterValidation + (execution : NormalizationCandidateExecution nparams types numNested + isUnsafe candidateContext) + (stats : InductiveStats) (validationContext : Context) + (h : buildNormalizationCandidateExecutionAfterValidation nparams types + numNested isUnsafe candidateContext stats validationContext = + .ok execution) : + execution.stats = stats ∧ + execution.validationContext = validationContext := by + unfold buildNormalizationCandidateExecutionAfterValidation at h + repeat' split at h + all_goals try simp_all + subst execution + exact ⟨rfl, rfl⟩ + +/-- Execute the ordinary singleton/mutual candidate pass while retaining the +exact operational provenance erased by the public candidate result. -/ +def buildNormalizationCandidateExecution + (nparams : Nat) (types : List InductiveType) + (numNested : Nat) (isUnsafe : Bool) (candidateContext : Context) : + Except Exception (NormalizationCandidateExecution nparams types + numNested isUnsafe candidateContext) := + checkInductiveTypes nparams types.toArray (fun stats => + buildNormalizationCandidateExecutionAfterValidation nparams types + numNested isUnsafe candidateContext stats) candidateContext + /-- Run the generic one-pass candidate producer at the same two environments as kernel inductive checking: family types in the input environment, then constructor types after insertion of every raw family constant. @@ -1662,6 +2157,58 @@ def buildNormalizationCandidate normalizeCandidateFamilyList familyTypes return ⟨families⟩) candidateContext +/-- Erase a retained successful execution back to the unchanged public +candidate producer. The family-validation equation supplies the continuation +boundary selected by `checkInductiveTypes`; every later rewrite comes from an +operation already stored in `execution`. -/ +theorem NormalizationCandidateExecution.produces + (execution : NormalizationCandidateExecution nparams types numNested + isUnsafe candidateContext) + (validationRun : ∀ {α} (k : InductiveStats → M α), + checkInductiveTypes nparams types.toArray k candidateContext = + k execution.stats execution.validationContext) : + buildNormalizationCandidate nparams types numNested isUnsafe + candidateContext = .ok execution.candidate := by + unfold buildNormalizationCandidate + rw [validationRun] + simp only [ReaderT.bind, Bind.bind] + rw [show + (withReader (fun _ : Context => + { candidateContext with lctx := {} }) + (normalizeCandidateFamilyTypeList types)) execution.validationContext = + .ok execution.familyTypes.candidates by + change normalizeCandidateFamilyTypeList types + { candidateContext with lctx := {} } = _ + exact execution.familyTypes.produced.normalize] + simp only [Except.bind] + rw [execution.declareRun] + unfold withEnv + change (ReaderT.bind + (checkConstructors types.toArray execution.stats isUnsafe) + (fun _ => ReaderT.bind + (withReader (fun _ : Context => + { candidateContext with + env := execution.familyEnv, lctx := {} }) + (normalizeCandidateFamilyList execution.familyTypes.candidates)) + (fun families => pure + (⟨families⟩ : NormalizationCandidate types)))) + ({ execution.validationContext with + env := execution.familyEnv } : Context) = _ + simp only [ReaderT.bind, Bind.bind] + rw [execution.constructorRun] + simp only [Except.bind] + rw [show + (withReader (fun _ : Context => + { candidateContext with + env := execution.familyEnv, lctx := {} }) + (normalizeCandidateFamilyList execution.familyTypes.candidates)) + { execution.validationContext with env := execution.familyEnv } = + .ok execution.families.candidates by + change normalizeCandidateFamilyList execution.familyTypes.candidates + { candidateContext with env := execution.familyEnv, lctx := {} } = _ + exact execution.families.produced.normalize] + rfl + /-- info: 'Lean4Lean.AddInductive.buildCandidateExpr' depends on axioms: [propext, Classical.choice, Quot.sound] -/ @@ -1910,24 +2457,40 @@ def isLargeEliminator (stats : InductiveStats) (indTypes : Array InductiveType) loop ctor.type 0 #[] (← readThe Context).fuel.inductiveFuel | _ => return false -partial -- TODO: remove +/-- Search the kernel's elimination-universe name sequence (`u`, `u_1`, …) +for its first entry not already used by the inductive declaration. Among +`lparams.length + 1` distinct candidates at least one is available; the +zero-fuel branch is therefore only a totality fallback. -/ +def getFreshElimParam.loop (lparams : List Name) (u : Name) (i : Nat) : + Nat → Name + | 0 => u + | fuel + 1 => + if lparams.contains u then + loop lparams ((`u).appendIndexAfter i) (i + 1) fuel + else + u + +def getFreshElimParam (lparams : List Name) : Name := + getFreshElimParam.loop lparams `u 1 (lparams.length + 1) + def getElimLevel (stats : InductiveStats) (indTypes : Array InductiveType) : M Level := do unless ← isLargeEliminator stats indTypes do return .zero let {lparams, ..} ← read - let rec loop u i := Id.run do - unless lparams.contains u do return .param u - loop ((`u).appendIndexAfter i) (i + 1) - return loop `u 1 + return .param (getFreshElimParam lparams) + +/-- The constructor-shape fragment of the kernel's K-target test. A visible +Pi is accepted only while it belongs to the shared parameter prefix; the +first visible field makes the target ineligible. -/ +def isKTargetCtor (nparams : Nat) : Nat → Expr → Bool + | i, .forallE _ _ body _ => i < nparams && isKTargetCtor nparams (i + 1) body + | _, _ => true def isKTarget (stats : InductiveStats) (indTypes : Array InductiveType) : M Bool := do let #[indType] := indTypes | return false unless stats.resultLevel.isZero do return false let [ctor] := indType.ctors | return false - let rec loop i - | .forallE _ _ body _ => i < stats.params.size && loop (i + 1) body - | _ => true - return loop 0 ctor.type + return isKTargetCtor stats.params.size 0 ctor.type @[inline] def getIIndices (stats : InductiveStats) (t : Expr) : Nat × Array Expr := ((isValidIndApp? stats t).get!, t.getAppArgs[stats.params.size:]) diff --git a/Lean4Lean/Inductive/EliminationTrace.lean b/Lean4Lean/Inductive/EliminationTrace.lean new file mode 100644 index 00000000..d3e62547 --- /dev/null +++ b/Lean4Lean/Inductive/EliminationTrace.lean @@ -0,0 +1,604 @@ +import Lean4Lean.Inductive.ValidationTrace + +namespace Lean4Lean +open Lean hiding Environment Exception +open Kernel + +namespace AddInductive +open TypeChecker + +/-- Exact successful traversal of the singleton-constructor branch of +`isLargeEliminator`. Non-parameter fields retain the precise `ensureType` +observation used to decide whether their local is relevant to the terminal +index-occurrence check. -/ +inductive LargeEliminatorLoopTrace (stats : InductiveStats) : + (context : Context) → (source : Expr) → (argIdx : Nat) → + (toCheck : Array Expr) → (fuel : Nat) → (result : Bool) → Type where + | parameter + (context : Context) (fuel argIdx : Nat) (toCheck : Array Expr) + (name : Name) (domain body : Expr) (binderInfo : BinderInfo) + (isParameter : argIdx < stats.params.size) + (tail : LargeEliminatorLoopTrace stats + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) toCheck fuel result) : + LargeEliminatorLoopTrace stats context + (.forallE name domain body binderInfo) argIdx toCheck (fuel + 1) result + | proofField + (context : Context) (fuel argIdx : Nat) (toCheck : Array Expr) + (name : Name) (domain body : Expr) (binderInfo : BinderInfo) + (sortResult : Expr) + (isField : argIdx ≥ stats.params.size) + (ensureType : ConstructorEnsureTypeStep.Valid + ⟨context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain), domain, sortResult⟩) + (isProp : sortResult.sortLevel!.isZero = true) + (tail : LargeEliminatorLoopTrace stats + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) toCheck fuel result) : + LargeEliminatorLoopTrace stats context + (.forallE name domain body binderInfo) argIdx toCheck (fuel + 1) result + | dataField + (context : Context) (fuel argIdx : Nat) (toCheck : Array Expr) + (name : Name) (domain body : Expr) (binderInfo : BinderInfo) + (sortResult : Expr) + (isField : argIdx ≥ stats.params.size) + (ensureType : ConstructorEnsureTypeStep.Valid + ⟨context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain), domain, sortResult⟩) + (isProp : sortResult.sortLevel!.isZero = false) + (tail : LargeEliminatorLoopTrace stats + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) + (toCheck.push context.freshExpr) fuel result) : + LargeEliminatorLoopTrace stats context + (.forallE name domain body binderInfo) argIdx toCheck (fuel + 1) result + | terminal + (context : Context) (source : Expr) (fuel argIdx : Nat) + (toCheck : Array Expr) (notForall : source.isForall = false) : + LargeEliminatorLoopTrace stats context source argIdx toCheck (fuel + 1) + (toCheck.all source.getAppArgs.contains) + +namespace LargeEliminatorLoopTrace + +def parameterCount + (trace : LargeEliminatorLoopTrace stats context source argIdx toCheck + fuel result) : Nat := + match trace with + | .parameter (tail := tail) .. => tail.parameterCount + 1 + | .proofField (tail := tail) .. => tail.parameterCount + | .dataField (tail := tail) .. => tail.parameterCount + | .terminal .. => 0 + +def proofFieldCount + (trace : LargeEliminatorLoopTrace stats context source argIdx toCheck + fuel result) : Nat := + match trace with + | .parameter (tail := tail) .. => tail.proofFieldCount + | .proofField (tail := tail) .. => tail.proofFieldCount + 1 + | .dataField (tail := tail) .. => tail.proofFieldCount + | .terminal .. => 0 + +def dataFieldCount + (trace : LargeEliminatorLoopTrace stats context source argIdx toCheck + fuel result) : Nat := + match trace with + | .parameter (tail := tail) .. => tail.dataFieldCount + | .proofField (tail := tail) .. => tail.dataFieldCount + | .dataField (tail := tail) .. => tail.dataFieldCount + 1 + | .terminal .. => 0 + +/-- Erasing the retained singleton trace replays the exact ordinary checker +loop, including every `ensureType` call and local declaration. -/ +theorem run + (trace : LargeEliminatorLoopTrace stats context source argIdx toCheck + fuel result) : + isLargeEliminator.loop stats source argIdx toCheck fuel context = + .ok result := by + induction trace with + | parameter context fuel argIdx toCheck name domain body binderInfo + isParameter tail ih => + rw [show fuel + 1 = Nat.succ fuel by omega] + rw [isLargeEliminator.loop.eq_2, withLocalDecl_apply] + have notField : ¬ argIdx ≥ stats.params.size := + Nat.not_le.mpr isParameter + simp only [notField, if_false, ReaderT.pure, Pure.pure, + ReaderT.bind, Bind.bind, Except.bind, Except.pure] + exact ih + | proofField context fuel argIdx toCheck name domain body binderInfo + sortResult isField ensureStep isProp tail ih => + rw [show fuel + 1 = Nat.succ fuel by omega] + rw [isLargeEliminator.loop.eq_2, withLocalDecl_apply] + simp only [isField, if_true, ReaderT.bind, Bind.bind, + liftTypeChecker_apply] + rw [ensureStep] + simp only [Except.bind, isProp, Bool.not_true, Bool.false_eq_true, + if_false, Pure.pure] + exact ih + | dataField context fuel argIdx toCheck name domain body binderInfo + sortResult isField ensureStep isProp tail ih => + rw [show fuel + 1 = Nat.succ fuel by omega] + rw [isLargeEliminator.loop.eq_2, withLocalDecl_apply] + simp only [isField, if_true, ReaderT.bind, Bind.bind, + liftTypeChecker_apply] + rw [ensureStep] + simp only [Except.bind, isProp, Bool.not_false, if_true, Pure.pure] + exact ih + | terminal context source fuel argIdx toCheck notForall => + cases source <;> + simp_all [isLargeEliminator.loop, ReaderT.pure, Pure.pure, + Except.pure, Expr.isForall] + +/-- Execute the singleton branch once while retaining the exact branch and +checker observations that produced its Boolean result. -/ +def buildExecution (stats : InductiveStats) (context : Context) + (source : Expr) (argIdx : Nat) (toCheck : Array Expr) : + (fuel : Nat) → Except Exception + (Sigma fun result => LargeEliminatorLoopTrace stats context source + argIdx toCheck fuel result) + | 0 => .error .deepRecursion + | fuel + 1 => + match hforall : source.isForall with + | false => .ok ⟨toCheck.all source.getAppArgs.contains, + .terminal context source fuel argIdx toCheck hforall⟩ + | true => + match source with + | .forallE name domain body binderInfo => + let nextContext := context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain) + let nextSource := body.instantiate1 context.freshExpr + if isParameter : argIdx < stats.params.size then + match buildExecution stats nextContext nextSource (argIdx + 1) + toCheck fuel with + | .error error => .error error + | .ok ⟨result, tail⟩ => .ok ⟨result, + .parameter context fuel argIdx toCheck name domain body + binderInfo isParameter tail⟩ + else + match hensure : TypeChecker.M.run nextContext.env nextContext.safety + nextContext.lctx nextContext.lparams nextContext.fuel + (TypeChecker.ensureType domain) with + | .error error => .error error + | .ok sortResult => + if isProp : sortResult.sortLevel!.isZero then + match buildExecution stats nextContext nextSource + (argIdx + 1) toCheck fuel with + | .error error => .error error + | .ok ⟨result, tail⟩ => .ok ⟨result, + .proofField context fuel argIdx toCheck name domain body + binderInfo sortResult (Nat.le_of_not_gt isParameter) + hensure isProp tail⟩ + else + match buildExecution stats nextContext nextSource + (argIdx + 1) (toCheck.push context.freshExpr) fuel with + | .error error => .error error + | .ok ⟨result, tail⟩ => .ok ⟨result, + .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) + tail⟩ + | _ => .error <| .other + "large-eliminator source shape disagrees with isForall" + +end LargeEliminatorLoopTrace + +/-- The source identity and exact loop retained when the singleton branch of +`isLargeEliminator` is selected. -/ +structure LargeEliminatorSingletonExecution + (stats : InductiveStats) (indTypes : Array InductiveType) + (context : Context) (result : Bool) where + indType : InductiveType + indTypes_eq : indTypes = #[indType] + ctor : Constructor + ctors_eq : indType.ctors = [ctor] + trace : LargeEliminatorLoopTrace stats context ctor.type 0 #[] + context.fuel.inductiveFuel result + +/-- One exact successful execution of `isLargeEliminator`. The ordinary +equation is always retained; the singleton payload additionally exposes all +field-sort observations made by the executable. -/ +structure LargeEliminatorExecution + (stats : InductiveStats) (indTypes : Array InductiveType) + (context : Context) where + result : Bool + singleton : Option + (LargeEliminatorSingletonExecution stats indTypes context result) + run_eq : isLargeEliminator stats indTypes context = .ok result + +namespace LargeEliminatorExecution + +/-- Execute the ordinary decision and retain a transparent refinement of its +singleton traversal. -/ +def buildExecution (stats : InductiveStats) (indTypes : Array InductiveType) + (context : Context) : + Except Exception (LargeEliminatorExecution stats indTypes context) := + match hrun : isLargeEliminator stats indTypes context with + | .error error => .error error + | .ok result => + if stats.isNotZero then + .ok { result, singleton := none, run_eq := hrun } + else + match htypes : indTypes with + | #[indType] => + match hctors : indType.ctors with + | [ctor] => + match LargeEliminatorLoopTrace.buildExecution stats context + ctor.type 0 #[] context.fuel.inductiveFuel with + | .error error => .error error + | .ok ⟨traceResult, trace⟩ => + if hsame : traceResult = result then + .ok { + result + singleton := some { + indType + indTypes_eq := rfl + ctor + ctors_eq := hctors + trace := hsame ▸ trace } + run_eq := by simpa only [htypes] using hrun } + else + .error <| .other + "large-eliminator trace disagrees with ordinary result" + | _ => .ok { + result + singleton := none + run_eq := by simpa only [htypes] using hrun } + | _ => .ok { + result + singleton := none + run_eq := by simpa only [htypes] using hrun } + +end LargeEliminatorExecution + +/-- Exact `getElimLevel` execution paired with the retained large-elimination +decision that controls it. `level_eq` exposes both the zero and fresh-parameter +branches without unfolding the monadic checker again. -/ +structure ElimLevelExecution + (stats : InductiveStats) (indTypes : Array InductiveType) + (context : Context) where + large : LargeEliminatorExecution stats indTypes context + level : Level + level_eq : level = if large.result then + .param (getFreshElimParam context.lparams) else .zero + run_eq : getElimLevel stats indTypes context = .ok level + +namespace ElimLevelExecution + +/-- Recompose `getElimLevel` from the retained exact large-elimination run. -/ +theorem run_of_large + (large : LargeEliminatorExecution stats indTypes context) : + getElimLevel stats indTypes context = .ok + (if large.result then .param (getFreshElimParam context.lparams) + else .zero) := by + unfold getElimLevel + simp only [ReaderT.bind, Bind.bind] + rw [large.run_eq] + cases large.result <;> rfl + +def buildExecution (stats : InductiveStats) (indTypes : Array InductiveType) + (context : Context) : + Except Exception (ElimLevelExecution stats indTypes context) := do + let large ← LargeEliminatorExecution.buildExecution stats indTypes context + let level := if large.result then + .param (getFreshElimParam context.lparams) else .zero + pure { + large + level + level_eq := rfl + run_eq := run_of_large large } + +theorem level_eq_zero (execution : ElimLevelExecution stats indTypes context) + (small : execution.large.result = false) : + execution.level = .zero := by + rw [execution.level_eq, small] + rfl + +theorem level_eq_param + (execution : ElimLevelExecution stats indTypes context) + (large : execution.large.result = true) : + execution.level = .param (getFreshElimParam context.lparams) := by + rw [execution.level_eq, large] + rfl + +/-- A small eliminator preserves the source universe-level order in recursor +applications. -/ +theorem recLevels_eq_small + (execution : ElimLevelExecution stats indTypes context) + (small : execution.large.result = false) (levels : List Level) : + getRecLevels execution.level levels = levels := by + rw [execution.level_eq_zero small] + rfl + +/-- A large eliminator prepends its fresh elimination level to every source +universe used by recursive calls. -/ +theorem recLevels_eq_large + (execution : ElimLevelExecution stats indTypes context) + (large : execution.large.result = true) (levels : List Level) : + getRecLevels execution.level levels = + .param (getFreshElimParam context.lparams) :: levels := by + rw [execution.level_eq_param large] + rfl + +/-- A small eliminator preserves the stored source level-parameter order. -/ +theorem recLevelParams_eq_small + (execution : ElimLevelExecution stats indTypes context) + (small : execution.large.result = false) (lparams : List Name) : + getRecLevelParams execution.level lparams = lparams := by + rw [execution.level_eq_zero small] + rfl + +/-- A large eliminator stores the fresh elimination parameter before every +source level parameter. -/ +theorem recLevelParams_eq_large + (execution : ElimLevelExecution stats indTypes context) + (large : execution.large.result = true) (lparams : List Name) : + getRecLevelParams execution.level lparams = + getFreshElimParam context.lparams :: lparams := by + rw [execution.level_eq_param large] + rfl + +end ElimLevelExecution + +/-- Exact traversal of the constructor-shape fragment of `isKTarget`. The +trace stops at the first visible non-parameter binder, just as the executable +does; it never treats K eligibility as evidence for large elimination. -/ +inductive KTargetCtorTrace (nparams : Nat) : + (source : Expr) → (argIdx : Nat) → (result : Bool) → Type where + | parameter + (argIdx : Nat) (name : Name) (domain body : Expr) + (binderInfo : BinderInfo) + (isParameter : argIdx < nparams) + (tail : KTargetCtorTrace nparams body (argIdx + 1) result) : + KTargetCtorTrace nparams (.forallE name domain body binderInfo) + argIdx result + | field + (argIdx : Nat) (name : Name) (domain body : Expr) + (binderInfo : BinderInfo) + (isField : argIdx ≥ nparams) : + KTargetCtorTrace nparams (.forallE name domain body binderInfo) + argIdx false + | terminal + (source : Expr) (argIdx : Nat) + (notForall : source.isForall = false) : + KTargetCtorTrace nparams source argIdx true + +namespace KTargetCtorTrace + +def parameterCount + (trace : KTargetCtorTrace nparams source argIdx result) : Nat := + match trace with + | .parameter (tail := tail) .. => tail.parameterCount + 1 + | .field .. => 0 + | .terminal .. => 0 + +/-- The K-target walk stops at the first visible constructor field, so this +count is either zero or one. -/ +def fieldCount + (trace : KTargetCtorTrace nparams source argIdx result) : Nat := + match trace with + | .parameter (tail := tail) .. => tail.fieldCount + | .field .. => 1 + | .terminal .. => 0 + +/-- Erasing the retained constructor trace yields the exact Boolean consumed +by `isKTarget`. -/ +theorem run + (trace : KTargetCtorTrace nparams source argIdx result) : + isKTargetCtor nparams argIdx source = result := by + induction trace with + | parameter argIdx name domain body binderInfo isParameter tail ih => + simp [isKTargetCtor, isParameter, ih] + | field argIdx name domain body binderInfo isField => + have notParameter : ¬ argIdx < nparams := Nat.not_lt.mpr isField + simp [isKTargetCtor, notParameter] + | terminal source argIdx notForall => + cases source <;> simp_all [isKTargetCtor, Expr.isForall] + +/-- Compute the K-target constructor branch while retaining the exact point +where the parameter prefix ends. -/ +def buildExecution (nparams : Nat) : + (source : Expr) → (argIdx : Nat) → + Sigma fun result => KTargetCtorTrace nparams source argIdx result + | .bvar i, argIdx => ⟨true, .terminal (.bvar i) argIdx rfl⟩ + | .fvar id, argIdx => ⟨true, .terminal (.fvar id) argIdx rfl⟩ + | .mvar id, argIdx => ⟨true, .terminal (.mvar id) argIdx rfl⟩ + | .sort level, argIdx => ⟨true, .terminal (.sort level) argIdx rfl⟩ + | .const name levels, argIdx => + ⟨true, .terminal (.const name levels) argIdx rfl⟩ + | .app fn arg, argIdx => ⟨true, .terminal (.app fn arg) argIdx rfl⟩ + | .lam name domain body binderInfo, argIdx => + ⟨true, .terminal (.lam name domain body binderInfo) argIdx rfl⟩ + | .forallE name domain body binderInfo, argIdx => + if isParameter : argIdx < nparams then + let ⟨result, tail⟩ := buildExecution nparams body (argIdx + 1) + ⟨result, .parameter argIdx name domain body binderInfo + isParameter tail⟩ + else + ⟨false, .field argIdx name domain body binderInfo + (Nat.le_of_not_gt isParameter)⟩ + | .letE name type value body nondep, argIdx => + ⟨true, .terminal (.letE name type value body nondep) argIdx rfl⟩ + | .lit literal, argIdx => ⟨true, .terminal (.lit literal) argIdx rfl⟩ + | .mdata data expr, argIdx => + ⟨true, .terminal (.mdata data expr) argIdx rfl⟩ + | .proj typeName idx struct, argIdx => + ⟨true, .terminal (.proj typeName idx struct) argIdx rfl⟩ + +end KTargetCtorTrace + +/-- The singleton-Prop branch data of one exact `isKTarget` execution. -/ +structure KTargetSingletonExecution + (stats : InductiveStats) (indTypes : Array InductiveType) + (result : Bool) where + indType : InductiveType + indTypes_eq : indTypes = #[indType] + resultLevelZero : stats.resultLevel.isZero = true + ctor : Constructor + ctors_eq : indType.ctors = [ctor] + trace : KTargetCtorTrace stats.params.size ctor.type 0 result + +/-- One exact successful execution of `isKTarget`. The ordinary monadic +equation is always retained; a singleton candidate additionally exposes the +constructor-prefix trace that decided its flag. -/ +structure KTargetExecution + (stats : InductiveStats) (indTypes : Array InductiveType) + (context : Context) where + result : Bool + singleton : Option (KTargetSingletonExecution stats indTypes result) + run_eq : isKTarget stats indTypes context = .ok result + +namespace KTargetExecution + +def buildExecution (stats : InductiveStats) + (indTypes : Array InductiveType) (context : Context) : + Except Exception (KTargetExecution stats indTypes context) := + match hrun : isKTarget stats indTypes context with + | .error error => .error error + | .ok result => + match _htypes : indTypes with + | #[indType] => + if hzero : stats.resultLevel.isZero then + match hctors : indType.ctors with + | [ctor] => + let ⟨traceResult, trace⟩ := + KTargetCtorTrace.buildExecution stats.params.size ctor.type 0 + if hsame : traceResult = result then + .ok { + result + singleton := some { + indType + indTypes_eq := rfl + resultLevelZero := hzero + ctor + ctors_eq := hctors + trace := hsame ▸ trace } + run_eq := hrun } + else + .error <| .other + "K-target trace disagrees with ordinary result" + | _ => .ok { result, singleton := none, run_eq := hrun } + else + .ok { result, singleton := none, run_eq := hrun } + | _ => .ok { result, singleton := none, run_eq := hrun } + +end KTargetExecution + +/-- The normalization/validation execution extended through constructor +declaration and the exact elimination-level and K-target decisions used by +`run`. This is an operational refinement only: erasing the added fields leaves the existing +normalization candidate and checker equations unchanged. -/ +structure NormalizationEliminationExecution + (nparams : Nat) (types : List InductiveType) + (numNested : Nat) (isUnsafe : Bool) (candidateContext : Context) where + normalization : NormalizationCandidateExecution nparams types numNested + isUnsafe candidateContext + constructorEnv : Environment + declareConstructorsRun : + declareConstructors normalization.stats types.toArray isUnsafe + { normalization.validationContext with + env := normalization.familyEnv } = .ok constructorEnv + elimination : ElimLevelExecution normalization.stats types.toArray + { normalization.validationContext with env := constructorEnv } + kTarget : KTargetExecution normalization.stats types.toArray + { normalization.validationContext with env := constructorEnv } + +namespace NormalizationEliminationExecution + +def candidate + (execution : NormalizationEliminationExecution nparams types numNested + isUnsafe candidateContext) : NormalizationCandidate types := + execution.normalization.candidate + +/-- Execute the existing detailed candidate producer, declare the already +validated constructors, and retain both recursor decisions at precisely the +post-constructor context used by `run`. -/ +def buildExecution + (nparams : Nat) (types : List InductiveType) + (numNested : Nat) (isUnsafe : Bool) (candidateContext : Context) : + Except Exception (NormalizationEliminationExecution nparams types + numNested isUnsafe candidateContext) := do + let normalization ← buildNormalizationCandidateExecution nparams types + numNested isUnsafe candidateContext + let constructorContext : Context := + { normalization.validationContext with env := normalization.familyEnv } + match hdeclare : declareConstructors normalization.stats types.toArray + isUnsafe constructorContext with + | .error error => .error error + | .ok constructorEnv => + let eliminationContext : Context := + { normalization.validationContext with env := constructorEnv } + match ElimLevelExecution.buildExecution normalization.stats + types.toArray eliminationContext with + | .error error => .error error + | .ok elimination => + match KTargetExecution.buildExecution normalization.stats + types.toArray eliminationContext with + | .error error => .error error + | .ok kTarget => .ok { + normalization + constructorEnv + declareConstructorsRun := by + simpa [constructorContext] using hdeclare + elimination := by simpa [eliminationContext] using elimination + kTarget := by simpa [eliminationContext] using kTarget } + +/-- The level list supplied to generated recursive calls. -/ +def recLevels + (execution : NormalizationEliminationExecution nparams types numNested + isUnsafe candidateContext) : List Level := + getRecLevels execution.elimination.level execution.normalization.stats.levels + +/-- The level-parameter list stored in generated recursor metadata. -/ +def recLevelParams + (execution : NormalizationEliminationExecution nparams types numNested + isUnsafe candidateContext) : List Name := + getRecLevelParams execution.elimination.level + execution.normalization.validationContext.lparams + +end NormalizationEliminationExecution + +/-- +info: 'Lean4Lean.AddInductive.KTargetCtorTrace.run' depends on axioms: [propext] +-/ +#guard_msgs in +#print axioms KTargetCtorTrace.run + +/-- +info: 'Lean4Lean.AddInductive.KTargetExecution.buildExecution' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms KTargetExecution.buildExecution + +/-- +info: 'Lean4Lean.AddInductive.LargeEliminatorLoopTrace.run' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms LargeEliminatorLoopTrace.run + +/-- +info: 'Lean4Lean.AddInductive.LargeEliminatorExecution.buildExecution' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms LargeEliminatorExecution.buildExecution + +/-- +info: 'Lean4Lean.AddInductive.ElimLevelExecution.run_of_large' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms ElimLevelExecution.run_of_large + +/-- +info: 'Lean4Lean.AddInductive.ElimLevelExecution.recLevelParams_eq_large' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ElimLevelExecution.recLevelParams_eq_large + +end AddInductive +end Lean4Lean diff --git a/Lean4Lean/Inductive/ValidationTrace.lean b/Lean4Lean/Inductive/ValidationTrace.lean new file mode 100644 index 00000000..314c604a --- /dev/null +++ b/Lean4Lean/Inductive/ValidationTrace.lean @@ -0,0 +1,1336 @@ +import Lean4Lean.Inductive.Add + +set_option linter.unusedSimpArgs false + +namespace Lean4Lean +open Lean hiding Environment Exception +open Kernel + +namespace AddInductive +open TypeChecker + +/-- The constructor root check runs with no validation-local declarations, +while retaining every other field of the post-family checker context. -/ +def Context.withEmptyLocalContext (context : Context) : Context := + { context with lctx := {} } + +/-- One exact successful `ensureType` execution used for an ordinary +constructor field. -/ +structure ConstructorEnsureTypeStep where + context : Context + source : Expr + result : Expr + +def ConstructorEnsureTypeStep.Valid + (step : ConstructorEnsureTypeStep) : Prop := + TypeChecker.M.run step.context.env step.context.safety + step.context.lctx step.context.lparams step.context.fuel + (TypeChecker.ensureType step.source) = + .ok step.result + +/-- The two successful universe branches of `checkConstructors`: either the +transparent structural comparison succeeds, or the exact fallback comparison +does. Keeping the branch choice prevents a trace from silently replacing the +executable universe test with a stronger premise. -/ +inductive ConstructorUniverseTrace (resultLevel fieldLevel : Level) : Type where + | structural + (valid : levelStructGe resultLevel fieldLevel = true) : + ConstructorUniverseTrace resultLevel fieldLevel + | fallback + (structuralFailed : levelStructGe resultLevel fieldLevel = false) + (valid : (resultLevel.isZero || resultLevel.geq fieldLevel) = true) : + ConstructorUniverseTrace resultLevel fieldLevel + +namespace ConstructorUniverseTrace + +/-- A field rejected by both executable universe comparisons cannot have a +successful universe trace. -/ +theorem not_nonempty_of_rejected + (structuralRejected : levelStructGe resultLevel fieldLevel = false) + (fallbackRejected : + (resultLevel.isZero || resultLevel.geq fieldLevel) = false) : + ¬ Nonempty (ConstructorUniverseTrace resultLevel fieldLevel) := by + rintro ⟨trace⟩ + cases trace with + | structural valid => simp_all + | fallback _ valid => simp_all + +end ConstructorUniverseTrace + +/-- Complete successful traversal of `checkPositivity.loop`, indexed by the +exact source expression, checker context, and remaining fuel. The recursive +constructor records the precise local declaration used by the executable +traversal; the terminal constructor records the accepted recursive target. -/ +inductive ConstructorPositivityTrace + (stats : InductiveStats) (ctor : Name) (argIdx : Nat) : + (context : Context) → (source : Expr) → (fuel : Nat) → Type where + | absent + (context : Context) (source result : Expr) (fuel : Nat) + (whnf : CandidateWhnfStep.Valid ⟨context, source, result⟩) + (occurs : hasIndOcc stats.indConsts result = false) : + ConstructorPositivityTrace stats ctor argIdx context source (fuel + 1) + | forallE + (context : Context) (source : Expr) (fuel : Nat) + (name : Name) (domain body : Expr) (binderInfo : BinderInfo) + (whnf : CandidateWhnfStep.Valid + ⟨context, source, .forallE name domain body binderInfo⟩) + (occurs : hasIndOcc stats.indConsts + (.forallE name domain body binderInfo) = true) + (domainFree : hasIndOcc stats.indConsts domain = false) + (tail : ConstructorPositivityTrace stats ctor argIdx + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) fuel) : + ConstructorPositivityTrace stats ctor argIdx context source (fuel + 1) + | target + (context : Context) (source result : Expr) (fuel targetIdx : Nat) + (whnf : CandidateWhnfStep.Valid ⟨context, source, result⟩) + (occurs : hasIndOcc stats.indConsts result = true) + (terminal : result.isForall = false) + (valid : isValidIndApp? stats result = some targetIdx) : + ConstructorPositivityTrace stats ctor argIdx context source (fuel + 1) + +namespace ConstructorPositivityTrace + +/-- Observable recursive-target data retained by the positivity traversal. +`binderDepth` counts positive Pi domains traversed before the terminal family +application. -/ +structure Target where + familyIdx : Nat + binderDepth : Nat + deriving DecidableEq, Repr + +/-- Erase proof fields while retaining the exact sibling-family ordinal and +positive-Pi depth selected by the executable positivity run. -/ +def target? : + ConstructorPositivityTrace stats ctor argIdx context source fuel → + Option Target + | .absent _ _ _ _ _ _ => none + | .forallE _ _ _ _ _ _ _ _ _ _ tail => + tail.target?.map fun target => + { target with binderDepth := target.binderDepth + 1 } + | .target _ _ _ _ familyIdx _ _ _ _ => + some { familyIdx, binderDepth := 0 } + +/-- Erasing a positivity trace replays the exact executable traversal. -/ +theorem run + (trace : ConstructorPositivityTrace stats ctor argIdx context source fuel) : + checkPositivity.loop stats ctor argIdx source fuel context = .ok () := by + induction trace with + | absent context source result fuel whnf occurs => + unfold checkPositivity.loop + simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply] + rw [whnf] + simp only [Except.bind] + rw [occurs] + rfl + | forallE context source fuel name domain body binderInfo whnf occurs + domainFree tail ih => + unfold checkPositivity.loop + simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply] + rw [whnf] + simp only [Except.bind] + rw [occurs] + simp only [Bool.not_true, Bool.false_eq_true, if_false, + ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind, + Except.bind, Except.pure] + rw [domainFree] + simp only [Bool.false_eq_true, if_false, withLocalDecl_apply] + exact ih + | target context source result fuel targetIdx whnf occurs terminal valid => + unfold checkPositivity.loop + simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply] + rw [whnf] + simp only [Except.bind] + rw [occurs] + simp only [Bool.not_true, Bool.false_eq_true, if_false, + ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind, + Except.bind, Except.pure] + cases result <;> + simp_all [Expr.isForall, ReaderT.pure, Pure.pure, Except.pure] + +/-- Every successful executable positivity traversal decomposes into the +source-indexed trace above. -/ +theorem exists_of_run + (success : checkPositivity.loop stats ctor argIdx source fuel context = + .ok ()) : + Nonempty (ConstructorPositivityTrace stats ctor argIdx + context source fuel) := 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 + cases hwhnf : TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel (TypeChecker.whnf source) with + | error err => simp_all [Except.bind] + | ok result => + rw [hwhnf] at success + simp only [Except.bind] at success + cases hocc : hasIndOcc stats.indConsts result with + | false => exact ⟨.absent context source result fuel hwhnf hocc⟩ + | true => + rw [hocc] 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 + case forallE name domain body binderInfo => + simp only at success + cases hdomain : hasIndOcc stats.indConsts domain with + | false => + rw [hdomain] at success + simp only [Bool.false_eq_true, if_false, + withLocalDecl_apply] at success + obtain ⟨tail⟩ := ih success + exact ⟨.forallE context source fuel name domain body + binderInfo hwhnf hocc hdomain tail⟩ + | true => + rw [hdomain] at success + change Except.error _ = Except.ok () at success + contradiction + all_goals + simp only at success + cases hvalid : isValidIndApp? stats _ with + | none => + rw [hvalid] at success + change Except.error _ = Except.ok () at success + contradiction + | some targetIdx => + exact ⟨.target context source _ fuel targetIdx + hwhnf hocc rfl hvalid⟩ + +/-- Execute the positivity traversal while retaining its exact dependent +trace as data. Unlike `exists_of_run`, this decomposition is transparent and +therefore remains available to later executable alignment audits; erasing the +result with `run` recovers the ordinary checker execution. -/ +def buildExecution (stats : InductiveStats) (ctor : Name) (argIdx : Nat) + (context : Context) (source : Expr) : + (fuel : Nat) → Except Exception + (ConstructorPositivityTrace stats ctor argIdx context source fuel) + | 0 => .error .deepRecursion + | fuel + 1 => + match hwhnf : TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel (TypeChecker.whnf source) with + | .error error => .error error + | .ok result => + match hoccurs : hasIndOcc stats.indConsts result with + | false => .ok (.absent context source result fuel hwhnf hoccurs) + | true => + match hforall : result.isForall with + | true => + match result with + | .forallE name domain body binderInfo => + match hdomain : hasIndOcc stats.indConsts domain with + | true => .error <| .other + s!"arg #{argIdx + 1} of '{ctor}' has a non positive occurrence of the datatypes being declared" + | false => + match buildExecution stats ctor argIdx + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) fuel with + | .error error => .error error + | .ok tail => .ok (.forallE context source fuel name + domain body binderInfo hwhnf hoccurs hdomain tail) + | _ => .error <| .other + "positivity WHNF shape disagrees with isForall" + | false => + match hvalid : isValidIndApp? stats result with + | none => .error <| .other + s!"arg #{argIdx + 1} of '{ctor}' has a non valid occurrence of the datatypes being declared" + | some targetIdx => .ok (.target context source result fuel + targetIdx hwhnf hoccurs hforall hvalid) + +/-- An exact positivity failure, including its diagnostic payload, excludes a +successful trace at precisely that source/context/fuel position. -/ +theorem not_nonempty_of_error + (failure : checkPositivity.loop stats ctor argIdx source fuel context = + .error err) : + ¬ Nonempty (ConstructorPositivityTrace stats ctor argIdx + context source fuel) := by + rintro ⟨trace⟩ + have success := trace.run + rw [failure] at success + contradiction + +end ConstructorPositivityTrace + +/-- Whether positivity was executed or skipped by the exact `isUnsafe` +branch of constructor validation. -/ +inductive ConstructorPositivityModeTrace + (stats : InductiveStats) (isUnsafe : Bool) + (ctor : Name) (argIdx : Nat) (context : Context) (source : Expr) : Type where + | skipped + (isUnsafe_eq : isUnsafe = true) : + ConstructorPositivityModeTrace stats isUnsafe ctor argIdx context source + | safe + (isUnsafe_eq : isUnsafe = false) + (trace : ConstructorPositivityTrace stats ctor argIdx context source + context.fuel.inductiveFuel) : + ConstructorPositivityModeTrace stats isUnsafe ctor argIdx context source + +namespace ConstructorPositivityModeTrace + +/-- Observable recursive target for the exact safe/unsafe positivity branch. +Unsafe validation deliberately exposes no positivity claim. -/ +def target? : + ConstructorPositivityModeTrace + stats isUnsafe ctor argIdx context source → + Option ConstructorPositivityTrace.Target + | .skipped _ => none + | .safe _ trace => trace.target? + +theorem run + (trace : ConstructorPositivityModeTrace + stats isUnsafe ctor argIdx context source) : + (if !isUnsafe then checkPositivity stats source ctor argIdx else pure ()) + context = .ok () := by + cases trace with + | skipped h => simp [h, ReaderT.pure, Pure.pure, Except.pure] + | safe h trace => + simp only [h, Bool.not_false, if_true] + unfold checkPositivity + simpa only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] using trace.run + +/-- Execute the recorded positivity branch and then an exact continuation. -/ +theorem bind_run + (trace : ConstructorPositivityModeTrace + stats isUnsafe ctor argIdx context source) + (next : M α) (result : α) + (nextRun : next context = .ok result) : + (do + if !isUnsafe then checkPositivity stats source ctor argIdx + next) context = .ok result := by + cases trace with + | skipped h => + simp [h, nextRun, ReaderT.bind, Bind.bind, + ReaderT.pure, Pure.pure, Except.bind, Except.pure] + | safe h trace => + have positivityRun : + checkPositivity stats source ctor argIdx context = .ok () := by + unfold checkPositivity + simpa only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] using trace.run + simp [h, positivityRun, nextRun, ReaderT.bind, Bind.bind, + ReaderT.pure, Pure.pure, Except.bind, Except.pure] + +/-- A successful executable positivity branch determines whether validation +was skipped for an unsafe declaration or supplies the full safe trace. -/ +theorem exists_of_run + (success : + (if !isUnsafe then checkPositivity stats source ctor argIdx else pure ()) + context = .ok ()) : + Nonempty (ConstructorPositivityModeTrace + stats isUnsafe ctor argIdx context source) := by + cases hUnsafe : isUnsafe with + | false => + simp only [hUnsafe, 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⟩ := ConstructorPositivityTrace.exists_of_run success + exact ⟨.safe rfl trace⟩ + | true => exact ⟨.skipped rfl⟩ + +/-- Transparently retain the exact safe/unsafe positivity branch selected by +constructor validation. -/ +def buildExecution (stats : InductiveStats) (isUnsafe : Bool) + (ctor : Name) (argIdx : Nat) (context : Context) (source : Expr) : + Except Exception + (ConstructorPositivityModeTrace stats isUnsafe ctor argIdx context source) := + match isUnsafe with + | true => .ok (.skipped rfl) + | false => + match ConstructorPositivityTrace.buildExecution stats ctor argIdx + context source context.fuel.inductiveFuel with + | .error error => .error error + | .ok trace => .ok (.safe rfl trace) + +/-- Failure of the exact safe/unsafe positivity branch excludes its retained +mode trace without changing the executable diagnostic. -/ +theorem not_nonempty_of_error + (failure : + (if !isUnsafe then checkPositivity stats source ctor argIdx else pure ()) + context = .error err) : + ¬ Nonempty (ConstructorPositivityModeTrace + stats isUnsafe ctor argIdx context source) := by + rintro ⟨trace⟩ + have success := trace.run + rw [failure] at success + contradiction + +end ConstructorPositivityModeTrace + +/-- Exact successful validation of one constructor type from its root through +its parameter prefix, ordinary fields, positivity checks, and terminal family +application. Every recursive index is selected by the executable traversal. -/ +inductive ConstructorTypeValidationTrace + (stats : InductiveStats) (isUnsafe : Bool) + (familyIdx : Nat) (ctor : Name) : + (context : Context) → (source : Expr) → + (argIdx fuel : Nat) → Type where + | parameter + (context : Context) (fuel argIdx : Nat) + (name : Name) (domain body : Expr) (binderInfo : BinderInfo) + (param parameterType : Expr) + (parameterAt : stats.params[argIdx]? = some param) + (parameterTypeRun : getType param context = .ok parameterType) + (defeq : CandidateIsDefEqStep.Valid + ⟨context, domain, parameterType⟩) + (tail : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context (body.instantiate1 param) (argIdx + 1) fuel) : + ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context (.forallE name domain body binderInfo) argIdx (fuel + 1) + | ordinary + (context : Context) (fuel argIdx : Nat) + (name : Name) (domain body : Expr) (binderInfo : BinderInfo) + (sortResult : Expr) + (noParameter : stats.params[argIdx]? = none) + (ensureType : ConstructorEnsureTypeStep.Valid + ⟨context, domain, sortResult⟩) + (universeTrace : ConstructorUniverseTrace + stats.resultLevel sortResult.sortLevel!) + (positivity : ConstructorPositivityModeTrace + stats isUnsafe ctor argIdx context domain) + (tail : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) fuel) : + ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context (.forallE name domain body binderInfo) argIdx (fuel + 1) + | terminal + (context : Context) (source : Expr) (fuel argIdx : Nat) + (terminal : source.isForall = false) + (valid : isValidIndAppIdx stats source familyIdx = true) : + ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx (fuel + 1) + +namespace ConstructorTypeValidationTrace + +/-- Field-ordered recursive-target observations for one constructor. Parameter +binders are omitted; every ordinary constructor field contributes one slot. -/ +def targets : + ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx fuel → + List (Option ConstructorPositivityTrace.Target) + | .parameter _ _ _ _ _ _ _ _ _ _ _ _ tail => tail.targets + | .ordinary _ _ _ _ _ _ _ _ _ _ _ positivity tail => + positivity.target? :: tail.targets + | .terminal _ _ _ _ _ _ => [] + +/-- Erasing one constructor-type trace replays the exact inner +`checkConstructorType.loop` execution. -/ +theorem run + (trace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx fuel) : + checkConstructorType.loop stats isUnsafe familyIdx ctor source argIdx fuel + context = .ok () := by + induction trace with + | parameter context fuel argIdx name domain body binderInfo param + parameterType parameterAt parameterTypeRun defeq tail ih => + rw [show fuel + 1 = Nat.succ fuel by omega] + rw [checkConstructorType.loop.eq_2] + rw [parameterAt] + simp only [ReaderT.bind, Bind.bind] + rw [parameterTypeRun] + simp only [Except.bind, liftTypeChecker_apply] + rw [defeq] + simp only [if_true, ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind, + Except.bind, Except.pure] + exact ih + | ordinary context fuel argIdx name domain body binderInfo sortResult noParameter + ensureType universeTrace positivity tail ih => + rw [show fuel + 1 = Nat.succ fuel by omega] + rw [checkConstructorType.loop.eq_2] + rw [noParameter] + simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply] + rw [ensureType] + simp only [Except.bind] + let next : M PUnit := + withLocalDecl name binderInfo (consumeTypeAnnotations domain) fun arg => + checkConstructorType.loop stats isUnsafe familyIdx ctor + (body.instantiate1 arg) (argIdx + 1) fuel + have nextRun : next context = .ok () := by + simp only [next, withLocalDecl_apply] + exact ih + have restRun : + (do + if !isUnsafe then checkPositivity stats domain ctor argIdx + next) context = .ok () := + positivity.bind_run next () nextRun + cases universeTrace with + | structural valid => + rw [valid] + simp only [if_true, ReaderT.pure, Pure.pure, + ReaderT.bind, Bind.bind, Except.bind, Except.pure] + exact restRun + | fallback structuralFailed valid => + rw [structuralFailed, valid] + simp only [Bool.true_eq_false, Bool.not_true, if_false, + Bool.false_eq_true, + ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind, + Except.bind, Except.pure] + exact restRun + | terminal context source fuel argIdx terminal valid => + rw [show fuel + 1 = Nat.succ fuel by omega] + cases source <;> + simp_all [checkConstructorType.loop, Expr.isForall, + ReaderT.pure, Pure.pure, Except.pure] + +/-- Every successful one-constructor telescope traversal decomposes into the +exact parameter, field, universe, positivity, and terminal trace. -/ +theorem exists_of_run + (success : + checkConstructorType.loop stats isUnsafe familyIdx ctor source argIdx fuel + context = .ok ()) : + Nonempty (ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx fuel) := 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 + cases hparam : stats.params[argIdx]? with + | some param => + rw [hparam] at success + simp only [ReaderT.bind, Bind.bind] at success + cases hget : getType param context with + | error err => simp_all [Except.bind] + | ok parameterType => + rw [hget] at success + simp only [Except.bind, liftTypeChecker_apply] at success + cases hdefeq : TypeChecker.M.run context.env context.safety + context.lctx context.lparams context.fuel + (TypeChecker.isDefEq domain parameterType) with + | error err => simp_all [Except.bind] + | ok equal => + rw [hdefeq] at success + simp only [Except.bind] at success + cases equal with + | false => + change Except.error _ = Except.ok () at success + contradiction + | true => + simp only [if_true, ReaderT.pure, Pure.pure, + ReaderT.bind, Bind.bind, Except.bind, + Except.pure] at success + obtain ⟨tail⟩ := ih success + exact ⟨.parameter context fuel argIdx name domain body + binderInfo param parameterType hparam hget hdefeq tail⟩ + | none => + rw [hparam] at success + simp only [ReaderT.bind, Bind.bind, + liftTypeChecker_apply] at success + cases hensure : TypeChecker.M.run context.env context.safety + context.lctx context.lparams context.fuel + (TypeChecker.ensureType domain) with + | error err => simp_all [Except.bind] + | ok sortResult => + rw [hensure] at success + simp only [Except.bind] at success + have finish + (universeTrace : ConstructorUniverseTrace + stats.resultLevel sortResult.sortLevel!) + (restSuccess : + (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 ()) : + Nonempty (ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context + (.forallE name domain body binderInfo) argIdx (fuel + 1)) := by + 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 typeUnit => + cases typeUnit + rw [hpos] at restSuccess + simp only [Except.bind, withLocalDecl_apply] at restSuccess + have hposLoop : + checkPositivity.loop stats ctor argIdx domain + context.fuel.inductiveFuel context = .ok () := by + unfold checkPositivity at hpos + simpa only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] using hpos + obtain ⟨positivityTrace⟩ := + ConstructorPositivityTrace.exists_of_run hposLoop + obtain ⟨tail⟩ := ih restSuccess + exact ⟨.ordinary context fuel argIdx name domain body + binderInfo sortResult hparam hensure universeTrace + (.safe rfl positivityTrace) tail⟩ + | true => + simp only [Bool.not_true, if_false, + ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind, + Except.bind, Except.pure, + withLocalDecl_apply] at restSuccess + obtain ⟨tail⟩ := ih restSuccess + exact ⟨.ordinary context fuel argIdx name domain body + binderInfo sortResult hparam hensure universeTrace + (.skipped rfl) tail⟩ + cases hstruct : levelStructGe stats.resultLevel + sortResult.sortLevel! with + | true => + rw [hstruct] at success + simp only [if_true, ReaderT.pure, Pure.pure, + ReaderT.bind, Bind.bind, Except.bind, + Except.pure] at success + exact finish (.structural hstruct) success + | false => + rw [hstruct] at success + simp only [Bool.false_eq_true, if_false] at success + cases hfallback : + (stats.resultLevel.isZero || + stats.resultLevel.geq sortResult.sortLevel!) with + | false => + rw [hfallback] at success + change Except.error _ = Except.ok () at success + contradiction + | true => + 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 + exact finish (.fallback hstruct hfallback) success + all_goals + unfold checkConstructorType.loop at success + simp only at success + cases hvalid : isValidIndAppIdx stats _ familyIdx with + | false => + rw [hvalid] at success + change Except.error _ = Except.ok () at success + contradiction + | true => + exact ⟨.terminal context _ fuel argIdx rfl hvalid⟩ + +/-- Execute one constructor telescope while retaining the exact parameter, +universe, positivity, and terminal choices made by the ordinary validator. +The returned data is transparent, so later executable gates can inspect the +same trace without selecting it through `Classical.choice`. -/ +def buildExecution (stats : InductiveStats) (isUnsafe : Bool) + (familyIdx : Nat) (ctor : Name) (context : Context) (source : Expr) + (argIdx : Nat) : + (fuel : Nat) → Except Exception + (ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx fuel) + | 0 => .error .deepRecursion + | fuel + 1 => + match hforall : source.isForall with + | false => + match hvalid : isValidIndAppIdx stats source familyIdx with + | false => .error <| .other s!"invalid return type for '{ctor}'" + | true => .ok (.terminal context source fuel argIdx hforall hvalid) + | true => + match source with + | .forallE name domain body binderInfo => + match hparam : stats.params[argIdx]? with + | some param => + match hget : getType param context with + | .error error => .error error + | .ok parameterType => + match hdefeq : TypeChecker.M.run context.env + context.safety context.lctx context.lparams + context.fuel + (TypeChecker.isDefEq domain parameterType) with + | .error error => .error error + | .ok false => .error <| .other + s!"arg #{argIdx + 1} of '{ctor}' does not match inductive datatype parameters" + | .ok true => + match buildExecution stats isUnsafe familyIdx ctor + context (body.instantiate1 param) (argIdx + 1) + fuel with + | .error error => .error error + | .ok tail => .ok (.parameter context fuel argIdx + name domain body binderInfo param parameterType + hparam hget hdefeq tail) + | none => + match hensure : TypeChecker.M.run context.env context.safety + context.lctx context.lparams context.fuel + (TypeChecker.ensureType domain) with + | .error error => .error error + | .ok sortResult => + let finish (universeTrace : ConstructorUniverseTrace + stats.resultLevel sortResult.sortLevel!) := + match ConstructorPositivityModeTrace.buildExecution + stats isUnsafe ctor argIdx context domain with + | .error error => .error error + | .ok positivity => + match buildExecution stats isUnsafe familyIdx ctor + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) + (argIdx + 1) fuel with + | .error error => .error error + | .ok tail => .ok (.ordinary context fuel argIdx + name domain body binderInfo sortResult hparam + hensure universeTrace positivity tail) + match hstruct : levelStructGe stats.resultLevel + sortResult.sortLevel! with + | true => finish (.structural hstruct) + | false => + match hfallback : stats.resultLevel.isZero || + 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" + | true => finish (.fallback hstruct hfallback) + | _ => .error <| .other + "constructor source shape disagrees with isForall" + +/-- Erasing the inner trace also replays the public one-constructor checker, +including its exact context-fuel read. -/ +theorem check_run + (trace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source 0 context.fuel.inductiveFuel) : + checkConstructorType stats isUnsafe familyIdx ctor source context = .ok () := by + unfold checkConstructorType + simpa only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] using trace.run + +/-- Any exact inner constructor-telescope failure excludes a trace at that +same parameter/field/terminal position and retains the original error value. -/ +theorem not_nonempty_of_error + (failure : + checkConstructorType.loop stats isUnsafe familyIdx ctor source argIdx fuel + context = .error err) : + ¬ Nonempty (ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx fuel) := by + rintro ⟨trace⟩ + have success := trace.run + rw [failure] at success + contradiction + +end ConstructorTypeValidationTrace + +/-- Source-ordered validation of a constructor list. The `seen` index makes +duplicate-name checks part of the trace and prevents reordering or omission. +Root closedness and full type checking are retained before the recursive type +trace, exactly as in `checkConstructors`. -/ +inductive ConstructorListValidationTrace + (stats : InductiveStats) (isUnsafe : Bool) + (familyIdx : Nat) (context : Context) : + NameSet → List Constructor → Type where + | nil (seen : NameSet) : + ConstructorListValidationTrace stats isUnsafe familyIdx context seen [] + | cons + (seen : NameSet) (head : Constructor) (tail : List Constructor) + (fresh : seen.contains head.name = false) + (closed : context.env.checkNoMVarNoFVar head.name head.type = .ok ()) + (rootCheck : CandidateCheckTypeObservation + context.withEmptyLocalContext head.type) + (typeTrace : ConstructorTypeValidationTrace + stats isUnsafe familyIdx head.name context head.type 0 + context.fuel.inductiveFuel) + (tailTrace : ConstructorListValidationTrace stats isUnsafe familyIdx + context (seen.insert head.name) tail) : + ConstructorListValidationTrace stats isUnsafe familyIdx context + seen (head :: tail) + +namespace ConstructorListValidationTrace + +/-- Constructor-ordered positivity observations for one family. -/ +def targets : + ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors → + List (List (Option ConstructorPositivityTrace.Target)) + | .nil _ => [] + | .cons _ _ _ _ _ _ typeTrace tailTrace => + typeTrace.targets :: tailTrace.targets + +/-- Execute the source-ordered constructor fold while retaining its exact +dependent validation trace. Every stored equation is obtained from the same +checker call made by `checkConstructorFold`; no semantic premise participates +in acceptance. -/ +def buildExecution (stats : InductiveStats) (isUnsafe : Bool) + (familyIdx : Nat) (context : Context) : + (seen : NameSet) → (constructors : List Constructor) → + Except Exception + (ConstructorListValidationTrace stats isUnsafe familyIdx context + seen constructors) + | seen, [] => .ok (.nil seen) + | seen, head :: tail => + match hfresh : seen.contains head.name with + | true => .error <| .other s!"duplicate constructor name '{head.name}'" + | false => + match hclosed : context.env.checkNoMVarNoFVar + head.name head.type with + | .error error => .error error + | .ok () => + match hroot : TypeChecker.M.run context.env context.safety {} + context.lparams context.fuel + (TypeChecker.checkType head.type) with + | .error error => .error error + | .ok inferred => + let rootCheck : CandidateCheckTypeObservation + context.withEmptyLocalContext head.type := + ⟨inferred, by + simpa only [CandidateCheckTypeStep.Valid, + Context.withEmptyLocalContext] using hroot⟩ + match ConstructorTypeValidationTrace.buildExecution stats + isUnsafe familyIdx head.name context head.type 0 + context.fuel.inductiveFuel with + | .error error => .error error + | .ok typeTrace => + match buildExecution stats isUnsafe familyIdx context + (seen.insert head.name) tail with + | .error error => .error error + | .ok tailTrace => .ok (.cons seen head tail hfresh + hclosed rootCheck typeTrace tailTrace) + +end ConstructorListValidationTrace + +/-- A transparent presentation of the constructor portion of the executable +validator, discarding only the final duplicate-name accumulator. -/ +def checkConstructorList + (stats : InductiveStats) (isUnsafe : Bool) (familyIdx : Nat) + (context : Context) (seen : NameSet) (ctors : List Constructor) : + Except Exception Unit := do + _ ← checkConstructorFold context.env stats isUnsafe familyIdx seen ctors context + pure () + +/-- For one family, the named list recursion is exactly the array/list shell +of the real constructor validator. -/ +theorem checkConstructors_singleton_eq_checkConstructorList + (indType : InductiveType) (stats : InductiveStats) + (isUnsafe : Bool) (context : Context) : + checkConstructors #[indType] stats isUnsafe context = + checkConstructorList stats isUnsafe 0 context {} indType.ctors := by + unfold checkConstructors + simp only [ReaderT.bind, Bind.bind] + rw [liftTypeChecker_apply] + have hget : + TypeChecker.M.run context.env context.safety context.lctx + 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] + 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 + +def finalSeen : NameSet → List Constructor → NameSet + | seen, [] => seen + | seen, head :: tail => finalSeen (seen.insert head.name) tail + +/-- Exact inversion for a nonempty source list. In particular the recursive +trace is indexed by the literal source tail and the accumulator obtained from +the literal source head, so omission, insertion, duplication, or reordering +cannot be hidden behind an unindexed traversal. -/ +theorem nonempty_cons_iff_exact_source : + Nonempty (ConstructorListValidationTrace stats isUnsafe familyIdx + context seen (head :: tail)) ↔ + seen.contains head.name = false ∧ + context.env.checkNoMVarNoFVar head.name head.type = .ok () ∧ + Nonempty (CandidateCheckTypeObservation + context.withEmptyLocalContext head.type) ∧ + Nonempty (ConstructorTypeValidationTrace stats isUnsafe familyIdx + head.name context head.type 0 context.fuel.inductiveFuel) ∧ + Nonempty (ConstructorListValidationTrace stats isUnsafe familyIdx + context (seen.insert head.name) tail) := by + constructor + · rintro ⟨trace⟩ + cases trace with + | cons _ _ _ fresh closed rootCheck typeTrace tailTrace => + exact ⟨fresh, closed, ⟨rootCheck⟩, ⟨typeTrace⟩, ⟨tailTrace⟩⟩ + · rintro ⟨fresh, closed, ⟨rootCheck⟩, ⟨typeTrace⟩, ⟨tailTrace⟩⟩ + exact ⟨.cons seen head tail fresh closed rootCheck typeTrace tailTrace⟩ + +/-- A duplicate at the current source position fails before all later +constructor phases, exactly as in the executable fold. -/ +theorem not_nonempty_of_duplicate + (duplicate : seen.contains head.name = true) : + ¬ Nonempty (ConstructorListValidationTrace stats isUnsafe familyIdx + context seen (head :: tail)) := by + intro trace + have fresh := (nonempty_cons_iff_exact_source.mp trace).1 + simp_all + +/-- A closedness error at the current source position excludes the trace before +the root type check or constructor telescope is entered. -/ +theorem not_nonempty_of_closedness_error + (failure : context.env.checkNoMVarNoFVar head.name head.type = .error err) : + ¬ Nonempty (ConstructorListValidationTrace stats isUnsafe familyIdx + context seen (head :: tail)) := by + intro trace + have closed := (nonempty_cons_iff_exact_source.mp trace).2.1 + rw [failure] at closed + contradiction + +/-- A closed-root `checkType` error excludes the trace at that exact source +constructor, before parameter and field validation. -/ +theorem not_nonempty_of_root_error + (failure : TypeChecker.M.run context.env context.safety {} + context.lparams context.fuel (TypeChecker.checkType head.type) = + .error err) : + ¬ Nonempty (ConstructorListValidationTrace stats isUnsafe familyIdx + context seen (head :: tail)) := by + intro trace + obtain ⟨rootCheck⟩ := + (nonempty_cons_iff_exact_source.mp trace).2.2.1 + have success := rootCheck.valid + change TypeChecker.M.run context.withEmptyLocalContext.env + context.withEmptyLocalContext.safety + context.withEmptyLocalContext.lctx + context.withEmptyLocalContext.lparams + context.withEmptyLocalContext.fuel + (TypeChecker.checkType head.type) = .ok rootCheck.inferred at success + simp only [Context.withEmptyLocalContext] at success + rw [failure] at success + contradiction + +/-- An inner parameter, field, universe, positivity, recursive-target, or +terminal-family error excludes the trace at the current constructor. -/ +theorem not_nonempty_of_type_error + (failure : checkConstructorType stats isUnsafe familyIdx + head.name head.type context = .error err) : + ¬ Nonempty (ConstructorListValidationTrace stats isUnsafe familyIdx + context seen (head :: tail)) := by + intro trace + obtain ⟨typeTrace⟩ := + (nonempty_cons_iff_exact_source.mp trace).2.2.2.1 + have success := typeTrace.check_run + rw [failure] at success + contradiction + +/-- Erasing an ordered trace replays the exact stateful constructor fold. -/ +theorem fold_run + (trace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen ctors) : + checkConstructorFold context.env stats isUnsafe familyIdx seen ctors context = + .ok (finalSeen seen ctors) := by + induction trace with + | nil => rfl + | cons seen head tail fresh closed rootCheck typeTrace tailTrace ih => + have hroot := rootCheck.valid + change TypeChecker.M.run context.withEmptyLocalContext.env + context.withEmptyLocalContext.safety + context.withEmptyLocalContext.lctx + context.withEmptyLocalContext.lparams + context.withEmptyLocalContext.fuel + (TypeChecker.checkType head.type) = + .ok rootCheck.inferred at hroot + simp only [Context.withEmptyLocalContext] at hroot + unfold checkConstructorFold + simp only + rw [fresh] + simp only [Bool.false_eq_true, if_false, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] + rw [closed] + simp only [ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure, liftExcept_apply] + rw [withEmptyLocalContext_apply] + rw [liftTypeChecker_apply] + rw [hroot] + simp only [Except.bind, readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.pure, Pure.pure, Except.pure] + rw [typeTrace.check_run] + change checkConstructorFold context.env stats isUnsafe familyIdx + (seen.insert head.name) tail context = + .ok (finalSeen (seen.insert head.name) tail) + exact ih + +/-- Any successful stateful constructor fold decomposes into the complete +source-ordered list trace; the final accumulator value itself is irrelevant. -/ +theorem exists_of_fold_run + (success : checkConstructorFold context.env stats isUnsafe familyIdx + seen ctors context = .ok result) : + Nonempty (ConstructorListValidationTrace stats isUnsafe familyIdx + context seen ctors) := by + induction ctors generalizing seen result with + | nil => exact ⟨.nil seen⟩ + | cons head tail ih => + unfold checkConstructorFold at success + simp only at success + cases hfresh : seen.contains head.name with + | true => + rw [hfresh] at success + change Except.error _ = Except.ok result at success + contradiction + | false => + 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 + cases hclosed : context.env.checkNoMVarNoFVar + head.name head.type with + | error err => simp_all [liftExcept_apply, Except.bind] + | ok closedResult => + cases closedResult + rw [hclosed] at success + simp only [liftExcept_apply, Except.bind] at success + rw [withEmptyLocalContext_apply, liftTypeChecker_apply] at success + cases hroot : TypeChecker.M.run context.env context.safety {} + context.lparams context.fuel + (TypeChecker.checkType head.type) with + | error err => simp_all [Except.bind] + | ok inferred => + rw [hroot] 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⟩ := + ConstructorTypeValidationTrace.exists_of_run htypeLoop + have rootCheck : CandidateCheckTypeObservation + context.withEmptyLocalContext head.type := + ⟨inferred, by + simpa only [CandidateCheckTypeStep.Valid, + Context.withEmptyLocalContext] using hroot⟩ + change checkConstructorFold context.env stats isUnsafe + familyIdx (seen.insert head.name) tail context = + .ok result at success + obtain ⟨tailTrace⟩ := ih success + exact ⟨.cons seen head tail hfresh hclosed rootCheck + typeTrace tailTrace⟩ + +/-- 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 + (failure : checkConstructorFold context.env stats isUnsafe familyIdx + seen ctors context = .error err) : + ¬ Nonempty (ConstructorListValidationTrace stats isUnsafe familyIdx + context seen ctors) := by + rintro ⟨trace⟩ + have success := trace.fold_run + rw [failure] at success + contradiction + +/-- Erasing an ordered list trace replays the transparent list validator. -/ +theorem run + (trace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen ctors) : + checkConstructorList stats isUnsafe familyIdx context seen ctors = .ok () := by + unfold checkConstructorList + rw [trace.fold_run] + rfl + +end ConstructorListValidationTrace + +/-! ## Arbitrary mutual-block validation owners -/ + +/-- The exact result selected when the ordinary family validator reaches its +continuation. Retaining the reader context matters: later constructor +validation uses the shared parameters and local declarations installed by +that very run. -/ +structure FamilyValidationBlockResult where + stats : InductiveStats + validationContext : Context + +/-- Observe the successful continuation of `checkInductiveTypes` without +changing any validation branch or error. -/ +def observeFamilyValidationBlock (nparams : Nat) + (indTypes : List InductiveType) (context : Context) : + Except Exception FamilyValidationBlockResult := + checkInductiveTypes nparams indTypes.toArray + (fun stats => fun validationContext => + .ok ⟨stats, validationContext⟩) context + +/-- Complete retained family-validation run for an arbitrary source-ordered +block. + +`run` is the real validator execution, so every later family has already +passed the kernel's definitional parameter comparison and result-level +equivalence phase. The remaining equations expose the terminal invariants +which Lean asserts before invoking the continuation. -/ +structure FamilyValidationBlockRun (nparams : Nat) + (indTypes : List InductiveType) (context : Context) where + result : FamilyValidationBlockResult + run : observeFamilyValidationBlock nparams indTypes context = .ok result + params_size : result.stats.params.size = nparams + nindices_size : result.stats.nindices.size = indTypes.length + indConsts_size : result.stats.indConsts.size = indTypes.length + +namespace FamilyValidationBlockRun + +/-- Execute and retain the ordinary family validator. The explicit terminal +checks mirror its internal assertions and make malformed instrumentation fail +instead of yielding a weaker certificate. -/ +def buildExecution (nparams : Nat) (indTypes : List InductiveType) + (context : Context) : + Except Exception (FamilyValidationBlockRun nparams indTypes context) := + match hrun : observeFamilyValidationBlock nparams indTypes context with + | .error error => .error error + | .ok result => + if hparams : result.stats.params.size = nparams then + if hnindices : result.stats.nindices.size = indTypes.length then + if hconsts : result.stats.indConsts.size = indTypes.length then + .ok { + result + run := hrun + params_size := hparams + nindices_size := hnindices + indConsts_size := hconsts } + else .error (.other "family-validation constant-count invariant failed") + else .error (.other "family-validation index-count invariant failed") + else .error (.other "family-validation parameter-count invariant failed") + +/-- Shared parameters selected by the first family and definitionally checked +against every later family. -/ +def parameters (run : FamilyValidationBlockRun nparams indTypes context) : + Array Expr := + run.result.stats.params + +/-- Common result universe selected by the first family and equivalence- +checked against every later family. -/ +def resultLevel (run : FamilyValidationBlockRun nparams indTypes context) : + Level := + run.result.stats.resultLevel + +end FamilyValidationBlockRun + +/-- Source-indexed constructor traces for every family in a block. The +natural index advances with the source list, so a trace for one family cannot +be reused at another family ordinal. -/ +inductive ConstructorBlockValidationTraces + (stats : InductiveStats) (isUnsafe : Bool) (context : Context) : + Nat → List InductiveType → Type where + | nil {familyIdx : Nat} : + ConstructorBlockValidationTraces stats isUnsafe context familyIdx [] + | cons {familyIdx : Nat} {type : InductiveType} + {types : List InductiveType} + (head : ConstructorListValidationTrace stats isUnsafe familyIdx + context {} type.ctors) + (tail : ConstructorBlockValidationTraces stats isUnsafe context + (familyIdx + 1) types) : + ConstructorBlockValidationTraces stats isUnsafe context familyIdx + (type :: types) + +namespace ConstructorBlockValidationTraces + +/-- Family-, constructor-, and field-ordered recursive-target matrix selected +by the executable arbitrary-block validator. -/ +def targets : + ConstructorBlockValidationTraces stats isUnsafe context familyIdx types → + List (List (List (Option ConstructorPositivityTrace.Target))) + | .nil => [] + | .cons head tail => head.targets :: tail.targets + +/-- Execute each source-indexed list trace in the one shared post-family +context. -/ +def buildExecution (stats : InductiveStats) (isUnsafe : Bool) + (context : Context) : + (familyIdx : Nat) → (types : List InductiveType) → + Except Exception + (ConstructorBlockValidationTraces stats isUnsafe context + familyIdx types) + | _, [] => .ok .nil + | familyIdx, type :: types => + match ConstructorListValidationTrace.buildExecution stats isUnsafe + familyIdx context {} type.ctors with + | .error error => .error error + | .ok head => + match buildExecution stats isUnsafe context (familyIdx + 1) types with + | .error error => .error error + | .ok tail => .ok (.cons head tail) + +end ConstructorBlockValidationTraces + +/-- Complete operational constructor-validation owner for an arbitrary +mutual block. `run` is the actual block call; `traces` retains every +family/constructor/field branch, including cross-family target ordinals and +recursive-Pi paths. -/ +structure ConstructorBlockValidationRun + (indTypes : List InductiveType) (stats : InductiveStats) + (isUnsafe : Bool) (context : Context) where + traces : ConstructorBlockValidationTraces stats isUnsafe context 0 indTypes + run : checkConstructors indTypes.toArray stats isUnsafe context = .ok () + +namespace ConstructorBlockValidationRun + +/-- Execute the real block validator and retain the exact dependent trace +hierarchy for that same source list. -/ +def buildExecution (indTypes : List InductiveType) + (stats : InductiveStats) (isUnsafe : Bool) (context : Context) : + Except Exception + (ConstructorBlockValidationRun indTypes stats isUnsafe context) := + match hrun : checkConstructors indTypes.toArray stats isUnsafe context with + | .error error => .error error + | .ok () => + match ConstructorBlockValidationTraces.buildExecution stats isUnsafe + context 0 indTypes with + | .error error => .error error + | .ok traces => .ok ⟨traces, hrun⟩ + +end ConstructorBlockValidationRun + +/-- The complete retained operational constructor-validation run for one +singleton family. -/ +structure ConstructorValidationRun + (indType : InductiveType) (stats : InductiveStats) + (isUnsafe : Bool) (context : Context) where + trace : ConstructorListValidationTrace stats isUnsafe 0 context {} + indType.ctors + +namespace ConstructorValidationRun + +/-- Transparent decomposition of the ordinary singleton constructor +validator. Successful output is executable data rather than a +`Classical.choice`, which lets subsequent D2/D3 audits compute over the exact +retained branch structure. -/ +def buildExecution (indType : InductiveType) (stats : InductiveStats) + (isUnsafe : Bool) (context : Context) : + Except Exception + (ConstructorValidationRun indType stats isUnsafe context) := + match ConstructorListValidationTrace.buildExecution stats isUnsafe 0 + context {} indType.ctors with + | .error error => .error error + | .ok trace => .ok ⟨trace⟩ + +/-- Recomposition: retained operational evidence replays the real singleton +`checkConstructors` execution exactly. -/ +theorem run + (validation : ConstructorValidationRun indType stats isUnsafe context) : + checkConstructors #[indType] stats isUnsafe context = .ok () := by + rw [checkConstructors_singleton_eq_checkConstructorList] + exact validation.trace.run + +/-- Decomposition: every successful real singleton `checkConstructors` run +has complete retained operational evidence. -/ +theorem nonempty_of_run + (success : checkConstructors #[indType] stats isUnsafe context = .ok ()) : + Nonempty (ConstructorValidationRun indType stats isUnsafe context) := 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⟩ := + 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 + (success : checkConstructors #[indType] stats isUnsafe context = .ok ()) : + ConstructorValidationRun indType stats isUnsafe context := + Classical.choice (nonempty_of_run success) + +/-- Exact decomposition/recomposition contract for singleton constructor +validation. -/ +theorem nonempty_iff_checkConstructors_ok : + Nonempty (ConstructorValidationRun indType stats isUnsafe context) ↔ + checkConstructors #[indType] stats isUnsafe context = .ok () := by + constructor + · rintro ⟨validation⟩ + exact validation.run + · exact nonempty_of_run + +/-- Any phase-specific executable error excludes a successful retained run. -/ +theorem not_nonempty_of_error + (failure : checkConstructors #[indType] stats isUnsafe context = .error err) : + ¬ Nonempty (ConstructorValidationRun indType stats isUnsafe context) := by + intro validation + have success := nonempty_iff_checkConstructors_ok.mp validation + rw [failure] at success + contradiction + +end ConstructorValidationRun + +/-- +info: 'Lean4Lean.AddInductive.FamilyValidationBlockRun.buildExecution' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms FamilyValidationBlockRun.buildExecution + +/-- +info: 'Lean4Lean.AddInductive.ConstructorBlockValidationRun.buildExecution' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorBlockValidationRun.buildExecution + +/-- +info: 'Lean4Lean.AddInductive.ConstructorListValidationTrace.nonempty_cons_iff_exact_source' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorListValidationTrace.nonempty_cons_iff_exact_source + +/-- +info: 'Lean4Lean.AddInductive.ConstructorValidationRun.run' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorValidationRun.run + +/-- +info: 'Lean4Lean.AddInductive.ConstructorValidationRun.nonempty_of_run' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorValidationRun.nonempty_of_run + +/-- +info: 'Lean4Lean.AddInductive.ConstructorValidationRun.of_run' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorValidationRun.of_run + +/-- +info: 'Lean4Lean.AddInductive.ConstructorValidationRun.nonempty_iff_checkConstructors_ok' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorValidationRun.nonempty_iff_checkConstructors_ok + +/-- +info: 'Lean4Lean.AddInductive.ConstructorValidationRun.not_nonempty_of_error' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorValidationRun.not_nonempty_of_error + +end AddInductive +end Lean4Lean diff --git a/Lean4Lean/Level.lean b/Lean4Lean/Level.lean index e8b64987..59c8777b 100644 --- a/Lean4Lean/Level.lean +++ b/Lean4Lean/Level.lean @@ -74,9 +74,7 @@ def NormLevel := Std.TreeMap (List Name) Node compare deriving Repr instance : BEq NormLevel where - beq l₁ l₂ := - (l₁.all fun p n => l₂.get? p == some n) && - (l₂.all fun p n => l₁.get? p == some n) + beq l₁ l₂ := l₁.toList == l₂.toList def VarNode.addVar (v : Name) (k : Nat) : List VarNode → List VarNode | [] => [⟨v, k⟩] @@ -131,17 +129,27 @@ 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 } + 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₂ => - if !subset compare p₂ p₁ then n₁ else - let same := p₁.length == p₂.length - 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 } + 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 @@ -162,12 +170,13 @@ def leVars : List VarNode → List VarNode → Bool | .gt => leVars (x :: xs) ys def NormLevel.le (l₁ l₂ : NormLevel) : Bool := - l₁.all fun p₁ n₁ => + l₁.toList.all fun (p₁, n₁) => if n₁.const = 0 && n₁.var.isEmpty then true else - l₂.any fun p₂ n₂ => + l₂.toList.any fun (p₂, n₂) => (!n₂.var.isEmpty || n₁.var.isEmpty) && subset compare p₂ p₁ && - (n₁.const ≤ n₂.const || n₂.var.any (n₁.const ≤ ·.offset + 1)) && + (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 @@ -243,9 +252,22 @@ end Normalize def normalize' (l : Level) : Level := (Normalize.normalize l (paths := true)).toTree.reify -def isEquiv' (u v : Level) : Bool := u == v || Normalize.normalize u == Normalize.normalize v - -def isEquivList : List Level → List Level → Bool := List.all2 isEquiv +/-- A transparent structural equality test for levels. Unlike `Level.beq`, +this test has no opaque runtime contract, so its successful branch can be used +directly by the verified checker. -/ +def isStructEq : Level → Level → Bool + | .zero, .zero => true + | .succ u, .succ v => isStructEq u v + | .max u₁ u₂, .max v₁ v₂ + | .imax u₁ u₂, .imax v₁ v₂ => isStructEq u₁ v₁ && isStructEq u₂ v₂ + | .param u, .param v => u == v + | .mvar ⟨u⟩, .mvar ⟨v⟩ => u == v + | _, _ => false + +def isEquiv' (u v : Level) : Bool := + isStructEq 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) diff --git a/Lean4Lean/Theory/ConstructorValidityFixtures.lean b/Lean4Lean/Theory/ConstructorValidityFixtures.lean new file mode 100644 index 00000000..26fc3e04 --- /dev/null +++ b/Lean4Lean/Theory/ConstructorValidityFixtures.lean @@ -0,0 +1,168 @@ +import Lean4Lean.Theory.InductiveFixtures + +/-! +# Constructor-validity parity fixtures + +Focused singleton declarations for L4L-05. The positive declarations retain +real kernel metadata while remaining inside the already-supported large- +elimination and non-K fragment. The failed declarations pin the nearest +Lean elaborator/kernel rejection for each neighboring positivity or universe +branch; `#guard_msgs` rolls every failed declaration back. +-/ + +namespace Lean4Lean +namespace InductiveFixtures +open VInductDecl + +universe u + +/-! ## Type-valued dependency and positivity matrix -/ + +/-- A source-ordered constructor covering the non-Prop universe boundary, +dependent proof fields, direct recursion, a recursive function, and an +independent/dependent suffix after both recursive outer fields. -/ +inductive ConstructorValidityMatrix (α : Type u) (P : α → Prop) : Type u where + | mk (x : α) (proof : P x) + (direct : ConstructorValidityMatrix α P) + (function : (y : α) → ConstructorValidityMatrix α P) + (later : α) (laterProof : P later) : + ConstructorValidityMatrix α P + +def constructorValidityMatrixType : VInductiveType where + name := ``ConstructorValidityMatrix + uvars := 1 + type := vconst(type_of% @ConstructorValidityMatrix).type + ctors := [⟨vconst(type_of% @ConstructorValidityMatrix.mk), + ``ConstructorValidityMatrix.mk⟩] + +def constructorValidityMatrixDecl : VInductDecl := + ⟨1, 2, [constructorValidityMatrixType]⟩ + +example : constructorValidityMatrixDecl.stage3 = true := rfl + +def constructorValidityMatrixChecked : constructorValidityMatrixDecl.Checked := + constructorValidityMatrixDecl.checked?.get (by decide) + +def constructorValidityMatrixGenerationChecked : + GenerationChecked constructorValidityMatrixDecl := + (identityGeneration? constructorValidityMatrixDecl).get (by decide) + +private def l4l05PermC (constant : VConstant) + (levels : List VLevel) : VConstant := + ⟨constant.uvars, constant.type.instL levels⟩ + +example : constructorValidityMatrixGenerationChecked.recursor = + l4l05PermC (vconst(type_of% @ConstructorValidityMatrix.rec)) + [.param 1, .param 0] := rfl + +example : constructorValidityMatrixChecked.resultLevel = + .succ (.param 0) := rfl + +example : constructorValidityMatrixChecked.constructors[0].fields.length = 6 := + rfl + +example : constructorValidityMatrixChecked.constructors[0].recursive.map + (fun position => (position.fieldIndex, position.binders.length)) = + [(2, 0), (3, 1)] := rfl + +example : + constructorValidityMatrixGenerationChecked.generatedRules.length = 1 := + rfl + +/-! ## Prop-valued recursive-function universe boundary -/ + +/-- The ordinary field `a : α` reaches the impredicative-Prop constructor +universe branch. The varying recursive target prevents parameter promotion, +and the single constructor remains a legitimate non-K large eliminator. -/ +inductive PropRecursiveBoundary (α : Type u) : α → Prop where + | mk (a : α) (next : (b : α) → PropRecursiveBoundary α b) : + PropRecursiveBoundary α a + +def propRecursiveBoundaryType : VInductiveType where + name := ``PropRecursiveBoundary + uvars := 1 + type := vconst(type_of% @PropRecursiveBoundary).type + ctors := [⟨vconst(type_of% @PropRecursiveBoundary.mk), + ``PropRecursiveBoundary.mk⟩] + +def propRecursiveBoundaryDecl : VInductDecl := + ⟨1, 1, [propRecursiveBoundaryType]⟩ + +example : propRecursiveBoundaryDecl.stage3 = true := rfl + +def propRecursiveBoundaryChecked : propRecursiveBoundaryDecl.Checked := + propRecursiveBoundaryDecl.checked?.get (by decide) + +def propRecursiveBoundaryGenerationChecked : + GenerationChecked propRecursiveBoundaryDecl := + (identityGeneration? propRecursiveBoundaryDecl).get (by decide) + +example : propRecursiveBoundaryGenerationChecked.recursor = + l4l05PermC (vconst(type_of% @PropRecursiveBoundary.rec)) + [.param 1, .param 0] := rfl + +example : propRecursiveBoundaryChecked.resultLevel = .zero := rfl + +example : propRecursiveBoundaryChecked.constructors[0].fields.length = 2 := rfl + +example : propRecursiveBoundaryChecked.constructors[0].recursive.map + (fun position => (position.fieldIndex, position.binders.length)) = + [(1, 1)] := rfl + +example : propRecursiveBoundaryGenerationChecked.generatedRules.length = 1 := + rfl + +/-! ## Nearest-kernel rejection matrix -/ + +namespace KernelDifferential + +opaque L4L05TypeBox : Type → Type +opaque L4L05ProofBox : Type → Prop +opaque L4L05DepProofBox (α : Type) : α → Prop + +/-- +error: (kernel) arg #1 of 'Lean4Lean.InductiveFixtures.KernelDifferential.L4L05NestedNegative.mk' has a non positive occurrence of the datatypes being declared +-/ +#guard_msgs in +inductive L4L05NestedNegative : Type where + | mk : ((L4L05NestedNegative → Prop) → L4L05NestedNegative) → + L4L05NestedNegative + +/-- +error: (kernel) arg #1 of 'Lean4Lean.InductiveFixtures.KernelDifferential.L4L05FamilyNonrecursive.mk' contains a non valid occurrence of the datatypes being declared +-/ +#guard_msgs in +inductive L4L05FamilyNonrecursive : Type where + | mk : L4L05TypeBox L4L05FamilyNonrecursive → L4L05FamilyNonrecursive + +/-- +error: (kernel) arg #1 of 'Lean4Lean.InductiveFixtures.KernelDifferential.L4L05FamilyProof.mk' contains a non valid occurrence of the datatypes being declared +-/ +#guard_msgs in +inductive L4L05FamilyProof : Type where + | mk : L4L05ProofBox L4L05FamilyProof → L4L05FamilyProof + +/-- +error: (kernel) arg #2 of 'Lean4Lean.InductiveFixtures.KernelDifferential.L4L05RecursiveDependency.mk' contains a non valid occurrence of the datatypes being declared +-/ +#guard_msgs in +inductive L4L05RecursiveDependency : Type where + | mk (recursive : L4L05RecursiveDependency) + (proof : L4L05DepProofBox L4L05RecursiveDependency recursive) : + L4L05RecursiveDependency + +/-- +error: Invalid universe level in constructor `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05UniverseReject.mk`: Parameter `α` has type + Type +at universe level + 2 +which is not less than or equal to the inductive type's resulting universe level + 1 +-/ +#guard_msgs in +inductive L4L05UniverseReject : Type where + | mk (α : Type) : L4L05UniverseReject + +end KernelDifferential +end InductiveFixtures +end Lean4Lean diff --git a/Lean4Lean/Theory/Inductive.lean b/Lean4Lean/Theory/Inductive.lean index caf51606..66a7bb1b 100644 --- a/Lean4Lean/Theory/Inductive.lean +++ b/Lean4Lean/Theory/Inductive.lean @@ -156,15 +156,121 @@ def recFieldIdxs (B : VExpr) : List VExpr := (VExpr.appArgs B []).drop np /-- One recursive constructor argument after normalization. `binders` is the possibly empty Pi telescope leading to the recursive target. `fieldIndex` addresses the constructor field itself, while target indices live under both -the preceding constructor fields and these binders. `targetType` is reserved -for the mutual-block index introduced by I3; it is zero in the current -one-family analyzer. -/ +the preceding constructor fields and these binders. `targetType` is the +source-ordered family ordinal retained by block analysis; it remains zero in +the one-family compatibility analyzer. -/ structure RecArg where fieldIndex : Nat binders : List VExpr targetType : Nat indices : List VExpr +/-- Whether an expression mentions any family in a block. Mutual analysis +uses one block-wide name set in family formers, recursive-Pi domains, and +recursive indices; checking only the current family would miss negative +occurrences of its siblings. -/ +def _root_.Lean4Lean.VExpr.hasAnyConst (names : List Name) (e : VExpr) : Bool := + names.any e.hasConst + +/-- The part of a family declaration needed to recognize a recursive target. +The position of a header in `familyHeaders` is the `RecArg.targetType` stored +by the block analyzer. -/ +structure FamilyHeader where + name : Name + indices : Nat + +/-- Family headers in declaration order. -/ +def familyHeaders (np : Nat) (types : List VInductiveType) : + List FamilyHeader := + types.map fun ty => + ⟨ty.name, (ctorFields (VExpr.dropN np ty.type)).length⟩ + +/-- Recognize an application of any family in a mutual block. The returned +ordinal is its exact position in `headers`; parameter arguments must be the +shared parameter variables and every index must be free of all block +families. -/ +def blockTarget? (U np j : Nat) (headers : List FamilyHeader) + (names : List Name) (B : VExpr) : Option (Nat × List VExpr) := + let head := B.appHead + let args := B.appArgs [] + let rec loop (target : Nat) : List FamilyHeader → + Option (Nat × List VExpr) + | [] => none + | header :: headers => + if head == .const header.name (VLevel.params U) && + args.length == np + header.indices && + args.take np == VExpr.bvarRevRange j np && + (args.drop np).all fun e => !e.hasAnyConst names then + some (target, args.drop np) + else + loop (target + 1) headers + loop 0 headers + +/-- Recognize a recursive mutual target below a possibly empty positive Pi +telescope. No block family may occur in a Pi domain. -/ +def blockRecTarget? (U np : Nat) (headers : List FamilyHeader) + (names : List Name) : Nat → VExpr → + Option (List VExpr × Nat × List VExpr) + | j, .forallE A rest => + if A.hasAnyConst names then none + else + match blockRecTarget? U np headers names (j+1) rest with + | some (binders, target, indices) => + some (A :: binders, target, indices) + | none => none + | j, B => + match blockTarget? U np j headers names B with + | some (target, indices) => some ([], target, indices) + | none => none + +/-- Analyze one constructor field against every family in a block. -/ +def blockRecArg? (U np : Nat) (headers : List FamilyHeader) + (names : List Name) (j : Nat) (B : VExpr) : Option RecArg := + match blockRecTarget? U np headers names j B with + | some (binders, targetType, indices) => + some { fieldIndex := j, binders, targetType, indices } + | none => none + +/-- Recursive arguments in source field order, with block-relative target +ordinals. -/ +def blockRecArgs (U np : Nat) (headers : List FamilyHeader) + (names : List Name) : List VExpr → (j : Nat := 0) → List RecArg + | [], _ => [] + | B :: Bs, j => + match blockRecArg? U np headers names j B with + | some r => r :: blockRecArgs U np headers names Bs (j+1) + | none => blockRecArgs U np headers names Bs (j+1) + +/-- Positional mutual recursive classification for every constructor field. +Unlike `blockRecArgs`, this list retains `none` entries, giving semantic +consumers an exact field-by-field alignment without rerunning the analyzer. -/ +def blockRecArgsAt (U np : Nat) (headers : List FamilyHeader) + (names : List Name) : List VExpr → (j : Nat := 0) → + List (Option RecArg) + | [], _ => [] + | B :: Bs, j => + blockRecArg? U np headers names j B :: + blockRecArgsAt U np headers names Bs (j + 1) + +/-- A mutual constructor field is either a positive recursive target of some +family in the block or is free of every block family. -/ +def blockStage3Field (U np : Nat) (headers : List FamilyHeader) + (names : List Name) (j : Nat) (B : VExpr) : Bool := + (blockRecArg? U np headers names j B).isSome || + !B.hasAnyConst names + +/-- Structural mutual constructor shape. Fields may target any family, but +the constructor result must target its owning family ordinal. -/ +def blockStage3Ctor (U np : Nat) (headers : List FamilyHeader) + (names : List Name) (owner : Nat) : Nat → VExpr → Bool + | j, .forallE B rest => + blockStage3Field U np headers names j B && + blockStage3Ctor U np headers names owner (j+1) rest + | j, result => + match blockTarget? U np j headers names result with + | some (target, _) => target == owner + | none => false + /-- Recognize the kernel's one-family `isRecArg` shape in raw VExpr normal form. Pi domains must be free of the family (the local strict-positivity condition); the terminal target must be the family applied to the declaration @@ -196,6 +302,13 @@ def recArgs (ni : Nat) : List VExpr → (j : Nat := 0) → List RecArg | some r => r :: recArgs ni Bs (j+1) | none => recArgs ni Bs (j+1) +/-- Positional one-family recursive classification retained for compatibility +with the block-wide checked-constructor representation. -/ +def recArgsAt (ni : Nat) : List VExpr → (j : Nat := 0) → + List (Option RecArg) + | [], _ => [] + | B :: Bs, j => recArg? U T np ni j B :: recArgsAt ni Bs (j + 1) + /-- Positions of the directly recursive fields, with their index arguments (`j` counts binders past the parameters). -/ def recPairs (ni : Nat) : List VExpr → (j : Nat := 0) → List (Nat × List VExpr) @@ -230,15 +343,55 @@ def stage3Ctor (ni : Nat) : Nat → VExpr → Bool | j, .forallE B rest => stage3Field U T np ni j B && stage3Ctor ni (j+1) rest | j, e => isRecField U T np ni j e -/-- The kernel's subsingleton-elimination criterion, strengthened -syntactically: every non-recursive field appears literally among the -result's index arguments. -/ +/-- Levels that are structurally forced to evaluate to zero. This is the +environment-free fragment needed to recognize proof-valued constructor +fields; Verify supplies the exact ordinary-checker sort observations. -/ +def _root_.Lean4Lean.VLevel.isDefinitelyZero : VLevel → Bool + | .zero => true + | .max l₁ l₂ => l₁.isDefinitelyZero && l₂.isDefinitelyZero + | .imax _ l₂ => l₂.isDefinitelyZero + | .param _ | .succ _ => false + +/-- Partial local type synthesis used only to recognize fields whose inferred +sort is structurally `Prop`. Constants and terms requiring reduction remain +unknown and are conservatively treated as data. -/ +def inferLocalType? (Γ : List VExpr) : VExpr → Option VExpr + | .bvar i => Γ[i]? + | .sort l => some (.sort (.succ l)) + | .const _ _ => none + | .app f a => do + let .forallE _ body ← inferLocalType? Γ f | none + return body.inst a + | .lam A body => do + let bodyType ← inferLocalType? (A :: Γ) body + return .forallE A bodyType + | .forallE A body => do + let .sort u ← inferLocalType? Γ A | none + let .sort v ← inferLocalType? (A :: Γ) body | none + return .sort (.imax u v) + +/-- Whether the partial local synthesis proves that a binder is a proof. -/ +def knownProofField (Γ : List VExpr) (B : VExpr) : Bool := + match inferLocalType? Γ B with + | some (.sort l) => l.isDefinitelyZero + | _ => false + +/-- The kernel's singleton large-elimination criterion. Recursive arguments +and proof fields impose no recovery condition; every remaining data field +must occur literally in the constructor result's index spine. The proof-field +test is a conservative environment-free reflection here and is connected to +the exact checker result by Verify. -/ def subsingletonOK (ni : Nat) (ct : VExpr) : Bool := - let Bs := ctorFields ct + let Bs := ctorFields (VExpr.dropN np ct) let m := Bs.length - let ridx := recFieldIdxs np (VExpr.resultOf ct) - Bs.zipIdx.all fun (B, j) => - (recArg? U T np ni j B).isSome || ridx.contains (.bvar (m-1-j)) + let ridx := recFieldIdxs np (VExpr.resultOf (VExpr.dropN np ct)) + let rec loop (Γ : List VExpr) (j : Nat) : List VExpr → Bool + | [] => true + | B :: Bs => + ((recArg? U T np ni j B).isSome || knownProofField Γ B || + ridx.contains (.bvar (m-1-j))) && + loop (B :: Γ) (j+1) Bs + loop (VExpr.telN np ct).reverse 0 Bs /-- Large elimination: a never-zero result sort, or the (syntactic) subsingleton criterion. -/ @@ -246,9 +399,27 @@ def largeElim (ni : Nat) (ty : VInductiveType) : Bool := (sortLevel np ty).isNeverZero || match ty.ctors with | [] => true - | [c] => subsingletonOK U T np ni (VExpr.dropN np c.type) + | [c] => subsingletonOK U T np ni c.type | _ => false +/-- The constructor-shape fragment of the kernel's K-target test. Only the +visible shared-parameter prefix may precede the constructor result. -/ +def isKTargetCtor (nparams : Nat) : Nat → VExpr → Bool + | i, .forallE _ body => + i < nparams && isKTargetCtor nparams (i + 1) body + | _, _ => true + +/-- Whether a checked one-family declaration receives the kernel's K-like +recursor reduction flag. This decision is deliberately independent of +`largeElim`: K eligibility must never be used to bypass the ordinary +large-elimination criterion. -/ +def isKTarget (np : Nat) (resultLevel : VLevel) + (ty : VInductiveType) : Bool := + resultLevel == .zero && + match ty.ctors with + | [ctor] => isKTargetCtor np 0 ctor.type + | _ => false + /-- A family type is checked before its own constant is declared, so neither its parameter nor index domains may already mention the family. This is the one-family form of `checkInductiveTypes`' pre-environment type check. -/ @@ -265,7 +436,6 @@ def stage3DirectCore (U np : Nat) (ty : VInductiveType) : Bool := | .sort l => decide (l.WF U) | _ => false) && typeFormerOK np ty && - largeElim U ty.name np ni ty && ty.ctors.all fun c => c.uvars == U && VExpr.telN np c.type == VExpr.telN np ty.type && stage3Ctor U ty.name np ni 0 (VExpr.dropN np c.type) @@ -300,6 +470,62 @@ def stage3Core : VInductDecl → Bool stage3DirectCore U np ty && (namesOK ty && (closedOK ty && levelsOK U ty)) | _ => false +/-- Family names in exact declaration order. -/ +def familyNames (types : List VInductiveType) : List Name := + types.map (·.name) + +/-- The shared parameter telescope selected by the first family. Empty +blocks are rejected by `checkedBlock?`; defining this total function keeps the +dependent traversal itself free of a singleton/nonempty witness. -/ +def blockParams (np : Nat) : List VInductiveType → List VExpr + | [] => [] + | ty :: _ => VExpr.telN np ty.type + +/-- A family former in a mutual block is checked before any family constant +is staged, so every parameter and index domain must be free of every family +in the block. -/ +def blockTypeFormerOK (np : Nat) (names : List Name) + (ty : VInductiveType) : Bool := + (VExpr.telN np ty.type).all (fun e => !e.hasAnyConst names) && + (ctorFields (VExpr.dropN np ty.type)).all + (fun e => !e.hasAnyConst names) + +/-- Names reserved by the mutual pipeline: all families, then all constructors +in family/source order, then one recursor per family. Validation retains this +order as checked data, and the block transaction inserts the same three +constant phases before installing generated rules. -/ +def blockGeneratedNames (types : List VInductiveType) : List Name := + types.map (·.name) ++ + types.flatMap (fun ty => ty.ctors.map (·.name)) ++ + types.map (fun ty => .str ty.name "rec") + +/-- Block-wide duplicate/collision check for all future generated names. -/ +def blockNamesOK (types : List VInductiveType) : Bool := + decide (blockGeneratedNames types).Nodup + +/-- Environment-free structural representation check for one family in a +mutual block. It checks raw metadata anatomy and cross-family positivity. +Environment-sensitive normalization, shared-result-universe semantics, and +staging are supplied separately by `ValidatedBlock.WF` and +`ValidationCertificate`. -/ +def blockFamilyCore (source : VInductDecl) (params : List VExpr) + (owner : Nat) (ty : VInductiveType) : Bool := + let names := familyNames source.types + let headers := familyHeaders source.nparams source.types + ty.uvars == source.uvars && + params.length == source.nparams && + VExpr.telN source.nparams ty.type == params && + (match VExpr.resultOf (VExpr.dropN source.nparams ty.type) with + | .sort l => decide (l.WF source.uvars) + | _ => false) && + blockTypeFormerOK source.nparams names ty && + closedOK ty && levelsOK source.uvars ty && + ty.ctors.all fun c => + c.uvars == source.uvars && + VExpr.telN source.nparams c.type == params && + blockStage3Ctor source.uvars source.nparams headers names owner 0 + (VExpr.dropN source.nparams c.type) + /-- Constructor identities retained across normalization. Types may change by WHNF/definitional equality, but names, universe arities, order, and count may not. -/ @@ -375,8 +601,8 @@ def Normalization.identity (source : VInductDecl) : Normalization source where /-- Semantic validity of a one-family normalization view. The family type is definitionally equal in the input environment; constructor types are definitionally equal after the raw family constant has been introduced, which -matches the staging of the kernel's inductive check. I3 will generalize the -single family insertion to a block insertion. -/ +matches the staging of the kernel's inductive check. `Normalization.BlockWF` +is the arbitrary-block counterpart. -/ def Normalization.WF {source : VInductDecl} (norm : Normalization source) (env : VEnv) : Prop := ∃ raw view, @@ -388,19 +614,102 @@ def Normalization.WF {source : VInductDecl} (norm : Normalization source) envT.IsDefEqU source.uvars [] rawCtor.type viewCtor.type) raw.ctors view.ctors +/-- Stage every raw family constant, in source order, without adding any +constructors, recursors, or reduction rules. This is the Theory image of the +environment used by Lean between `declareInductiveTypes` and +`checkConstructors`; it is deliberately validation-only. -/ +def _root_.Lean4Lean.VEnv.stageInductiveTypes (env : VEnv) + (types : List VInductiveType) : Option VEnv := + types.foldlM (fun env type => + env.addConst type.name type.toVConstant) env + +/-- Semantic validity of a normalization view for an arbitrary mutual block. + +Every family type is compared in the common input environment. The exact raw +family list is then staged as one source-ordered fold, and every constructor +comparison is performed in the resulting shared environment. The nested +`Forall₂` relations retain family and constructor order and cannot truncate a +reordered or shorter view. -/ +def Normalization.BlockWF {source : VInductDecl} + (norm : Normalization source) (env blockEnv : VEnv) : Prop := + env.stageInductiveTypes source.types = some blockEnv ∧ + List.Forall₂ + (fun raw view => + env.IsDefEqU source.uvars [] raw.type view.type ∧ + List.Forall₂ + (fun rawCtor viewCtor => + blockEnv.IsDefEqU source.uvars [] + rawCtor.type viewCtor.type) + raw.ctors view.ctors) + source.types norm.view.types + /-- Whether the recursor may eliminate into a fresh universe or is confined -to `Prop`. I2 will make the small case constructible; the current direct -indexed slice produces `large` descriptors only. -/ +to `Prop`. -/ inductive ElimMode where | large | small deriving DecidableEq, Repr +/-- Universe-slot offset used by recursor metadata. Large elimination inserts +the fresh motive universe before the declaration universes; small elimination +adds no universe parameter. -/ +def ElimMode.offset : ElimMode → Nat + | .large => 1 + | .small => 0 + +/-- Universe arity of the generated recursor. -/ +abbrev ElimMode.recUvars (mode : ElimMode) (U : Nat) : Nat := U + mode.offset + +/-- The motive's result level in the recursor universe context. -/ +def ElimMode.motiveLevel : ElimMode → VLevel + | .large => .param 0 + | .small => .zero + +/-- Declaration universes as seen by the recursor. Large elimination shifts +them past the fresh motive level; small elimination retains their order. -/ +abbrev ElimMode.sourceLevels (mode : ElimMode) (U : Nat) : List VLevel := + VLevel.params' U mode.offset + +/-- Identity universe arguments for recursive calls to the generated +recursor. -/ +abbrev ElimMode.recLevels (mode : ElimMode) (U : Nat) : List VLevel := + VLevel.params (mode.recUvars U) + +@[simp] theorem ElimMode.large_offset : ElimMode.large.offset = 1 := rfl +@[simp] theorem ElimMode.small_offset : ElimMode.small.offset = 0 := rfl + +@[simp] theorem ElimMode.large_recUvars (U : Nat) : + ElimMode.large.recUvars U = U + 1 := rfl + +@[simp] theorem ElimMode.small_recUvars (U : Nat) : + ElimMode.small.recUvars U = U := by + simp [ElimMode.recUvars, ElimMode.offset] + +@[simp] theorem ElimMode.large_sourceLevels (U : Nat) : + ElimMode.large.sourceLevels U = VLevel.params' U 1 := rfl + +@[simp] theorem ElimMode.small_sourceLevels (U : Nat) : + ElimMode.small.sourceLevels U = VLevel.params U := rfl + +@[simp] theorem ElimMode.large_motiveLevel : + ElimMode.large.motiveLevel = .param 0 := rfl + +@[simp] theorem ElimMode.small_motiveLevel : + ElimMode.small.motiveLevel = .zero := rfl + +/-- Environment-free elimination analysis used by the raw compatibility +path. Verify's ordinary checker replay refines the singleton criterion with +the exact inferred field sorts. -/ +def eliminationMode (U : Nat) (T : Name) (np ni : Nat) + (ty : VInductiveType) : ElimMode := + if largeElim U T np ni ty then .large else .small + /-- Normalized data for one constructor. -/ structure CheckedCtor where value : VConstVal fields : List VExpr recursive : List RecArg + recursiveAt : List (Option RecArg) resultIndices : List VExpr def CheckedCtor.ofDirect (U : Nat) (T : Name) (np ni : Nat) @@ -408,13 +717,260 @@ def CheckedCtor.ofDirect (U : Nat) (T : Name) (np ni : Nat) value := c fields := ctorFields (VExpr.dropN np c.type) recursive := recArgs U T np ni (ctorFields (VExpr.dropN np c.type)) + recursiveAt := recArgsAt U T np ni (ctorFields (VExpr.dropN np c.type)) resultIndices := recFieldIdxs np (VExpr.resultOf (VExpr.dropN np c.type)) -/-- Data-bearing result of the shared one-family analysis. The descriptor is -dependent on its source declaration, so it cannot silently describe a -different block. Its normalized fields are consumed by generation, proofs, -fixtures, and Verify alignment as I2 replaces the remaining duplicated -analysis. -/ +/-- Analyze one constructor against the complete source-ordered family block. +Unlike `ofDirect`, recursive descriptors retain the ordinal of a sibling +target instead of forcing `targetType := 0`. -/ +def CheckedCtor.ofBlock (source : VInductDecl) + (c : VConstVal) : CheckedCtor where + value := c + fields := ctorFields (VExpr.dropN source.nparams c.type) + recursive := blockRecArgs source.uvars source.nparams + (familyHeaders source.nparams source.types) (familyNames source.types) + (ctorFields (VExpr.dropN source.nparams c.type)) + recursiveAt := blockRecArgsAt source.uvars source.nparams + (familyHeaders source.nparams source.types) (familyNames source.types) + (ctorFields (VExpr.dropN source.nparams c.type)) + resultIndices := recFieldIdxs source.nparams + (VExpr.resultOf (VExpr.dropN source.nparams c.type)) + +/-- Checked representation of one family at its exact block ordinal. The +family itself is a type index rather than a replaceable field; this prevents a +descriptor from being reused for another position or declaration. -/ +structure CheckedFamily (source : VInductDecl) (params : List VExpr) + (ordinal : Nat) (type : VInductiveType) where + params_eq : VExpr.telN source.nparams type.type = params + indices : List VExpr + indices_eq : indices = ctorFields (VExpr.dropN source.nparams type.type) + resultLevel : VLevel + result_eq : VExpr.resultOf (VExpr.dropN source.nparams type.type) = + .sort resultLevel + constructors : List CheckedCtor + constructors_eq : constructors = type.ctors.map (CheckedCtor.ofBlock source) + accepted : blockFamilyCore source params ordinal type = true + +/-- Recover the source family indexing a checked family. -/ +def CheckedFamily.value {source : VInductDecl} {params : List VExpr} + {ordinal : Nat} {type : VInductiveType} + (_ : CheckedFamily source params ordinal type) : VInductiveType := + type + +/-- Recover the block-relative ordinal indexing a checked family. -/ +def CheckedFamily.ordinal {source : VInductDecl} {params : List VExpr} + {ordinal : Nat} {type : VInductiveType} + (_ : CheckedFamily source params ordinal type) : Nat := + ordinal + +/-- A genuinely dependent family spine. Its list index is the exact suffix +of `source.types`, and its natural-number index is the ordinal of that +suffix's head. Consequently neither family order nor recursive-target +numbering is represented by an unchecked parallel list. -/ +inductive CheckedFamilies (source : VInductDecl) (params : List VExpr) : + Nat → List VInductiveType → Type where + | nil {ordinal : Nat} : CheckedFamilies source params ordinal [] + | cons {ordinal : Nat} {type : VInductiveType} + {types : List VInductiveType} + (head : CheckedFamily source params ordinal type) + (tail : CheckedFamilies source params (ordinal + 1) types) : + CheckedFamilies source params ordinal (type :: types) + +namespace CheckedFamilies + +/-- Erase only the dependent evidence, retaining exact family source order. -/ +def values {source : VInductDecl} {params : List VExpr} : + {ordinal : Nat} → {types : List VInductiveType} → + CheckedFamilies source params ordinal types → List VInductiveType + | _, _, .nil => [] + | _, _, .cons head tail => head.value :: values tail + +/-- Erasing a dependent family spine recovers its exact source-list index. -/ +@[simp] theorem values_eq {source : VInductDecl} {params : List VExpr} + {ordinal : Nat} {types : List VInductiveType} + (families : CheckedFamilies source params ordinal types) : + families.values = types := by + induction families with + | nil => rfl + | cons head tail ih => + simp only [values, CheckedFamily.value] + rw [ih] + +/-- Family ordinals in the same order as `values`. -/ +def ordinals {source : VInductDecl} {params : List VExpr} : + {ordinal : Nat} → {types : List VInductiveType} → + CheckedFamilies source params ordinal types → List Nat + | _, _, .nil => [] + | _, _, .cons head tail => head.ordinal :: ordinals tail + +/-- Per-family index telescopes in declaration order. -/ +def indices {source : VInductDecl} {params : List VExpr} : + {ordinal : Nat} → {types : List VInductiveType} → + CheckedFamilies source params ordinal types → List (List VExpr) + | _, _, .nil => [] + | _, _, .cons head tail => head.indices :: indices tail + +/-- Per-family result levels in declaration order. -/ +def resultLevels {source : VInductDecl} {params : List VExpr} : + {ordinal : Nat} → {types : List VInductiveType} → + CheckedFamilies source params ordinal types → List VLevel + | _, _, .nil => [] + | _, _, .cons head tail => head.resultLevel :: resultLevels tail + +/-- Ordered constructor descriptors, grouped by source family. -/ +def constructors {source : VInductDecl} {params : List VExpr} : + {ordinal : Nat} → {types : List VInductiveType} → + CheckedFamilies source params ordinal types → List (List CheckedCtor) + | _, _, .nil => [] + | _, _, .cons head tail => head.constructors :: constructors tail + +/-- Family names projected from the dependent source spine. -/ +def names {source : VInductDecl} {params : List VExpr} + {ordinal : Nat} {types : List VInductiveType} + (families : CheckedFamilies source params ordinal types) : List Name := + families.values.map (·.name) + +/-- Constructor names retain both family order and within-family order. -/ +def constructorNames {source : VInductDecl} {params : List VExpr} + {ordinal : Nat} {types : List VInductiveType} + (families : CheckedFamilies source params ordinal types) : + List (List Name) := + families.constructors.map fun constructors => + constructors.map (·.value.name) + +/-- Recursive target ordinals retain family, constructor, and field order. -/ +def recursiveTargets {source : VInductDecl} {params : List VExpr} + {ordinal : Nat} {types : List VInductiveType} + (families : CheckedFamilies source params ordinal types) : + List (List (List Nat)) := + families.constructors.map fun constructors => + constructors.map fun constructor => + constructor.recursive.map (·.targetType) + +end CheckedFamilies + +/-- Check one family while retaining every computed representation component. +This is a pure structural pass; no environment or generated constant is an +input. -/ +def checkedFamily? (source : VInductDecl) (params : List VExpr) + (ordinal : Nat) (type : VInductiveType) : + Option (CheckedFamily source params ordinal type) := + let indices := ctorFields (VExpr.dropN source.nparams type.type) + match hresult : VExpr.resultOf (VExpr.dropN source.nparams type.type) with + | .sort resultLevel => + if hparams : VExpr.telN source.nparams type.type = params then + if haccepted : blockFamilyCore source params ordinal type then + some { + params_eq := hparams + indices + indices_eq := rfl + resultLevel + result_eq := hresult + constructors := type.ctors.map (CheckedCtor.ofBlock source) + constructors_eq := rfl + accepted := haccepted } + else none + else none + | _ => none + +/-- Analyze an arbitrary source-ordered family list into the dependent spine. +The ordinal advances together with the list index. -/ +def checkedFamilies? (source : VInductDecl) (params : List VExpr) : + (ordinal : Nat) → (types : List VInductiveType) → + Option (CheckedFamilies source params ordinal types) + | _, [] => some .nil + | ordinal, type :: types => do + let head ← checkedFamily? source params ordinal type + let tail ← checkedFamilies? source params (ordinal + 1) types + return .cons head tail + +/-- Source-indexed checked representation of a complete inductive block. +Shared parameters are stored once; every per-family component lives in the +dependent `families` spine indexed by `source.types` itself. This is the +L4L-08A analysis boundary and intentionally has no generation or insertion +projection. -/ +structure CheckedBlock (source : VInductDecl) where + params : List VExpr + params_eq : params = blockParams source.nparams source.types + params_length : params.length = source.nparams + families : CheckedFamilies source params 0 source.types + nonempty : source.types.isEmpty = false + names : List Name + names_eq : names = blockGeneratedNames source.types + names_nodup : names.Nodup + +/-- Analyze a complete block without singleton destructuring. Empty blocks, +inconsistent raw parameter surfaces, malformed families/constructors, and +block-wide generated-name collisions are rejected before a descriptor is +returned. -/ +def checkedBlock? (source : VInductDecl) : Option source.CheckedBlock := + let params := blockParams source.nparams source.types + if hnonempty : source.types.isEmpty = false then + if hparams : params.length = source.nparams then + if hnames : (blockGeneratedNames source.types).Nodup then + match checkedFamilies? source params 0 source.types with + | some families => some { + params + params_eq := rfl + params_length := hparams + families + nonempty := hnonempty + names := blockGeneratedNames source.types + names_eq := rfl + names_nodup := hnames } + | none => none + else none + else none + else none + +/-- Analyze the normalized view of an arbitrary source block. The +`Normalization` index fixes every family and constructor header while the +dependent `CheckedBlock` fixes the complete normalized family order. -/ +def Normalization.checkedBlock? {source : VInductDecl} + (norm : Normalization source) : Option norm.view.CheckedBlock := + norm.view.checkedBlock? + +/-- One accepted raw/view mutual block. Unlike the legacy +`NormalizedChecked`, this type performs no singleton projection and exposes no +generation operation. -/ +structure NormalizedCheckedBlock (source : VInductDecl) where + normalization : Normalization source + checked : normalization.view.CheckedBlock + checked_eq : normalization.checkedBlock? = some checked + +/-- Analyze one normalization boundary and retain the exact dependent block +descriptor that accepted its view. -/ +def Normalization.checkBlock? {source : VInductDecl} + (norm : Normalization source) : Option (NormalizedCheckedBlock source) := + match hchecked : norm.checkedBlock? with + | some checked => some ⟨norm, checked, hchecked⟩ + | none => none + +/-- Construct and analyze a raw/view mutual normalization in one +computational transaction. -/ +def normalizedCheckedBlock? (source view : VInductDecl) : + Option (NormalizedCheckedBlock source) := do + let norm ← normalization? source view + norm.checkBlock? + +/-- Compatibility analyzer for a block already in analyzer normal form. -/ +def identityCheckedBlock? (source : VInductDecl) : + Option (NormalizedCheckedBlock source) := + (Normalization.identity source).checkBlock? + +/-- The validator-owned shared result universe paired with one exact checked +normalization view. Universe equality is semantic (`VLevel.Equiv`) and is +therefore certified by `ValidatedBlock.WF`, not guessed by the structural +analyzer. -/ +structure ValidatedBlock (source : VInductDecl) where + block : NormalizedCheckedBlock source + resultLevel : VLevel + +/-- Data-bearing compatibility result for the one-family generation path. +`CheckedBlock` and `ValidatedBlock` provide the public block-wide analysis and +validation; this legacy singleton projection remains available for existing +one-family certificates. The descriptor is dependent on its source +declaration, so it cannot silently describe a different block. -/ structure Checked (source : VInductDecl) where type : VInductiveType types_eq : source.types = [type] @@ -425,7 +981,10 @@ structure Checked (source : VInductDecl) where resultLevel : VLevel result_eq : VExpr.resultOf (VExpr.dropN source.nparams type.type) = .sort resultLevel elimination : ElimMode - elimination_eq : elimination = .large + elimination_eq : elimination = + eliminationMode source.uvars type.name source.nparams indices.length type + kTarget : Bool + kTarget_eq : kTarget = isKTarget source.nparams resultLevel type names : List Name names_eq : names = generatedNames type constructors : List CheckedCtor @@ -451,8 +1010,10 @@ def checked? : (decl : VInductDecl) → Option decl.Checked indices_eq := rfl resultLevel := l result_eq := hresult - elimination := .large + elimination := eliminationMode U ty.name np indices.length ty elimination_eq := rfl + kTarget := isKTarget np l ty + kTarget_eq := rfl names := generatedNames ty names_eq := rfl constructors := ty.ctors.map (CheckedCtor.ofDirect U ty.name np indices.length) @@ -480,7 +1041,9 @@ theorem Checked.unique {decl : VInductDecl} rw [← htype, a.result_eq] at hb injection hb have helim : a.elimination = b.elimination := by - rw [a.elimination_eq, b.elimination_eq] + rw [a.elimination_eq, b.elimination_eq, htype, hindices] + have hkTarget : a.kTarget = b.kTarget := by + rw [a.kTarget_eq, b.kTarget_eq, htype, hlevel] have hnames : a.names = b.names := by rw [a.names_eq, b.names_eq, htype] have hctors : a.constructors = b.constructors := by @@ -499,13 +1062,13 @@ theorem Checked.analyzer_isSome {decl : VInductDecl} rcases checked with ⟨type, types_eq, params, params_eq, indices, indices_eq, resultLevel, result_eq, - elimination, elimination_eq, names, names_eq, + elimination, elimination_eq, kTarget, kTarget_eq, names, names_eq, constructors, constructors_eq, accepted⟩ change types = [type] at types_eq subst types subst params subst indices - subst elimination + subst kTarget subst names subst constructors change (VExpr.dropN np type.type).resultOf = @@ -540,7 +1103,7 @@ theorem Checked.direct_layout {decl : VInductDecl} have hdirect := hcore.1 simp only [stage3DirectCore, Bool.and_eq_true, beq_iff_eq, List.all_eq_true] at hdirect - obtain ⟨⟨⟨⟨⟨-, hparams⟩, -⟩, -⟩, -⟩, hctors⟩ := hdirect + obtain ⟨⟨⟨⟨-, hparams⟩, -⟩, -⟩, hctors⟩ := hdirect refine ⟨hparams, fun c hc => ?_⟩ rw [(hctors c hc).1.2] exact hparams @@ -649,6 +1212,48 @@ def NormalizedChecked.rawResult {source : VInductDecl} (block : NormalizedChecked source) : VExpr := VExpr.resultOf (VExpr.dropN source.nparams block.sourceType.type) +/-- Whether a stored parameter domain has one of the four top-level type +annotations consumed by Lean before it creates the common recursor parameter +telescope. Ordinary reducible constants are intentionally not inspected: +their raw syntax remains observable in generated kernel metadata. -/ +def _root_.Lean4Lean.VExpr.hasTypeAnnotation : VExpr → Bool + | .app (.const name _) _ => + name == ``_root_.outParam || name == ``_root_.semiOutParam + | .app (.app (.const name _) _) _ => + name == ``_root_.optParam || name == ``_root_.autoParam + | _ => false + +/-- Parameter surface emitted by recursor generation. Annotation wrappers use +the analyzer-owned consumed view; every other parameter keeps the stored raw +domain even when its WHNF differs. -/ +def generationParam (raw view : VExpr) : VExpr := + if raw.hasTypeAnnotation then view else raw + +/-- Positional common-parameter telescope used by generated artifacts. -/ +def generationParams : List VExpr → List VExpr → List VExpr + | raw :: raws, view :: views => + generationParam raw view :: generationParams raws views + | _, _ => [] + +@[simp] theorem generationParams_self : + ∀ params, generationParams params params = params + | [] => rfl + | param :: params => by + simp [generationParams, generationParam, generationParams_self params] + +theorem generationParams_length_of_eq : + ∀ {raw view : List VExpr}, raw.length = view.length → + (generationParams raw view).length = raw.length + | [], [], _ => rfl + | _ :: _, _ :: _, h => by + simp only [generationParams, List.length_cons] + exact congrArg Nat.succ + (generationParams_length_of_eq (Nat.succ.inj h)) + +def NormalizedChecked.generationParams {source : VInductDecl} + (block : NormalizedChecked source) : List VExpr := + VInductDecl.generationParams block.rawParams block.checked.params + def NormalizedChecked.ctorPairs {source : VInductDecl} (block : NormalizedChecked source) : List NormalizedCtor := pairNormalizedCtors block.sourceType.ctors block.checked.constructors @@ -749,42 +1354,46 @@ def identityGeneration? (source : VInductDecl) : let block ← identityChecked? source block.generation? -/-- The public acceptance predicate is the existence of a checked descriptor, -not a second ad-hoc pass over the declaration. -/ -def stage3 (decl : VInductDecl) : Bool := decl.checked?.isSome +/-- Compatibility acceptance predicate for the legacy one-family checked +descriptor. The public block-wide predicate is `stage3`, defined once the +mutual generation descriptor is available below. -/ +def singletonStage3 (decl : VInductDecl) : Bool := decl.checked?.isSome /-- The parameter telescope in the recursor's universe context. -/ -def paramsTel (ty : VInductiveType) : List VExpr := - (VExpr.telN np ty.type).map (VExpr.instL (VLevel.params' U 1)) +def paramsTel (ty : VInductiveType) (mode : ElimMode := .large) : List VExpr := + (VExpr.telN np ty.type).map (VExpr.instL (mode.sourceLevels U)) /-- The index telescope in the recursor's universe context (at parameter depth). -/ -def idxTel (ty : VInductiveType) : List VExpr := - (ctorFields (VExpr.dropN np ty.type)).map (VExpr.instL (VLevel.params' U 1)) +def idxTel (ty : VInductiveType) (mode : ElimMode := .large) : List VExpr := + (ctorFields (VExpr.dropN np ty.type)).map + (VExpr.instL (mode.sourceLevels U)) /-- `recApp` in the recursor's universe context. -/ -def recApp' (off : Nat) : VExpr := - VExpr.appN (.const T (VLevel.params' U 1)) (VExpr.bvarRevRange off np) +def recApp' (off : Nat) (mode : ElimMode := .large) : VExpr := + VExpr.appN (.const T (mode.sourceLevels U)) (VExpr.bvarRevRange off np) /-- `motive : ∀ indices, T params indices → Sort u`, in context `params`. -/ -def motiveType (ty : VInductiveType) : VExpr := - let ni := (idxTel U np ty).length - VExpr.forallN (idxTel U np ty) - (.forallE (VExpr.appN (.const T (VLevel.params' U 1)) +def motiveType (ty : VInductiveType) (mode : ElimMode := .large) : VExpr := + let ni := (idxTel U np ty mode).length + VExpr.forallN (idxTel U np ty mode) + (.forallE (VExpr.appN (.const T (mode.sourceLevels U)) (VExpr.bvarRevRange ni np ++ VExpr.bvarRevRange 0 ni)) - (.sort (.param 0))) + (.sort mode.motiveLevel)) /-- Constructor fields in the recursor's universe context (still at parameter depth, no motive shift). -/ -def ctorFieldsR (c : VConstVal) : List VExpr := - (ctorFields (VExpr.dropN np c.type)).map (VExpr.instL (VLevel.params' U 1)) +def ctorFieldsR (c : VConstVal) (mode : ElimMode := .large) : List VExpr := + (ctorFields (VExpr.dropN np c.type)).map + (VExpr.instL (mode.sourceLevels U)) /-- The recursive positions of a constructor with their index arguments, in the recursor's universe context. -/ -def recPairsR (ni : Nat) (c : VConstVal) : List (Nat × List VExpr) := +def recPairsR (ni : Nat) (c : VConstVal) + (mode : ElimMode := .large) : List (Nat × List VExpr) := (recPairs U T np ni (ctorFields (VExpr.dropN np c.type))).map - fun (j, idxs) => (j, idxs.map (VExpr.instL (VLevel.params' U 1))) + fun (j, idxs) => (j, idxs.map (VExpr.instL (mode.sourceLevels U))) /-- A recursive-argument descriptor transported into the recursor's universe context. Telescope dependency is preserved because universe instantiation does @@ -797,31 +1406,33 @@ def RecArg.instL (r : RecArg) (ls : List VLevel) : RecArg where /-- Recursive constructor arguments, including recursive Pi arguments, in the recursor universe context. -/ -def recArgsR (ni : Nat) (c : VConstVal) : List RecArg := +def recArgsR (ni : Nat) (c : VConstVal) + (mode : ElimMode := .large) : List RecArg := (recArgs U T np ni (ctorFields (VExpr.dropN np c.type))).map - fun r => r.instL (VLevel.params' U 1) + fun r => r.instL (mode.sourceLevels U) /-- The result index arguments of a constructor, recursor universes (at result depth: past the parameters and all fields, no motive). -/ -def ctorIdxs (c : VConstVal) : List VExpr := +def ctorIdxs (c : VConstVal) (mode : ElimMode := .large) : List VExpr := (recFieldIdxs np (VExpr.resultOf (VExpr.dropN np c.type))).map - (VExpr.instL (VLevel.params' U 1)) + (VExpr.instL (mode.sourceLevels U)) /-- The minor premise for one constructor, in context `params ++ [motive]`: `∀ fields, ∀ ihs, motive idxs (ctor params fields)`, with one induction hypothesis per directly recursive field. The fields shift by one for the interposed motive. -/ -def minorType (ty : VInductiveType) (c : VConstVal) : VExpr := - let Bs := ctorFieldsR U np c +def minorType (ty : VInductiveType) (c : VConstVal) + (mode : ElimMode := .large) : VExpr := + let Bs := ctorFieldsR U np c mode let m := Bs.length - let ni := (idxTel U np ty).length - let rsP := recPairsR U T np ni c + let ni := (idxTel U np ty mode).length + let rsP := recPairsR U T np ni c mode let r := rsP.length VExpr.forallN (VExpr.liftTelN 1 Bs 0) (VExpr.forallN (ihsFrom m rsP 0) (VExpr.appN (.bvar (m+r)) - (((ctorIdxs U np c).map fun e => (e.liftN 1 m).liftN r) ++ - [VExpr.appN (.const c.name (VLevel.params' U 1)) + (((ctorIdxs U np c mode).map fun e => (e.liftN 1 m).liftN r) ++ + [VExpr.appN (.const c.name (mode.sourceLevels U)) (VExpr.bvarRevRange (r+m+1) np ++ VExpr.bvarRevRange r m)]))) /-- Binder telescope of a functional induction hypothesis. Starting from the @@ -852,35 +1463,42 @@ def ihsFromRecArgs (m : Nat) : List RecArg → Nat → List VExpr /-- General one-family minor premise, extending `minorType` to recursive arguments beneath Pi telescopes. -/ -def minorTypeRec (ty : VInductiveType) (c : VConstVal) : VExpr := - let Bs := ctorFieldsR U np c +def minorTypeRec (ty : VInductiveType) (c : VConstVal) + (mode : ElimMode := .large) : VExpr := + let Bs := ctorFieldsR U np c mode let m := Bs.length - let ni := (idxTel U np ty).length - let rs := recArgsR U T np ni c + let ni := (idxTel U np ty mode).length + let rs := recArgsR U T np ni c mode let r := rs.length VExpr.forallN (VExpr.liftTelN 1 Bs 0) (VExpr.forallN (ihsFromRecArgs m rs 0) (VExpr.appN (.bvar (m+r)) - (((ctorIdxs U np c).map fun e => (e.liftN 1 m).liftN r) ++ - [VExpr.appN (.const c.name (VLevel.params' U 1)) + (((ctorIdxs U np c mode).map fun e => (e.liftN 1 m).liftN r) ++ + [VExpr.appN (.const c.name (mode.sourceLevels U)) (VExpr.bvarRevRange (r+m+1) np ++ VExpr.bvarRevRange r m)]))) -def minorTypesRec (ty : VInductiveType) : List VConstVal → (i : Nat := 0) → List VExpr - | [], _ => [] - | c :: cs, i => VExpr.liftN i (minorTypeRec U T np ty c) :: minorTypesRec ty cs (i+1) +def minorTypesRec (ty : VInductiveType) : List VConstVal → + (i : Nat := 0) → (mode : ElimMode := .large) → List VExpr + | [], _, _ => [] + | c :: cs, i, mode => + VExpr.liftN i (minorTypeRec U T np ty c mode) :: + minorTypesRec ty cs (i+1) mode -def recTypeRec (ty : VInductiveType) : VExpr := +def recTypeRec (ty : VInductiveType) + (mode : ElimMode := .large) : VExpr := let k := ty.ctors.length - let ni := (idxTel U np ty).length - VExpr.forallN (paramsTel U np ty) <| - .forallE (motiveType U T np ty) <| - VExpr.forallN (minorTypesRec U T np ty ty.ctors) <| - VExpr.forallN (VExpr.liftTelN (k+1) (idxTel U np ty) 0) <| - .forallE (VExpr.appN (.const T (VLevel.params' U 1)) + let ni := (idxTel U np ty mode).length + VExpr.forallN (paramsTel U np ty mode) <| + .forallE (motiveType U T np ty mode) <| + VExpr.forallN (minorTypesRec U T np ty ty.ctors (mode := mode)) <| + VExpr.forallN (VExpr.liftTelN (k+1) (idxTel U np ty mode) 0) <| + .forallE (VExpr.appN (.const T (mode.sourceLevels U)) (VExpr.bvarRevRange (ni+k+1) np ++ VExpr.bvarRevRange 0 ni)) <| .app (VExpr.appN (.bvar (ni+k+1)) (VExpr.bvarRevRange 1 ni)) (.bvar 0) -def recConstRec (ty : VInductiveType) : VConstant := ⟨U + 1, recTypeRec U T np ty⟩ +def recConstRec (ty : VInductiveType) + (mode : ElimMode := .large) : VConstant := + ⟨mode.recUvars U, recTypeRec U T np ty mode⟩ /-- The telescope introduced around a functional recursive call in an iota RHS. It is the source Pi telescope transported under the recursor's common @@ -919,29 +1537,32 @@ def ruleIHs (m k : Nat) : List RecArg → Nat → List VExpr | [], _ => [] | r :: rs, p => (r.ruleIH m k).liftN p :: ruleIHs m k rs (p+1) -def ruleRec (ty : VInductiveType) (i : Nat) (c : VConstVal) : VDefEq := +def ruleRec (ty : VInductiveType) (i : Nat) (c : VConstVal) + (mode : ElimMode := .large) : VDefEq := let k := ty.ctors.length - let Bs := ctorFieldsR U np c + let Bs := ctorFieldsR U np c mode let m := Bs.length - let ni := (idxTel U np ty).length - let rs := recArgsR U T np ni c - let binders := paramsTel U np ty ++ - motiveType U T np ty :: minorTypesRec U T np ty ty.ctors ++ + let ni := (idxTel U np ty mode).length + let rs := recArgsR U T np ni c mode + let binders := paramsTel U np ty mode ++ + motiveType U T np ty mode :: + minorTypesRec U T np ty ty.ctors (mode := mode) ++ VExpr.liftTelN (k+1) Bs 0 - let recBase := VExpr.appN (.const (.str T "rec") (VLevel.params (U+1))) + let recBase := VExpr.appN (.const (.str T "rec") (mode.recLevels U)) (VExpr.bvarRevRange m (np+k+1)) - let idxR := (ctorIdxs U np c).map fun e => e.liftN (k+1) m - let ctorApp := VExpr.appN (.const c.name (VLevel.params' U 1)) + let idxR := (ctorIdxs U np c mode).map fun e => e.liftN (k+1) m + let ctorApp := VExpr.appN (.const c.name (mode.sourceLevels U)) (VExpr.bvarRevRange (m+k+1) np ++ VExpr.bvarRevRange 0 m) let ihs := rs.map fun r => r.ruleCall m k recBase - { uvars := U + 1 + { uvars := mode.recUvars U lhs := VExpr.lamN binders (VExpr.appN recBase (idxR ++ [ctorApp])) rhs := VExpr.lamN binders (VExpr.appN (.bvar (k-1-i+m)) (VExpr.bvarRevRange 0 m ++ ihs)) type := VExpr.forallN binders (VExpr.appN (.bvar (k+m)) (idxR ++ [ctorApp])) } -def rulesRec (ty : VInductiveType) : List VDefEq := - ty.ctors.zipIdx.map fun (c, i) => ruleRec U T np ty i c +def rulesRec (ty : VInductiveType) + (mode : ElimMode := .large) : List VDefEq := + ty.ctors.zipIdx.map fun (c, i) => ruleRec U T np ty i c mode /-- Minor premise types in position: the `i`-th lives under `params ++ motive` and the previous `i` minors. -/ @@ -999,17 +1620,20 @@ def rules (ty : VInductiveType) : List VDefEq := namespace NormalizedCtor /-- Raw field binders transported to the recursor universe context. -/ -def fieldsR (ctor : NormalizedCtor) (U np : Nat) : List VExpr := - (ctor.rawFields np).map (VExpr.instL (VLevel.params' U 1)) +def fieldsR (ctor : NormalizedCtor) (U np : Nat) + (mode : ElimMode := .large) : List VExpr := + (ctor.rawFields np).map (VExpr.instL (mode.sourceLevels U)) /-- Normalized recursive classifications transported without re-peeling the raw constructor type. -/ -def recArgsR (ctor : NormalizedCtor) (U : Nat) : List RecArg := - ctor.view.recursive.map fun r => r.instL (VLevel.params' U 1) +def recArgsR (ctor : NormalizedCtor) (U : Nat) + (mode : ElimMode := .large) : List RecArg := + ctor.view.recursive.map fun r => r.instL (mode.sourceLevels U) /-- Normalized constructor-result indices in recursor universes. -/ -def resultIndicesR (ctor : NormalizedCtor) (U : Nat) : List VExpr := - ctor.view.resultIndices.map (VExpr.instL (VLevel.params' U 1)) +def resultIndicesR (ctor : NormalizedCtor) (U : Nat) + (mode : ElimMode := .large) : List VExpr := + ctor.view.resultIndices.map (VExpr.instL (mode.sourceLevels U)) end NormalizedCtor @@ -1023,15 +1647,48 @@ below re-runs `recArg?` on raw metadata. namespace GenerationChecked -/-- Raw parameter telescope in recursor universes. -/ +/-- Elimination mode retained by the single checked analysis. -/ +abbrev elimination {source : VInductDecl} (gen : GenerationChecked source) : + ElimMode := + gen.block.checked.elimination + +/-- K-like reduction flag retained by the single checked analysis. It is +metadata for reduction and does not select the elimination mode. -/ +abbrev kTarget {source : VInductDecl} (gen : GenerationChecked source) : Bool := + gen.block.checked.kTarget + +/-- Universe arity of this generated recursor. -/ +abbrev recUvars {source : VInductDecl} (gen : GenerationChecked source) : Nat := + gen.elimination.recUvars source.uvars + +/-- Declaration universes in this recursor's universe context. -/ +abbrev sourceLevels {source : VInductDecl} + (gen : GenerationChecked source) : List VLevel := + gen.elimination.sourceLevels source.uvars + +/-- Result level of the motive. -/ +abbrev motiveLevel {source : VInductDecl} + (gen : GenerationChecked source) : VLevel := + gen.elimination.motiveLevel + +/-- Identity universe arguments of recursive recursor calls. -/ +abbrev recLevels {source : VInductDecl} + (gen : GenerationChecked source) : List VLevel := + gen.elimination.recLevels source.uvars + +/-- Kernel-observable family-parameter telescope in recursor universes. + +Lean consumes the four parameter annotations before emission, but otherwise +retains stored syntax rather than replacing reducible aliases by their WHNF. -/ def paramsTel {source : VInductDecl} (gen : GenerationChecked source) : List VExpr := - gen.block.rawParams.map (VExpr.instL (VLevel.params' source.uvars 1)) + gen.block.generationParams.map + (VExpr.instL gen.sourceLevels) /-- Raw index-binder telescope in recursor universes. -/ def idxTel {source : VInductDecl} (gen : GenerationChecked source) : List VExpr := - gen.block.rawIndices.map (VExpr.instL (VLevel.params' source.uvars 1)) + gen.block.rawIndices.map (VExpr.instL gen.sourceLevels) /-- Mixed motive: raw index binders, normalized index arity, and the retained raw family identity. -/ @@ -1040,24 +1697,25 @@ def motiveType {source : VInductDecl} (gen : GenerationChecked source) : VExpr : VExpr.forallN gen.idxTel (.forallE (VExpr.appN - (.const gen.block.sourceType.name (VLevel.params' source.uvars 1)) + (.const gen.block.sourceType.name gen.sourceLevels) (VExpr.bvarRevRange ni source.nparams ++ VExpr.bvarRevRange 0 ni)) - (.sort (.param 0))) + (.sort gen.motiveLevel)) /-- One mixed minor premise. Raw fields are bound verbatim, while induction hypotheses and constructor result indices come from the checked view. -/ -def minorType {source : VInductDecl} (ctor : NormalizedCtor) : VExpr := - let Bs := ctor.fieldsR source.uvars source.nparams +def minorType {source : VInductDecl} (ctor : NormalizedCtor) + (mode : ElimMode := .large) : VExpr := + let Bs := ctor.fieldsR source.uvars source.nparams mode let m := Bs.length - let rs := ctor.recArgsR source.uvars + let rs := ctor.recArgsR source.uvars mode let r := rs.length VExpr.forallN (VExpr.liftTelN 1 Bs 0) (VExpr.forallN (ihsFromRecArgs m rs 0) (VExpr.appN (.bvar (m+r)) - ((ctor.resultIndicesR source.uvars |>.map fun e => + ((ctor.resultIndicesR source.uvars mode |>.map fun e => (e.liftN 1 m).liftN r) ++ [VExpr.appN - (.const ctor.raw.name (VLevel.params' source.uvars 1)) + (.const ctor.raw.name (mode.sourceLevels source.uvars)) (VExpr.bvarRevRange (r+m+1) source.nparams ++ VExpr.bvarRevRange r m)]))) @@ -1065,7 +1723,7 @@ def minorTypesAux {source : VInductDecl} (gen : GenerationChecked source) : List NormalizedCtor → (i : Nat := 0) → List VExpr | [], _ => [] | ctor :: ctors, i => - VExpr.liftN i (minorType (source := source) ctor) :: + VExpr.liftN i (minorType (source := source) ctor gen.elimination) :: gen.minorTypesAux ctors (i+1) def minorTypes {source : VInductDecl} (gen : GenerationChecked source) : @@ -1084,7 +1742,7 @@ def recType {source : VInductDecl} (gen : GenerationChecked source) : VExpr := .forallE (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + gen.sourceLevels) (VExpr.bvarRevRange (ni+k+1) source.nparams ++ VExpr.bvarRevRange 0 ni)) <| .app @@ -1093,7 +1751,7 @@ def recType {source : VInductDecl} (gen : GenerationChecked source) : VExpr := def recursor {source : VInductDecl} (gen : GenerationChecked source) : VConstant := - ⟨source.uvars + 1, gen.recType⟩ + ⟨gen.recUvars, gen.recType⟩ /-- One mixed iota rule. Raw fields and constructor names are observable in the rule telescope; normalized recursive descriptors determine recursive calls @@ -1101,24 +1759,24 @@ and normalized result indices determine the major's index spine. -/ def rule {source : VInductDecl} (gen : GenerationChecked source) (i : Nat) (ctor : NormalizedCtor) : VDefEq := let k := gen.block.ctorPairs.length - let Bs := ctor.fieldsR source.uvars source.nparams + let Bs := ctor.fieldsR source.uvars source.nparams gen.elimination let m := Bs.length - let rs := ctor.recArgsR source.uvars + let rs := ctor.recArgsR source.uvars gen.elimination let binders := gen.paramsTel ++ gen.motiveType :: gen.minorTypes ++ VExpr.liftTelN (k+1) Bs 0 let recBase := VExpr.appN (.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars+1))) + gen.recLevels) (VExpr.bvarRevRange m (source.nparams+k+1)) - let idxR := ctor.resultIndicesR source.uvars |>.map fun e => + let idxR := ctor.resultIndicesR source.uvars gen.elimination |>.map fun e => e.liftN (k+1) m let ctorApp := VExpr.appN - (.const ctor.raw.name (VLevel.params' source.uvars 1)) + (.const ctor.raw.name gen.sourceLevels) (VExpr.bvarRevRange (m+k+1) source.nparams ++ VExpr.bvarRevRange 0 m) let ihs := rs.map fun r => r.ruleCall m k recBase - { uvars := source.uvars + 1 + { uvars := gen.recUvars lhs := VExpr.lamN binders (VExpr.appN recBase (idxR ++ [ctorApp])) rhs := VExpr.lamN binders (VExpr.appN (.bvar (k-1-i+m)) (VExpr.bvarRevRange 0 m ++ ihs)) @@ -1133,31 +1791,65 @@ end GenerationChecked namespace Checked +@[simp] theorem identityGeneration_elimination {decl : VInductDecl} + (checked : decl.Checked) : + checked.identityGeneration.elimination = checked.elimination := rfl + +@[simp] theorem identityGeneration_kTarget {decl : VInductDecl} + (checked : decl.Checked) : + checked.identityGeneration.kTarget = checked.kTarget := rfl + +@[simp] theorem identityGeneration_recUvars {decl : VInductDecl} + (checked : decl.Checked) : + checked.identityGeneration.recUvars = + checked.elimination.recUvars decl.uvars := rfl + +@[simp] theorem identityGeneration_sourceLevels {decl : VInductDecl} + (checked : decl.Checked) : + checked.identityGeneration.sourceLevels = + checked.elimination.sourceLevels decl.uvars := rfl + +@[simp] theorem identityGeneration_motiveLevel {decl : VInductDecl} + (checked : decl.Checked) : + checked.identityGeneration.motiveLevel = checked.elimination.motiveLevel := rfl + +@[simp] theorem identityGeneration_recLevels {decl : VInductDecl} + (checked : decl.Checked) : + checked.identityGeneration.recLevels = + checked.elimination.recLevels decl.uvars := rfl + private theorem identity_paramsTel {decl : VInductDecl} (checked : decl.Checked) : checked.identityGeneration.paramsTel = - VInductDecl.paramsTel decl.uvars decl.nparams checked.type := rfl + VInductDecl.paramsTel decl.uvars decl.nparams checked.type + checked.elimination := by + simp [GenerationChecked.paramsTel, VInductDecl.paramsTel, + GenerationChecked.sourceLevels, GenerationChecked.elimination, + NormalizedChecked.generationParams, NormalizedChecked.rawParams, + Checked.identityGeneration, Checked.identityBlock, checked.params_eq] private theorem identity_idxTel {decl : VInductDecl} (checked : decl.Checked) : checked.identityGeneration.idxTel = - VInductDecl.idxTel decl.uvars decl.nparams checked.type := rfl + VInductDecl.idxTel decl.uvars decl.nparams checked.type + checked.elimination := rfl private theorem identity_motiveType {decl : VInductDecl} (checked : decl.Checked) : checked.identityGeneration.motiveType = VInductDecl.motiveType decl.uvars checked.type.name decl.nparams - checked.type := rfl + checked.type checked.elimination := rfl private theorem identity_minorType {decl : VInductDecl} (checked : decl.Checked) (c : VConstVal) : GenerationChecked.minorType (source := decl) ⟨c, CheckedCtor.ofDirect decl.uvars checked.type.name decl.nparams - checked.indices.length c⟩ = + checked.indices.length c⟩ checked.elimination = VInductDecl.minorTypeRec decl.uvars checked.type.name decl.nparams - checked.type c := by + checked.type c checked.elimination := by have hni : checked.indices.length = - (VInductDecl.idxTel decl.uvars decl.nparams checked.type).length := by + (VInductDecl.idxTel decl.uvars decl.nparams checked.type + checked.elimination).length := by rw [checked.indices_eq] simp [VInductDecl.idxTel] rw [hni] @@ -1171,7 +1863,7 @@ private theorem identity_minorTypesAux {decl : VInductDecl} (cs.map (CheckedCtor.ofDirect decl.uvars checked.type.name decl.nparams checked.indices.length))) i = VInductDecl.minorTypesRec decl.uvars checked.type.name decl.nparams - checked.type cs i + checked.type cs i checked.elimination | [], _ => rfl | c :: cs, i => by simp [pairNormalizedCtors, GenerationChecked.minorTypesAux, @@ -1182,7 +1874,7 @@ private theorem identity_minorTypes {decl : VInductDecl} (checked : decl.Checked) : checked.identityGeneration.minorTypes = VInductDecl.minorTypesRec decl.uvars checked.type.name decl.nparams - checked.type checked.type.ctors := by + checked.type checked.type.ctors (mode := checked.elimination) := by unfold GenerationChecked.minorTypes simp only [Checked.identityGeneration, Checked.identityBlock, NormalizedChecked.ctorPairs] @@ -1193,7 +1885,7 @@ private theorem identity_recType {decl : VInductDecl} (checked : decl.Checked) : checked.identityGeneration.recType = VInductDecl.recTypeRec decl.uvars checked.type.name decl.nparams - checked.type := by + checked.type checked.elimination := by simp only [GenerationChecked.recType, VInductDecl.recTypeRec] rw [identity_paramsTel checked, identity_motiveType checked, identity_minorTypes checked, identity_idxTel checked] @@ -1208,9 +1900,11 @@ private theorem identity_recursor {decl : VInductDecl} (checked : decl.Checked) : checked.identityGeneration.recursor = VInductDecl.recConstRec decl.uvars checked.type.name decl.nparams - checked.type := by + checked.type checked.elimination := by unfold GenerationChecked.recursor VInductDecl.recConstRec rw [identity_recType checked] + simp [GenerationChecked.recUvars, GenerationChecked.elimination, + Checked.identityGeneration, Checked.identityBlock] private theorem identity_rule {decl : VInductDecl} (checked : decl.Checked) (i : Nat) (c : VConstVal) : @@ -1218,9 +1912,10 @@ private theorem identity_rule {decl : VInductDecl} ⟨c, CheckedCtor.ofDirect decl.uvars checked.type.name decl.nparams checked.indices.length c⟩ = VInductDecl.ruleRec decl.uvars checked.type.name decl.nparams - checked.type i c := by + checked.type i c checked.elimination := by have hni : checked.indices.length = - (VInductDecl.idxTel decl.uvars decl.nparams checked.type).length := by + (VInductDecl.idxTel decl.uvars decl.nparams checked.type + checked.elimination).length := by rw [checked.indices_eq] simp [VInductDecl.idxTel] have hk : checked.identityGeneration.block.ctorPairs.length = @@ -1248,7 +1943,7 @@ private theorem identity_rulesAux {decl : VInductDecl} List.map (fun (c, i) => VInductDecl.ruleRec decl.uvars checked.type.name decl.nparams - checked.type i c) + checked.type i c checked.elimination) (List.zipIdx cs n) | [], _ => rfl | c :: cs, n => by @@ -1259,7 +1954,7 @@ private theorem identity_generatedRules {decl : VInductDecl} (checked : decl.Checked) : checked.identityGeneration.generatedRules = VInductDecl.rulesRec decl.uvars checked.type.name decl.nparams - checked.type := by + checked.type checked.elimination := by unfold GenerationChecked.generatedRules VInductDecl.rulesRec simp only [Checked.identityGeneration, Checked.identityBlock, NormalizedChecked.ctorPairs] @@ -1291,7 +1986,7 @@ theorem motiveType_eq_legacy {decl : VInductDecl} (checked : decl.Checked) : checked.motiveType = VInductDecl.motiveType decl.uvars checked.type.name decl.nparams - checked.type := + checked.type checked.elimination := identity_motiveType checked /-- The public minor telescope retains the exact legacy identity-normal @@ -1300,7 +1995,7 @@ theorem minorTypes_eq_legacy {decl : VInductDecl} (checked : decl.Checked) : checked.minorTypes = VInductDecl.minorTypesRec decl.uvars checked.type.name decl.nparams - checked.type checked.type.ctors := + checked.type checked.type.ctors (mode := checked.elimination) := identity_minorTypes checked /-- The public recursor retains the exact legacy identity-normal form while @@ -1309,7 +2004,7 @@ theorem recursor_eq_legacy {decl : VInductDecl} (checked : decl.Checked) : checked.recursor = VInductDecl.recConstRec decl.uvars checked.type.name decl.nparams - checked.type := + checked.type checked.elimination := identity_recursor checked /-- The public iota-rule list retains the exact legacy identity-normal form @@ -1318,11 +2013,432 @@ theorem generatedRules_eq_legacy {decl : VInductDecl} (checked : decl.Checked) : checked.generatedRules = VInductDecl.rulesRec decl.uvars checked.type.name decl.nparams - checked.type := + checked.type checked.elimination := identity_generatedRules checked end Checked +/-! ## Mutual raw/view artifacts + +The singleton generator above remains the compatibility proof surface while +the block generator below mirrors `AddInductive.mkRecInfos`: all motives are +introduced in family order, all constructor minors are then flattened in +family/constructor order, and every recursive descriptor selects its target +family by the ordinal retained by `CheckedCtor.ofBlock`. +-/ + +/-- Erased data for one member of the dependent checked-family spine. The +ordinal and normalized family value travel with the projections they index, +so later positional pairing does not manufacture a parallel family order. -/ +structure CheckedFamilyData where + ordinal : Nat + value : VInductiveType + indices : List VExpr + resultLevel : VLevel + constructors : List CheckedCtor + +namespace CheckedFamilies + +/-- Erase a dependent checked-family spine without changing its order. -/ +def data {source : VInductDecl} {params : List VExpr} : + {ordinal : Nat} → {types : List VInductiveType} → + CheckedFamilies source params ordinal types → List CheckedFamilyData + | _, _, .nil => [] + | _, _, .cons head tail => + { ordinal := head.ordinal + value := head.value + indices := head.indices + resultLevel := head.resultLevel + constructors := head.constructors } :: data tail + +end CheckedFamilies + +/-- One stored family paired positionally with the checked normalized family +that drove generation. Stored family/index syntax remains observable in +metadata; the view owns recursive classification and result indices. -/ +structure NormalizedFamily where + raw : VInductiveType + view : CheckedFamilyData + +/-- Positional family pairing. `blockGenerationShape` separately proves +that neither side is truncated. -/ +def pairNormalizedFamilies : + List VInductiveType → List CheckedFamilyData → List NormalizedFamily + | raw :: raws, view :: views => + ⟨raw, view⟩ :: pairNormalizedFamilies raws views + | _, _ => [] + +def NormalizedFamily.rawParams (family : NormalizedFamily) (np : Nat) : + List VExpr := + VExpr.telN np family.raw.type + +def NormalizedFamily.rawIndices (family : NormalizedFamily) (np : Nat) : + List VExpr := + ctorFields (VExpr.dropN np family.raw.type) + +def NormalizedFamily.ctorPairs (family : NormalizedFamily) : + List NormalizedCtor := + pairNormalizedCtors family.raw.ctors family.view.constructors + +/-- One flattened constructor together with its source-family identity. -/ +structure NormalizedBlockCtor where + owner : Nat + familyName : Name + familyIndices : List VExpr + ctor : NormalizedCtor + +def NormalizedFamily.blockCtors (family : NormalizedFamily) : + List NormalizedBlockCtor := + family.ctorPairs.map fun ctor => + { owner := family.view.ordinal + familyName := family.raw.name + familyIndices := family.view.indices + ctor } + +/-- Per-family layout gate for mutual mixed generation. -/ +def NormalizedFamily.generationShape (np : Nat) + (family : NormalizedFamily) : Bool := + family.raw.name == family.view.value.name && + family.raw.uvars == family.view.value.uvars && + (family.rawParams np).length == np && + (family.rawIndices np).length == family.view.indices.length && + family.ctorPairs.length == family.raw.ctors.length && + family.ctorPairs.length == family.view.constructors.length && + family.ctorPairs.all (NormalizedCtor.generationShape np) + +def NormalizedCheckedBlock.rawParams {source : VInductDecl} + (block : NormalizedCheckedBlock source) : List VExpr := + blockParams source.nparams source.types + +def NormalizedCheckedBlock.familyPairs {source : VInductDecl} + (block : NormalizedCheckedBlock source) : List NormalizedFamily := + pairNormalizedFamilies source.types block.checked.families.data + +def NormalizedCheckedBlock.flatCtors {source : VInductDecl} + (block : NormalizedCheckedBlock source) : List NormalizedBlockCtor := + block.familyPairs.flatMap (·.blockCtors) + +/-- Executable positional gate for a complete normalized block. It checks +the shared parameter surface, every family/index position, and every +constructor position before raw and checked syntax are mixed. -/ +def NormalizedCheckedBlock.blockGenerationShape {source : VInductDecl} + (block : NormalizedCheckedBlock source) : Bool := + block.rawParams.length == source.nparams && + block.rawParams.length == block.checked.params.length && + block.familyPairs.length == source.types.length && + block.familyPairs.length == block.checked.families.data.length && + block.familyPairs.all + (NormalizedFamily.generationShape source.nparams) && + block.familyPairs.all fun family => + family.raw.uvars == source.uvars && + family.ctorPairs.all fun ctor => ctor.raw.uvars == source.uvars + +/-- A validator-owned mutual normalization whose raw/view positions are +usable by artifact generation. -/ +structure BlockGenerationChecked (source : VInductDecl) where + validated : ValidatedBlock source + shape_eq : validated.block.blockGenerationShape = true + +def ValidatedBlock.generation? {source : VInductDecl} + (validated : ValidatedBlock source) : + Option (BlockGenerationChecked source) := + if h : validated.block.blockGenerationShape then + some ⟨validated, h⟩ + else none + +/-- The common result level selected by an identity-normalized checked block. +The empty fallback is unreachable after `checkedBlock?`, but keeps the +executable analyzer total. -/ +def CheckedBlock.firstResultLevel {source : VInductDecl} + (checked : CheckedBlock source) : VLevel := + checked.families.resultLevels.head?.getD .zero + +/-- Analyze an already-normalized arbitrary block for mutual generation, +without any singleton destructuring. -/ +def identityBlockGeneration? (source : VInductDecl) : + Option (BlockGenerationChecked source) := do + let block ← identityCheckedBlock? source + let validated : ValidatedBlock source := + { block + resultLevel := block.checked.firstResultLevel } + validated.generation? + +/-- Public structural acceptance is exact block-generation readiness. This +retains the complete source-ordered mutual descriptor instead of projecting a +singleton family and then rebuilding generation data. -/ +def stage3 (source : VInductDecl) : Bool := + source.identityBlockGeneration?.isSome + +namespace BlockGenerationChecked + +abbrev block {source : VInductDecl} (gen : BlockGenerationChecked source) : + NormalizedCheckedBlock source := + gen.validated.block + +abbrev checked {source : VInductDecl} (gen : BlockGenerationChecked source) : + gen.block.normalization.view.CheckedBlock := + gen.block.checked + +def families {source : VInductDecl} (gen : BlockGenerationChecked source) : + List NormalizedFamily := + gen.block.familyPairs + +def flatCtors {source : VInductDecl} (gen : BlockGenerationChecked source) : + List NormalizedBlockCtor := + gen.block.flatCtors + +abbrev familyCount {source : VInductDecl} + (gen : BlockGenerationChecked source) : Nat := + gen.families.length + +abbrev minorCount {source : VInductDecl} + (gen : BlockGenerationChecked source) : Nat := + gen.flatCtors.length + +/-- Whether the accepted block contains any recursive constructor argument. +For a positive checked block this is the kernel's `inductInfo.isRec` decision +expressed through the analyzer-owned recursive descriptors. -/ +def isRec {source : VInductDecl} + (gen : BlockGenerationChecked source) : Bool := + gen.flatCtors.any fun constructor => + !constructor.ctor.view.recursive.isEmpty + +/-- Whether some recursive argument is hidden beneath a function telescope, +matching the kernel's `inductInfo.isReflexive` flag. -/ +def isReflexive {source : VInductDecl} + (gen : BlockGenerationChecked source) : Bool := + gen.flatCtors.any fun constructor => + constructor.ctor.view.recursive.any fun recursive => + !recursive.binders.isEmpty + +/-- The block large-elimination decision. A non-Prop common result admits +large elimination; at `Prop`, only the kernel's singleton exception can do +so. In particular every genuinely mutual Prop block is small. -/ +def elimination {source : VInductDecl} + (gen : BlockGenerationChecked source) : ElimMode := + if gen.validated.resultLevel.isNeverZero then .large + else + match gen.families with + | [family] => + if largeElim source.uvars family.raw.name source.nparams + family.view.indices.length family.view.value then .large else .small + | _ => .small + +/-- K-like reduction is a singleton-only kernel flag. -/ +def kTarget {source : VInductDecl} + (gen : BlockGenerationChecked source) : Bool := + match gen.families with + | [family] => + isKTarget source.nparams gen.validated.resultLevel family.view.value + | _ => false + +abbrev recUvars {source : VInductDecl} + (gen : BlockGenerationChecked source) : Nat := + gen.elimination.recUvars source.uvars + +abbrev sourceLevels {source : VInductDecl} + (gen : BlockGenerationChecked source) : List VLevel := + gen.elimination.sourceLevels source.uvars + +abbrev motiveLevel {source : VInductDecl} + (gen : BlockGenerationChecked source) : VLevel := + gen.elimination.motiveLevel + +abbrev recLevels {source : VInductDecl} + (gen : BlockGenerationChecked source) : List VLevel := + gen.elimination.recLevels source.uvars + +/-- Shared emitted parameters in recursor universes. -/ +def paramsTel {source : VInductDecl} + (gen : BlockGenerationChecked source) : List VExpr := + generationParams gen.block.rawParams gen.block.checked.params |>.map + (VExpr.instL gen.sourceLevels) + +def familyNameAt {source : VInductDecl} + (gen : BlockGenerationChecked source) (ordinal : Nat) : Name := + (gen.families[ordinal]?).map (fun family => family.raw.name) |>.getD .anonymous + +def idxTel {source : VInductDecl} (gen : BlockGenerationChecked source) + (family : NormalizedFamily) : List VExpr := + (family.rawIndices source.nparams).map (VExpr.instL gen.sourceLevels) + +/-- One family motive before preceding motives have been inserted. -/ +def motiveType {source : VInductDecl} + (gen : BlockGenerationChecked source) + (family : NormalizedFamily) : VExpr := + let indices := gen.idxTel family + let ni := indices.length + VExpr.forallN indices + (.forallE + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange ni source.nparams ++ + VExpr.bvarRevRange 0 ni)) + (.sort gen.motiveLevel)) + +/-- Motives in kernel order. Each later motive is weakened past all earlier +motives while retaining the shared parameter context. -/ +def motiveTypesAux {source : VInductDecl} + (gen : BlockGenerationChecked source) : + List NormalizedFamily → (i : Nat := 0) → List VExpr + | [], _ => [] + | family :: families, i => + (gen.motiveType family).liftN i :: + gen.motiveTypesAux families (i + 1) + +def motiveTypes {source : VInductDecl} + (gen : BlockGenerationChecked source) : List VExpr := + gen.motiveTypesAux gen.families + +/-- Binder telescope of one mutual functional induction hypothesis. -/ +def blockMinorBinders (d m p : Nat) (r : RecArg) : List VExpr := + VExpr.liftTelN (m - r.fieldIndex + p) + (VExpr.liftTelN d r.binders r.fieldIndex) 0 + +/-- Mutual induction hypothesis routed to the recursive argument's target +motive. -/ +def blockMinorIH (d m p : Nat) (r : RecArg) : VExpr := + let n := r.binders.length + VExpr.forallN (blockMinorBinders d m p r) + (VExpr.appN (.bvar (d - 1 - r.targetType + m + p + n)) + ((r.indices.map fun e => + (e.liftN d (r.fieldIndex + n)).liftN + (m - r.fieldIndex + p) n) ++ + [VExpr.appN (.bvar (m - 1 - r.fieldIndex + p + n)) + (VExpr.bvarRevRange 0 n)])) + +def blockIHsFromRecArgs (d m : Nat) : List RecArg → Nat → List VExpr + | [], _ => [] + | r :: rs, p => + blockMinorIH d m p r :: blockIHsFromRecArgs d m rs (p + 1) + +/-- One constructor minor in the context of all block motives. -/ +def minorType {source : VInductDecl} + (gen : BlockGenerationChecked source) + (constructor : NormalizedBlockCtor) : VExpr := + let d := gen.familyCount + let Bs := constructor.ctor.fieldsR source.uvars source.nparams gen.elimination + let m := Bs.length + let rs := constructor.ctor.recArgsR source.uvars gen.elimination + let r := rs.length + VExpr.forallN (VExpr.liftTelN d Bs 0) + (VExpr.forallN (blockIHsFromRecArgs d m rs 0) + (VExpr.appN (.bvar (d - 1 - constructor.owner + m + r)) + ((constructor.ctor.resultIndicesR source.uvars gen.elimination |>.map + fun e => (e.liftN d m).liftN r) ++ + [VExpr.appN (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (r + m + d) source.nparams ++ + VExpr.bvarRevRange r m)]))) + +/-- Globally flattened constructor minors in family/constructor order. -/ +def minorTypesAux {source : VInductDecl} + (gen : BlockGenerationChecked source) : + List NormalizedBlockCtor → (i : Nat := 0) → List VExpr + | [], _ => [] + | constructor :: constructors, i => + (gen.minorType constructor).liftN i :: + gen.minorTypesAux constructors (i + 1) + +def minorTypes {source : VInductDecl} + (gen : BlockGenerationChecked source) : List VExpr := + gen.minorTypesAux gen.flatCtors + +/-- One recursor type for the selected family, sharing every motive and minor +with the other family recursors. -/ +def recType {source : VInductDecl} + (gen : BlockGenerationChecked source) + (family : NormalizedFamily) : VExpr := + let d := gen.familyCount + let k := gen.minorCount + let indices := gen.idxTel family + let ni := indices.length + VExpr.forallN gen.paramsTel <| + VExpr.forallN gen.motiveTypes <| + VExpr.forallN gen.minorTypes <| + VExpr.forallN (VExpr.liftTelN (d + k) indices 0) <| + .forallE + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (ni + d + k) source.nparams ++ + VExpr.bvarRevRange 0 ni)) <| + .app + (VExpr.appN + (.bvar (d - 1 - family.view.ordinal + k + ni + 1)) + (VExpr.bvarRevRange 1 ni)) + (.bvar 0) + +def recursor {source : VInductDecl} + (gen : BlockGenerationChecked source) + (family : NormalizedFamily) : VConstant := + ⟨gen.recUvars, gen.recType family⟩ + +/-- Named generated recursors in family order. -/ +def recursors {source : VInductDecl} + (gen : BlockGenerationChecked source) : List VConstVal := + gen.families.map fun family => + ⟨gen.recursor family, .str family.raw.name "rec"⟩ + +/-- Telescope introduced around a mutual recursive rule call. -/ +def blockRuleBinders (common m : Nat) (r : RecArg) : List VExpr := + VExpr.liftTelN (m - r.fieldIndex) + (VExpr.liftTelN common r.binders r.fieldIndex) 0 + +/-- Recursive iota-rule call routed to the target family's recursor. -/ +def blockRuleCall (common m : Nat) (recBase : VExpr) + (r : RecArg) : VExpr := + let n := r.binders.length + VExpr.lamN (blockRuleBinders common m r) + (VExpr.appN (recBase.liftN n) + ((r.indices.map fun e => + (e.liftN common (r.fieldIndex + n)).liftN + (m - r.fieldIndex) n) ++ + [VExpr.appN (.bvar (m - 1 - r.fieldIndex + n)) + (VExpr.bvarRevRange 0 n)])) + +def recBase {source : VInductDecl} + (gen : BlockGenerationChecked source) (m target : Nat) : VExpr := + VExpr.appN + (.const (.str (gen.familyNameAt target) "rec") gen.recLevels) + (VExpr.bvarRevRange m + (source.nparams + gen.familyCount + gen.minorCount)) + +/-- One mutual iota rule at its global flattened minor ordinal. -/ +def rule {source : VInductDecl} + (gen : BlockGenerationChecked source) + (minorIndex : Nat) (constructor : NormalizedBlockCtor) : VDefEq := + let d := gen.familyCount + let k := gen.minorCount + let common := d + k + let Bs := constructor.ctor.fieldsR source.uvars source.nparams gen.elimination + let m := Bs.length + let rs := constructor.ctor.recArgsR source.uvars gen.elimination + let binders := gen.paramsTel ++ gen.motiveTypes ++ gen.minorTypes ++ + VExpr.liftTelN common Bs 0 + let ownerRecBase := gen.recBase m constructor.owner + let idxR := constructor.ctor.resultIndicesR source.uvars gen.elimination |>.map + fun e => e.liftN common m + let ctorApp := VExpr.appN + (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (m + common) source.nparams ++ + VExpr.bvarRevRange 0 m) + let ihs := rs.map fun recursive => + blockRuleCall common m (gen.recBase m recursive.targetType) recursive + { uvars := gen.recUvars + lhs := VExpr.lamN binders + (VExpr.appN ownerRecBase (idxR ++ [ctorApp])) + rhs := VExpr.lamN binders + (VExpr.appN (.bvar (k - 1 - minorIndex + m)) + (VExpr.bvarRevRange 0 m ++ ihs)) + type := VExpr.forallN binders + (VExpr.appN + (.bvar (d - 1 - constructor.owner + k + m)) + (idxR ++ [ctorApp])) } + +def generatedRules {source : VInductDecl} + (gen : BlockGenerationChecked source) : List VDefEq := + gen.flatCtors.zipIdx.map fun (constructor, i) => + gen.rule i constructor + +end BlockGenerationChecked + /-- Semantic evidence for a recursive argument beneath a Pi telescope. The binder domains are checked over the constructor context before the recursive field; its terminal index spine is checked underneath those binders. -/ @@ -1334,6 +2450,132 @@ def RecArg.WF (r : RecArg) (env : VEnv) (l : VLevel) (Is : List VExpr) (.sort l)) r.indices (.sort l) +/-- Semantic well-formedness of every constructor field in a mutual block. + +Recursive fields may end in any source-indexed family and may sit below a Pi +telescope. Their target ordinal selects the corresponding index telescope +from `familyIndices`. A non-recursive field must be a block-free type in the +pre-family environment and obey the common result-universe bound. -/ +def blockFieldsWF (source : VInductDecl) (env : VEnv) + (resultLevel : VLevel) (familyIndices : List (List VExpr)) : + List VExpr → Nat → List VExpr → Prop + | _, _, [] => True + | Γ, j, B :: Bs => + (match blockRecArg? source.uvars source.nparams + (familyHeaders source.nparams source.types) + (familyNames source.types) j B with + | some recursive => + match familyIndices[recursive.targetType]? with + | some indices => + recursive.WF source.uvars env resultLevel indices Γ + | none => False + | none => + ∃ u, env.HasType source.uvars Γ B (.sort u) ∧ + (resultLevel = .zero ∨ u ≤ resultLevel)) ∧ + blockFieldsWF source env resultLevel familyIndices + (B :: Γ) (j + 1) Bs + +/-- Interpret the analyzer-retained positional classifications rather than +recomputing recursive recognition from field syntax. The list lengths and +field indices are checked in the proposition, while each recursive target +selects its exact source-ordered family index telescope. -/ +def checkedBlockFieldsWF (env : VEnv) (U : Nat) + (resultLevel : VLevel) (familyIndices : List (List VExpr)) : + List VExpr → List (Option RecArg) → List VExpr → Nat → Prop + | [], [], _, _ => True + | B :: Bs, classification :: classifications, Γ, j => + (match classification with + | some recursive => + recursive.fieldIndex = j ∧ + match familyIndices[recursive.targetType]? with + | some indices => recursive.WF U env resultLevel indices Γ + | none => False + | none => + ∃ u, env.HasType U Γ B (.sort u) ∧ + (resultLevel = .zero ∨ u ≤ resultLevel)) ∧ + checkedBlockFieldsWF env U resultLevel familyIndices + Bs classifications (B :: Γ) (j + 1) + | _, _, _, _ => False + +/-- Interpret a dependent source-ordered family spine at one shared result +universe. Family formers and the block-free portions of constructor fields +are interpreted in the common pre-family environment. Recursive targets are +reduced to their selected family index telescopes, so this layer does not +pretend that generated constants or recursors already exist. -/ +def CheckedFamilies.WF {source : VInductDecl} {params : List VExpr} + {ordinal : Nat} {types : List VInductiveType} + (families : CheckedFamilies source params ordinal types) + (env : VEnv) (resultLevel : VLevel) + (familyIndices : List (List VExpr)) : Prop := + match families with + | .nil => True + | .cons head tail => + head.resultLevel ≈ resultLevel ∧ + VEnv.OnTel env source.uvars [] (params ++ head.indices) ∧ + (∀ constructor ∈ head.constructors, + blockFieldsWF source env resultLevel familyIndices + params.reverse 0 constructor.fields ∧ + env.SpineWF source.uvars + (constructor.fields.reverse ++ params.reverse) + (VExpr.forallN + (VExpr.liftTelN constructor.fields.length head.indices 0) + (.sort resultLevel)) + constructor.resultIndices (.sort resultLevel)) ∧ + tail.WF env resultLevel familyIndices + +/-- Erased semantic fold over the exact projections of a dependent checked +family spine. `CheckedBlock.WF` uses this presentation so concrete checked +descriptors obtained by computation reduce through their public projections +without exposing proof fields stored inside `Option.get`. -/ +def checkedFamilyListsWF (source : VInductDecl) (params : List VExpr) + (env : VEnv) (resultLevel : VLevel) + (familyIndices : List (List VExpr)) : + List VLevel → List (List VExpr) → List (List CheckedCtor) → Prop + | [], [], [] => True + | level :: levels, indices :: indicesTail, + constructors :: constructorsTail => + level ≈ resultLevel ∧ + VEnv.OnTel env source.uvars [] (params ++ indices) ∧ + (∀ constructor ∈ constructors, + checkedBlockFieldsWF env source.uvars resultLevel familyIndices + constructor.fields constructor.recursiveAt params.reverse 0 ∧ + env.SpineWF source.uvars + (constructor.fields.reverse ++ params.reverse) + (VExpr.forallN + (VExpr.liftTelN constructor.fields.length indices 0) + (.sort resultLevel)) + constructor.resultIndices (.sort resultLevel)) ∧ + checkedFamilyListsWF source params env resultLevel familyIndices + levels indicesTail constructorsTail + | _, _, _ => False + +/-- Environment-indexed semantics of a structurally checked mutual block. +The common `resultLevel` is explicit and every family result is required to be +semantically equivalent to it. -/ +def CheckedBlock.WF {source : VInductDecl} + (checked : source.CheckedBlock) (env : VEnv) + (resultLevel : VLevel) : Prop := + checkedFamilyListsWF source checked.params env resultLevel + checked.families.indices checked.families.resultLevels + checked.families.indices checked.families.constructors + +/-- Complete Theory semantics of one validator-owned mutual normalization. +Normalization compares raw family types before staging and raw constructor +types after all-family staging; the checked view supplies the block-wide +strict-positivity and result-spine interpretation. -/ +def ValidatedBlock.WF {source : VInductDecl} + (validated : ValidatedBlock source) (env blockEnv : VEnv) : Prop := + validated.block.normalization.BlockWF env blockEnv ∧ + validated.block.checked.WF env validated.resultLevel + +/-- Consumer-facing validation-only package. It deliberately contains no +generated motive, recursor, rule, or environment insertion beyond the +temporary all-family validation stage. -/ +structure ValidationCertificate (source : VInductDecl) (env : VEnv) where + validated : ValidatedBlock source + blockEnv : VEnv + wf : validated.WF env blockEnv + /-- Semantic well-formedness of constructor fields over the pre-environment. Direct recursive fields retain the Stage-3 spine contract. A recursive Pi field additionally carries a well-formed binder telescope and the terminal @@ -1380,11 +2622,15 @@ def NormalizedChecked.WF {source : VInductDecl} (block : NormalizedChecked source) (env : VEnv) : Prop := block.normalization.WF env ∧ block.checked.WF env -/-- The binders emitted for one mixed minor/rule: the raw family parameter -surface followed by the stored raw constructor fields. -/ +/-- The binders emitted for one mixed minor/rule: the checked family +parameters followed by the stored raw constructor fields. + +Lean consumes parameter annotations while checking the family and uses those +checked locals when it builds the recursor. Constructor fields, by contrast, +retain their stored surface syntax. -/ def NormalizedCtor.emittedBinders {source : VInductDecl} (block : NormalizedChecked source) (ctor : NormalizedCtor) : List VExpr := - block.rawParams ++ ctor.rawFields source.nparams + block.checked.params ++ ctor.rawFields source.nparams /-- The normalized binders whose semantic analysis drives the mixed artifact. These expressions are never emitted in place of their raw partners. -/ @@ -1450,6 +2696,128 @@ structure GenerationChecked.WF {source : VInductDecl} gen.block.sourceType.toVConstant = some envT → ∀ ctor ∈ gen.block.ctorPairs, ctor.WF gen.block envT +/-! ### Mutual generation certificates -/ + +def NormalizedFamily.rawResult (family : NormalizedFamily) (np : Nat) : + VExpr := + VExpr.resultOf (VExpr.dropN np family.raw.type) + +def NormalizedBlockCtor.declaredBinders {source : VInductDecl} + (constructor : NormalizedBlockCtor) : List VExpr := + constructor.ctor.declaredBinders source.nparams + +/-- Constructor binders used by generated mutual artifacts before universe +instantiation. -/ +def NormalizedBlockCtor.emittedBinders {source : VInductDecl} + (gen : BlockGenerationChecked source) + (constructor : NormalizedBlockCtor) : List VExpr := + gen.block.checked.params ++ constructor.ctor.rawFields source.nparams + +def NormalizedBlockCtor.viewBinders {source : VInductDecl} + (gen : BlockGenerationChecked source) + (constructor : NormalizedBlockCtor) : List VExpr := + gen.block.checked.params ++ constructor.ctor.view.fields + +def NormalizedBlockCtor.rawResult {source : VInductDecl} + (constructor : NormalizedBlockCtor) : VExpr := + constructor.ctor.rawResult source.nparams + +/-- Normalized constructor result reconstructed with the stored owner name. -/ +def NormalizedBlockCtor.resultTarget {source : VInductDecl} + (gen : BlockGenerationChecked source) + (constructor : NormalizedBlockCtor) : VExpr := + VExpr.appN + (.const constructor.familyName (VLevel.params source.uvars)) + (VExpr.bvarRevRange + (constructor.ctor.rawFields source.nparams).length source.nparams ++ + constructor.ctor.view.resultIndices) + +/-- Granular raw/view semantics for one mutual family. -/ +structure NormalizedFamily.WF {source : VInductDecl} + (gen : BlockGenerationChecked source) (family : NormalizedFamily) + (env : VEnv) : Prop where + familyTel : + env.TelDefEq source.uvars [] + (family.rawParams source.nparams ++ family.rawIndices source.nparams) + (gen.block.checked.params ++ family.view.indices) + familyResult : + env.IsDefEq source.uvars + (family.rawParams source.nparams ++ + family.rawIndices source.nparams).reverse + (family.rawResult source.nparams) + (.sort gen.validated.resultLevel) + (.sort (.succ gen.validated.resultLevel)) + +/-- Declaration-stage raw/view semantics for one constructor after every +family has been staged. -/ +structure NormalizedBlockCtor.WF {source : VInductDecl} + (gen : BlockGenerationChecked source) + (constructor : NormalizedBlockCtor) (env : VEnv) : Prop where + declaredTel : + env.TelDefEq source.uvars [] + (NormalizedBlockCtor.declaredBinders (source := source) constructor) + (NormalizedBlockCtor.viewBinders gen constructor) + declaredResult : + env.IsDefEq source.uvars + (NormalizedBlockCtor.declaredBinders + (source := source) constructor).reverse + (NormalizedBlockCtor.rawResult (source := source) constructor) + (NormalizedBlockCtor.resultTarget gen constructor) + (.sort gen.validated.resultLevel) + emittedTel : + env.TelDefEq source.uvars [] + (NormalizedBlockCtor.emittedBinders gen constructor) + (NormalizedBlockCtor.viewBinders gen constructor) + emittedResult : + env.IsDefEq source.uvars + (NormalizedBlockCtor.emittedBinders gen constructor).reverse + (NormalizedBlockCtor.rawResult (source := source) constructor) + (NormalizedBlockCtor.resultTarget gen constructor) + (.sort gen.validated.resultLevel) + owner : ∃ family ∈ gen.families, + family.view.ordinal = constructor.owner ∧ + family.raw.name = constructor.familyName ∧ + family.view.indices = constructor.familyIndices + recursive : ∀ recursive ∈ constructor.ctor.view.recursive, + ∃ family ∈ gen.families, + family.view.ordinal = recursive.targetType ∧ + (∃ B, + constructor.ctor.view.fields[recursive.fieldIndex]? = some B ∧ + B = VExpr.forallN recursive.binders + (VExpr.appN + (.const family.raw.name (VLevel.params source.uvars)) + (VExpr.bvarRevRange + (recursive.fieldIndex + recursive.binders.length) + source.nparams ++ recursive.indices))) ∧ + recursive.WF source.uvars env gen.validated.resultLevel + family.view.indices + ((constructor.ctor.view.fields.take recursive.fieldIndex).reverse ++ + gen.block.checked.params.reverse) + resultSpine : + env.SpineWF source.uvars + (constructor.ctor.view.fields.reverse ++ + gen.block.checked.params.reverse) + (VExpr.forallN + (VExpr.liftTelN constructor.ctor.view.fields.length + constructor.familyIndices 0) + (.sort gen.validated.resultLevel)) + constructor.ctor.view.resultIndices + (.sort gen.validated.resultLevel) + +/-- Semantic input to block artifact preservation. No field assumes a +generated motive, minor, recursor, or rule typing judgment. -/ +structure BlockGenerationChecked.WF {source : VInductDecl} + (gen : BlockGenerationChecked source) (env blockEnv : VEnv) : Prop where + blockWF : gen.validated.WF env blockEnv + resultLevelWF : gen.validated.resultLevel.WF source.uvars + paramsTel : + env.TelDefEq source.uvars [] gen.block.rawParams + gen.block.checked.params + families : ∀ family ∈ gen.families, family.WF gen env + constructors : + ∀ constructor ∈ gen.flatCtors, + NormalizedBlockCtor.WF gen constructor blockEnv + /-- Consumer-facing semantic package for one generation-ready inductive declaration. The executable transaction inspects only `generation`; `wf` is the ordinary Theory certificate used by preservation and is never a @@ -1461,10 +2829,18 @@ structure GenerationCertificate (source : VInductDecl) (env : VEnv) where generation : GenerationChecked source wf : generation.WF env +/-- Consumer-facing proof-carrying mutual generation package. -/ +structure BlockGenerationCertificate (source : VInductDecl) (env : VEnv) where + generation : BlockGenerationChecked source + blockEnv : VEnv + wf : generation.WF env blockEnv + end VInductDecl +/-- Legacy declaration-level semantic contract for one-family compatibility. +Block-wide preservation consumes `BlockGenerationChecked.WF` directly. -/ def VInductDecl.WF (env : VEnv) (decl : VInductDecl) : Prop := - decl.stage3 ∧ + decl.singletonStage3 ∧ ∀ ty ∈ decl.types, VEnv.OnTel env decl.uvars [] (VExpr.telN decl.nparams ty.type ++ @@ -1486,6 +2862,16 @@ def VInductDecl.WF (env : VEnv) (decl : VInductDecl) : Prop := (VExpr.resultOf (VExpr.dropN decl.nparams c.type))) (.sort (VInductDecl.sortLevel decl.nparams ty)) +/-- Raw family constants of a block in source order. -/ +def VInductDecl.blockTypeConstants (source : VInductDecl) : + List VConstVal := + source.types.map (·.toVConstVal) + +/-- Raw constructor constants flattened in family/constructor order. -/ +def VInductDecl.blockConstructorConstants (source : VInductDecl) : + List VConstVal := + source.types.flatMap (·.ctors) + /-- The single computational transaction for a generation-ready raw/view block. Stored family and constructor constants come from the raw source; recursor and rules come from the mixed artifact implementation. Semantic @@ -1499,6 +2885,20 @@ def VEnv.addInductGeneration {source : VInductDecl} let env ← env.addConst (.str ty.name "rec") gen.recursor return gen.generatedRules.foldl VEnv.addDefEq env +/-- The block-wide generation transaction. Its four phases deliberately +match the kernel's visibility boundaries: every family is present before any +constructor, every constructor before any recursor, and every recursor before +the first reduction rule. -/ +def VEnv.addInductBlockGeneration {source : VInductDecl} + (env : VEnv) (gen : source.BlockGenerationChecked) : 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 ← gen.recursors.foldlM + (fun env recursor => env.addConst recursor.name recursor.toVConstant) env + return gen.generatedRules.foldl VEnv.addDefEq env + /-- Public proof-carrying wrapper around `addInductGeneration`. The certificate's proof is erased and does not influence computation. This @@ -1510,6 +2910,13 @@ def VEnv.addInductCertified {source : VInductDecl} Option VEnv := env.addInductGeneration certificate.generation +/-- Proof-carrying wrapper for a block-wide generation transaction. The +certificate is erased from computation. -/ +def VEnv.addInductBlockCertified {source : VInductDecl} + (env : VEnv) (certificate : source.BlockGenerationCertificate env) : + Option VEnv := + env.addInductBlockGeneration certificate.generation + @[simp] theorem VEnv.addInductCertified_eq_addInductGeneration {source : VInductDecl} (env : VEnv) (certificate : source.GenerationCertificate env) : @@ -1517,6 +2924,13 @@ def VEnv.addInductCertified {source : VInductDecl} env.addInductGeneration certificate.generation := rfl +@[simp] theorem VEnv.addInductBlockCertified_eq_addInductBlockGeneration + {source : VInductDecl} (env : VEnv) + (certificate : source.BlockGenerationCertificate env) : + env.addInductBlockCertified certificate = + env.addInductBlockGeneration certificate.generation := + rfl + /-- Exact intermediate states of a successful normalized inductive transaction. Stable lookup, freshness, monotonicity, and preservation consequences are derived from this one trace in the typing layer. -/ @@ -1538,38 +2952,86 @@ structure VEnv.AddInductGenerationTrace {source : VInductDecl} addRules : gen.generatedRules.foldl VEnv.addDefEq recEnv = env' -/-- The existing raw-normal-form API is exactly the identity-normalization -wrapper around `addInductGeneration`. -/ +/-- Exact phase boundaries of a successful block-wide generation +transaction. -/ +structure VEnv.AddInductBlockGenerationTrace {source : VInductDecl} + (env env' : VEnv) (gen : source.BlockGenerationChecked) 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 : + gen.recursors.foldlM + (fun env recursor => env.addConst recursor.name recursor.toVConstant) + ctorEnv = some recEnv + addRules : + gen.generatedRules.foldl VEnv.addDefEq recEnv = env' + +/-- The raw-normal-form API analyzes and inserts a complete mutual block. -/ def VEnv.addInduct (env : VEnv) (decl : VInductDecl) : Option VEnv := do + let generation ← decl.identityBlockGeneration? + env.addInductBlockGeneration generation + +/-- Compatibility wrapper for the pre-L4L-08C one-family raw transaction. + +Unlike `addInduct`, this deliberately projects the legacy `Checked` artifact +and therefore rejects every genuinely mutual declaration. It remains only +for a deprecation window so existing one-family consumers can separate their +API migration from the semantic switch to block-wide generation. -/ +@[deprecated VEnv.addInduct (since := "2026-08-07")] +def VEnv.addInductSingleton (env : VEnv) (decl : VInductDecl) : Option VEnv := do let checked ← decl.checked? env.addInductGeneration checked.identityGeneration -/-- The raw public API is transparently the identity-normalization -specialization of the normalized transaction. -/ -theorem VEnv.addInduct_eq_addInductGeneration +/-- The compatibility wrapper is exactly the former identity-normalization +transaction; it is not a second block-generation path. -/ +@[simp, deprecated VEnv.addInduct (since := "2026-08-07")] +theorem VEnv.addInductSingleton_eq_addInductGeneration (env : VEnv) (decl : VInductDecl) : - env.addInduct decl = + env.addInductSingleton decl = decl.checked? >>= fun checked => env.addInductGeneration checked.identityGeneration := rfl +/-- The raw public API is transparently the identity-normalization +specialization of the normalized block transaction. -/ +theorem VEnv.addInduct_eq_addInductBlockGeneration + (env : VEnv) (decl : VInductDecl) : + env.addInduct decl = + decl.identityBlockGeneration? >>= fun generation => + env.addInductBlockGeneration generation := + rfl + +/-- +info: 'Lean4Lean.VEnv.addInductSingleton_eq_addInductGeneration' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.addInductSingleton_eq_addInductGeneration + /-- Stable, consumer-facing consequences of a successful `addInduct` transaction. This deliberately hides the internal `foldlM` sequence: a caller receives the complete output environment and all generated objects, or `addInduct` returns `none` without exposing an intermediate environment. -/ structure VEnv.AddInductSuccess (env env' : VEnv) (decl : VInductDecl) : Prop where - checked : ∃ checked, decl.checked? = some checked + generation : ∃ generation, decl.identityBlockGeneration? = some generation accepted : decl.stage3 = true - singleton : ∃ ty, decl.types = [ty] le : env ≤ env' type_fresh : ∀ ty ∈ decl.types, env.constants ty.name = none type_lookup : ∀ ty ∈ decl.types, env'.constants ty.name = some ty.toVConstant ctor_fresh : ∀ ty ∈ decl.types, ∀ c ∈ ty.ctors, env.constants c.name = none ctor_lookup : ∀ ty ∈ decl.types, ∀ c ∈ ty.ctors, env'.constants c.name = some c.toVConstant - rec_fresh : ∀ ty ∈ decl.types, env.constants (.str ty.name "rec") = none - rec_lookup : ∀ ty ∈ decl.types, - env'.constants (.str ty.name "rec") = - some (VInductDecl.recConstRec decl.uvars ty.name decl.nparams ty) - rule_mem : ∀ ty ∈ decl.types, - ∀ df ∈ VInductDecl.rulesRec decl.uvars ty.name decl.nparams ty, env'.defeqs df + rec_fresh : ∀ generation, decl.identityBlockGeneration? = some generation → + ∀ recursor ∈ generation.recursors, env.constants recursor.name = none + rec_lookup : ∀ generation, decl.identityBlockGeneration? = some generation → + ∀ recursor ∈ generation.recursors, + env'.constants recursor.name = some recursor.toVConstant + rule_mem : ∀ generation, decl.identityBlockGeneration? = some generation → + ∀ df ∈ generation.generatedRules, env'.defeqs df diff --git a/Lean4Lean/Theory/InductiveFixtures.lean b/Lean4Lean/Theory/InductiveFixtures.lean index b2fd1e65..2a85a300 100644 --- a/Lean4Lean/Theory/InductiveFixtures.lean +++ b/Lean4Lean/Theory/InductiveFixtures.lean @@ -47,6 +47,10 @@ def natNormalizedChecked : NormalizedChecked natDecl := def natGenerationChecked : GenerationChecked natDecl := (identityGeneration? natDecl).get (by decide) +/-- The public block descriptor specializes to the same singleton metadata. -/ +def natBlockGenerationChecked : BlockGenerationChecked natDecl := + (identityBlockGeneration? natDecl).get (by decide) + example : natNormalizedChecked.normalization.view = natDecl := rfl example : natNormalizedChecked.checked.type = natType := rfl example : (normalizedChecked? natDecl natDecl).isSome = true := rfl @@ -64,6 +68,8 @@ example : natChecked.params = [] := rfl example : natChecked.indices = [] := rfl example : natChecked.resultLevel = .succ .zero := rfl example : natChecked.elimination = .large := rfl +example : natChecked.kTarget = false := rfl +example : natGenerationChecked.kTarget = false := rfl example : natChecked.constructors.length = 2 := rfl example : natChecked.constructors[1].recursive.length = 1 := rfl example : natChecked.constructors[1].recursive[0].fieldIndex = 0 := rfl @@ -119,6 +125,136 @@ example : (rules 0 ``Bool 0 boolType)[0]? = example : (rules 0 ``Bool 0 boolType)[1]? = some (vdefeq(motive f t => @Bool.rec motive f t .true ≡ t)) := rfl +/-! ## Unit/Empty edge shapes + +`Unit` is a reducible alias for `PUnit` on this Lean revision, so the actual +one-constructor kernel metadata is recorded under `PUnit`. Together with +`Empty`, these fixtures exercise the one- and zero-constructor generation +paths without inventing an alias-level recursor that the kernel does not +declare. -/ + +def punitType : VInductiveType where + name := ``PUnit + uvars := 1 + type := vconst(type_of% @PUnit).type + ctors := [⟨vconst(type_of% @PUnit.unit), ``PUnit.unit⟩] + +def punitDecl : VInductDecl := ⟨1, 0, [punitType]⟩ + +example : punitDecl.stage3 = true := rfl + +def punitChecked : punitDecl.Checked := punitDecl.checked?.get (by decide) + +def punitGenerationChecked : GenerationChecked punitDecl := + (identityGeneration? punitDecl).get (by decide) + +example : punitChecked.params = [] := rfl +example : punitChecked.indices = [] := rfl +example : punitChecked.resultLevel = .param 0 := rfl +example : punitChecked.elimination = .large := rfl +example : punitChecked.kTarget = false := rfl +example : punitChecked.constructors.length = 1 := rfl +example : punitChecked.constructors[0].fields = [] := rfl +example : punitChecked.constructors[0].recursive = [] := rfl +example : punitGenerationChecked.block.ctorPairs.length = 1 := rfl +example : punitGenerationChecked.minorTypes.length = 1 := rfl +example : punitGenerationChecked.generatedRules.length = 1 := rfl + +/-- The one-constructor recursor retains the fresh elimination universe before +the source universe, and its sole minor occurs before the major. -/ +example : punitGenerationChecked.recursor = + permC (vconst(type_of% @PUnit.rec)) [.param 1, .param 0] := rfl + +example : punitGenerationChecked.generatedRules[0]? = + some (permE + (vdefeq((motive : PUnit.{u} → Sort v) unit => + @PUnit.rec.{v, u} motive unit @PUnit.unit.{u} ≡ unit)) + [.param 1, .param 0]) := rfl + +theorem punitDecl_wf : punitDecl.WF VEnv.empty := by + refine ⟨rfl, ?_⟩ + intro ty hty + have hty' : ty = punitType := + List.mem_singleton.1 (by simpa [punitDecl] using hty) + subst ty + refine ⟨?_, ?_⟩ + · change True + trivial + · intro c hc + have hc' := List.mem_singleton.1 hc + subst c + constructor + · change True + trivial + · change VExpr.sort (.param 0) = VExpr.sort (.param 0) + rfl + +def punitEnv : VEnv := + (VEnv.empty.addInduct punitDecl).get (by decide) + +/-- The public checked transaction and the normalized generation core are the +same computation for this identity-normalized edge fixture. -/ +example : VEnv.empty.addInduct punitDecl = + VEnv.empty.addInductGeneration punitGenerationChecked := rfl + +theorem punitEnv_ordered : punitEnv.Ordered := + VEnv.addInductGeneration_WF .empty + ((punitChecked.wf_of_decl punitDecl_wf).identityGeneration .empty) rfl + +def emptyType : VInductiveType where + name := ``Empty + uvars := 0 + type := vconst(type_of% @Empty).type + ctors := [] + +def emptyDecl : VInductDecl := ⟨0, 0, [emptyType]⟩ + +example : emptyDecl.stage3 = true := rfl + +def emptyChecked : emptyDecl.Checked := emptyDecl.checked?.get (by decide) + +def emptyGenerationChecked : GenerationChecked emptyDecl := + (identityGeneration? emptyDecl).get (by decide) + +def emptyBlockGenerationChecked : BlockGenerationChecked emptyDecl := + (identityBlockGeneration? emptyDecl).get (by decide) + +example : emptyChecked.params = [] := rfl +example : emptyChecked.indices = [] := rfl +example : emptyChecked.resultLevel = .succ .zero := rfl +example : emptyChecked.elimination = .large := rfl +example : emptyChecked.kTarget = false := rfl +example : emptyChecked.constructors = [] := rfl +example : emptyGenerationChecked.block.ctorPairs = [] := rfl +example : emptyGenerationChecked.minorTypes = [] := rfl +example : emptyGenerationChecked.generatedRules = [] := rfl + +/-- Empty elimination has a motive and major but no constructor minor. -/ +example : emptyGenerationChecked.recursor = + vconst(type_of% @Empty.rec) := rfl + +theorem emptyDecl_wf : emptyDecl.WF VEnv.empty := by + refine ⟨rfl, ?_⟩ + intro ty hty + have hty' : ty = emptyType := + List.mem_singleton.1 (by simpa [emptyDecl] using hty) + subst ty + refine ⟨?_, ?_⟩ + · change True + trivial + · intro c hc + simp [emptyType] at hc + +def emptyEnv : VEnv := + (VEnv.empty.addInduct emptyDecl).get (by decide) + +example : VEnv.empty.addInduct emptyDecl = + VEnv.empty.addInductGeneration emptyGenerationChecked := rfl + +theorem emptyEnv_ordered : emptyEnv.Ordered := + VEnv.addInductGeneration_WF .empty + ((emptyChecked.wf_of_decl emptyDecl_wf).identityGeneration .empty) rfl + /-! ## List: one parameter, a dependent field, direct recursion -/ def listType : VInductiveType where @@ -215,6 +351,8 @@ example : eqChecked.params = [.sort (.param 0), .bvar 0] := rfl example : eqChecked.indices = [.bvar 1] := rfl example : eqChecked.resultLevel = .zero := rfl example : eqChecked.elimination = .large := rfl +example : eqChecked.kTarget = true := rfl +example : eqGenerationChecked.kTarget = true := rfl example : eqChecked.constructors[0].resultIndices = [.bvar 0] := rfl example : eqChecked.recursor = recConst 1 ``Eq 2 eqType := rfl example : eqGenerationChecked.motiveType = eqChecked.motiveType := rfl @@ -353,11 +491,12 @@ example : ∀ env', VEnv.empty.addInduct indexedVecDecl = some env' → VEnv.AddInductSuccess VEnv.empty env' indexedVecDecl := fun _ => VEnv.addInduct_success -/-- The transaction certificate exposes the exact analyzer result for ix-like -consumers without re-running `checked?`. -/ +/-- The transaction certificate exposes the exact block-generation result for +ix-like consumers without re-running structural analysis. -/ example : ∀ env', VEnv.empty.addInduct indexedVecDecl = some env' → - ∃ checked, indexedVecDecl.checked? = some checked := - fun _ => VEnv.addInduct_checked + ∃ generation, + indexedVecDecl.identityBlockGeneration? = some generation := + fun _ => VEnv.addInduct_generation /-! ## Acc: recursive argument beneath a Pi telescope @@ -380,6 +519,9 @@ def accChecked : accDecl.Checked := accDecl.checked?.get (by decide) def accGenerationChecked : GenerationChecked accDecl := (identityGeneration? accDecl).get (by decide) +def accBlockGenerationChecked : BlockGenerationChecked accDecl := + (identityBlockGeneration? accDecl).get (by decide) + def accRecArgs : List RecArg := recArgs 1 ``Acc 2 1 (ctorFields (VExpr.dropN 2 accType.ctors[0].type)) @@ -426,9 +568,10 @@ example : (VEnv.empty.addInduct accDecl).map (·.constants ``Acc.rec) = example : ∀ env', VEnv.empty.addInduct accDecl = some env' → env'.defeqs (ruleRec 1 ``Acc 2 accType 0 accType.ctors[0]) := by intro env' hadd - apply VEnv.addInduct_rule_mem hadd (.head _) + apply VEnv.addInduct_rule_mem hadd + (generation := accBlockGenerationChecked) rfl change ruleRec 1 ``Acc 2 accType 0 accType.ctors[0] ∈ - [ruleRec 1 ``Acc 2 accType 0 accType.ctors[0]] + accBlockGenerationChecked.generatedRules exact .head _ example : ∀ env', VEnv.empty.addInduct accDecl = some env' → @@ -502,7 +645,8 @@ theorem accDecl_wf : accDecl.WF VEnv.empty := by def accEnv : VEnv := (VEnv.empty.addInduct accDecl).get (by decide) example : accEnv.Ordered := - VEnv.addInduct_WF .empty accDecl_wf rfl + VEnv.addInductGeneration_WF .empty + ((accChecked.wf_of_decl accDecl_wf).identityGeneration .empty) rfl /-- A collision at the generated recursor name still rejects the whole Acc transaction; no recursive-Pi special case bypasses freshness. -/ @@ -510,7 +654,8 @@ def accRecCollisionEnv : VEnv := (VEnv.empty.addConst ``Acc.rec ⟨0, .sort .zero⟩).get (by decide) example : accRecCollisionEnv.addInduct accDecl = none := - VEnv.addInduct_eq_none_of_rec_present rfl ⟨_, rfl⟩ + VEnv.addInduct_eq_none_of_rec_present + (generation := accBlockGenerationChecked) rfl (.head _) ⟨_, rfl⟩ /-! ## AnnotatedPi: recursive Pi normalization below a constructor field @@ -664,6 +809,275 @@ theorem annotatedPiViewChecked_wf : some outParamConstEnv)).trans VEnv.addDefEq_le) exact annotatedPiViewChecked.wf_of_decl annotatedPiViewDecl_wf +/-! ## AnnotatedParam: definitionally equal constructor parameters + +Family validation consumes the `outParam` annotation before recording its +parameter local. Constructor metadata retains the annotation, so the ordinary +validator must use definitional equality rather than syntax when it checks the +constructor's parameter prefix. -/ + +inductive AnnotatedParam (alpha : outParam Type) : Type where + | mk : AnnotatedParam alpha + +def annotatedParamRawType : VInductiveType where + name := ``AnnotatedParam + uvars := 0 + type := vconst(type_of% @AnnotatedParam).type + ctors := [⟨vconst(type_of% @AnnotatedParam.mk), ``AnnotatedParam.mk⟩] + +def annotatedParamRawDecl : VInductDecl := + ⟨0, 1, [annotatedParamRawType]⟩ + +def annotatedParamViewCtor : VConstVal where + name := ``AnnotatedParam.mk + uvars := 0 + type := .forallE (.sort (.succ .zero)) + (.app (.const ``AnnotatedParam []) (.bvar 0)) + +def annotatedParamViewType : VInductiveType where + name := ``AnnotatedParam + uvars := 0 + type := .forallE (.sort (.succ .zero)) (.sort (.succ .zero)) + ctors := [annotatedParamViewCtor] + +def annotatedParamViewDecl : VInductDecl := + ⟨0, 1, [annotatedParamViewType]⟩ + +example : annotatedParamRawType.type = + .forallE + (.app (.const ``outParam [.succ (.succ .zero)]) + (.sort (.succ .zero))) + (.sort (.succ .zero)) := rfl + +example : annotatedParamRawType.ctors[0].type = + .forallE + (.app (.const ``outParam [.succ (.succ .zero)]) + (.sort (.succ .zero))) + (.app (.const ``AnnotatedParam []) (.bvar 0)) := rfl + +example : annotatedParamViewDecl.checked?.isSome = true := rfl +example : normalizationShape annotatedParamRawDecl annotatedParamViewDecl = + true := rfl + +def annotatedParamNormalization : Normalization annotatedParamRawDecl where + view := annotatedParamViewDecl + shape_eq := rfl + +def annotatedParamViewChecked : annotatedParamViewDecl.Checked := + annotatedParamViewDecl.checked?.get (by decide) + +def annotatedParamBlock : NormalizedChecked annotatedParamRawDecl := + annotatedParamNormalization.check?.get (by decide) + +def annotatedParamGenerationChecked : + GenerationChecked annotatedParamRawDecl := + annotatedParamBlock.generation?.get (by decide) + +example : annotatedParamGenerationChecked.recursor = + vconst(type_of% @AnnotatedParam.rec) := rfl + +example : annotatedParamGenerationChecked.generatedRules[0]? = + some (vdefeq((alpha : Type) + (motive : AnnotatedParam alpha → Sort u) + (mk : motive (@AnnotatedParam.mk alpha)) => + @AnnotatedParam.rec alpha motive mk (@AnnotatedParam.mk alpha) ≡ mk)) := rfl + +/-- The raw parameter domain retained by kernel metadata before annotation +consumption. -/ +def annotatedParamRawDomain : VExpr := + .app (.const ``outParam [.succ (.succ .zero)]) + (.sort (.succ .zero)) + +/-- The stored `outParam Type` parameter and the checked `Type` parameter are +definitionally equal in the exact pre-declaration environment. -/ +theorem annotatedParamRawDomain_defeq : + outParamEnv.IsDefEq 0 [] annotatedParamRawDomain + (.sort (.succ .zero)) (.sort (.succ (.succ .zero))) := by + have hfn : outParamEnv.IsDefEq 0 [] + (.const ``outParam [.succ (.succ .zero)]) + (.lam (.sort (.succ (.succ .zero))) (.bvar 0)) + (.forallE (.sort (.succ (.succ .zero))) + (.sort (.succ (.succ .zero)))) := by + simpa [outParamDefEq, VExpr.instL, VLevel.inst] using + (VEnv.IsDefEq.extra (env := outParamEnv) (uvars := 0) (Γ := []) + (df := outParamDefEq) (ls := [.succ (.succ .zero)]) + (by simp [outParamEnv, VEnv.addDefEq]) + (by simp; decide) rfl) + have harg : outParamEnv.HasType 0 [] + (.sort (.succ .zero)) (.sort (.succ (.succ .zero))) := + VEnv.HasType.sort (by decide) + exact (VEnv.IsDefEq.appDF hfn harg).trans + (VEnv.IsDefEq.beta (VEnv.HasType.bvar .zero) harg) + +/-- +info: 'Lean4Lean.InductiveFixtures.annotatedParamRawDomain_defeq' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms annotatedParamRawDomain_defeq + +/-- The annotation-consumed declaration accepted by the structural analyzer +has the ordinary direct semantic interpretation. -/ +theorem annotatedParamViewDecl_wf : + annotatedParamViewDecl.WF VEnv.empty := by + refine ⟨rfl, ?_⟩ + intro ty hty + have hty' : ty = annotatedParamViewType := + List.mem_singleton.1 (by + simpa [annotatedParamViewDecl] using hty) + subst ty + refine ⟨?_, ?_⟩ + · change VEnv.OnTel VEnv.empty 0 [] [.sort (.succ .zero)] + exact ⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩ + · intro c hc + have hc' : c = annotatedParamViewCtor := + List.mem_singleton.1 (by + simpa [annotatedParamViewType] using hc) + subst c + exact ⟨trivial, rfl⟩ + +/-- Exact Theory environment after staging the stored family constant. -/ +def annotatedParamTypeEnv : VEnv := + (outParamEnv.addConst annotatedParamRawType.name + annotatedParamRawType.toVConstant).get (by decide) + +theorem annotatedParamTypeEnv_ordered : + annotatedParamTypeEnv.Ordered := by + have hbody : outParamEnv.HasType 0 [annotatedParamRawDomain] + (.sort (.succ .zero)) (.sort (.succ (.succ .zero))) := + VEnv.HasType.sort (by decide) + apply VEnv.Ordered.const (n := annotatedParamRawType.name) + (ci := annotatedParamRawType.toVConstant) + outParamEnv_ordered + · exact ⟨.imax (.succ (.succ .zero)) (.succ (.succ .zero)), + VEnv.HasType.forallE + (VEnv.IsDefEq.hasType annotatedParamRawDomain_defeq).1 hbody⟩ + · rfl + +private theorem annotatedParamFamilyApp_hasType (domain : VExpr) + (hdomain : annotatedParamTypeEnv.HasType 0 [domain] + (.bvar 0) annotatedParamRawDomain) : + annotatedParamTypeEnv.HasType 0 [domain] + (.app (.const ``AnnotatedParam []) (.bvar 0)) + (.sort (.succ .zero)) := by + apply VEnv.HasType.app + (A := annotatedParamRawDomain) (B := .sort (.succ .zero)) + · simpa [annotatedParamRawType, annotatedParamRawDomain, + VExpr.instL, VLevel.inst] using + VEnv.HasType.const (env := annotatedParamTypeEnv) (U := 0) + (Γ := [domain]) (c := ``AnnotatedParam) + (ci := annotatedParamRawType.toVConstant) (ls := []) + (VEnv.addConst_self (show + outParamEnv.addConst annotatedParamRawType.name + annotatedParamRawType.toVConstant = + some annotatedParamTypeEnv from rfl)) + (by simp) rfl + · exact hdomain + +theorem annotatedParamRawCtorBody_hasType : + annotatedParamTypeEnv.HasType 0 [annotatedParamRawDomain] + (.app (.const ``AnnotatedParam []) (.bvar 0)) + (.sort (.succ .zero)) := by + apply annotatedParamFamilyApp_hasType + simpa [annotatedParamRawDomain, VExpr.liftN] using + (VEnv.HasType.bvar (env := annotatedParamTypeEnv) (U := 0) + (Lookup.zero (Γ := []) (ty := annotatedParamRawDomain))) + +theorem annotatedParamCheckedCtorBody_hasType : + annotatedParamTypeEnv.HasType 0 [.sort (.succ .zero)] + (.app (.const ``AnnotatedParam []) (.bvar 0)) + (.sort (.succ .zero)) := by + apply annotatedParamFamilyApp_hasType + have hb : annotatedParamTypeEnv.HasType 0 [.sort (.succ .zero)] + (.bvar 0) (.sort (.succ .zero)) := by + simpa [VExpr.liftN] using + (VEnv.HasType.bvar (env := annotatedParamTypeEnv) (U := 0) + (Lookup.zero (Γ := []) (ty := .sort (.succ .zero)))) + have hd := annotatedParamRawDomain_defeq.mono + (VEnv.addConst_le (show + outParamEnv.addConst annotatedParamRawType.name + annotatedParamRawType.toVConstant = + some annotatedParamTypeEnv from rfl)) + exact (hd.weak0 annotatedParamTypeEnv_ordered).symm.defeq hb + +/-- The raw family and constructor metadata are semantically related to the +annotation-consumed analyzer view at their exact declaration stages. -/ +theorem annotatedParamNormalization_wf : + annotatedParamNormalization.WF outParamEnv := by + refine ⟨annotatedParamRawType, annotatedParamViewType, + rfl, rfl, ?_, ?_⟩ + · have hbody : outParamEnv.HasType 0 [annotatedParamRawDomain] + (.sort (.succ .zero)) (.sort (.succ (.succ .zero))) := + VEnv.HasType.sort (by decide) + exact ⟨_, VEnv.IsDefEq.forallEDF + annotatedParamRawDomain_defeq hbody⟩ + · intro envT hadd + have henv : envT = annotatedParamTypeEnv := by + have : some envT = some annotatedParamTypeEnv := + hadd.symm.trans (show + outParamEnv.addConst annotatedParamRawType.name + annotatedParamRawType.toVConstant = + some annotatedParamTypeEnv from rfl) + exact Option.some.inj this + subst envT + exact .cons ⟨_, VEnv.IsDefEq.forallEDF + (annotatedParamRawDomain_defeq.mono + (VEnv.addConst_le (show + outParamEnv.addConst annotatedParamRawType.name + annotatedParamRawType.toVConstant = + some annotatedParamTypeEnv from rfl))) + annotatedParamRawCtorBody_hasType⟩ .nil + +theorem annotatedParamViewChecked_wf : + annotatedParamViewChecked.WF outParamEnv := by + apply VInductDecl.Checked.WF.mono + ((VEnv.addConst_le (by rfl : + VEnv.empty.addConst ``outParam (vconst(type_of% @outParam)) = + some outParamConstEnv)).trans VEnv.addDefEq_le) + exact annotatedParamViewChecked.wf_of_decl annotatedParamViewDecl_wf + +/-- The mixed generation value uses the checked parameter for emitted +recursor binders while retaining the raw constructor surface, and all four +raw/view telescope/result obligations hold in their respective contexts. -/ +theorem annotatedParamGenerationChecked_wf : + annotatedParamGenerationChecked.WF outParamEnv := by + refine { + blockWF := ⟨annotatedParamNormalization_wf, + annotatedParamViewChecked_wf⟩ + familyTel := ?_ + familyResult := ?_ + ctors := ?_ } + · change outParamEnv.TelDefEq 0 [] [annotatedParamRawDomain] + [.sort (.succ .zero)] + exact ⟨⟨_, annotatedParamRawDomain_defeq⟩, trivial⟩ + · exact VEnv.HasType.sort (by decide) + · intro envT hadd ctor hctor + have henv : envT = annotatedParamTypeEnv := by + have : some envT = some annotatedParamTypeEnv := + hadd.symm.trans (show + outParamEnv.addConst annotatedParamRawType.name + annotatedParamRawType.toVConstant = + some annotatedParamTypeEnv from rfl) + exact Option.some.inj this + subst envT + change ctor ∈ [⟨annotatedParamRawType.ctors[0], + annotatedParamViewChecked.constructors[0]⟩] at hctor + obtain rfl := List.mem_singleton.1 hctor + refine { + declaredTel := ⟨⟨_, annotatedParamRawDomain_defeq.mono + (VEnv.addConst_le (show + outParamEnv.addConst annotatedParamRawType.name + annotatedParamRawType.toVConstant = + some annotatedParamTypeEnv from rfl))⟩, trivial⟩ + declaredResult := annotatedParamRawCtorBody_hasType + emittedTel := ⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩ + emittedResult := annotatedParamCheckedCtorBody_hasType } + +/-- +info: 'Lean4Lean.InductiveFixtures.annotatedParamGenerationChecked_wf' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms annotatedParamGenerationChecked_wf + /-! ## Explicit normalization boundary Lean stores reducible aliases in inductive metadata even though @@ -1313,6 +1727,840 @@ info: 'Lean4Lean.InductiveFixtures.aliasRecFinalEnv_ordered' depends on axioms: #guard_msgs in #print axioms aliasRecFinalEnv_ordered +/-! ## Normalization differential matrix + +The isolated `AliasFormer` and `AliasRec` fixtures above establish that Lean +retains reducible aliases at family results and direct recursive targets. The +single indexed declaration below covers every remaining normalization +position in one real kernel payload: parameter and index domains, ordinary +fields, direct recursion, recursion hidden behind a Pi-producing alias, and +beta/let redexes retained in alias definitions. Its view is deliberately +written out so changes to either Lean's stored metadata or the Theory +normalizer fail by computation. +-/ + +abbrev MatrixBetaAlias (alpha : Sort u) := + (fun type : Sort u => type) alpha + +abbrev MatrixLetAlias (alpha : Sort u) := + let type := alpha + type + +abbrev MatrixPiAlias (alpha : Sort u) := (proof : Prop) → alpha + +abbrev MatrixIndexAlias + (index : TypeFamilyAlias) : TypeFamilyAlias := index + +inductive NormalizationMatrix (alpha : TypeFamilyAlias) : + TypeFamilyAlias → Type 1 where + | mk (index : TypeFamilyAlias) + (ordinary : RecAlias Prop) + (beta : MatrixBetaAlias Prop) + (letBound : MatrixLetAlias Prop) + (direct : RecAlias + (NormalizationMatrix alpha (MatrixIndexAlias index))) + (piHidden : MatrixPiAlias + (NormalizationMatrix alpha (MatrixIndexAlias index))) + (betaRecursive : MatrixBetaAlias + (NormalizationMatrix alpha (MatrixIndexAlias index))) + (letRecursive : MatrixLetAlias + (NormalizationMatrix alpha (MatrixIndexAlias index))) : + NormalizationMatrix alpha (MatrixIndexAlias index) + +def normalizationMatrixRawType : VInductiveType where + name := ``NormalizationMatrix + uvars := 0 + type := vconst(type_of% @NormalizationMatrix).type + ctors := [⟨vconst(type_of% @NormalizationMatrix.mk), + ``NormalizationMatrix.mk⟩] + +def normalizationMatrixRawDecl : VInductDecl := + ⟨0, 1, [normalizationMatrixRawType]⟩ + +def normalizationMatrixTarget (alpha index : VExpr) : VExpr := + (VExpr.const ``NormalizationMatrix []).app alpha |>.app + ((VExpr.const ``MatrixIndexAlias []).app index) + +def normalizationMatrixViewCtorType : VExpr := + .forallE (.sort (.succ .zero)) <| + .forallE (.sort (.succ .zero)) <| + .forallE (.sort .zero) <| + .forallE (.sort .zero) <| + .forallE (.sort .zero) <| + .forallE (normalizationMatrixTarget (.bvar 4) (.bvar 3)) <| + .forallE (.forallE (.sort .zero) + (normalizationMatrixTarget (.bvar 6) (.bvar 5))) <| + .forallE (normalizationMatrixTarget (.bvar 6) (.bvar 5)) <| + .forallE (normalizationMatrixTarget (.bvar 7) (.bvar 6)) <| + normalizationMatrixTarget (.bvar 8) (.bvar 7) + +def normalizationMatrixViewCtor : VConstVal := + { normalizationMatrixRawType.ctors[0] with + type := normalizationMatrixViewCtorType } + +def normalizationMatrixViewType : VInductiveType := + { normalizationMatrixRawType with + type := .forallE (.sort (.succ .zero)) + (.forallE (.sort (.succ .zero)) + (.sort (.succ (.succ .zero)))) + ctors := [normalizationMatrixViewCtor] } + +def normalizationMatrixViewDecl : VInductDecl := + ⟨0, 1, [normalizationMatrixViewType]⟩ + +example : normalizationMatrixRawType.type = + (VExpr.const ``TypeFamilyAlias []).forallE + ((VExpr.const ``TypeFamilyAlias []).forallE + (VExpr.sort (.succ (.succ .zero)))) := rfl + +example : normalizationMatrixRawType.ctors[0].type = + vconst(type_of% @NormalizationMatrix.mk).type := rfl + +example : normalizationMatrixRawDecl.checked? = none := rfl +example : normalizationMatrixViewDecl.checked?.isSome = true := rfl +example : normalizationShape normalizationMatrixRawDecl + normalizationMatrixViewDecl = true := rfl + +def normalizationMatrixNormalization : + Normalization normalizationMatrixRawDecl where + view := normalizationMatrixViewDecl + shape_eq := rfl + +def normalizationMatrixViewChecked : + normalizationMatrixViewDecl.Checked := + normalizationMatrixViewDecl.checked?.get (by decide) + +def normalizationMatrixBlock : + NormalizedChecked normalizationMatrixRawDecl := + normalizationMatrixNormalization.check?.get (by decide) + +def normalizationMatrixGenerationChecked : + GenerationChecked normalizationMatrixRawDecl := + normalizationMatrixBlock.generation?.get (by decide) + +example : normalizationMatrixNormalization.accepted = true := rfl +example : (normalizedChecked? normalizationMatrixRawDecl + normalizationMatrixViewDecl).isSome = true := rfl +example : normalizationMatrixBlock.checked.type = + normalizationMatrixViewType := rfl +example : normalizationMatrixViewChecked.params = + [.sort (.succ .zero)] := rfl +example : normalizationMatrixViewChecked.indices = + [.sort (.succ .zero)] := rfl +example : normalizationMatrixViewChecked.constructors[0].fields.length = 8 := + rfl +example : normalizationMatrixViewChecked.constructors[0].recursive.length = 4 := + rfl +example : normalizationMatrixViewChecked.constructors[0].recursive.map + (fun position => (position.fieldIndex, position.binders.length)) = + [(4, 0), (5, 1), (6, 0), (7, 0)] := rfl +example : normalizationMatrixGenerationChecked.recursor = + vconst(type_of% @NormalizationMatrix.rec) := rfl +example : normalizationMatrixGenerationChecked.generatedRules[0]? = + some (vdefeq(alpha motive mk index ordinary beta letBound direct + piHidden betaRecursive letRecursive => + @NormalizationMatrix.rec alpha motive mk (MatrixIndexAlias index) + (@NormalizationMatrix.mk alpha index ordinary beta letBound direct + piHidden betaRecursive letRecursive) ≡ + mk index ordinary beta letBound direct piHidden betaRecursive + letRecursive + (@NormalizationMatrix.rec alpha motive mk + (MatrixIndexAlias index) direct) + (fun proof => @NormalizationMatrix.rec alpha motive mk + (MatrixIndexAlias index) (piHidden proof)) + (@NormalizationMatrix.rec alpha motive mk + (MatrixIndexAlias index) betaRecursive) + (@NormalizationMatrix.rec alpha motive mk + (MatrixIndexAlias index) letRecursive))) := rfl +example : normalizationMatrixGenerationChecked.generatedRules.length = 1 := rfl + +/-! The semantic pre-environment contains the exact reducible definitions +whose WHNFs justify the normalized descriptor. Each abbreviation is added +as a constant followed by its delta equation so the final transaction uses +the same staged environment discipline as ordinary declarations. -/ + +def normalizationMatrixRecAliasConstEnv : VEnv := + (typeFamilyAliasEnv.addConst ``RecAlias + (vconst(type_of% @RecAlias))).get (by decide) + +def normalizationMatrixRecAliasEnv : VEnv := + normalizationMatrixRecAliasConstEnv.addDefEq recAliasDefEq + +theorem normalizationMatrixRecAliasEnv_ordered : + normalizationMatrixRecAliasEnv.Ordered := by + apply VEnv.Ordered.defeq + · apply VEnv.Ordered.const (n := ``RecAlias) + (ci := vconst(type_of% @RecAlias)) + (env' := normalizationMatrixRecAliasConstEnv) + typeFamilyAliasEnv_ordered + · exact ⟨_, by type_tac⟩ + · rfl + · have hlookup : normalizationMatrixRecAliasConstEnv.constants + ``RecAlias = some (vconst(type_of% @RecAlias)) := rfl + constructor <;> type_tac + +def matrixBetaAliasDefEq : VDefEq := + vdefeq(@MatrixBetaAlias ≡ fun (alpha : Sort u) => + (fun type : Sort u => type) alpha) + +def normalizationMatrixBetaAliasConstEnv : VEnv := + (normalizationMatrixRecAliasEnv.addConst ``MatrixBetaAlias + (vconst(type_of% @MatrixBetaAlias))).get (by decide) + +def normalizationMatrixBetaAliasEnv : VEnv := + normalizationMatrixBetaAliasConstEnv.addDefEq matrixBetaAliasDefEq + +theorem normalizationMatrixBetaAliasEnv_ordered : + normalizationMatrixBetaAliasEnv.Ordered := by + apply VEnv.Ordered.defeq + · apply VEnv.Ordered.const (n := ``MatrixBetaAlias) + (ci := vconst(type_of% @MatrixBetaAlias)) + (env' := normalizationMatrixBetaAliasConstEnv) + normalizationMatrixRecAliasEnv_ordered + · exact ⟨_, by type_tac⟩ + · rfl + · have hlookup : normalizationMatrixBetaAliasConstEnv.constants + ``MatrixBetaAlias = some (vconst(type_of% @MatrixBetaAlias)) := rfl + constructor <;> type_tac + +def matrixLetAliasDefEq : VDefEq := + vdefeq(@MatrixLetAlias ≡ fun (alpha : Sort u) => + let type := alpha + type) + +def normalizationMatrixLetAliasConstEnv : VEnv := + (normalizationMatrixBetaAliasEnv.addConst ``MatrixLetAlias + (vconst(type_of% @MatrixLetAlias))).get (by decide) + +def normalizationMatrixLetAliasEnv : VEnv := + normalizationMatrixLetAliasConstEnv.addDefEq matrixLetAliasDefEq + +theorem normalizationMatrixLetAliasEnv_ordered : + normalizationMatrixLetAliasEnv.Ordered := by + apply VEnv.Ordered.defeq + · apply VEnv.Ordered.const (n := ``MatrixLetAlias) + (ci := vconst(type_of% @MatrixLetAlias)) + (env' := normalizationMatrixLetAliasConstEnv) + normalizationMatrixBetaAliasEnv_ordered + · exact ⟨_, by type_tac⟩ + · rfl + · have hlookup : normalizationMatrixLetAliasConstEnv.constants + ``MatrixLetAlias = some (vconst(type_of% @MatrixLetAlias)) := rfl + constructor <;> type_tac + +def matrixPiAliasDefEq : VDefEq := + vdefeq(@MatrixPiAlias ≡ fun (alpha : Sort u) => + (proof : Prop) → alpha) + +def normalizationMatrixPiAliasConstEnv : VEnv := + (normalizationMatrixLetAliasEnv.addConst ``MatrixPiAlias + (vconst(type_of% @MatrixPiAlias))).get (by decide) + +def normalizationMatrixPiAliasEnv : VEnv := + normalizationMatrixPiAliasConstEnv.addDefEq matrixPiAliasDefEq + +theorem normalizationMatrixPiAliasEnv_ordered : + normalizationMatrixPiAliasEnv.Ordered := by + apply VEnv.Ordered.defeq + · apply VEnv.Ordered.const (n := ``MatrixPiAlias) + (ci := vconst(type_of% @MatrixPiAlias)) + (env' := normalizationMatrixPiAliasConstEnv) + normalizationMatrixLetAliasEnv_ordered + · exact ⟨_, by type_tac⟩ + · rfl + · have hlookup : normalizationMatrixPiAliasConstEnv.constants + ``MatrixPiAlias = some (vconst(type_of% @MatrixPiAlias)) := rfl + constructor + · type_tac + · apply VEnv.HasType.lam + · exact VEnv.HasType.sort (by decide) + · apply VEnv.IsDefEq.defeq + (VEnv.IsDefEq.sortDF + (l := .imax (.succ .zero) (.param 0)) + (l' := .param 0) (by decide) (by decide) (by + rw [VLevel.equiv_def] + intro ls + simp only [VLevel.eval, Nat.zero_add] + let n := ls.getD 0 0 + change Nat.imax 1 n = n + by_cases h : n = 0 + · simp [Nat.imax, h] + · have hn : 1 ≤ n := Nat.one_le_iff_ne_zero.mpr h + simp [Nat.imax, h, Nat.max_eq_right hn])) + exact VEnv.HasType.forallE + (VEnv.HasType.sort (by decide)) + (VEnv.HasType.bvar (.succ .zero)) + +def matrixIndexAliasDefEq : VDefEq := + vdefeq(MatrixIndexAlias ≡ fun index : TypeFamilyAlias => index) + +def normalizationMatrixIndexAliasConstEnv : VEnv := + (normalizationMatrixPiAliasEnv.addConst ``MatrixIndexAlias + (vconst(type_of% @MatrixIndexAlias))).get (by decide) + +def normalizationMatrixAliasEnv : VEnv := + normalizationMatrixIndexAliasConstEnv.addDefEq matrixIndexAliasDefEq + +theorem normalizationMatrixAliasEnv_ordered : + normalizationMatrixAliasEnv.Ordered := by + apply VEnv.Ordered.defeq + · apply VEnv.Ordered.const (n := ``MatrixIndexAlias) + (ci := vconst(type_of% @MatrixIndexAlias)) + (env' := normalizationMatrixIndexAliasConstEnv) + normalizationMatrixPiAliasEnv_ordered + · have hfamily : normalizationMatrixPiAliasEnv.constants + ``TypeFamilyAlias = some (vconst(type_of% @TypeFamilyAlias)) := rfl + exact ⟨_, by type_tac⟩ + · rfl + · have hfamily : normalizationMatrixIndexAliasConstEnv.constants + ``TypeFamilyAlias = some (vconst(type_of% @TypeFamilyAlias)) := rfl + have hlookup : normalizationMatrixIndexAliasConstEnv.constants + ``MatrixIndexAlias = some (vconst(type_of% @MatrixIndexAlias)) := rfl + constructor <;> type_tac + +theorem normalizationMatrixRecAliasEnv_le_betaAliasEnv : + normalizationMatrixRecAliasEnv ≤ normalizationMatrixBetaAliasEnv := + (VEnv.addConst_le (by rfl : normalizationMatrixRecAliasEnv.addConst + ``MatrixBetaAlias (vconst(type_of% @MatrixBetaAlias)) = + some normalizationMatrixBetaAliasConstEnv)).trans VEnv.addDefEq_le + +theorem normalizationMatrixBetaAliasEnv_le_letAliasEnv : + normalizationMatrixBetaAliasEnv ≤ normalizationMatrixLetAliasEnv := + (VEnv.addConst_le (by rfl : normalizationMatrixBetaAliasEnv.addConst + ``MatrixLetAlias (vconst(type_of% @MatrixLetAlias)) = + some normalizationMatrixLetAliasConstEnv)).trans VEnv.addDefEq_le + +theorem normalizationMatrixLetAliasEnv_le_piAliasEnv : + normalizationMatrixLetAliasEnv ≤ normalizationMatrixPiAliasEnv := + (VEnv.addConst_le (by rfl : normalizationMatrixLetAliasEnv.addConst + ``MatrixPiAlias (vconst(type_of% @MatrixPiAlias)) = + some normalizationMatrixPiAliasConstEnv)).trans VEnv.addDefEq_le + +theorem normalizationMatrixPiAliasEnv_le_aliasEnv : + normalizationMatrixPiAliasEnv ≤ normalizationMatrixAliasEnv := + (VEnv.addConst_le (by rfl : normalizationMatrixPiAliasEnv.addConst + ``MatrixIndexAlias (vconst(type_of% @MatrixIndexAlias)) = + some normalizationMatrixIndexAliasConstEnv)).trans VEnv.addDefEq_le + +theorem normalizationMatrixRecAliasEnv_le_aliasEnv : + normalizationMatrixRecAliasEnv ≤ normalizationMatrixAliasEnv := + normalizationMatrixRecAliasEnv_le_betaAliasEnv.trans <| + normalizationMatrixBetaAliasEnv_le_letAliasEnv.trans <| + normalizationMatrixLetAliasEnv_le_piAliasEnv.trans + normalizationMatrixPiAliasEnv_le_aliasEnv + +theorem typeFamilyAliasEnv_le_normalizationMatrixAliasEnv : + typeFamilyAliasEnv ≤ normalizationMatrixAliasEnv := by + exact ((VEnv.addConst_le (by rfl : typeFamilyAliasEnv.addConst ``RecAlias + (vconst(type_of% @RecAlias)) = + some normalizationMatrixRecAliasConstEnv)).trans VEnv.addDefEq_le).trans + normalizationMatrixRecAliasEnv_le_aliasEnv + +theorem normalizationMatrix_typeFamilyAliasDefEq_mem : + normalizationMatrixAliasEnv.defeqs typeFamilyAliasDefEq := + typeFamilyAliasEnv_le_normalizationMatrixAliasEnv.defeqs + VEnv.addDefEq_self + +theorem normalizationMatrix_recAliasDefEq_mem : + normalizationMatrixAliasEnv.defeqs recAliasDefEq := + normalizationMatrixRecAliasEnv_le_aliasEnv.defeqs VEnv.addDefEq_self + +theorem normalizationMatrix_betaAliasDefEq_mem : + normalizationMatrixAliasEnv.defeqs matrixBetaAliasDefEq := + (normalizationMatrixBetaAliasEnv_le_letAliasEnv.trans <| + normalizationMatrixLetAliasEnv_le_piAliasEnv.trans + normalizationMatrixPiAliasEnv_le_aliasEnv).defeqs VEnv.addDefEq_self + +theorem normalizationMatrix_letAliasDefEq_mem : + normalizationMatrixAliasEnv.defeqs matrixLetAliasDefEq := + (normalizationMatrixLetAliasEnv_le_piAliasEnv.trans + normalizationMatrixPiAliasEnv_le_aliasEnv).defeqs VEnv.addDefEq_self + +theorem normalizationMatrix_piAliasDefEq_mem : + normalizationMatrixAliasEnv.defeqs matrixPiAliasDefEq := + normalizationMatrixPiAliasEnv_le_aliasEnv.defeqs VEnv.addDefEq_self + +theorem normalizationMatrixTypeFamily_defeq {env : VEnv} {U : Nat} + {Γ : List VExpr} (henv : normalizationMatrixAliasEnv ≤ env) : + env.IsDefEq U Γ (VExpr.const ``TypeFamilyAlias []) + (VExpr.sort (.succ .zero)) + (VExpr.sort (.succ (.succ .zero))) := by + exact .extra (df := typeFamilyAliasDefEq) (ls := []) + (henv.defeqs normalizationMatrix_typeFamilyAliasDefEq_mem) + (fun _ h => nomatch h) rfl + +theorem normalizationMatrixRecAlias_app_defeq {env : VEnv} {U : Nat} + {Γ : List VExpr} {u : VLevel} {A : VExpr} (hu : u.WF U) + (henv : normalizationMatrixAliasEnv ≤ env) + (hA : env.HasType U Γ A (VExpr.sort u)) : + env.IsDefEq U Γ ((VExpr.const ``RecAlias [u]).app A) A + (VExpr.sort u) := by + have hdelta : env.IsDefEq U Γ (VExpr.const ``RecAlias [u]) + (VExpr.lam (VExpr.sort u) (VExpr.bvar 0)) + (VExpr.forallE (VExpr.sort u) (VExpr.sort u)) := + .extra (df := recAliasDefEq) (ls := [u]) + (henv.defeqs normalizationMatrix_recAliasDefEq_mem) + (by simpa using hu) rfl + have hbeta := VEnv.IsDefEq.beta (VEnv.IsDefEq.bvar .zero) hA + exact (VEnv.IsDefEq.appDF hdelta hA).trans (by + simpa [VExpr.inst, VExpr.instVar, VExpr.liftN] using hbeta) + +theorem normalizationMatrixBetaAlias_app_defeq {env : VEnv} {U : Nat} + {Γ : List VExpr} {u : VLevel} {A : VExpr} (hu : u.WF U) + (henv : normalizationMatrixAliasEnv ≤ env) + (hA : env.HasType U Γ A (VExpr.sort u)) : + env.IsDefEq U Γ ((VExpr.const ``MatrixBetaAlias [u]).app A) A + (VExpr.sort u) := by + have hdelta : env.IsDefEq U Γ (VExpr.const ``MatrixBetaAlias [u]) + (VExpr.lam (VExpr.sort u) + ((VExpr.lam (VExpr.sort u) (VExpr.bvar 0)).app (VExpr.bvar 0))) + (VExpr.forallE (VExpr.sort u) (VExpr.sort u)) := + .extra (df := matrixBetaAliasDefEq) (ls := [u]) + (henv.defeqs normalizationMatrix_betaAliasDefEq_mem) + (by simpa using hu) rfl + have hbody : env.HasType U (VExpr.sort u :: Γ) + ((VExpr.lam (VExpr.sort u) (VExpr.bvar 0)).app (VExpr.bvar 0)) + (VExpr.sort u) := + VEnv.HasType.app + (VEnv.HasType.lam (VEnv.HasType.sort hu) (VEnv.HasType.bvar .zero)) + (VEnv.HasType.bvar .zero) + have houterBeta := VEnv.IsDefEq.beta hbody hA + have houter := (VEnv.IsDefEq.appDF hdelta hA).trans (by + simpa [VExpr.inst, VExpr.instVar, VExpr.liftN] using houterBeta) + have hinnerBeta := VEnv.IsDefEq.beta (VEnv.IsDefEq.bvar .zero) hA + exact houter.trans (by + simpa [VExpr.inst, VExpr.instVar, VExpr.liftN] using hinnerBeta) + +theorem normalizationMatrixLetAlias_app_defeq {env : VEnv} {U : Nat} + {Γ : List VExpr} {u : VLevel} {A : VExpr} (hu : u.WF U) + (henv : normalizationMatrixAliasEnv ≤ env) + (hA : env.HasType U Γ A (VExpr.sort u)) : + env.IsDefEq U Γ ((VExpr.const ``MatrixLetAlias [u]).app A) A + (VExpr.sort u) := by + have hdelta : env.IsDefEq U Γ (VExpr.const ``MatrixLetAlias [u]) + (VExpr.lam (VExpr.sort u) (VExpr.bvar 0)) + (VExpr.forallE (VExpr.sort u) (VExpr.sort u)) := + .extra (df := matrixLetAliasDefEq) (ls := [u]) + (henv.defeqs normalizationMatrix_letAliasDefEq_mem) + (by simpa using hu) rfl + have hbeta := VEnv.IsDefEq.beta (VEnv.IsDefEq.bvar .zero) hA + exact (VEnv.IsDefEq.appDF hdelta hA).trans (by + simpa [VExpr.inst, VExpr.instVar, VExpr.liftN] using hbeta) + +private theorem normalizationMatrix_one_imax_equiv (u : VLevel) : + .imax (.succ .zero) u ≈ u := by + rw [VLevel.equiv_def] + intro ls + simp only [VLevel.eval, Nat.zero_add] + let n := u.eval ls + change Nat.imax 1 n = n + by_cases h : n = 0 + · simp [Nat.imax, h] + · have hn : 1 ≤ n := Nat.one_le_iff_ne_zero.mpr h + simp [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) + (henv : normalizationMatrixAliasEnv ≤ env) + (hA : env.HasType U Γ A (VExpr.sort u)) : + env.IsDefEq U Γ ((VExpr.const ``MatrixPiAlias [u]).app A) + (VExpr.forallE (VExpr.sort .zero) A.lift) (VExpr.sort u) := by + have hdelta : env.IsDefEq U Γ (VExpr.const ``MatrixPiAlias [u]) + (VExpr.lam (VExpr.sort u) + (VExpr.forallE (VExpr.sort .zero) (VExpr.bvar 1))) + (VExpr.forallE (VExpr.sort u) (VExpr.sort u)) := + .extra (df := matrixPiAliasDefEq) (ls := [u]) + (henv.defeqs normalizationMatrix_piAliasDefEq_mem) + (by simpa using hu) rfl + have hbody : env.HasType U (VExpr.sort u :: Γ) + (VExpr.forallE (VExpr.sort .zero) (VExpr.bvar 1)) + (VExpr.sort u) := by + apply VEnv.IsDefEq.defeq + (VEnv.IsDefEq.sortDF + (l := .imax (.succ .zero) u) (l' := u) + ⟨trivial, hu⟩ hu (normalizationMatrix_one_imax_equiv u)) + exact VEnv.HasType.forallE (VEnv.HasType.sort (by trivial)) + (VEnv.HasType.bvar (.succ .zero)) + have hbeta := VEnv.IsDefEq.beta hbody hA + exact (VEnv.IsDefEq.appDF hdelta hA).trans (by + simpa [VExpr.inst, VExpr.instVar, VExpr.liftN] using hbeta) + +theorem normalizationMatrixIndexAlias_app_hasType {env : VEnv} {U : Nat} + {Γ : List VExpr} {index : VExpr} + (henv : normalizationMatrixAliasEnv ≤ env) + (hindex : env.HasType U Γ index (VExpr.sort (.succ .zero))) : + env.HasType U Γ ((VExpr.const ``MatrixIndexAlias []).app index) + (VExpr.sort (.succ .zero)) := by + have hfn : env.HasType U Γ (VExpr.const ``MatrixIndexAlias []) + ((VExpr.const ``TypeFamilyAlias []).forallE + (VExpr.const ``TypeFamilyAlias [])) := + .constDF (henv.constants (by rfl : normalizationMatrixAliasEnv.constants + ``MatrixIndexAlias = some (vconst(type_of% @MatrixIndexAlias)))) + (fun _ h => nomatch h) (fun _ h => nomatch h) rfl .nil + have hindexRaw := (normalizationMatrixTypeFamily_defeq henv).defeq' hindex + exact (normalizationMatrixTypeFamily_defeq henv).defeq + (VEnv.HasType.app hfn hindexRaw) + +theorem normalizationMatrixTarget_hasType {env : VEnv} {U : Nat} + {Γ : List VExpr} {alpha index : VExpr} + (henv : normalizationMatrixAliasEnv ≤ env) + (hfamily : env.constants ``NormalizationMatrix = + some normalizationMatrixRawType.toVConstant) + (halpha : env.HasType U Γ alpha (VExpr.const ``TypeFamilyAlias [])) + (hindex : env.HasType U Γ index (VExpr.const ``TypeFamilyAlias [])) : + env.HasType U Γ (normalizationMatrixTarget alpha index) + (VExpr.sort (.succ (.succ .zero))) := by + have hfn : env.HasType U Γ (VExpr.const ``NormalizationMatrix []) + (VExpr.forallE (VExpr.const ``TypeFamilyAlias []) + (VExpr.forallE (VExpr.const ``TypeFamilyAlias []) + (VExpr.sort (.succ (.succ .zero))))) := + .constDF hfamily (fun _ h => nomatch h) (fun _ h => nomatch h) + rfl .nil + have hindexFn : env.HasType U Γ (VExpr.const ``MatrixIndexAlias []) + ((VExpr.const ``TypeFamilyAlias []).forallE + (VExpr.const ``TypeFamilyAlias [])) := + .constDF (henv.constants (by rfl : normalizationMatrixAliasEnv.constants + ``MatrixIndexAlias = some (vconst(type_of% @MatrixIndexAlias)))) + (fun _ h => nomatch h) (fun _ h => nomatch h) rfl .nil + exact VEnv.HasType.app (VEnv.HasType.app hfn halpha) + (VEnv.HasType.app hindexFn hindex) + +theorem normalizationMatrixNormalization_wf : + normalizationMatrixNormalization.WF normalizationMatrixAliasEnv := by + refine ⟨normalizationMatrixRawType, normalizationMatrixViewType, + rfl, rfl, ?_, ?_⟩ + · refine ⟨VExpr.sort (.imax (.succ (.succ .zero)) + (.imax (.succ (.succ .zero)) + (.succ (.succ (.succ .zero))))), ?_⟩ + change normalizationMatrixAliasEnv.IsDefEq 0 [] + ((VExpr.const ``TypeFamilyAlias []).forallE + ((VExpr.const ``TypeFamilyAlias []).forallE + (VExpr.sort (.succ (.succ .zero))))) + ((VExpr.sort (.succ .zero)).forallE + ((VExpr.sort (.succ .zero)).forallE + (VExpr.sort (.succ (.succ .zero))))) + (VExpr.sort (.imax (.succ (.succ .zero)) + (.imax (.succ (.succ .zero)) + (.succ (.succ (.succ .zero)))))) + apply VEnv.IsDefEq.forallEDF + · exact normalizationMatrixTypeFamily_defeq .rfl + · apply VEnv.IsDefEq.forallEDF + · exact normalizationMatrixTypeFamily_defeq .rfl + · exact VEnv.IsDefEq.sortDF (by decide) (by decide) rfl + · intro envT hadd + have henv : normalizationMatrixAliasEnv ≤ envT := + VEnv.addConst_le hadd + have htypeFamily : envT.constants ``TypeFamilyAlias = + some (vconst(type_of% @TypeFamilyAlias)) := + henv.constants (by rfl) + have hrecAlias : envT.constants ``RecAlias = + some (vconst(type_of% @RecAlias)) := + henv.constants (by rfl) + have hbetaAlias : envT.constants ``MatrixBetaAlias = + some (vconst(type_of% @MatrixBetaAlias)) := + henv.constants (by rfl) + have hletAlias : envT.constants ``MatrixLetAlias = + some (vconst(type_of% @MatrixLetAlias)) := + henv.constants (by rfl) + have hpiAlias : envT.constants ``MatrixPiAlias = + some (vconst(type_of% @MatrixPiAlias)) := + henv.constants (by rfl) + have hindexAlias : envT.constants ``MatrixIndexAlias = + some (vconst(type_of% @MatrixIndexAlias)) := + henv.constants (by rfl) + have hfamily : envT.constants ``NormalizationMatrix = + some normalizationMatrixRawType.toVConstant := + VEnv.addConst_self hadd + exact .cons ⟨_, by + apply VEnv.IsDefEq.forallEDF + · exact normalizationMatrixTypeFamily_defeq henv + · apply VEnv.IsDefEq.forallEDF + · exact normalizationMatrixTypeFamily_defeq henv + · apply VEnv.IsDefEq.forallEDF + · exact normalizationMatrixRecAlias_app_defeq + (by decide) henv (by type_tac) + · apply VEnv.IsDefEq.forallEDF + · exact normalizationMatrixBetaAlias_app_defeq + (by decide) henv (by type_tac) + · apply VEnv.IsDefEq.forallEDF + · exact normalizationMatrixLetAlias_app_defeq + (by decide) henv (by type_tac) + · apply VEnv.IsDefEq.forallEDF + · exact normalizationMatrixRecAlias_app_defeq + (by decide) henv (by type_tac) + · apply VEnv.IsDefEq.forallEDF + · exact normalizationMatrixPiAlias_app_defeq + (by decide) henv (by type_tac) + · apply VEnv.IsDefEq.forallEDF + · exact normalizationMatrixBetaAlias_app_defeq + (by decide) henv (by type_tac) + · apply VEnv.IsDefEq.forallEDF + · exact normalizationMatrixLetAlias_app_defeq + (by decide) henv (by type_tac) + · type_tac⟩ .nil + +theorem normalizationMatrixViewChecked_wf : + normalizationMatrixViewChecked.WF normalizationMatrixAliasEnv := by + refine ⟨?_, ?_⟩ + · change normalizationMatrixAliasEnv.OnTel 0 [] + [VExpr.sort (.succ .zero), VExpr.sort (.succ .zero)] + exact ⟨⟨_, by type_tac⟩, ⟨⟨_, by type_tac⟩, trivial⟩⟩ + · intro c hc + change c ∈ [normalizationMatrixViewCtor] at hc + have hc' : c = normalizationMatrixViewCtor := + List.mem_singleton.1 hc + subst c + constructor + · change fieldsWF 0 ``NormalizationMatrix 1 + normalizationMatrixAliasEnv (.succ (.succ .zero)) + [VExpr.sort (.succ .zero)] [VExpr.sort (.succ .zero)] 0 + [VExpr.sort (.succ .zero), VExpr.sort .zero, + VExpr.sort .zero, VExpr.sort .zero, + normalizationMatrixTarget (.bvar 4) (.bvar 3), + (VExpr.sort .zero).forallE + (normalizationMatrixTarget (.bvar 6) (.bvar 5)), + normalizationMatrixTarget (.bvar 6) (.bvar 5), + normalizationMatrixTarget (.bvar 7) (.bvar 6)] + refine ⟨?_, ?_, ?_⟩ + · exact .inr (.inr ⟨rfl, .succ (.succ .zero), by type_tac, + .inr (VLevel.le_refl _)⟩) + · intro h + change false = true at h + contradiction + · refine ⟨?_, ?_, ?_⟩ + · exact .inr (.inr ⟨rfl, .succ .zero, by type_tac, + .inr VLevel.le_succ⟩) + · intro h + change false = true at h + contradiction + · refine ⟨?_, ?_, ?_⟩ + · exact .inr (.inr ⟨rfl, .succ .zero, by type_tac, + .inr VLevel.le_succ⟩) + · intro h + change false = true at h + contradiction + · refine ⟨?_, ?_, ?_⟩ + · exact .inr (.inr ⟨rfl, .succ .zero, by type_tac, + .inr VLevel.le_succ⟩) + · intro h + change false = true at h + contradiction + · refine ⟨?_, ?_, ?_⟩ + · exact .inl rfl + · intro _ + exact ⟨_, _, rfl, + normalizationMatrixIndexAlias_app_hasType .rfl + (by type_tac), rfl⟩ + · refine ⟨?_, ?_, ?_⟩ + · refine .inr (.inl ⟨_, rfl, by decide, ?_⟩) + constructor + · exact ⟨⟨_, by type_tac⟩, trivial⟩ + · exact ⟨_, _, rfl, + normalizationMatrixIndexAlias_app_hasType .rfl + (by type_tac), rfl⟩ + · intro h + change false = true at h + contradiction + · refine ⟨?_, ?_, ?_⟩ + · exact .inl rfl + · intro _ + exact ⟨_, _, rfl, + normalizationMatrixIndexAlias_app_hasType .rfl + (by type_tac), rfl⟩ + · 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⟩ + +theorem normalizationMatrixBlock_wf : + normalizationMatrixBlock.WF normalizationMatrixAliasEnv := + ⟨normalizationMatrixNormalization_wf, + normalizationMatrixViewChecked_wf⟩ + +theorem normalizationMatrixGenerationChecked_wf : + normalizationMatrixGenerationChecked.WF normalizationMatrixAliasEnv := by + refine { + blockWF := normalizationMatrixBlock_wf + familyTel := ?_ + familyResult := ?_ + ctors := ?_ } + · refine ⟨⟨_, normalizationMatrixTypeFamily_defeq .rfl⟩, ?_⟩ + exact ⟨⟨_, normalizationMatrixTypeFamily_defeq .rfl⟩, trivial⟩ + · exact VEnv.IsDefEq.sortDF (by decide) (by decide) rfl + · intro envT hadd ctor hctor + change ctor ∈ + [⟨normalizationMatrixRawType.ctors[0], + normalizationMatrixViewChecked.constructors[0]⟩] at hctor + obtain rfl := List.mem_singleton.1 hctor + have henv : normalizationMatrixAliasEnv ≤ envT := + VEnv.addConst_le hadd + have hfamily : envT.constants ``NormalizationMatrix = + some normalizationMatrixRawType.toVConstant := + VEnv.addConst_self hadd + have hindexAlias : envT.constants ``MatrixIndexAlias = + some (vconst(type_of% @MatrixIndexAlias)) := + henv.constants (by rfl) + refine { + declaredTel := ?_ + declaredResult := ?_ + emittedTel := ?_ + emittedResult := ?_ } + · refine ⟨⟨_, normalizationMatrixTypeFamily_defeq henv⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixTypeFamily_defeq henv⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixRecAlias_app_defeq + (by decide) henv (by type_tac)⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixBetaAlias_app_defeq + (by decide) henv (by type_tac)⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixLetAlias_app_defeq + (by decide) henv (by type_tac)⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixRecAlias_app_defeq + (by decide) henv (by type_tac)⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixPiAlias_app_defeq + (by decide) henv (by type_tac)⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixBetaAlias_app_defeq + (by decide) henv (by type_tac)⟩, ?_⟩ + exact ⟨⟨_, normalizationMatrixLetAlias_app_defeq + (by decide) henv (by type_tac)⟩, trivial⟩ + · exact normalizationMatrixTarget_hasType henv hfamily + (by type_tac) (by type_tac) + · refine ⟨⟨_, by type_tac⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixTypeFamily_defeq henv⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixRecAlias_app_defeq + (by decide) henv (by type_tac)⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixBetaAlias_app_defeq + (by decide) henv (by type_tac)⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixLetAlias_app_defeq + (by decide) henv (by type_tac)⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixRecAlias_app_defeq + (by decide) henv (by + exact normalizationMatrixTarget_hasType henv hfamily + ((normalizationMatrixTypeFamily_defeq henv).defeq' + (by type_tac)) + (by type_tac))⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixPiAlias_app_defeq + (by decide) henv (by + exact normalizationMatrixTarget_hasType henv hfamily + ((normalizationMatrixTypeFamily_defeq henv).defeq' + (by type_tac)) + (by type_tac))⟩, ?_⟩ + refine ⟨⟨_, normalizationMatrixBetaAlias_app_defeq + (by decide) henv (by + exact normalizationMatrixTarget_hasType henv hfamily + ((normalizationMatrixTypeFamily_defeq henv).defeq' + (by type_tac)) + (by type_tac))⟩, ?_⟩ + exact ⟨⟨_, normalizationMatrixLetAlias_app_defeq + (by decide) henv (by + exact normalizationMatrixTarget_hasType henv hfamily + ((normalizationMatrixTypeFamily_defeq henv).defeq' + (by type_tac)) + (by type_tac))⟩, trivial⟩ + · exact normalizationMatrixTarget_hasType henv hfamily + ((normalizationMatrixTypeFamily_defeq henv).defeq' + (by type_tac)) + (by type_tac) + +def normalizationMatrixFinalEnv : VEnv := + (normalizationMatrixAliasEnv.addInductGeneration + normalizationMatrixGenerationChecked).get (by decide) + +theorem normalizationMatrix_addInductGeneration : + normalizationMatrixAliasEnv.addInductGeneration + normalizationMatrixGenerationChecked = + some normalizationMatrixFinalEnv := rfl + +theorem normalizationMatrixFinalEnv_trace : + Nonempty (VEnv.AddInductGenerationTrace normalizationMatrixAliasEnv + normalizationMatrixFinalEnv normalizationMatrixGenerationChecked) := + VEnv.addInductGeneration_trace normalizationMatrix_addInductGeneration + +theorem normalizationMatrixFinalEnv_family_lookup : + normalizationMatrixFinalEnv.constants ``NormalizationMatrix = + some normalizationMatrixRawType.toVConstant := by + rcases normalizationMatrixFinalEnv_trace with ⟨H⟩ + exact H.family_lookup + +theorem normalizationMatrixFinalEnv_ctor_lookup : + normalizationMatrixFinalEnv.constants ``NormalizationMatrix.mk = + some normalizationMatrixRawType.ctors[0].toVConstant := by + rcases normalizationMatrixFinalEnv_trace with ⟨H⟩ + exact H.ctor_lookup (.head _) + +theorem normalizationMatrixFinalEnv_rec_lookup : + normalizationMatrixFinalEnv.constants ``NormalizationMatrix.rec = + some (vconst(type_of% @NormalizationMatrix.rec)) := by + rcases normalizationMatrixFinalEnv_trace with ⟨H⟩ + exact H.rec_lookup + +theorem normalizationMatrixFinalEnv_iota_mem : + normalizationMatrixFinalEnv.defeqs + (vdefeq(alpha motive mk index ordinary beta letBound direct + piHidden betaRecursive letRecursive => + @NormalizationMatrix.rec alpha motive mk (MatrixIndexAlias index) + (@NormalizationMatrix.mk alpha index ordinary beta letBound direct + piHidden betaRecursive letRecursive) ≡ + mk index ordinary beta letBound direct piHidden betaRecursive + letRecursive + (@NormalizationMatrix.rec alpha motive mk + (MatrixIndexAlias index) direct) + (fun proof => @NormalizationMatrix.rec alpha motive mk + (MatrixIndexAlias index) (piHidden proof)) + (@NormalizationMatrix.rec alpha motive mk + (MatrixIndexAlias index) betaRecursive) + (@NormalizationMatrix.rec alpha motive mk + (MatrixIndexAlias index) letRecursive))) := by + rcases normalizationMatrixFinalEnv_trace with ⟨H⟩ + apply H.rule_mem + exact .head _ + +theorem normalizationMatrixFinalEnv_ordered : + normalizationMatrixFinalEnv.Ordered := + VEnv.addInductGeneration_WF normalizationMatrixAliasEnv_ordered + normalizationMatrixGenerationChecked_wf + normalizationMatrix_addInductGeneration + +/-- +info: 'Lean4Lean.InductiveFixtures.normalizationMatrixNormalization_wf' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms normalizationMatrixNormalization_wf + +/-- +info: 'Lean4Lean.InductiveFixtures.normalizationMatrixViewChecked_wf' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms normalizationMatrixViewChecked_wf + +/-- +info: 'Lean4Lean.InductiveFixtures.normalizationMatrixGenerationChecked_wf' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms normalizationMatrixGenerationChecked_wf + +/-- +info: 'Lean4Lean.InductiveFixtures.normalizationMatrixFinalEnv_trace' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms normalizationMatrixFinalEnv_trace + +/-- +info: 'Lean4Lean.InductiveFixtures.normalizationMatrixFinalEnv_iota_mem' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms normalizationMatrixFinalEnv_iota_mem + +/-- +info: 'Lean4Lean.InductiveFixtures.normalizationMatrixFinalEnv_ordered' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms normalizationMatrixFinalEnv_ordered + /-! ## Checked-analysis rejection fixtures -/ /- @@ -1676,34 +2924,72 @@ def ctorCollisionEnv : VEnv := example : ctorCollisionEnv.constants ``Nat.zero = some ⟨0, .sort .zero⟩ := rfl example : ctorCollisionEnv.addInduct natDecl = none := - VEnv.addInduct_eq_none_of_ctor_present rfl (.head _) ⟨_, rfl⟩ + VEnv.addInduct_eq_none_of_ctor_present (.head _) (.head _) ⟨_, rfl⟩ def recCollisionEnv : VEnv := (VEnv.empty.addConst ``Nat.rec ⟨0, .sort .zero⟩).get (by decide) example : recCollisionEnv.constants ``Nat.rec = some ⟨0, .sort .zero⟩ := rfl example : recCollisionEnv.addInduct natDecl = none := - VEnv.addInduct_eq_none_of_rec_present rfl ⟨_, rfl⟩ - -/-! ## Conservativity: outside the stage-3 class `addInduct` refuses. -/ - -/-- `Or` is Prop-valued with two constructors: no large elimination, so -stage 3 rejects it. -/ -example : (show VInductDecl from ⟨0, 2, [{ - name := ``Or - uvars := 0 - type := vconst(type_of% @Or).type - ctors := [⟨vconst(type_of% @Or.inl), ``Or.inl⟩, - ⟨vconst(type_of% @Or.inr), ``Or.inr⟩] }]⟩).checked? = none := rfl - -example : - VEnv.empty.addInduct ⟨0, 2, [{ - name := ``Or - uvars := 0 - type := vconst(type_of% @Or).type - ctors := [⟨vconst(type_of% @Or.inl), ``Or.inl⟩, - ⟨vconst(type_of% @Or.inr), ``Or.inr⟩] }]⟩ = none := rfl + VEnv.addInduct_eq_none_of_rec_present + (generation := natBlockGenerationChecked) rfl (.head _) ⟨_, rfl⟩ + +/-! ## Small elimination -/ + +/-- `Or` is the canonical small-elimination family: its motive remains in +`Prop`, so the generated recursor introduces no fresh universe parameter. -/ +def orType : VInductiveType where + name := ``Or + uvars := 0 + type := vconst(type_of% @Or).type + ctors := [⟨vconst(type_of% @Or.inl), ``Or.inl⟩, + ⟨vconst(type_of% @Or.inr), ``Or.inr⟩] + +def orDecl : VInductDecl := ⟨0, 2, [orType]⟩ + +def orChecked : orDecl.Checked := orDecl.checked?.get (by decide) + +example : orDecl.stage3 = true := rfl +example : orChecked.elimination = .small := rfl +example : orChecked.kTarget = false := rfl +example : orChecked.recursor.uvars = 0 := rfl +example : orChecked.recursor = vconst(type_of% @Or.rec) := rfl +example : orChecked.generatedRules[0]? = + some (vdefeq(a b motive inl inr h => + @Or.rec a b motive inl inr (@Or.inl a b h) ≡ inl h)) := rfl +example : orChecked.generatedRules[1]? = + some (vdefeq(a b motive inl inr h => + @Or.rec a b motive inl inr (@Or.inr a b h) ≡ inr h)) := rfl +example : (VEnv.empty.addInduct orDecl).isSome = true := rfl + +/-- `And` is the canonical singleton-Prop exception: both constructor fields +are proofs, so Lean legitimately gives it a large eliminator with one fresh +universe parameter. -/ +def andType : VInductiveType where + name := ``And + uvars := 0 + type := vconst(type_of% @And).type + ctors := [⟨vconst(type_of% @And.intro), ``And.intro⟩] + +def andDecl : VInductDecl := ⟨0, 2, [andType]⟩ + +def andChecked : andDecl.Checked := andDecl.checked?.get (by decide) + +example : andDecl.stage3 = true := rfl +example : andChecked.elimination = .large := rfl +/-- Large elimination and K eligibility are independent: `And` has the +singleton-proof elimination exception, but its constructor has fields. -/ +example : andChecked.kTarget = false := rfl +example : andChecked.recursor.uvars = 1 := rfl +example : andChecked.recursor = vconst(type_of% @And.rec) := rfl +example : andChecked.generatedRules[0]? = + some (vdefeq(a b motive intro left right => + @And.rec a b motive intro (@And.intro a b left right) ≡ + intro left right)) := rfl +example : (VEnv.empty.addInduct andDecl).isSome = true := rfl + +/-! ## Conservativity: malformed declarations and name collisions refuse. -/ /-- A name collision rejects the whole transaction. -/ example (env : VEnv) (h : env.contains ``Nat) : env.addInduct natDecl = none := - VEnv.addInduct_eq_none_of_type_present rfl h + VEnv.addInduct_eq_none_of_type_present (.head _) h diff --git a/Lean4Lean/Theory/MutualInductiveFixtures.lean b/Lean4Lean/Theory/MutualInductiveFixtures.lean new file mode 100644 index 00000000..b7bc8a3a --- /dev/null +++ b/Lean4Lean/Theory/MutualInductiveFixtures.lean @@ -0,0 +1,208 @@ +import Lean4Lean.Theory.Inductive +import Lean4Lean.Theory.Meta + +/-! +# Mutual public-generation fixtures + +These real kernel declarations pin shared parameters, per-family +indices/results, constructor order, and cross-family recursive target +ordinals at the `VInductDecl.CheckedBlock` boundary, then exercise the +block-wide public generation transaction added by L4L-08C. The Verify mutual +fixture supplies semantic preservation, complete kernel metadata comparison, +and environment replay. +-/ + +namespace Lean4Lean.MutualInductiveFixtures + +open VInductDecl + +universe u + +/-! ## Unindexed Tree/TreeList -/ + +mutual + +inductive Tree (α : Type u) : Type u where + | leaf : α → Tree α + | node : TreeList α → Tree α + | branch : (α → TreeList α) → Tree α + +inductive TreeList (α : Type u) : Type u where + | nil : TreeList α + | cons : Tree α → TreeList α → TreeList α + +end + +def treeType : VInductiveType where + name := ``Tree + uvars := 1 + type := vconst(type_of% @Tree).type + ctors := [⟨vconst(type_of% @Tree.leaf), ``Tree.leaf⟩, + ⟨vconst(type_of% @Tree.node), ``Tree.node⟩, + ⟨vconst(type_of% @Tree.branch), ``Tree.branch⟩] + +def treeListType : VInductiveType where + name := ``TreeList + uvars := 1 + type := vconst(type_of% @TreeList).type + ctors := [⟨vconst(type_of% @TreeList.nil), ``TreeList.nil⟩, + ⟨vconst(type_of% @TreeList.cons), ``TreeList.cons⟩] + +def treeDecl : VInductDecl := + ⟨1, 1, [treeType, treeListType]⟩ + +def treeChecked : treeDecl.CheckedBlock := + treeDecl.checkedBlock?.get (by decide) + +/-- Block-wide generation data for the real unindexed mutual declaration. -/ +def treeGeneration : BlockGenerationChecked treeDecl := + treeDecl.identityBlockGeneration?.get (by decide) + +example : treeChecked.params = [.sort (.succ (.param 0))] := rfl +example : treeChecked.families.values = [treeType, treeListType] := rfl +example : treeChecked.families.ordinals = [0, 1] := rfl +example : treeChecked.families.names = [``Tree, ``TreeList] := rfl +example : treeChecked.families.indices = [[], []] := rfl +example : treeChecked.families.resultLevels = + [.succ (.param 0), .succ (.param 0)] := rfl +example : treeChecked.families.constructorNames = + [[``Tree.leaf, ``Tree.node, ``Tree.branch], + [``TreeList.nil, ``TreeList.cons]] := rfl +example : treeChecked.families.recursiveTargets = + [[[], [1], [1]], [[], [0, 1]]] := rfl +example : treeChecked.names = + [``Tree, ``TreeList, ``Tree.leaf, ``Tree.node, ``Tree.branch, + ``TreeList.nil, ``TreeList.cons, ``Tree.rec, ``TreeList.rec] := rfl + +example : treeGeneration.families.map (·.raw.name) = + [``Tree, ``TreeList] := rfl +example : treeGeneration.motiveTypes.length = 2 := rfl +example : treeGeneration.minorTypes.length = 5 := rfl +example : treeGeneration.recursors.map (·.name) = + [``Tree.rec, ``TreeList.rec] := rfl +example : treeGeneration.generatedRules.length = 5 := rfl + +example : treeChecked.families.constructors[0][1].recursive[0].fieldIndex = 0 := rfl +example : treeChecked.families.constructors[0][1].recursive[0].targetType = 1 := rfl +example : treeChecked.families.constructors[0][2].recursive[0].fieldIndex = 0 := rfl +example : treeChecked.families.constructors[0][2].recursive[0].binders.length = 1 := rfl +example : treeChecked.families.constructors[0][2].recursive[0].targetType = 1 := rfl +example : treeChecked.families.constructors[1][1].recursive[0].targetType = 0 := rfl +example : treeChecked.families.constructors[1][1].recursive[1].targetType = 1 := rfl + +/-! ## Indexed mutual block -/ + +mutual + +inductive IndexedTree (α : Type u) : Nat → Type u where + | leaf : α → IndexedTree α .zero + | node {n : Nat} : IndexedTreeList α n → IndexedTree α (.succ n) + +inductive IndexedTreeList (α : Type u) : Nat → Type u where + | nil : IndexedTreeList α .zero + | cons {n : Nat} : + IndexedTree α n → IndexedTreeList α n → IndexedTreeList α (.succ n) + +end + +def indexedTreeType : VInductiveType where + name := ``IndexedTree + uvars := 1 + type := vconst(type_of% @IndexedTree).type + ctors := [⟨vconst(type_of% @IndexedTree.leaf), ``IndexedTree.leaf⟩, + ⟨vconst(type_of% @IndexedTree.node), ``IndexedTree.node⟩] + +def indexedTreeListType : VInductiveType where + name := ``IndexedTreeList + uvars := 1 + type := vconst(type_of% @IndexedTreeList).type + ctors := [⟨vconst(type_of% @IndexedTreeList.nil), ``IndexedTreeList.nil⟩, + ⟨vconst(type_of% @IndexedTreeList.cons), ``IndexedTreeList.cons⟩] + +def indexedTreeDecl : VInductDecl := + ⟨1, 1, [indexedTreeType, indexedTreeListType]⟩ + +def indexedTreeChecked : indexedTreeDecl.CheckedBlock := + indexedTreeDecl.checkedBlock?.get (by decide) + +/-- Block-wide generation data for the real indexed mutual declaration. -/ +def indexedTreeGeneration : BlockGenerationChecked indexedTreeDecl := + indexedTreeDecl.identityBlockGeneration?.get (by decide) + +example : indexedTreeChecked.params = [.sort (.succ (.param 0))] := rfl +example : indexedTreeChecked.families.values = + [indexedTreeType, indexedTreeListType] := rfl +example : indexedTreeChecked.families.ordinals = [0, 1] := rfl +example : indexedTreeChecked.families.names = + [``IndexedTree, ``IndexedTreeList] := rfl +example : indexedTreeChecked.families.indices = + [[.const ``Nat []], [.const ``Nat []]] := rfl +example : indexedTreeChecked.families.resultLevels = + [.succ (.param 0), .succ (.param 0)] := rfl +example : indexedTreeChecked.families.constructorNames = + [[``IndexedTree.leaf, ``IndexedTree.node], + [``IndexedTreeList.nil, ``IndexedTreeList.cons]] := rfl +example : indexedTreeChecked.families.recursiveTargets = + [[[], [1]], [[], [0, 1]]] := rfl + +example : indexedTreeGeneration.families.map (·.raw.name) = + [``IndexedTree, ``IndexedTreeList] := rfl +example : indexedTreeGeneration.motiveTypes.length = 2 := rfl +example : indexedTreeGeneration.minorTypes.length = 4 := rfl +example : indexedTreeGeneration.recursors.map (·.name) = + [``IndexedTree.rec, ``IndexedTreeList.rec] := rfl +example : indexedTreeGeneration.generatedRules.length = 4 := rfl + +example : indexedTreeChecked.families.constructors[0][0].resultIndices = + [.const ``Nat.zero []] := rfl +example : indexedTreeChecked.families.constructors[0][1].resultIndices = + [.app (.const ``Nat.succ []) (.bvar 1)] := rfl +example : indexedTreeChecked.families.constructors[1][0].resultIndices = + [.const ``Nat.zero []] := rfl +example : indexedTreeChecked.families.constructors[1][1].resultIndices = + [.app (.const ``Nat.succ []) (.bvar 2)] := rfl +example : indexedTreeChecked.families.constructors[0][1].recursive[0].fieldIndex = 1 := rfl +example : indexedTreeChecked.families.constructors[0][1].recursive[0].targetType = 1 := rfl +example : indexedTreeChecked.families.constructors[0][1].recursive[0].indices = + [.bvar 0] := rfl +example : indexedTreeChecked.families.constructors[1][1].recursive[0].fieldIndex = 1 := rfl +example : indexedTreeChecked.families.constructors[1][1].recursive[0].targetType = 0 := rfl +example : indexedTreeChecked.families.constructors[1][1].recursive[1].fieldIndex = 2 := rfl +example : indexedTreeChecked.families.constructors[1][1].recursive[1].targetType = 1 := rfl + +/-! ## Public block-wide boundary -/ + +example : treeDecl.stage3 = true := rfl +example : indexedTreeDecl.stage3 = true := rfl +example : VEnv.empty.addInduct treeDecl = + VEnv.empty.addInductBlockGeneration treeGeneration := rfl +example : VEnv.empty.addInduct indexedTreeDecl = + VEnv.empty.addInductBlockGeneration indexedTreeGeneration := rfl +example : (VEnv.empty.addInduct treeDecl).isSome = true := rfl +example : (VEnv.empty.addInduct indexedTreeDecl).isSome = true := rfl + +/-- +info: 'Lean4Lean.VInductDecl.checkedBlock?' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VInductDecl.checkedBlock? + +/-- +info: 'Lean4Lean.MutualInductiveFixtures.treeChecked' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms treeChecked + +/-- +info: 'Lean4Lean.MutualInductiveFixtures.indexedTreeChecked' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms indexedTreeChecked + +/-- +info: 'Lean4Lean.VInductDecl.CheckedFamilies.values_eq' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms CheckedFamilies.values_eq + +end Lean4Lean.MutualInductiveFixtures diff --git a/Lean4Lean/Theory/SingletonParity.lean b/Lean4Lean/Theory/SingletonParity.lean new file mode 100644 index 00000000..1bfcc36c --- /dev/null +++ b/Lean4Lean/Theory/SingletonParity.lean @@ -0,0 +1,185 @@ +import Lean4Lean.Theory.InductiveFixtures + +/-! +# Complete singleton-family parity inputs + +This module is the Theory-side inventory for L4L-07. Each row owns the exact +raw declaration together with the one checked generation artifact consumed by +the kernel differential and environment-replay matrix. `Unit` is represented +honestly by the kernel's polymorphic `PUnit` family; the reducible `Unit` +definition itself is pinned on the Verify side. +-/ + +namespace Lean4Lean.InductiveFixtures + +open VInductDecl + +private def permC07 (constant : VConstant) (levels : List VLevel) : + VConstant := + ⟨constant.uvars, constant.type.instL levels⟩ + +/-! ## Checked artifacts for the pre-existing fixed rows -/ + +def boolChecked : boolDecl.Checked := boolDecl.checked?.get (by decide) + +def boolGenerationChecked : GenerationChecked boolDecl := + (identityGeneration? boolDecl).get (by decide) + +def listChecked : listDecl.Checked := listDecl.checked?.get (by decide) + +def listGenerationChecked : GenerationChecked listDecl := + (identityGeneration? listDecl).get (by decide) + +def optionChecked : optionDecl.Checked := optionDecl.checked?.get (by decide) + +def optionGenerationChecked : GenerationChecked optionDecl := + (identityGeneration? optionDecl).get (by decide) + +def prodChecked : prodDecl.Checked := prodDecl.checked?.get (by decide) + +def prodGenerationChecked : GenerationChecked prodDecl := + (identityGeneration? prodDecl).get (by decide) + +def heqChecked : heqDecl.Checked := heqDecl.checked?.get (by decide) + +def heqGenerationChecked : GenerationChecked heqDecl := + (identityGeneration? heqDecl).get (by decide) + +def orGenerationChecked : GenerationChecked orDecl := + (identityGeneration? orDecl).get (by decide) + +def andGenerationChecked : GenerationChecked andDecl := + (identityGeneration? andDecl).get (by decide) + +/-! ## Fin -/ + +def finType : VInductiveType where + name := ``Fin + uvars := 0 + type := vconst(type_of% @Fin).type + ctors := [⟨vconst(type_of% @Fin.mk), ``Fin.mk⟩] + +def finDecl : VInductDecl := ⟨0, 1, [finType]⟩ + +def finChecked : finDecl.Checked := finDecl.checked?.get (by decide) + +def finGenerationChecked : GenerationChecked finDecl := + (identityGeneration? finDecl).get (by decide) + +example : finDecl.stage3 = true := rfl +example : finChecked.params = [.const ``Nat []] := rfl +example : finChecked.indices = [] := rfl +example : finChecked.resultLevel = .succ .zero := rfl +example : finChecked.elimination = .large := rfl +example : finChecked.kTarget = false := rfl +example : finChecked.constructors.length = 1 := rfl +example : finChecked.constructors[0].fields.length = 2 := rfl +example : finChecked.constructors[0].recursive = [] := rfl +example : finGenerationChecked.recursor = + vconst(type_of% @Fin.rec) := rfl + +/-! ## Vector -/ + +def vectorType : VInductiveType where + name := ``Vector + uvars := 1 + type := vconst(type_of% @Vector).type + ctors := [⟨vconst(type_of% @Vector.mk), ``Vector.mk⟩] + +def vectorDecl : VInductDecl := ⟨1, 2, [vectorType]⟩ + +def vectorChecked : vectorDecl.Checked := vectorDecl.checked?.get (by decide) + +def vectorGenerationChecked : GenerationChecked vectorDecl := + (identityGeneration? vectorDecl).get (by decide) + +example : vectorDecl.stage3 = true := rfl +example : vectorChecked.params = + [.sort (.succ (.param 0)), .const ``Nat []] := rfl +example : vectorChecked.indices = [] := rfl +example : vectorChecked.resultLevel = .succ (.param 0) := rfl +example : vectorChecked.elimination = .large := rfl +example : vectorChecked.kTarget = false := rfl +example : vectorChecked.constructors.length = 1 := rfl +example : vectorChecked.constructors[0].fields.length = 2 := rfl +example : vectorChecked.constructors[0].recursive = [] := rfl +example : vectorGenerationChecked.recursor = + permC07 (vconst(type_of% @Vector.rec)) [.param 1, .param 0] := rfl + +/-! ## One authoritative singleton artifact inventory -/ + +/-- A source-indexed singleton artifact. Merely constructing a row proves +that the public checked analyzer accepted that exact raw declaration and that +all downstream generation data came from the same checked path. -/ +structure SingletonParityArtifact where + label : Name + source : VInductDecl + generation : source.GenerationChecked + +namespace SingletonParityArtifact + +def typeName (artifact : SingletonParityArtifact) : Name := + artifact.generation.block.sourceType.name + +def constructorNames (artifact : SingletonParityArtifact) : List Name := + artifact.generation.block.sourceType.ctors.map (·.name) + +end SingletonParityArtifact + +/-- The fixed L4L-07 positive matrix, in roadmap order. The `Unit` row points +to `PUnit`, matching the actual v4.31 kernel representation rather than +inventing alias-level inductive metadata. -/ +def singletonPositiveArtifacts : List SingletonParityArtifact := + [⟨``Nat, natDecl, natGenerationChecked⟩, + ⟨``Bool, boolDecl, boolGenerationChecked⟩, + ⟨``List, listDecl, listGenerationChecked⟩, + ⟨``Option, optionDecl, optionGenerationChecked⟩, + ⟨``Prod, prodDecl, prodGenerationChecked⟩, + ⟨``Unit, punitDecl, punitGenerationChecked⟩, + ⟨``Empty, emptyDecl, emptyGenerationChecked⟩, + ⟨``Or, orDecl, orGenerationChecked⟩, + ⟨``And, andDecl, andGenerationChecked⟩, + ⟨``Eq, eqDecl, eqGenerationChecked⟩, + ⟨``HEq, heqDecl, heqGenerationChecked⟩, + ⟨``Fin, finDecl, finGenerationChecked⟩, + ⟨``Vector, vectorDecl, vectorGenerationChecked⟩, + ⟨``Acc, accDecl, accGenerationChecked⟩] + +/-- The focused non-identity normalization rows retained alongside the fixed +standard-library matrix. -/ +def singletonNormalizationArtifacts : List SingletonParityArtifact := + [⟨``AliasFormer, aliasFormerRawDecl, aliasFormerGenerationChecked⟩, + ⟨``AliasRec, aliasRecRawDecl, aliasRecGenerationChecked⟩, + ⟨``NormalizationMatrix, normalizationMatrixRawDecl, + normalizationMatrixGenerationChecked⟩, + ⟨``AnnotatedPi, annotatedPiRawDecl, annotatedPiGenerationChecked⟩, + ⟨``AnnotatedParam, annotatedParamRawDecl, + annotatedParamGenerationChecked⟩] + +example : singletonPositiveArtifacts.length = 14 := rfl +example : singletonPositiveArtifacts.map (·.label) = + [``Nat, ``Bool, ``List, ``Option, ``Prod, ``Unit, ``Empty, ``Or, ``And, + ``Eq, ``HEq, ``Fin, ``Vector, ``Acc] := rfl +example : singletonPositiveArtifacts.map (·.typeName) = + [``Nat, ``Bool, ``List, ``Option, ``Prod, ``PUnit, ``Empty, ``Or, ``And, + ``Eq, ``HEq, ``Fin, ``Vector, ``Acc] := rfl +example : singletonNormalizationArtifacts.length = 5 := rfl + +/-! +The inventory roots are trust-sensitive: pin their exact logical closure so +later fixture refactors cannot silently import a broader proof surface. +-/ + +/-- +info: 'Lean4Lean.InductiveFixtures.singletonPositiveArtifacts' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms singletonPositiveArtifacts + +/-- +info: 'Lean4Lean.InductiveFixtures.singletonNormalizationArtifacts' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms singletonNormalizationArtifacts + +end Lean4Lean.InductiveFixtures diff --git a/Lean4Lean/Theory/Typing/Env.lean b/Lean4Lean/Theory/Typing/Env.lean index 4309f0c6..de6f89cb 100644 --- a/Lean4Lean/Theory/Typing/Env.lean +++ b/Lean4Lean/Theory/Typing/Env.lean @@ -31,6 +31,10 @@ inductive VDecl.WF : VEnv → VDecl → VEnv → Prop where gen.WF env → env.addInductGeneration gen = some env' → VDecl.WF env (.induct decl) env' + | inductBlock {gen : decl.BlockGenerationChecked} : + gen.WF env blockEnv → + env.addInductBlockGeneration gen = some env' → + VDecl.WF env (.induct decl) env' inductive VEnv.WF' : List VDecl → VEnv → Prop where | empty : VEnv.WF' [] .empty diff --git a/Lean4Lean/Theory/Typing/EnvLemmas.lean b/Lean4Lean/Theory/Typing/EnvLemmas.lean index f672e9fd..cedcfc16 100644 --- a/Lean4Lean/Theory/Typing/EnvLemmas.lean +++ b/Lean4Lean/Theory/Typing/EnvLemmas.lean @@ -22,5 +22,6 @@ theorem VEnv.WF.ordered : WF env → Ordered env | «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 instance : CoeOut (VEnv.WF env) env.Ordered := ⟨(·.ordered)⟩ diff --git a/Lean4Lean/Theory/Typing/InductiveLemmas.lean b/Lean4Lean/Theory/Typing/InductiveLemmas.lean index 7040f4cd..ce2f7686 100644 --- a/Lean4Lean/Theory/Typing/InductiveLemmas.lean +++ b/Lean4Lean/Theory/Typing/InductiveLemmas.lean @@ -23,7 +23,7 @@ theorem params'_wf : ∀ l ∈ params' n k, l.WF (n + k) := by theorem params'_one_wf : ∀ l ∈ params' n 1, l.WF (n + 1) := params'_wf theorem params_map_inst_params' : - (params n).map (VLevel.inst (params' n 1)) = params' n 1 := + (params n).map (VLevel.inst (params' n k)) = params' n k := inst_map_id params'_length end VLevel @@ -296,6 +296,29 @@ theorem liftN_liftN_comm : ∀ (e : VExpr) (n k c K : Nat), c ≤ K → have := ihb n k (c+1) (K+1) (by omega) rwa [show K+1+n = K+n+1 from by omega] at this +/-- Generalized form of `liftN_liftN_mid`: expanding an arbitrary lift at +the seam above a disjoint lower lift adds the new width to that arbitrary +lift. -/ +theorem liftN_liftN_midN (e : VExpr) {j c : Nat} + (a k d : Nat) (hc : c ≤ j) : + ((e.liftN a j).liftN d c).liftN k (j+d) = + (e.liftN (a+k) j).liftN d c := by + rw [← liftN_liftN_comm (e.liftN a j) d k c j hc] + rw [liftN'_liftN_hi] + +/-- Telescope form of `liftN_liftN_midN`. -/ +theorem liftTelN_liftN_midN : + ∀ (tel : List VExpr) {j c : Nat} (a k d : Nat), c ≤ j → + liftTelN k (liftTelN d (liftTelN a tel j) c) (j+d) = + liftTelN d (liftTelN (a+k) tel j) c + | [], _, _, _, _, _, _ => rfl + | A :: tel, j, c, a, k, d, hc => by + show ((A.liftN a j).liftN d c).liftN k (j+d) :: _ = _ + rw [liftN_liftN_midN A a k d hc] + congr 1 + 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 @@ -646,21 +669,40 @@ theorem stage3Ctor_eq {U T np ni} : ∀ {j₀ : Nat} {e : VExpr}, exact ⟨(isRecField_eq h).1, (isRecField_eq h).2.1, (isRecField_eq h).2.2, fun q B h' => by simp [ctorFields] at h'⟩ -/-- Failure of the public acceptance predicate is exactly failure to produce -the shared checked descriptor. -/ +/-- Failure of the legacy singleton predicate is exactly failure to produce +the one-family checked descriptor. -/ theorem checked?_eq_none_iff {decl : VInductDecl} : - decl.checked? = none ↔ decl.stage3 = false := by - unfold stage3 + decl.checked? = none ↔ decl.singletonStage3 = false := by + unfold singletonStage3 cases decl.checked? <;> simp -/-- Successful acceptance retains the descriptor rather than discarding it. -/ -theorem exists_checked_of_stage3 {decl : VInductDecl} (h : decl.stage3 = true) : +/-- Successful singleton acceptance retains the descriptor rather than +discarding it. -/ +theorem exists_checked_of_singletonStage3 {decl : VInductDecl} + (h : decl.singletonStage3 = true) : ∃ checked, decl.checked? = some checked := by - unfold stage3 at h + unfold singletonStage3 at h cases hc : decl.checked? with | none => simp [hc] at h | some checked => exact ⟨checked, rfl⟩ +/-- Public Stage-3 rejection is exactly failure to retain a complete mutual +generation descriptor. -/ +theorem identityBlockGeneration?_eq_none_iff {decl : VInductDecl} : + decl.identityBlockGeneration? = none ↔ decl.stage3 = false := by + unfold stage3 + cases decl.identityBlockGeneration? <;> simp + +/-- Public Stage-3 acceptance retains the exact block descriptor used by the +transaction. -/ +theorem exists_blockGeneration_of_stage3 {decl : VInductDecl} + (h : decl.stage3 = true) : + ∃ generation, decl.identityBlockGeneration? = some generation := by + unfold stage3 at h + cases hgeneration : decl.identityBlockGeneration? with + | none => simp [hgeneration] at h + | some generation => exact ⟨generation, rfl⟩ + /-- Proof-level constructor-header coherence exported from the computational normalization-shape check. -/ def CtorHeaderEq (source view : VConstVal) : Prop := @@ -859,6 +901,168 @@ theorem GenerationChecked.viewCtors_eq {source : VInductDecl} apply pairNormalizedCtors_map_view exact gen.shape.2.2.2.1.symm.trans gen.shape.2.2.2.2.1 +/-! ### Block-generation positional facts -/ + +theorem pairNormalizedFamilies_map_raw : + ∀ (raws : List VInductiveType) (views : List CheckedFamilyData), + raws.length = views.length → + (pairNormalizedFamilies raws views).map (·.raw) = raws + | [], [], _ => rfl + | raw :: raws, view :: views, h => by + simp only [pairNormalizedFamilies, List.map_cons, + List.cons.injEq, true_and] + apply pairNormalizedFamilies_map_raw + simpa using h + +theorem pairNormalizedFamilies_map_view : + ∀ (raws : List VInductiveType) (views : List CheckedFamilyData), + raws.length = views.length → + (pairNormalizedFamilies raws views).map (·.view) = views + | [], [], _ => rfl + | raw :: raws, view :: views, h => by + simp only [pairNormalizedFamilies, List.map_cons, + List.cons.injEq, true_and] + apply pairNormalizedFamilies_map_view + simpa using h + +/-- Unpack the executable positional gate for mutual generation. -/ +theorem BlockGenerationChecked.shape {source : VInductDecl} + (gen : BlockGenerationChecked source) : + gen.block.rawParams.length = source.nparams ∧ + gen.block.rawParams.length = gen.block.checked.params.length ∧ + gen.families.length = source.types.length ∧ + gen.families.length = gen.block.checked.families.data.length ∧ + ∀ family ∈ gen.families, + family.raw.name = family.view.value.name ∧ + family.raw.uvars = family.view.value.uvars ∧ + (family.rawParams source.nparams).length = source.nparams ∧ + (family.rawIndices source.nparams).length = + family.view.indices.length ∧ + family.ctorPairs.length = family.raw.ctors.length ∧ + family.ctorPairs.length = family.view.constructors.length ∧ + ∀ ctor ∈ family.ctorPairs, + ctor.raw.name = ctor.view.value.name ∧ + ctor.raw.uvars = ctor.view.value.uvars ∧ + (VExpr.telN source.nparams ctor.raw.type).length = + source.nparams ∧ + (ctor.rawFields source.nparams).length = ctor.view.fields.length := by + have h := gen.shape_eq + simp only [NormalizedCheckedBlock.blockGenerationShape, + NormalizedFamily.generationShape, NormalizedCtor.generationShape, + Bool.and_eq_true, beq_iff_eq, List.all_eq_true] at h + obtain ⟨h, -⟩ := h + obtain ⟨⟨⟨⟨hparams, hparams'⟩, hraws⟩, hviews⟩, hfamilies⟩ := h + refine ⟨hparams, hparams', hraws, hviews, ?_⟩ + intro family hfamily + obtain ⟨⟨⟨⟨⟨⟨hname, hU⟩, htel⟩, hindices⟩, + hrawCtors⟩, hviewCtors⟩, hctors⟩ := hfamilies family hfamily + refine ⟨hname, hU, htel, hindices, hrawCtors, hviewCtors, ?_⟩ + intro ctor hctor + obtain ⟨⟨⟨hctorName, hctorU⟩, hctorTel⟩, hctorFields⟩ := + hctors ctor hctor + exact ⟨hctorName, hctorU, hctorTel, hctorFields⟩ + +theorem BlockGenerationChecked.family_uvars {source : VInductDecl} + (gen : BlockGenerationChecked source) {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + family.raw.uvars = source.uvars := by + have h := gen.shape_eq + simp only [NormalizedCheckedBlock.blockGenerationShape, + Bool.and_eq_true, beq_iff_eq, List.all_eq_true] at h + exact (h.2 family hfamily).1 + +theorem BlockGenerationChecked.ctor_uvars {source : VInductDecl} + (gen : BlockGenerationChecked source) {family : NormalizedFamily} + (hfamily : family ∈ gen.families) {ctor : NormalizedCtor} + (hctor : ctor ∈ family.ctorPairs) : + ctor.raw.uvars = source.uvars := by + have h := gen.shape_eq + simp only [NormalizedCheckedBlock.blockGenerationShape, + Bool.and_eq_true, beq_iff_eq, List.all_eq_true] at h + exact (h.2 family hfamily).2 ctor hctor + +theorem BlockGenerationChecked.families_map_raw {source : VInductDecl} + (gen : BlockGenerationChecked source) : + gen.families.map (·.raw) = source.types := by + apply pairNormalizedFamilies_map_raw + exact gen.shape.2.2.1.symm.trans gen.shape.2.2.2.1 + +theorem NormalizedFamily.ctorPairs_map_raw + {source : VInductDecl} {gen : BlockGenerationChecked source} + {family : NormalizedFamily} (hfamily : family ∈ gen.families) : + family.ctorPairs.map (·.raw) = family.raw.ctors := by + apply pairNormalizedCtors_map_raw + exact (gen.shape.2.2.2.2 family hfamily).2.2.2.2.1.symm.trans + (gen.shape.2.2.2.2 family hfamily).2.2.2.2.2.1 + +@[simp] theorem NormalizedFamily.blockCtors_map_raw + (family : NormalizedFamily) : + family.blockCtors.map (·.ctor.raw) = family.ctorPairs.map (·.raw) := by + unfold NormalizedFamily.blockCtors + induction family.ctorPairs with + | nil => rfl + | cons ctor ctors ih => + simp only [List.map_cons, List.cons.injEq, true_and] + exact ih + +theorem flatMap_congr_of_mem {α β : Type} (xs : List α) + (f g : α → List β) (h : ∀ x ∈ xs, f x = g x) : + xs.flatMap f = xs.flatMap g := by + induction xs with + | nil => rfl + | cons x xs ih => + simp only [List.flatMap_cons] + rw [h x (.head _), ih (fun y hy => h y (.tail _ hy))] + +theorem map_flatMap_eq {α β γ : Type} (xs : List α) + (f : α → List β) (g : β → γ) : + (xs.flatMap f).map g = xs.flatMap (fun x => (f x).map g) := by + induction xs with + | nil => rfl + | cons x xs ih => + simp only [List.flatMap_cons, List.map_append] + rw [ih] + +theorem BlockGenerationChecked.flatCtors_map_raw + {source : VInductDecl} (gen : BlockGenerationChecked source) : + gen.flatCtors.map (·.ctor.raw) = source.blockConstructorConstants := by + rw [VInductDecl.blockConstructorConstants, ← gen.families_map_raw] + unfold BlockGenerationChecked.flatCtors NormalizedCheckedBlock.flatCtors + rw [map_flatMap_eq] + simp only [List.flatMap_map] + apply flatMap_congr_of_mem + intro family hfamily + rw [family.blockCtors_map_raw] + exact family.ctorPairs_map_raw hfamily + +theorem BlockGenerationChecked.flatCtor_uvars + {source : VInductDecl} (gen : BlockGenerationChecked source) + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) : + constructor.ctor.raw.uvars = source.uvars := by + simp only [BlockGenerationChecked.flatCtors, + NormalizedCheckedBlock.flatCtors, List.mem_flatMap] at hconstructor + obtain ⟨family, hfamily, hconstructor⟩ := hconstructor + simp only [NormalizedFamily.blockCtors, List.mem_map] at hconstructor + obtain ⟨ctor, hctor, rfl⟩ := hconstructor + exact gen.ctor_uvars hfamily hctor + +/-- The validation staging fold is definitionally the family-constant phase +of block generation, modulo the explicit `toVConstVal` map. -/ +theorem blockTypeConstants_foldlM_eq_stageInductiveTypes + (env : VEnv) (source : VInductDecl) : + source.blockTypeConstants.foldlM + (fun env type => env.addConst type.name type.toVConstant) env = + env.stageInductiveTypes source.types := by + unfold VInductDecl.blockTypeConstants VEnv.stageInductiveTypes + induction source.types generalizing env with + | nil => rfl + | cons type types ih => + simp only [List.map_cons, List.foldlM_cons] + apply Option.bind_congr + intro env' _ + exact ih env' + /-- Identity normalization is computationally the legacy analyzer. -/ theorem Normalization.identity_checked? (source : VInductDecl) : (Normalization.identity source).checked? = source.checked? := rfl @@ -1072,7 +1276,7 @@ theorem Checked.direct_anatomy {decl : VInductDecl} (checked : decl.Checked) : have hdirect := checked.analysis_accepted.1 simp only [stage3DirectCore, Bool.and_eq_true, beq_iff_eq, List.all_eq_true] at hdirect - obtain ⟨⟨⟨⟨⟨hU, hparams⟩, hresult⟩, hformer⟩, -⟩, hctors⟩ := hdirect + obtain ⟨⟨⟨⟨hU, hparams⟩, hresult⟩, hformer⟩, hctors⟩ := hdirect simp only [typeFormerOK, Bool.and_eq_true, List.all_eq_true] at hformer refine ⟨hU, by simpa [checked.params_eq] using hparams, ?_, ?_, ?_, ?_⟩ · rw [checked.result_eq] at hresult @@ -1161,7 +1365,7 @@ theorem Checked.wf_of_decl {decl : VInductDecl} (checked : decl.Checked) to `Checked.WF`. -/ theorem Checked.to_declWF {decl : VInductDecl} (checked : decl.Checked) (hchecked : decl.checked? = some checked) (hwf : checked.WF env) : decl.WF env := by - refine ⟨by simp [stage3, hchecked], ?_⟩ + refine ⟨by simp [singletonStage3, hchecked], ?_⟩ intro ty hty rw [checked.types_eq] at hty obtain rfl := List.mem_singleton.1 hty @@ -1176,7 +1380,7 @@ theorem wf_iff_exists_checked {decl : VInductDecl} : decl.WF env ↔ ∃ checked, decl.checked? = some checked ∧ checked.WF env := by constructor · intro hdecl - obtain ⟨checked, hchecked⟩ := exists_checked_of_stage3 hdecl.1 + obtain ⟨checked, hchecked⟩ := exists_checked_of_singletonStage3 hdecl.1 exact ⟨checked, hchecked, checked.wf_of_decl hdecl⟩ · rintro ⟨checked, hchecked, hwf⟩ exact checked.to_declWF hchecked hwf @@ -1245,7 +1449,8 @@ info: 'Lean4Lean.VInductDecl.wf_iff_exists_checked' depends on axioms: [propext, /-- Unpack `stage3` for a declaration already known (from `addInduct` success) to have a singleton type list. -/ -theorem stage3_anatomy {U np ty} (h : stage3 ⟨U, np, [ty]⟩ = true) : +theorem singletonStage3_anatomy {U np ty} + (h : singletonStage3 ⟨U, np, [ty]⟩ = true) : ty.uvars = U ∧ (VExpr.telN np ty.type).length = np ∧ (∃ l, VExpr.resultOf (VExpr.dropN np ty.type) = .sort l ∧ l.WF U) ∧ (∀ I ∈ ctorFields (VExpr.dropN np ty.type), I.hasConst ty.name = false) ∧ @@ -1253,13 +1458,13 @@ theorem stage3_anatomy {U np ty} (h : stage3 ⟨U, np, [ty]⟩ = true) : VExpr.telN np c.type = VExpr.telN np ty.type ∧ stage3Ctor U ty.name np (ctorFields (VExpr.dropN np ty.type)).length 0 (VExpr.dropN np c.type) = true := by - obtain ⟨checked, -⟩ := exists_checked_of_stage3 h + obtain ⟨checked, -⟩ := exists_checked_of_singletonStage3 h have hcore := checked.accepted simp only [stage3Core, Bool.and_eq_true] at hcore have hdirect := hcore.1 simp only [stage3DirectCore, Bool.and_eq_true, beq_iff_eq, List.all_eq_true] at hdirect - obtain ⟨⟨⟨⟨⟨h1, h2⟩, h3⟩, h4⟩, -⟩, h6⟩ := hdirect + obtain ⟨⟨⟨⟨h1, h2⟩, h3⟩, h4⟩, h6⟩ := hdirect simp only [typeFormerOK, Bool.and_eq_true, List.all_eq_true] at h4 refine ⟨h1, h2, ?_, fun I hI => by simpa [Bool.not_eq_true'] using h4.2 I hI, fun c hc => by simpa [and_assoc] using h6 c hc⟩ @@ -1569,6 +1774,28 @@ theorem SpineWF.retarget {env : VEnv} {U : Nat} {Γ : List VExpr} {es : List VEx 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. -/ +theorem SpineWF.forallN_sort_length + {env : VEnv} {U : Nat} {Γ : List VExpr} {l : VLevel} : + ∀ {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 + | 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 + end VEnv /-! ## The induction-hypothesis telescope under lifting -/ @@ -1789,12 +2016,14 @@ target. -/ theorem recArg_minor_fieldType {U : Nat} {T : Name} {np ni : Nat} {B : VExpr} {r₀ : RecArg} (hr : recArg? U T np ni r₀.fieldIndex B = some r₀) - (m p : Nat) (hj : r₀.fieldIndex < m) : - let r := r₀.instL (VLevel.params' U 1) - ((B.instL (VLevel.params' U 1)).liftN 1 r.fieldIndex).liftN + (m p : Nat) (hj : r₀.fieldIndex < m) + (mode : ElimMode := .large) : + let ls := mode.sourceLevels U + let r := r₀.instL ls + ((B.instL ls).liftN 1 r.fieldIndex).liftN (m-r.fieldIndex+p) = VExpr.forallN (r.minorBinders m p) - (VExpr.appN (.const T (VLevel.params' U 1)) + (VExpr.appN (.const T ls) (VExpr.bvarRevRange (m+p+r.binders.length+1) np ++ r.indices.map fun e => (e.liftN 1 (r.fieldIndex+r.binders.length)).liftN @@ -1804,9 +2033,10 @@ theorem recArg_minor_fieldType {U : Nat} {T : Name} {np ni : Nat} conv => lhs; rw [hB] simp only [RecArg.instL, VExpr.instL_forallN, VExpr.instL_appN, List.map_append, bvarRevRange_instL, - show (VExpr.const T (VLevel.params U)).instL (VLevel.params' U 1) = - .const T (VLevel.params' U 1) from by - simp [VExpr.instL, VLevel.params_map_inst_params'], + show (VExpr.const T (VLevel.params U)).instL (mode.sourceLevels U) = + .const T (mode.sourceLevels U) from by + simp [VExpr.instL, ElimMode.sourceLevels, + VLevel.params_map_inst_params'], VExpr.liftN_forallN, VExpr.liftN_appN] simp only [List.length_map, VExpr.liftTelN_length, Nat.zero_add] rw [bvarRevRange_liftN_ge _ _ _ _ (Nat.le_refl _), @@ -1816,7 +2046,7 @@ theorem recArg_minor_fieldType {U : Nat} {T : Name} {np ni : Nat} m + p + r₀.binders.length + 1 from by omega] simp only [List.map_map, RecArg.minorBinders] apply congrArg (VExpr.forallN _) - apply congrArg (VExpr.appN (.const T (VLevel.params' U 1))) + apply congrArg (VExpr.appN (.const T (mode.sourceLevels U))) apply congrArg (VExpr.bvarRevRange (m + p + r₀.binders.length + 1) np ++ ·) apply List.map_congr_left intro e _ @@ -1828,12 +2058,14 @@ constructor fields. -/ theorem recArg_rule_fieldType {U : Nat} {T : Name} {np ni : Nat} {B : VExpr} {r₀ : RecArg} (hr : recArg? U T np ni r₀.fieldIndex B = some r₀) - (m k : Nat) (hj : r₀.fieldIndex < m) : - let r := r₀.instL (VLevel.params' U 1) - ((B.instL (VLevel.params' U 1)).liftN (k+1) r.fieldIndex).liftN + (m k : Nat) (hj : r₀.fieldIndex < m) + (mode : ElimMode := .large) : + let ls := mode.sourceLevels U + let r := r₀.instL ls + ((B.instL ls).liftN (k+1) r.fieldIndex).liftN (m-r.fieldIndex) = VExpr.forallN (r.ruleBinders m k) - (VExpr.appN (.const T (VLevel.params' U 1)) + (VExpr.appN (.const T ls) (VExpr.bvarRevRange (m+k+r.binders.length+1) np ++ r.indices.map fun e => (e.liftN (k+1) (r.fieldIndex+r.binders.length)).liftN @@ -1843,9 +2075,10 @@ theorem recArg_rule_fieldType {U : Nat} {T : Name} {np ni : Nat} conv => lhs; rw [hB] simp only [RecArg.instL, VExpr.instL_forallN, VExpr.instL_appN, List.map_append, bvarRevRange_instL, - show (VExpr.const T (VLevel.params U)).instL (VLevel.params' U 1) = - .const T (VLevel.params' U 1) from by - simp [VExpr.instL, VLevel.params_map_inst_params'], + show (VExpr.const T (VLevel.params U)).instL (mode.sourceLevels U) = + .const T (mode.sourceLevels U) from by + simp [VExpr.instL, ElimMode.sourceLevels, + VLevel.params_map_inst_params'], VExpr.liftN_forallN, VExpr.liftN_appN] simp only [List.length_map, VExpr.liftTelN_length, Nat.zero_add] rw [bvarRevRange_liftN_ge _ _ _ _ (Nat.le_refl _), @@ -1854,7 +2087,7 @@ theorem recArg_rule_fieldType {U : Nat} {T : Name} {np ni : Nat} m + k + r₀.binders.length + 1 from by omega] simp only [List.map_map, RecArg.ruleBinders] apply congrArg (VExpr.forallN _) - apply congrArg (VExpr.appN (.const T (VLevel.params' U 1))) + apply congrArg (VExpr.appN (.const T (mode.sourceLevels U))) apply congrArg (VExpr.bvarRevRange (m+k+r₀.binders.length+1) np ++ ·) apply List.map_congr_left intro e _ @@ -2006,7 +2239,8 @@ theorem recApp_instL {U : Nat} {T : Name} {np off : Nat} : (recApp U T np off).instL (VLevel.params' U 1) = recApp' U T np off := by simp only [recApp, recApp', VExpr.instL_appN] rw [bvarRevRange_instL] - simp [VExpr.instL, VLevel.params_map_inst_params'] + simp [VExpr.instL, VLevel.params_map_inst_params', ElimMode.sourceLevels, + ElimMode.offset] theorem recApp'_congr {U : Nat} {T : Name} {np : Nat} {off off' : Nat} (h : off = off') : recApp' U T np off = recApp' U T np off' := h ▸ rfl @@ -2114,6 +2348,20 @@ theorem TelDefEq.raw_onTel {env : VEnv} {U : Nat} : | _, _ :: _, _ :: _, ⟨⟨_, hA⟩, hT⟩ => ⟨⟨_, hA.hasType.1⟩, TelDefEq.raw_onTel hT⟩ +/-- Extend a structural telescope equality by an identical, well-formed +suffix. The suffix is checked in the completed left-hand context, exactly as +required by `TelDefEq`'s raw-context convention. -/ +theorem TelDefEq.append_refl {env : VEnv} {U : Nat} : + ∀ {Γ As As'}, TelDefEq env U Γ As As' → + ∀ {Bs}, OnTel env U (As.reverse ++ Γ) Bs → + TelDefEq env U Γ (As ++ Bs) (As' ++ Bs) + | _, [], [], _, _, hBs => by + simpa using hBs.telDefEq_refl + | Γ, A :: As, A' :: As', ⟨hA, hT⟩, Bs, hBs => by + refine ⟨hA, ?_⟩ + apply TelDefEq.append_refl hT + simpa [List.reverse_cons, List.append_assoc] using hBs + /-- Structural telescope equality is monotone in the environment. -/ theorem TelDefEq.mono {env env' : VEnv} {U : Nat} (henv : env ≤ env') : ∀ {Γ As As'}, TelDefEq env U Γ As As' → TelDefEq env' U Γ As As' @@ -2288,6 +2536,53 @@ theorem OnTel.defeqDFC {env : VEnv} {U : Nat} (ord : env.Ordered) exact ⟨⟨u, hAt.defeqDFC ord hΓ⟩, OnTel.defeqDFC ord (.succ hΓ hAt) hT⟩ +/-- The view side of a structural telescope equality is itself well formed. +Each tail is transported from the accumulated raw context to the accumulated +view context before recursion continues. -/ +theorem TelDefEq.view_onTel {env : VEnv} {U : Nat} (ord : env.Ordered) : + ∀ {Γ As As'}, TelDefEq env U Γ As As' → OnTel env U Γ As' + | _, [], [], _ => trivial + | _, _ :: _, _ :: _, ⟨⟨u, hA⟩, hT⟩ => + ⟨⟨u, hA.hasType.2⟩, + (TelDefEq.view_onTel ord hT).defeqDFC ord + (.succ .zero hA)⟩ + +/-- Transport a structural telescope equality across definitionally equal +base contexts while retaining its raw/view surfaces. -/ +theorem TelDefEq.defeqDFC {env : VEnv} {U : Nat} (ord : env.Ordered) + {Γ₀ Γ₁ Γ₂ : List VExpr} (hΓ : IsDefEqCtx env U Γ₀ Γ₁ Γ₂) : + ∀ {As As'}, TelDefEq env U Γ₁ As As' → TelDefEq env U Γ₂ As As' + | [], [], _ => trivial + | A :: As, _ :: As', ⟨⟨u, hA⟩, hT⟩ => by + have hA' := hA.defeqDFC ord hΓ + refine ⟨⟨u, hA'⟩, ?_⟩ + exact TelDefEq.defeqDFC ord + (.succ hΓ hA.hasType.1) hT + +/-- Select Lean's kernel-observable parameter surface without losing the +structural equality to the analyzer-owned parameter telescope. Ordinary +parameters keep the raw domain; annotated parameters use the checked domain. +-/ +theorem TelDefEq.generationParams {env : VEnv} {U : Nat} + (ord : env.Ordered) : + ∀ {Γ raw view}, TelDefEq env U Γ raw view → + TelDefEq env U Γ (VInductDecl.generationParams raw view) view + | _, [], [], _ => trivial + | Γ, raw :: raws, view :: views, ⟨⟨u, head⟩, tail⟩ => by + simp only [VInductDecl.generationParams, + VInductDecl.generationParam] + split + · refine ⟨⟨u, head.hasType.2⟩, ?_⟩ + exact (TelDefEq.generationParams ord tail).defeqDFC ord + (.succ (.zero (Γ₀ := Γ)) head) + · exact ⟨⟨u, head⟩, TelDefEq.generationParams ord tail⟩ + +/-- +info: 'Lean4Lean.VEnv.TelDefEq.generationParams' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms TelDefEq.generationParams + /-- Transport application-spine typing across definitionally equal contexts. -/ theorem SpineWF.defeqDFC {env : VEnv} {U : Nat} (ord : env.Ordered) @@ -2409,6 +2704,121 @@ theorem GenerationChecked.WF.rawCtor_isType {source : VInductDecl} envT.IsType source.uvars [] ctor.raw.type := (h.ctors envT hadd ctor hctor).rawDeclared_isType +/-! Mutual declaration-stage consequences. -/ + +theorem NormalizedFamily.WF.rawFamily_onTel {source : VInductDecl} + {gen : BlockGenerationChecked source} {family : NormalizedFamily} + {env : VEnv} (h : family.WF gen env) : + env.OnTel source.uvars [] + (family.rawParams source.nparams ++ + family.rawIndices source.nparams) := + h.familyTel.raw_onTel + +theorem NormalizedFamily.WF.rawFamily_isType {source : VInductDecl} + {gen : BlockGenerationChecked source} {family : NormalizedFamily} + {env : VEnv} (h : family.WF gen env) : + env.IsType source.uvars [] family.raw.type := by + rw [← VExpr.forallN_telN_dropN source.nparams family.raw.type, + ← forallN_ctorFields_resultOf + (VExpr.dropN source.nparams family.raw.type), + ← VExpr.forallN_append] + have hresult₀ : env.IsType source.uvars + (family.rawParams source.nparams ++ + family.rawIndices source.nparams).reverse + (family.rawResult source.nparams) := + ⟨_, h.familyResult.hasType.1⟩ + have hresult : env.IsType source.uvars + ((family.rawParams source.nparams ++ + family.rawIndices source.nparams).reverse ++ []) + (family.rawResult source.nparams) := by + simpa using hresult₀ + have hout := IsType.forallN h.rawFamily_onTel hresult + simpa [NormalizedFamily.rawParams, NormalizedFamily.rawIndices, + NormalizedFamily.rawResult] using hout + +theorem NormalizedFamily.WF.mono {source : VInductDecl} + {gen : BlockGenerationChecked source} {family : NormalizedFamily} + {env env' : VEnv} (henv : env ≤ env') (h : family.WF gen env) : + family.WF gen env' where + familyTel := h.familyTel.mono henv + familyResult := h.familyResult.mono henv + +theorem NormalizedBlockCtor.WF.rawDeclared_onTel + {source : VInductDecl} {gen : BlockGenerationChecked source} + {constructor : NormalizedBlockCtor} {env : VEnv} + (h : NormalizedBlockCtor.WF gen constructor env) : + env.OnTel source.uvars [] + (NormalizedBlockCtor.declaredBinders + (source := source) constructor) := + h.declaredTel.raw_onTel + +theorem NormalizedBlockCtor.WF.rawDeclared_isType + {source : VInductDecl} {gen : BlockGenerationChecked source} + {constructor : NormalizedBlockCtor} {env : VEnv} + (h : NormalizedBlockCtor.WF gen constructor env) : + env.IsType source.uvars [] constructor.ctor.raw.type := by + rw [← VExpr.forallN_telN_dropN source.nparams + constructor.ctor.raw.type, + ← forallN_ctorFields_resultOf + (VExpr.dropN source.nparams constructor.ctor.raw.type), + ← VExpr.forallN_append] + have hresult₀ : env.IsType source.uvars + (NormalizedBlockCtor.declaredBinders + (source := source) constructor).reverse + (NormalizedBlockCtor.rawResult + (source := source) constructor) := + ⟨_, h.declaredResult.hasType.1⟩ + have hresult : env.IsType source.uvars + ((NormalizedBlockCtor.declaredBinders + (source := source) constructor).reverse ++ []) + (NormalizedBlockCtor.rawResult + (source := source) constructor) := by + simpa using hresult₀ + have hout := IsType.forallN h.rawDeclared_onTel hresult + simpa [NormalizedBlockCtor.declaredBinders, + NormalizedBlockCtor.rawResult, NormalizedCtor.declaredBinders, + NormalizedCtor.rawFields, NormalizedCtor.rawResult] using hout + +theorem NormalizedBlockCtor.WF.rawEmitted_onTel + {source : VInductDecl} {gen : BlockGenerationChecked source} + {constructor : NormalizedBlockCtor} {env : VEnv} + (h : NormalizedBlockCtor.WF gen constructor env) : + env.OnTel source.uvars [] + (NormalizedBlockCtor.emittedBinders gen constructor) := + h.emittedTel.raw_onTel + +theorem NormalizedBlockCtor.WF.mono + {source : VInductDecl} {gen : BlockGenerationChecked source} + {constructor : NormalizedBlockCtor} {env env' : VEnv} + (henv : env ≤ env') (h : NormalizedBlockCtor.WF gen constructor env) : + NormalizedBlockCtor.WF gen constructor env' where + declaredTel := h.declaredTel.mono henv + declaredResult := h.declaredResult.mono henv + emittedTel := h.emittedTel.mono henv + emittedResult := h.emittedResult.mono henv + owner := h.owner + recursive := fun recursive hrecursive => by + obtain ⟨family, hfamily, hordinal, hfield, hwf⟩ := + h.recursive recursive hrecursive + exact ⟨family, hfamily, hordinal, hfield, + ⟨hwf.1.mono henv, hwf.2.mono henv⟩⟩ + resultSpine := h.resultSpine.mono henv + +theorem BlockGenerationChecked.WF.rawFamily_isType + {source : VInductDecl} {gen : BlockGenerationChecked source} + {env blockEnv : VEnv} (h : gen.WF env blockEnv) + {family : NormalizedFamily} (hfamily : family ∈ gen.families) : + env.IsType source.uvars [] family.raw.type := + (h.families family hfamily).rawFamily_isType + +theorem BlockGenerationChecked.WF.rawCtor_isType + {source : VInductDecl} {gen : BlockGenerationChecked source} + {env blockEnv : VEnv} (h : gen.WF env blockEnv) + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) : + blockEnv.IsType source.uvars [] constructor.ctor.raw.type := + (h.constructors constructor hconstructor).rawDeclared_isType + /-- info: 'Lean4Lean.VInductDecl.GenerationChecked.WF.rawFamily_isType' depends on axioms: [propext, Quot.sound] -/ @@ -2426,6 +2836,74 @@ theorem RecArg.WF.mono {env env' : VEnv} {U : Nat} {l : VLevel} (h : r.WF U env l Is Γ) : r.WF U env' l Is Γ := ⟨h.1.mono henv, h.2.mono henv⟩ +/-- The checked recursive/non-recursive field interpretation is monotone in +the environment. -/ +theorem checkedBlockFieldsWF_mono {env env' : VEnv} {U : Nat} + {resultLevel : VLevel} {familyIndices : List (List VExpr)} + (henv : env ≤ env') : ∀ {fields classifications Γ j}, + checkedBlockFieldsWF env U resultLevel familyIndices + fields classifications Γ j → + checkedBlockFieldsWF env' U resultLevel familyIndices + fields classifications Γ j + | [], [], _, _, _ => trivial + | [], _ :: _, _, _, h => by + simp [checkedBlockFieldsWF] at h + | _ :: _, [], _, _, h => by + simp [checkedBlockFieldsWF] at h + | B :: Bs, none :: classifications, Γ, j, + ⟨⟨u, hB, hlevel⟩, htail⟩ => + ⟨⟨u, hB.mono henv, hlevel⟩, + checkedBlockFieldsWF_mono henv htail⟩ + | B :: Bs, some recursive :: classifications, Γ, j, h => by + simp only [checkedBlockFieldsWF] at h ⊢ + obtain ⟨⟨hfield, hrecursive⟩, htail⟩ := h + refine ⟨⟨hfield, ?_⟩, + checkedBlockFieldsWF_mono henv htail⟩ + cases htarget : familyIndices[recursive.targetType]? with + | none => simp [htarget] at hrecursive + | some indices => + rw [htarget] at hrecursive + exact hrecursive.mono henv + +/-- The erased family-spine semantics is monotone in the environment. -/ +theorem checkedFamilyListsWF_mono {source : VInductDecl} + {params : List VExpr} {env env' : VEnv} {resultLevel : VLevel} + {familyIndices : List (List VExpr)} (henv : env ≤ env') : + ∀ levels indices constructors, + checkedFamilyListsWF source params env resultLevel familyIndices + levels indices constructors → + checkedFamilyListsWF source params env' resultLevel familyIndices + levels indices constructors := by + intro levels + induction levels with + | nil => + intro indices constructors h + cases indices <;> cases constructors <;> + simp_all [checkedFamilyListsWF] + | cons level levels ih => + intro indices constructors h + cases indices with + | nil => simp [checkedFamilyListsWF] at h + | cons index indices => + cases constructors with + | nil => simp [checkedFamilyListsWF] at h + | cons familyConstructors constructors => + simp only [checkedFamilyListsWF] at h ⊢ + obtain ⟨hlevel, hindices, hconstructors, htail⟩ := h + exact ⟨hlevel, hindices.mono henv, + fun constructor hconstructor => + ⟨checkedBlockFieldsWF_mono henv + (hconstructors constructor hconstructor).1, + (hconstructors constructor hconstructor).2.mono henv⟩, + ih indices constructors htail⟩ + +theorem CheckedBlock.WF.mono {source : VInductDecl} + {checked : source.CheckedBlock} {env env' : VEnv} + {resultLevel : VLevel} (henv : env ≤ env') + (h : checked.WF env resultLevel) : + checked.WF env' resultLevel := + checkedFamilyListsWF_mono henv _ _ _ h + /-- Transport recursive-argument evidence across definitionally equal base contexts. The private binder telescope is transported first, then the terminal family-index spine is transported beneath that same telescope. -/ @@ -2596,6 +3074,47 @@ info: 'Lean4Lean.VInductDecl.GenerationChecked.checkedResultTarget_hasType' depe /-- Final-environment invariant for mixed raw/view generation. It contains only facts stable after the raw family and constructors have been inserted; the staged pre-family/post-family split remains in `GenerationChecked.WF`. -/ +theorem GenerationChecked.sourceLevels_wf {source : VInductDecl} + (gen : GenerationChecked source) : + ∀ l ∈ gen.sourceLevels, l.WF gen.recUvars := + VLevel.params'_wf + +@[simp] theorem GenerationChecked.sourceLevels_eq {source : VInductDecl} + (gen : GenerationChecked source) : + gen.sourceLevels = + VLevel.params' source.uvars gen.elimination.offset := rfl + +@[simp] theorem GenerationChecked.recUvars_eq {source : VInductDecl} + (gen : GenerationChecked source) : + gen.recUvars = source.uvars + gen.elimination.offset := rfl + +@[simp] theorem GenerationChecked.recLevels_eq {source : VInductDecl} + (gen : GenerationChecked source) : + gen.recLevels = VLevel.params gen.recUvars := rfl + +theorem GenerationChecked.sourceLevels_length {source : VInductDecl} + (gen : GenerationChecked source) : + gen.sourceLevels.length = source.uvars := + VLevel.params'_length + +theorem GenerationChecked.motiveLevel_wf {source : VInductDecl} + (gen : GenerationChecked source) : + gen.motiveLevel.WF gen.recUvars := by + cases h : gen.elimination <;> + simp [GenerationChecked.motiveLevel, + GenerationChecked.recUvars, ElimMode.recUvars, + ElimMode.offset, ElimMode.motiveLevel, VLevel.WF, h] + +theorem GenerationChecked.recLevels_wf {source : VInductDecl} + (gen : GenerationChecked source) : + ∀ l ∈ gen.recLevels, l.WF gen.recUvars := + VLevel.params_wf + +theorem GenerationChecked.recLevels_length {source : VInductDecl} + (gen : GenerationChecked source) : + gen.recLevels.length = gen.recUvars := + VLevel.params_length + structure GenerationEnv {source : VInductDecl} (gen : GenerationChecked source) (env : VEnv) : Prop where ord : env.Ordered @@ -2639,6 +3158,389 @@ theorem GenerationChecked.WF.toGenerationEnv {source : VInductDecl} familyConst := hfamily ctorConst := hctors +theorem BlockGenerationChecked.sourceLevels_wf {source : VInductDecl} + (gen : BlockGenerationChecked source) : + ∀ l ∈ gen.sourceLevels, l.WF gen.recUvars := + VLevel.params'_wf + +@[simp] theorem BlockGenerationChecked.sourceLevels_eq + {source : VInductDecl} (gen : BlockGenerationChecked source) : + gen.sourceLevels = + VLevel.params' source.uvars gen.elimination.offset := rfl + +@[simp] theorem BlockGenerationChecked.recUvars_eq + {source : VInductDecl} (gen : BlockGenerationChecked source) : + gen.recUvars = source.uvars + gen.elimination.offset := rfl + +@[simp] theorem BlockGenerationChecked.recLevels_eq + {source : VInductDecl} (gen : BlockGenerationChecked source) : + gen.recLevels = VLevel.params gen.recUvars := rfl + +theorem BlockGenerationChecked.sourceLevels_length + {source : VInductDecl} (gen : BlockGenerationChecked source) : + gen.sourceLevels.length = source.uvars := + VLevel.params'_length + +theorem BlockGenerationChecked.motiveLevel_wf + {source : VInductDecl} (gen : BlockGenerationChecked source) : + gen.motiveLevel.WF gen.recUvars := by + cases h : gen.elimination <;> + simp [BlockGenerationChecked.motiveLevel, + BlockGenerationChecked.recUvars, ElimMode.recUvars, + ElimMode.offset, ElimMode.motiveLevel, VLevel.WF, h] + +theorem BlockGenerationChecked.recLevels_wf + {source : VInductDecl} (gen : BlockGenerationChecked source) : + ∀ l ∈ gen.recLevels, l.WF gen.recUvars := + VLevel.params_wf + +theorem BlockGenerationChecked.recLevels_length + {source : VInductDecl} (gen : BlockGenerationChecked source) : + gen.recLevels.length = gen.recUvars := + VLevel.params_length + +/-- Stable final-environment invariant for mutual artifact generation. -/ +structure BlockGenerationEnv {source : VInductDecl} + (gen : BlockGenerationChecked source) (env : VEnv) : Prop where + ord : env.Ordered + resultLevelWF : gen.validated.resultLevel.WF source.uvars + checked : + gen.block.checked.WF env gen.validated.resultLevel + paramsTel : + env.TelDefEq source.uvars [] gen.block.rawParams + gen.block.checked.params + familyWF : ∀ family ∈ gen.families, family.WF gen env + ctorWF : ∀ constructor ∈ gen.flatCtors, + NormalizedBlockCtor.WF gen constructor env + familyConst : ∀ family ∈ gen.families, + env.constants family.raw.name = some family.raw.toVConstant + ctorConst : ∀ constructor ∈ gen.flatCtors, + env.constants constructor.ctor.raw.name = + some constructor.ctor.raw.toVConstant + +theorem BlockGenerationChecked.WF.toBlockGenerationEnv + {source : VInductDecl} {gen : BlockGenerationChecked source} + {pre blockEnv env : VEnv} (h : gen.WF pre blockEnv) + (hlePre : pre ≤ env) (hleBlock : blockEnv ≤ env) + (ord : env.Ordered) + (hfamilies : ∀ family ∈ gen.families, + env.constants family.raw.name = some family.raw.toVConstant) + (hctors : ∀ constructor ∈ gen.flatCtors, + env.constants constructor.ctor.raw.name = + some constructor.ctor.raw.toVConstant) : + BlockGenerationEnv gen env where + ord := ord + resultLevelWF := h.resultLevelWF + checked := h.blockWF.2.mono hlePre + paramsTel := h.paramsTel.mono hlePre + familyWF := fun family hfamily => + (h.families family hfamily).mono hlePre + ctorWF := fun constructor hconstructor => + (h.constructors constructor hconstructor).mono hleBlock + familyConst := hfamilies + ctorConst := hctors + +theorem NormalizedFamily.rawType_eq {source : VInductDecl} + (family : NormalizedFamily) : + family.raw.type = + VExpr.forallN (family.rawParams source.nparams) + (VExpr.forallN (family.rawIndices source.nparams) + (family.rawResult source.nparams)) := by + conv => lhs + rw [← VExpr.forallN_telN_dropN source.nparams family.raw.type, + ← forallN_ctorFields_resultOf + (VExpr.dropN source.nparams family.raw.type)] + rfl + +namespace BlockGenerationEnv + +variable {source : VInductDecl} {gen : BlockGenerationChecked source} + {env : VEnv} (S : BlockGenerationEnv gen env) +include S + +theorem mono {env' : VEnv} (henv : env ≤ env') (ord : env'.Ordered) : + BlockGenerationEnv gen env' where + ord := ord + resultLevelWF := S.resultLevelWF + checked := S.checked.mono henv + paramsTel := S.paramsTel.mono henv + familyWF := fun family hfamily => (S.familyWF family hfamily).mono henv + ctorWF := fun constructor hconstructor => + (S.ctorWF constructor hconstructor).mono henv + familyConst := fun family hfamily => + henv.constants (S.familyConst family hfamily) + ctorConst := fun constructor hconstructor => + henv.constants (S.ctorConst constructor hconstructor) + +theorem generationParams_defeq : + env.TelDefEq source.uvars [] + (generationParams gen.block.rawParams gen.block.checked.params) + gen.block.checked.params := + S.paramsTel.generationParams S.ord + +theorem generationParams_length : + (generationParams gen.block.rawParams + gen.block.checked.params).length = source.nparams := by + exact (generationParams_length_of_eq S.paramsTel.length_eq).trans + gen.shape.1 + +theorem generationParams_ctx : + env.IsDefEqCtx source.uvars [] + (generationParams gen.block.rawParams + gen.block.checked.params).reverse + gen.block.checked.params.reverse := by + simpa using S.generationParams_defeq.ctx + +theorem generationParams_ctx_rec : + env.IsDefEqCtx gen.recUvars [] gen.paramsTel.reverse + (gen.block.checked.params.map + (VExpr.instL gen.sourceLevels)).reverse := by + have h := S.generationParams_defeq.instL + (U' := gen.recUvars) gen.sourceLevels_wf + simpa [BlockGenerationChecked.paramsTel, List.map_reverse] using h.ctx + +theorem rawFamily_onTel {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.OnTel source.uvars [] + (family.rawParams source.nparams ++ + family.rawIndices source.nparams) := + (S.familyWF family hfamily).familyTel.raw_onTel + +theorem familyConst_decl {family : NormalizedFamily} + (hfamily : family ∈ gen.families) {Γ : List VExpr} : + env.HasType source.uvars Γ + (.const family.raw.name (VLevel.params source.uvars)) + family.raw.type := by + have hwf : family.raw.toVConstant.WF env := by + show env.IsType family.raw.uvars [] family.raw.type + rw [gen.family_uvars hfamily] + exact (S.familyWF family hfamily).rawFamily_isType + have h := HasType.const0 (S.familyConst family hfamily) hwf + rw [gen.family_uvars hfamily] at h + exact h.weak0 S.ord + +theorem ctorConst_decl {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) {Γ : List VExpr} : + env.HasType source.uvars Γ + (.const constructor.ctor.raw.name (VLevel.params source.uvars)) + constructor.ctor.raw.type := by + have hwf : constructor.ctor.raw.toVConstant.WF env := by + show env.IsType constructor.ctor.raw.uvars [] + constructor.ctor.raw.type + rw [gen.flatCtor_uvars hconstructor] + exact (S.ctorWF constructor hconstructor).rawDeclared_isType + have h := HasType.const0 (S.ctorConst constructor hconstructor) hwf + rw [gen.flatCtor_uvars hconstructor] at h + exact h.weak0 S.ord + +theorem rawParams_defeq {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.TelDefEq source.uvars [] + (family.rawParams source.nparams) gen.block.checked.params := by + have h := (S.familyWF family hfamily).familyTel.take source.nparams + have hraw : + (family.rawParams source.nparams ++ + family.rawIndices source.nparams).take source.nparams = + family.rawParams source.nparams := by + let Ps := family.rawParams source.nparams + let Is := family.rawIndices source.nparams + have hlen : Ps.length = source.nparams := + (gen.shape.2.2.2.2 family hfamily).2.2.1 + change (Ps ++ Is).take source.nparams = Ps + rw [← hlen, List.take_append, List.take_length] + simp + have hviewLen : gen.block.checked.params.length = source.nparams := + gen.shape.2.1.symm.trans gen.shape.1 + have hview : + (gen.block.checked.params ++ family.view.indices).take + source.nparams = gen.block.checked.params := by + rw [← hviewLen, List.take_append, List.take_length] + simp + rw [hraw, hview] at h + exact h + +theorem emittedFamilyTel {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.TelDefEq source.uvars [] + (family.rawParams source.nparams ++ family.rawIndices source.nparams) + (gen.block.checked.params ++ family.rawIndices source.nparams) := by + have hindices : env.OnTel source.uvars + (family.rawParams source.nparams).reverse + (family.rawIndices source.nparams) := by + simpa using (S.rawFamily_onTel hfamily).of_append.2 + exact (S.rawParams_defeq hfamily).append_refl (by simpa using hindices) + +theorem emittedFamily_onTel {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.OnTel source.uvars [] + (gen.block.checked.params ++ family.rawIndices source.nparams) := + (S.emittedFamilyTel hfamily).view_onTel S.ord + +theorem generationFamilyTel {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.TelDefEq source.uvars [] + (generationParams gen.block.rawParams gen.block.checked.params ++ + family.rawIndices source.nparams) + (gen.block.checked.params ++ family.rawIndices source.nparams) := by + have hindicesChecked : env.OnTel source.uvars + gen.block.checked.params.reverse (family.rawIndices source.nparams) := by + simpa using (S.emittedFamily_onTel hfamily).of_append.2 + have hindicesGeneration : env.OnTel source.uvars + (generationParams gen.block.rawParams + gen.block.checked.params).reverse + (family.rawIndices source.nparams) := + hindicesChecked.defeqDFC S.ord + (S.generationParams_ctx.symm S.ord) + exact S.generationParams_defeq.append_refl + (by simpa using hindicesGeneration) + +theorem generationFamily_onTel {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.OnTel source.uvars [] + (generationParams gen.block.rawParams gen.block.checked.params ++ + family.rawIndices source.nparams) := + (S.generationFamilyTel hfamily).raw_onTel + +theorem emittedFamily_ctx {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.IsDefEqCtx source.uvars [] + (family.rawParams source.nparams ++ + family.rawIndices source.nparams).reverse + (gen.block.checked.params ++ + family.rawIndices source.nparams).reverse := by + simpa using (S.emittedFamilyTel hfamily).ctx + +theorem generationFamily_ctx {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.IsDefEqCtx source.uvars [] + (generationParams gen.block.rawParams gen.block.checked.params ++ + family.rawIndices source.nparams).reverse + (gen.block.checked.params ++ + family.rawIndices source.nparams).reverse := by + simpa using (S.generationFamilyTel hfamily).ctx + +theorem familyConst_emitted_decl {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.HasType source.uvars [] + (.const family.raw.name (VLevel.params source.uvars)) + (VExpr.forallN + (gen.block.checked.params ++ family.rawIndices source.nparams) + (family.rawResult source.nparams)) := by + have hc : env.HasType source.uvars [] + (.const family.raw.name (VLevel.params source.uvars)) + (VExpr.forallN + (family.rawParams source.nparams ++ family.rawIndices source.nparams) + (family.rawResult source.nparams)) := by + rw [VExpr.forallN_append, ← family.rawType_eq] + exact S.familyConst_decl hfamily + obtain ⟨_, htel⟩ := (S.emittedFamilyTel hfamily).forallN_defeq + (by simpa [VEnv.HasType] using + (S.familyWF family hfamily).familyResult.hasType.1) + exact htel.defeq hc + +theorem familyConst_generation_decl {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.HasType source.uvars [] + (.const family.raw.name (VLevel.params source.uvars)) + (VExpr.forallN + (generationParams gen.block.rawParams gen.block.checked.params ++ + family.rawIndices source.nparams) + (family.rawResult source.nparams)) := by + have hresultChecked := + (S.familyWF family hfamily).familyResult.defeqDFC S.ord + (S.emittedFamily_ctx hfamily) + have hresultGeneration := hresultChecked.defeqDFC S.ord + ((S.generationFamily_ctx hfamily).symm S.ord) + obtain ⟨_, htel⟩ := (S.generationFamilyTel hfamily).forallN_defeq + (by simpa [VEnv.HasType] using hresultGeneration.hasType.1) + exact htel.defeq' (S.familyConst_emitted_decl hfamily) + +theorem familyApp_hasType {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.HasType gen.recUvars + ((gen.idxTel family).reverse ++ gen.paramsTel.reverse) + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (gen.idxTel family).length source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)) + (.sort (gen.validated.resultLevel.inst gen.sourceLevels)) := by + let ls := gen.sourceLevels + have hconst₀ := (S.familyConst_generation_decl hfamily).instL + (U' := gen.recUvars) gen.sourceLevels_wf + have hconst₁ : env.HasType gen.recUvars [] + (.const family.raw.name ls) + (VExpr.forallN (gen.paramsTel ++ gen.idxTel family) + ((family.rawResult source.nparams).instL ls)) := by + simpa [ls, BlockGenerationChecked.paramsTel, + BlockGenerationChecked.idxTel, VExpr.instL_forallN, + VExpr.instL, VLevel.params_map_inst_params'] using hconst₀ + have hclosed : + (VExpr.forallN (gen.paramsTel ++ gen.idxTel family) + ((family.rawResult source.nparams).instL ls)).ClosedN 0 := + (hconst₁.closedN' S.ord.closed trivial).2.2 + have hconst : env.HasType gen.recUvars + ((gen.paramsTel ++ gen.idxTel family).reverse) + (.const family.raw.name ls) + (VExpr.forallN (gen.paramsTel ++ gen.idxTel family) + ((family.rawResult source.nparams).instL ls)) := + hconst₁.weak0 S.ord + have happ := HasType.appN_selfSpine' + (Δ := []) (Γ := []) hclosed (by simpa using hconst) + simp only [List.length_nil, VExpr.liftN_zero, List.nil_append, + List.append_nil] at happ + have hlen : (gen.paramsTel ++ gen.idxTel family).length = + (gen.idxTel family).length + source.nparams := by + simp only [List.length_append, BlockGenerationChecked.paramsTel, + BlockGenerationChecked.idxTel, List.length_map] + rw [S.generationParams_length] + omega + rw [VExpr.bvarRevRange_congr' 0 hlen, + ← VExpr.bvarRevRange_append] at happ + have hresult := (S.familyWF family hfamily).familyResult.instL + (U' := gen.recUvars) gen.sourceLevels_wf + simp only [List.map_reverse] at hresult + have hctxChecked := ((S.emittedFamilyTel hfamily).instL + (U' := gen.recUvars) gen.sourceLevels_wf).ctx + simp only [List.map_nil, List.append_nil, + List.map_reverse] at hctxChecked + have hresultChecked := hresult.defeqDFC S.ord hctxChecked + have hctxGeneration := ((S.generationFamilyTel hfamily).instL + (U' := gen.recUvars) gen.sourceLevels_wf).ctx + simp only [List.map_nil, List.append_nil, + List.map_reverse] at hctxGeneration + have hresultGeneration := hresultChecked.defeqDFC S.ord + (hctxGeneration.symm S.ord) + have hresult' : env.IsDefEq gen.recUvars + ((gen.idxTel family).reverse ++ gen.paramsTel.reverse) + ((family.rawResult source.nparams).instL ls) + (.sort (gen.validated.resultLevel.inst ls)) + (.sort (.succ (gen.validated.resultLevel.inst ls))) := by + simpa [ls, BlockGenerationChecked.paramsTel, + BlockGenerationChecked.idxTel, List.map_reverse, VLevel.inst] using + hresultGeneration + exact hresult'.defeq (by + simpa [List.reverse_append] using happ) + +theorem motive_isType {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.IsType gen.recUvars gen.paramsTel.reverse + (gen.motiveType family) := by + have htel₀ := (S.generationFamily_onTel hfamily).instL + (U' := gen.recUvars) gen.sourceLevels_wf + have htel : env.OnTel gen.recUvars [] + (gen.paramsTel ++ gen.idxTel family) := by + simpa [BlockGenerationChecked.paramsTel, + BlockGenerationChecked.idxTel] using htel₀ + have hidx : env.OnTel gen.recUvars gen.paramsTel.reverse + (gen.idxTel family) := by + simpa using htel.of_append.2 + refine IsType.forallN hidx ?_ + exact ⟨_, by + simpa [BlockGenerationChecked.motiveType] using + HasType.forallE (S.familyApp_hasType hfamily) + (HasType.sort gen.motiveLevel_wf)⟩ + +end BlockGenerationEnv + /-- Exact decomposition of the stored raw family type. -/ theorem NormalizedChecked.rawType_eq {source : VInductDecl} (block : NormalizedChecked source) : @@ -2697,6 +3599,149 @@ theorem rawFamily_onTel : (gen.block.rawParams ++ gen.block.rawIndices) := S.familyTel.raw_onTel +/-- The family parameter prefix is structurally definitionally equal to the +checked locals retained by validation. -/ +theorem rawParams_defeq : + env.TelDefEq source.uvars [] gen.block.rawParams + gen.block.checked.params := by + have h := S.familyTel.take source.nparams + have hraw : + (gen.block.rawParams ++ gen.block.rawIndices).take source.nparams = + gen.block.rawParams := by + rw [← gen.shape.1, List.take_append, List.take_length] + simp + have hviewLen : gen.block.checked.params.length = source.nparams := + gen.shape.2.1.symm.trans gen.shape.1 + have hview : + (gen.block.checked.params ++ gen.block.checked.indices).take + source.nparams = gen.block.checked.params := by + rw [← hviewLen, List.take_append, List.take_length] + simp + rw [hraw, hview] at h + exact h + +/-- Raw and checked parameter contexts denote the same local telescope. -/ +theorem rawParams_ctx : + env.IsDefEqCtx source.uvars [] gen.block.rawParams.reverse + gen.block.checked.params.reverse := + by simpa using S.rawParams_defeq.ctx + +/-- The exact parameter surface emitted in recursor metadata remains +definitionally equal to the analyzer-owned parameters. -/ +theorem generationParams_defeq : + env.TelDefEq source.uvars [] gen.block.generationParams + gen.block.checked.params := by + exact S.rawParams_defeq.generationParams S.ord + +theorem generationParams_ctx : + env.IsDefEqCtx source.uvars [] gen.block.generationParams.reverse + gen.block.checked.params.reverse := + by simpa using S.generationParams_defeq.ctx + +theorem generationParams_length : + gen.block.generationParams.length = source.nparams := by + have hrawView := S.rawParams_defeq.length_eq + exact (VInductDecl.generationParams_length_of_eq hrawView).trans + gen.shape.1 + +theorem generationParams_ctx_rec : + env.IsDefEqCtx (gen.recUvars) [] gen.paramsTel.reverse + (gen.block.checked.params.map + (VExpr.instL (gen.sourceLevels))).reverse := by + have h := S.generationParams_defeq.instL + (U' := gen.recUvars) gen.sourceLevels_wf + simpa [GenerationChecked.paramsTel, List.map_reverse] using h.ctx + +/-- +info: 'Lean4Lean.VInductDecl.GenerationEnv.generationParams_defeq' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms generationParams_defeq + +/-- Stored constructor fields are well formed over the exact generated +parameter surface after universe transport. -/ +theorem generationFields_onTel_rec {ctor : NormalizedCtor} + (hctor : ctor ∈ gen.block.ctorPairs) : + env.OnTel (gen.recUvars) gen.paramsTel.reverse + (ctor.fieldsR source.uvars source.nparams gen.elimination) := by + have hemitted := (S.ctorWF ctor hctor).rawEmitted_onTel + have hfields₀ := (OnTel.of_append + (As := gen.block.checked.params) hemitted).2 + have hfields₁ := hfields₀.instL + (U' := gen.recUvars) gen.sourceLevels_wf + have hfieldsChecked : env.OnTel (gen.recUvars) + (gen.block.checked.params.map + (VExpr.instL (gen.sourceLevels))).reverse + (ctor.fieldsR source.uvars source.nparams gen.elimination) := by + simpa [NormalizedCtor.fieldsR, List.map_reverse] using hfields₁ + exact hfieldsChecked.defeqDFC S.ord + (S.generationParams_ctx_rec.symm S.ord) + +theorem generationFieldPrefix_ctx_rec {ctor : NormalizedCtor} + (hctor : ctor ∈ gen.block.ctorPairs) (j : Nat) : + env.IsDefEqCtx (gen.recUvars) [] + ((ctor.fieldsR source.uvars source.nparams gen.elimination |>.take j).reverse ++ + gen.paramsTel.reverse) + ((ctor.fieldsR source.uvars source.nparams gen.elimination |>.take j).reverse ++ + (gen.block.checked.params.map + (VExpr.instL (gen.sourceLevels))).reverse) := by + have hfields := S.generationFields_onTel_rec hctor + rw [← List.take_append_drop j + (ctor.fieldsR source.uvars source.nparams gen.elimination)] at hfields + exact (hfields.of_append.1).extendDefEqCtx + S.generationParams_ctx_rec + +/-- The family telescope used by generated artifacts keeps raw index syntax +but uses the checked parameter prefix consumed by validation. -/ +theorem emittedFamilyTel : + env.TelDefEq source.uvars [] + (gen.block.rawParams ++ gen.block.rawIndices) + (gen.block.checked.params ++ gen.block.rawIndices) := by + have hindices : env.OnTel source.uvars gen.block.rawParams.reverse + gen.block.rawIndices := by + simpa using S.rawFamily_onTel.of_append.2 + exact S.rawParams_defeq.append_refl (by simpa using hindices) + +/-- The emitted mixed family telescope is well formed. -/ +theorem emittedFamily_onTel : + env.OnTel source.uvars [] + (gen.block.checked.params ++ gen.block.rawIndices) := + S.emittedFamilyTel.view_onTel S.ord + +/-- Replace the checked parameter prefix by the kernel-observable generation +surface while leaving the stored raw index telescope unchanged. -/ +theorem generationFamilyTel : + env.TelDefEq source.uvars [] + (gen.block.generationParams ++ gen.block.rawIndices) + (gen.block.checked.params ++ gen.block.rawIndices) := by + have hindicesChecked : env.OnTel source.uvars + gen.block.checked.params.reverse gen.block.rawIndices := by + simpa using S.emittedFamily_onTel.of_append.2 + have hindicesGeneration : env.OnTel source.uvars + gen.block.generationParams.reverse gen.block.rawIndices := + hindicesChecked.defeqDFC S.ord + (S.generationParams_ctx.symm S.ord) + exact S.generationParams_defeq.append_refl + (by simpa using hindicesGeneration) + +theorem generationFamily_onTel : + env.OnTel source.uvars [] + (gen.block.generationParams ++ gen.block.rawIndices) := + S.generationFamilyTel.raw_onTel + +theorem generationFamily_ctx : + env.IsDefEqCtx source.uvars [] + (gen.block.generationParams ++ gen.block.rawIndices).reverse + (gen.block.checked.params ++ gen.block.rawIndices).reverse := + by simpa using S.generationFamilyTel.ctx + +/-- Completed raw and emitted family contexts are definitionally equal. -/ +theorem emittedFamily_ctx : + env.IsDefEqCtx source.uvars [] + (gen.block.rawParams ++ gen.block.rawIndices).reverse + (gen.block.checked.params ++ gen.block.rawIndices).reverse := + by simpa using S.emittedFamilyTel.ctx + theorem rawFamily_isType : env.IsType source.uvars [] gen.block.sourceType.type := by rw [gen.block.rawType_eq, ← VExpr.forallN_append] @@ -2744,15 +3789,14 @@ theorem ctorConst_decl {ctor : NormalizedCtor} rw [gen.ctor_uvars_eq hctor] at h exact h.weak0 S.ord -/-- The stored constructor constant applied to the raw parameter/field -self-spine emitted by mixed artifacts. The proof passes through the common -checked view, so the constructor's declared raw parameter prefix need only be -definitionally equal to the block's emitted raw parameter prefix. -/ +/-- The stored constructor constant applied to the checked-parameter/raw-field +self-spine emitted by mixed artifacts. The constructor's declared parameter +prefix need only be definitionally equal to this checked family prefix. -/ theorem ctorApp_emitted_decl {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) : env.HasType source.uvars ((ctor.rawFields source.nparams).reverse ++ - gen.block.rawParams.reverse) + gen.block.checked.params.reverse) (VExpr.appN (.const ctor.raw.name (VLevel.params source.uvars)) (VExpr.bvarRevRange @@ -2803,14 +3847,16 @@ theorem ctorApp_emitted_decl {ctor : NormalizedCtor} have hEctx : E.reverse = (ctor.rawFields source.nparams).reverse ++ - gen.block.rawParams.reverse := by + gen.block.checked.params.reverse := by simp [E, NormalizedCtor.emittedBinders, List.reverse_append] have hElen : E.length = (ctor.rawFields source.nparams).length + source.nparams := by - simp [E, NormalizedCtor.emittedBinders, gen.shape.1] + have hp : gen.block.checked.params.length = source.nparams := + gen.shape.2.1.symm.trans gen.shape.1 + simp [E, NormalizedCtor.emittedBinders, hp] omega rw [hEctx, hElen, ← VExpr.bvarRevRange_append source.nparams @@ -2819,62 +3865,109 @@ theorem ctorApp_emitted_decl {ctor : NormalizedCtor} /-- The raw family constant instantiated into recursor universes. -/ theorem familyConst_rec {Γ : List VExpr} : - env.HasType (source.uvars + 1) Γ + env.HasType (gen.recUvars) Γ (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (gen.block.sourceType.type.instL - (VLevel.params' source.uvars 1)) := by + (gen.sourceLevels)) := by have h := (S.familyConst_decl (Γ := [])).instL - (U' := source.uvars + 1) VLevel.params'_one_wf + (U' := gen.recUvars) gen.sourceLevels_wf rw [show (VExpr.const gen.block.sourceType.name (VLevel.params source.uvars)).instL - (VLevel.params' source.uvars 1) = + (gen.sourceLevels) = .const gen.block.sourceType.name - (VLevel.params' source.uvars 1) by + (gen.sourceLevels) by simp [VExpr.instL, VLevel.params_map_inst_params']] at h exact h.weak0 S.ord /-- The raw family type decomposed in recursor universes. -/ theorem rawType_rec_eq : - gen.block.sourceType.type.instL (VLevel.params' source.uvars 1) = - VExpr.forallN gen.paramsTel + gen.block.sourceType.type.instL (gen.sourceLevels) = + VExpr.forallN + (gen.block.rawParams.map + (VExpr.instL (gen.sourceLevels))) (VExpr.forallN gen.idxTel (gen.block.rawResult.instL - (VLevel.params' source.uvars 1))) := by + (gen.sourceLevels))) := by rw [gen.block.rawType_eq, VExpr.instL_forallN, VExpr.instL_forallN] rfl -/-- The raw family applied to its complete raw self-spine has the normalized -result sort. -/ +/-- The family constant may be viewed through the checked-parameter/raw-index +telescope emitted by generated artifacts. -/ +theorem familyConst_emitted_decl : + env.HasType source.uvars [] + (.const gen.block.sourceType.name (VLevel.params source.uvars)) + (VExpr.forallN + (gen.block.checked.params ++ gen.block.rawIndices) + gen.block.rawResult) := by + have hc : env.HasType source.uvars [] + (.const gen.block.sourceType.name (VLevel.params source.uvars)) + (VExpr.forallN + (gen.block.rawParams ++ gen.block.rawIndices) + gen.block.rawResult) := by + rw [VExpr.forallN_append, ← gen.block.rawType_eq] + exact S.familyConst_decl + obtain ⟨_, htel⟩ := S.emittedFamilyTel.forallN_defeq + (by simpa [VEnv.HasType] using S.familyResult.hasType.1) + exact htel.defeq hc + +/-- The family constant viewed through the exact parameter syntax retained +by generated kernel metadata. -/ +theorem familyConst_generation_decl : + env.HasType source.uvars [] + (.const gen.block.sourceType.name (VLevel.params source.uvars)) + (VExpr.forallN + (gen.block.generationParams ++ gen.block.rawIndices) + gen.block.rawResult) := by + have hresultChecked := S.familyResult.defeqDFC S.ord + S.emittedFamily_ctx + have hresultGeneration := hresultChecked.defeqDFC S.ord + (S.generationFamily_ctx.symm S.ord) + obtain ⟨_, htel⟩ := S.generationFamilyTel.forallN_defeq + (by simpa [VEnv.HasType] using hresultGeneration.hasType.1) + exact htel.defeq' S.familyConst_emitted_decl + +/-- +info: 'Lean4Lean.VInductDecl.GenerationEnv.familyConst_generation_decl' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms familyConst_generation_decl + +/-- The family applied to its checked-parameter/raw-index self-spine has the +normalized result sort. -/ theorem familyApp_hasType : - env.HasType (source.uvars + 1) + env.HasType (gen.recUvars) (gen.idxTel.reverse ++ gen.paramsTel.reverse) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange gen.idxTel.length source.nparams ++ VExpr.bvarRevRange 0 gen.idxTel.length)) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1))) := by - let ls := VLevel.params' source.uvars 1 - have hclosed : - (gen.block.sourceType.type.instL ls).ClosedN 0 := - (Ordered.closedC S.ord S.familyConst).instL - have hconst : env.HasType (source.uvars + 1) - ((gen.paramsTel ++ gen.idxTel).reverse) + (gen.sourceLevels))) := by + let ls := gen.sourceLevels + have hconst₀ := S.familyConst_generation_decl.instL + (U' := gen.recUvars) gen.sourceLevels_wf + have hconst₁ : env.HasType (gen.recUvars) [] (.const gen.block.sourceType.name ls) (VExpr.forallN (gen.paramsTel ++ gen.idxTel) (gen.block.rawResult.instL ls)) := by - rw [VExpr.forallN_append, ← S.rawType_rec_eq] - exact S.familyConst_rec + simpa [ls, GenerationChecked.paramsTel, + GenerationChecked.idxTel, VExpr.instL_forallN, + VExpr.instL, VLevel.params_map_inst_params'] using hconst₀ have hcanonicalClosed : (VExpr.forallN (gen.paramsTel ++ gen.idxTel) (gen.block.rawResult.instL ls)).ClosedN 0 := by - rw [VExpr.forallN_append, ← S.rawType_rec_eq] - exact hclosed + exact (hconst₁.closedN' S.ord.closed trivial).2.2 + have hconst : env.HasType (gen.recUvars) + ((gen.paramsTel ++ gen.idxTel).reverse) + (.const gen.block.sourceType.name ls) + (VExpr.forallN (gen.paramsTel ++ gen.idxTel) + (gen.block.rawResult.instL ls)) := + hconst₁.weak0 S.ord have happ := HasType.appN_selfSpine' (Δ := []) (Γ := []) hcanonicalClosed (by simpa using hconst) @@ -2885,50 +3978,2946 @@ theorem familyApp_hasType : gen.idxTel.length + source.nparams := by simp only [List.length_append, GenerationChecked.paramsTel, GenerationChecked.idxTel, List.length_map] - rw [gen.shape.1] + rw [S.generationParams_length] omega rw [VExpr.bvarRevRange_congr' 0 hlen, ← VExpr.bvarRevRange_append] at happ have hresult := S.familyResult.instL - (U' := source.uvars + 1) VLevel.params'_one_wf - have hresult' : env.IsDefEq (source.uvars + 1) + (U' := gen.recUvars) gen.sourceLevels_wf + simp only [List.map_reverse] at hresult + have hctxChecked := (S.emittedFamilyTel.instL + (U' := gen.recUvars) gen.sourceLevels_wf).ctx + simp only [List.map_nil, List.append_nil, + List.map_reverse] at hctxChecked + have hresultChecked := hresult.defeqDFC S.ord hctxChecked + have hctxGeneration := (S.generationFamilyTel.instL + (U' := gen.recUvars) gen.sourceLevels_wf).ctx + simp only [List.map_nil, List.append_nil, + List.map_reverse] at hctxGeneration + have hresultGeneration := hresultChecked.defeqDFC S.ord + (hctxGeneration.symm S.ord) + have hresult' : env.IsDefEq (gen.recUvars) (gen.idxTel.reverse ++ gen.paramsTel.reverse) (gen.block.rawResult.instL ls) (.sort (gen.block.checked.resultLevel.inst ls)) (.sort (.succ (gen.block.checked.resultLevel.inst ls))) := by simpa [ls, GenerationChecked.paramsTel, GenerationChecked.idxTel, - List.map_reverse, VLevel.inst] using hresult + List.map_reverse, VLevel.inst] using hresultGeneration exact hresult'.defeq (by simpa [List.reverse_append] using happ) -/-- The mixed motive is a well-formed type over the raw parameter context. -/ +/-- The mixed motive is a well-formed type over the checked parameter +context. -/ theorem motive_isType : - env.IsType (source.uvars + 1) gen.paramsTel.reverse + env.IsType (gen.recUvars) gen.paramsTel.reverse gen.motiveType := by - have htel₀ := S.rawFamily_onTel.instL - (U' := source.uvars + 1) VLevel.params'_one_wf + have htel₀ := S.generationFamily_onTel.instL + (U' := gen.recUvars) gen.sourceLevels_wf have htel : - env.OnTel (source.uvars + 1) [] + env.OnTel (gen.recUvars) [] (gen.paramsTel ++ gen.idxTel) := by simpa [GenerationChecked.paramsTel, GenerationChecked.idxTel] using htel₀ - have hidx : env.OnTel (source.uvars + 1) gen.paramsTel.reverse + have hidx : env.OnTel (gen.recUvars) gen.paramsTel.reverse gen.idxTel := by simpa using htel.of_append.2 refine IsType.forallN hidx ?_ exact ⟨_, by simpa [GenerationChecked.motiveType] using HasType.forallE S.familyApp_hasType - (HasType.sort (by - change 0 < source.uvars + 1 - omega))⟩ + (HasType.sort gen.motiveLevel_wf)⟩ end GenerationEnv -/-- -info: 'Lean4Lean.VInductDecl.GenerationEnv.motive_isType' depends on axioms: [propext, Quot.sound] --/ -#guard_msgs in -#print axioms GenerationEnv.motive_isType +/-- +info: 'Lean4Lean.VInductDecl.GenerationEnv.motive_isType' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms GenerationEnv.motive_isType + +theorem BlockGenerationChecked.motiveTypesAux_length + {source : VInductDecl} (gen : BlockGenerationChecked source) : + ∀ (families : List NormalizedFamily) (i : Nat), + (gen.motiveTypesAux families i).length = families.length + | [], _ => rfl + | _ :: families, i => by + simp only [BlockGenerationChecked.motiveTypesAux, List.length_cons] + rw [gen.motiveTypesAux_length families (i + 1)] + +theorem BlockGenerationChecked.motiveTypes_length + {source : VInductDecl} (gen : BlockGenerationChecked source) : + gen.motiveTypes.length = gen.familyCount := by + unfold BlockGenerationChecked.motiveTypes + exact gen.motiveTypesAux_length gen.families 0 + +/-- Pairing arbitrary stored families with a dependent checked-family spine +does not change the checked ordinal at any surviving position. -/ +theorem CheckedFamilies.pairNormalizedFamilies_getElem?_ordinal + {source : VInductDecl} {params : List VExpr} + {ordinal : Nat} {types : List VInductiveType} + (families : CheckedFamilies source params ordinal types) : + ∀ {raws i family}, + (pairNormalizedFamilies raws families.data)[i]? = some family → + family.view.ordinal = ordinal + i := by + induction families with + | nil => + intro raws i family h + simp [CheckedFamilies.data, pairNormalizedFamilies] at h + | @cons ordinal type types head tail ih => + intro raws i family h + cases raws with + | nil => simp [pairNormalizedFamilies] at h + | cons raw raws => + cases i with + | zero => + simp only [CheckedFamilies.data, pairNormalizedFamilies, + List.getElem?_cons_zero] at h + injection h with hfamily + subst family + rfl + | succ i => + simp only [CheckedFamilies.data, pairNormalizedFamilies, + List.getElem?_cons_succ] at h + have hord := ih h + omega + +/-- Every retained family is found at its checked source ordinal. -/ +theorem BlockGenerationChecked.family_getElem?_ordinal + {source : VInductDecl} (gen : BlockGenerationChecked source) + {family : NormalizedFamily} (hfamily : family ∈ gen.families) : + gen.families[family.view.ordinal]? = some family := by + obtain ⟨i, hi⟩ := List.mem_iff_getElem?.1 hfamily + have hi' : + (pairNormalizedFamilies source.types + gen.block.checked.families.data)[i]? = some family := by + simpa [BlockGenerationChecked.families, + NormalizedCheckedBlock.familyPairs] using hi + have hord := + CheckedFamilies.pairNormalizedFamilies_getElem?_ordinal + gen.block.checked.families hi' + have hord' : family.view.ordinal = i := by + simpa using hord + rwa [hord'] + +theorem BlockGenerationChecked.family_ordinal_lt + {source : VInductDecl} (gen : BlockGenerationChecked source) + {family : NormalizedFamily} (hfamily : family ∈ gen.families) : + family.view.ordinal < gen.familyCount := by + obtain ⟨h, -⟩ := List.getElem?_eq_some_iff.1 + (gen.family_getElem?_ordinal hfamily) + exact h + +/-- Selecting a retained family by its checked ordinal recovers its exact +raw constant name. -/ +@[simp] theorem BlockGenerationChecked.familyNameAt_ordinal + {source : VInductDecl} (gen : BlockGenerationChecked source) + {family : NormalizedFamily} (hfamily : family ∈ gen.families) : + gen.familyNameAt family.view.ordinal = family.raw.name := by + simp [BlockGenerationChecked.familyNameAt, + gen.family_getElem?_ordinal hfamily] + +/-- Positional lookup through the progressively weakened mutual motive +telescope. -/ +theorem BlockGenerationChecked.motiveTypesAux_getElem? + {source : VInductDecl} (gen : BlockGenerationChecked source) : + ∀ (families : List NormalizedFamily) (i q : Nat), + (gen.motiveTypesAux families i)[q]? = + families[q]?.map fun family => + (gen.motiveType family).liftN (i + q) + | [], _, q => by simp [BlockGenerationChecked.motiveTypesAux] + | _ :: _, _, 0 => by simp [BlockGenerationChecked.motiveTypesAux] + | _ :: families, i, q + 1 => by + simp only [BlockGenerationChecked.motiveTypesAux, + List.getElem?_cons_succ] + rw [gen.motiveTypesAux_getElem? families (i + 1) q, + show i + 1 + q = i + (q + 1) by omega] + +theorem BlockGenerationChecked.motiveTypes_getElem?_ordinal + {source : VInductDecl} (gen : BlockGenerationChecked source) + {family : NormalizedFamily} (hfamily : family ∈ gen.families) : + gen.motiveTypes[family.view.ordinal]? = + some ((gen.motiveType family).liftN family.view.ordinal) := by + rw [show gen.motiveTypes = gen.motiveTypesAux gen.families 0 from rfl, + gen.motiveTypesAux_getElem?] + rw [gen.family_getElem?_ordinal hfamily] + simp + +/-- Paired block constructors retain the raw/view field arity certified by +normalization. -/ +theorem BlockGenerationChecked.flatCtor_fields_length + {source : VInductDecl} (gen : BlockGenerationChecked source) + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) : + (constructor.ctor.rawFields source.nparams).length = + constructor.ctor.view.fields.length := by + simp only [BlockGenerationChecked.flatCtors, + NormalizedCheckedBlock.flatCtors, List.mem_flatMap] at hconstructor + obtain ⟨family, hfamily, hconstructor⟩ := hconstructor + simp only [NormalizedFamily.blockCtors, List.mem_map] at hconstructor + obtain ⟨ctor, hctor, rfl⟩ := hconstructor + exact ((gen.shape.2.2.2.2 family hfamily).2.2.2.2.2.2 + ctor hctor).2.2.2 + +/-- Syntactic lifting law for any member of the mutual motive telescope. -/ +theorem BlockGenerationChecked.motiveType_liftN + {source : VInductDecl} (gen : BlockGenerationChecked source) + (family : NormalizedFamily) (n : Nat) : + (gen.motiveType family).liftN n = + VExpr.forallN (VExpr.liftTelN n (gen.idxTel family) 0) + (.forallE + (VExpr.appN + (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (n + (gen.idxTel family).length) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)) + (.sort gen.motiveLevel)) := by + rw [show gen.motiveType family = + VExpr.forallN (gen.idxTel family) + (.forallE + (VExpr.appN + (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (gen.idxTel family).length source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)) + (.sort gen.motiveLevel)) from rfl, + VExpr.liftN_forallN] + refine congrArg _ ?_ + show VExpr.forallE _ _ = VExpr.forallE _ _ + refine congr (congrArg _ ?_) rfl + rw [VExpr.liftN_appN, List.map_append, + bvarRevRange_liftN_ge _ _ _ _ (by omega), + VExpr.bvarRevRange_liftN_high _ _ _ _ (by omega)] + rfl + +/-- Apply a selected mutual motive variable to its target-family indices and +a typed major premise. -/ +theorem BlockGenerationChecked.motiveVarApp_hasType + {source : VInductDecl} (gen : BlockGenerationChecked source) + (family : NormalizedFamily) {env : VEnv} {l : VLevel} + {Γ : List VExpr} {K q : Nat} {idxs : List VExpr} {a : VExpr} + (hM : env.HasType gen.recUvars Γ (.bvar K) + ((gen.motiveType family).liftN (q + K + 1))) + (hidx : env.SpineWF gen.recUvars Γ + (VExpr.forallN + (VExpr.liftTelN (q + K + 1) (gen.idxTel family) 0) + (.sort l)) + idxs (.sort l)) + (hlen : idxs.length = (gen.idxTel family).length) + (ha : env.HasType gen.recUvars Γ a + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (q + K + 1) source.nparams ++ idxs))) : + env.HasType gen.recUvars Γ + (VExpr.appN (.bvar K) (idxs ++ [a])) + (.sort gen.motiveLevel) := by + rw [gen.motiveType_liftN family] at hM + have hshape := hidx.retarget + (by simpa only [VExpr.liftTelN_length] using hlen) + (.forallE + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + (q + K + 1 + (gen.idxTel family).length) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)) + (.sort gen.motiveLevel)) + rw [VExpr.instRev_forallE_sort, VExpr.instRev_appN, + VExpr.instRev_closedN _ + (C := .const family.raw.name gen.sourceLevels) trivial, + List.map_append, + VExpr.map_instRev_bvarRevRange_ge _ _ _ (by rw [hlen]; omega), + show q + K + 1 + (gen.idxTel family).length - idxs.length = + q + K + 1 from by rw [hlen]; omega, + VExpr.bvarRevRange_congr' 0 hlen.symm, + VExpr.map_instRev_bvarRevRange] at hshape + rw [hlen] at hshape + have hApp := hshape.hasType_appN hM + rw [VExpr.appN_append] + exact HasType.app hApp (by simpa using ha) + +/-- A recursive raw field, after inserting the full mutual motive telescope +and the constructor-local binders, is the family application expected by its +generated induction hypothesis. -/ +theorem blockMinor_fieldType_of_eq + {source : VInductDecl} {familyName : Name} + {B : VExpr} {r₀ : RecArg} + (hB : B = VExpr.forallN r₀.binders + (VExpr.appN (.const familyName (VLevel.params source.uvars)) + (VExpr.bvarRevRange + (r₀.fieldIndex + r₀.binders.length) source.nparams ++ + r₀.indices))) + (d m p : Nat) (hj : r₀.fieldIndex < m) + (mode : ElimMode := .large) : + let ls := mode.sourceLevels source.uvars + let r := r₀.instL ls + ((B.instL ls).liftN d r.fieldIndex).liftN + (m - r.fieldIndex + p) = + VExpr.forallN + (BlockGenerationChecked.blockMinorBinders d m p r) + (VExpr.appN (.const familyName ls) + (VExpr.bvarRevRange + (m + p + r.binders.length + d) source.nparams ++ + r.indices.map fun e => + (e.liftN d (r.fieldIndex + r.binders.length)).liftN + (m - r.fieldIndex + p) r.binders.length)) := by + dsimp only + conv => lhs; rw [hB] + simp only [RecArg.instL, VExpr.instL_forallN, VExpr.instL_appN, + List.map_append, bvarRevRange_instL, + show (VExpr.const familyName (VLevel.params source.uvars)).instL + (mode.sourceLevels source.uvars) = + .const familyName (mode.sourceLevels source.uvars) from by + simp [VExpr.instL, ElimMode.sourceLevels, + VLevel.params_map_inst_params'], + VExpr.liftN_forallN, VExpr.liftN_appN] + simp only [List.length_map, VExpr.liftTelN_length, Nat.zero_add] + rw [bvarRevRange_liftN_ge _ _ _ _ (Nat.le_refl _), + bvarRevRange_liftN_ge _ _ _ _ (by omega), + show m - r₀.fieldIndex + p + + (d + (r₀.fieldIndex + r₀.binders.length)) = + m + p + r₀.binders.length + d from by omega] + simp only [List.map_map, + BlockGenerationChecked.blockMinorBinders] + apply congrArg (VExpr.forallN _) + apply congrArg (VExpr.appN + (.const familyName (mode.sourceLevels source.uvars))) + apply congrArg + (VExpr.bvarRevRange (m + p + r₀.binders.length + d) + source.nparams ++ ·) + apply List.map_congr_left + intro e _ + simp only [Function.comp_apply] + +/-- Raw mixed fields preserve their arity under recursor-universe +instantiation. -/ +theorem NormalizedCtor.fieldsR_length {source : VInductDecl} + (ctor : NormalizedCtor) {mode : ElimMode} : + (ctor.fieldsR source.uvars source.nparams mode).length = + (ctor.rawFields source.nparams).length := + List.length_map .. + +/-- Pointwise lookup through the raw mixed field universe transport. -/ +theorem NormalizedCtor.fieldsR_getElem? {source : VInductDecl} + {ctor : NormalizedCtor} {q : Nat} {mode : ElimMode} : + (ctor.fieldsR source.uvars source.nparams mode)[q]? = + (ctor.rawFields source.nparams)[q]?.map + (VExpr.instL (mode.sourceLevels source.uvars)) := + List.getElem?_map .. + +/-- Unpack one mixed recursive descriptor to the retained declaration-level +descriptor from the checked view. -/ +theorem NormalizedCtor.recArgsR_mem {source : VInductDecl} + {ctor : NormalizedCtor} {r : RecArg} {mode : ElimMode} + (hr : r ∈ ctor.recArgsR source.uvars mode) : + ∃ r₀, r₀ ∈ ctor.view.recursive ∧ + r = r₀.instL (mode.sourceLevels source.uvars) := by + obtain ⟨r₀, hr₀, rfl⟩ := List.mem_map.1 hr + exact ⟨r₀, hr₀, rfl⟩ + +theorem liftTelN_congr {a a' : Nat} (tel : List VExpr) (k : Nat) + (h : a = a') : + VExpr.liftTelN a tel k = VExpr.liftTelN a' tel k := h ▸ rfl + +theorem BlockGenerationChecked.blockIHsFromRecArgs_length (d m : Nat) : + ∀ (rs : List RecArg) (p : Nat), + (BlockGenerationChecked.blockIHsFromRecArgs d m rs p).length = rs.length + | [], _ => rfl + | _ :: rs, p => by + simp [BlockGenerationChecked.blockIHsFromRecArgs, + BlockGenerationChecked.blockIHsFromRecArgs_length d m rs (p + 1)] + +/-- Rule-context normal form of one mutual induction hypothesis. The +recursive result is routed to the motive selected by `targetType`. -/ +def BlockGenerationChecked.blockRuleIH + (d k m : Nat) (r : RecArg) : VExpr := + let n := r.binders.length + VExpr.forallN + (BlockGenerationChecked.blockRuleBinders (d+k) m r) + (VExpr.appN + (.bvar (d - 1 - r.targetType + k + m + n)) + ((r.indices.map fun e => + (e.liftN (d+k) (r.fieldIndex+n)).liftN + (m-r.fieldIndex) n) ++ + [VExpr.appN (.bvar (m-1-r.fieldIndex+n)) + (VExpr.bvarRevRange 0 n)])) + +/-- Rule-context induction hypotheses, weakened past their preceding +hypothesis binders. -/ +def BlockGenerationChecked.blockRuleIHs (d k m : Nat) : + List RecArg → Nat → List VExpr + | [], _ => [] + | r :: rs, p => + (BlockGenerationChecked.blockRuleIH d k m r).liftN p :: + BlockGenerationChecked.blockRuleIHs d k m rs (p+1) + +theorem BlockGenerationChecked.blockMinorBinders_shift + (d : Nat) (r : RecArg) (m p : Nat) : + BlockGenerationChecked.blockMinorBinders d m p r = + VExpr.liftTelN p + (BlockGenerationChecked.blockMinorBinders d m 0 r) 0 := by + simp only [BlockGenerationChecked.blockMinorBinders, Nat.add_zero] + rw [VExpr.liftTelN_liftTelN] + +/-- The shift parameter of a mutual minor IH is precisely weakening past +the preceding IH binders. -/ +theorem BlockGenerationChecked.blockMinorIH_shift + (d : Nat) (r : RecArg) (m p : Nat) (hj : r.fieldIndex < m) : + BlockGenerationChecked.blockMinorIH d m p r = + (BlockGenerationChecked.blockMinorIH d m 0 r).liftN p := by + simp only [BlockGenerationChecked.blockMinorIH, + VExpr.liftN_forallN] + rw [← BlockGenerationChecked.blockMinorBinders_shift d r m p] + rw [show + (BlockGenerationChecked.blockMinorBinders d m 0 r).length = + r.binders.length by + simp [BlockGenerationChecked.blockMinorBinders, + VExpr.liftTelN_length], + Nat.zero_add] + apply congrArg (VExpr.forallN _) + rw [VExpr.liftN_appN, List.map_append, List.map_map] + show VExpr.appN _ (_ ++ [_]) = VExpr.appN _ (_ ++ [_]) + congr 1 + · rw [show + (VExpr.bvar + (d - 1 - r.targetType + m + 0 + r.binders.length)).liftN + p r.binders.length = + .bvar (d - 1 - r.targetType + m + p + r.binders.length) from by + simp only [VExpr.liftN] + rw [liftVar_le (by omega)] + congr 1 + ac_rfl] + · congr 1 + · apply List.map_congr_left + intro e _ + simp only [Function.comp_apply, Nat.add_zero] + rw [VExpr.liftN'_liftN_hi] + · congr 1 + simp only [Nat.add_zero, VExpr.liftN_appN] + rw [show + (VExpr.bvar + (m - 1 - r.fieldIndex + r.binders.length)).liftN + p r.binders.length = + .bvar (m - 1 - r.fieldIndex + p + r.binders.length) from by + simp only [VExpr.liftN] + rw [liftVar_le (by omega)] + congr 1 + omega, + VExpr.bvarRevRange_liftN_high _ _ _ _ (by omega)] + +/-- Lifting a base mutual minor IH through all constructor minors yields the +rule-context normal form. -/ +theorem BlockGenerationChecked.blockMinorIH_zero_lift_ruleIH + (d : Nat) (r : RecArg) (m k : Nat) (hj : r.fieldIndex < m) : + (BlockGenerationChecked.blockMinorIH d m 0 r).liftN k m = + BlockGenerationChecked.blockRuleIH d k m r := by + simp only [BlockGenerationChecked.blockMinorIH, + BlockGenerationChecked.blockRuleIH, + BlockGenerationChecked.blockMinorBinders, + BlockGenerationChecked.blockRuleBinders, + VExpr.liftN_forallN, VExpr.liftTelN_length, Nat.add_zero] + congr 1 + · rw [show m = r.fieldIndex + (m-r.fieldIndex) by omega] + rw [show r.fieldIndex + (m-r.fieldIndex) - r.fieldIndex = + m-r.fieldIndex by omega] + rw [VExpr.liftTelN_liftN_midN r.binders d k + (m-r.fieldIndex) (Nat.zero_le _)] + · congr 1 + rw [VExpr.liftN_appN, List.map_append, List.map_map] + show VExpr.appN _ (_ ++ [_]) = VExpr.appN _ (_ ++ [_]) + congr 1 + · simp only [VExpr.liftN] + rw [liftVar_le (by omega)] + congr 1 + ac_rfl + · congr 1 + · apply List.map_congr_left + intro e _ + simp only [Function.comp_apply] + rw [show m + r.binders.length = + (r.fieldIndex+r.binders.length) + (m-r.fieldIndex) by omega, + VExpr.liftN_liftN_midN e d k (m-r.fieldIndex) (by omega)] + · congr 1 + simp only [VExpr.liftN_appN] + rw [show + (VExpr.bvar + (m - 1 - r.fieldIndex + r.binders.length)).liftN + k (m+r.binders.length) = + .bvar (m - 1 - r.fieldIndex + r.binders.length) from by + simp only [VExpr.liftN] + rw [liftVar_lt (by omega)], + VExpr.bvarRevRange_liftN_high _ _ _ _ (by omega)] + +/-- General mutual minor-IH normalization after `p` earlier hypotheses. -/ +theorem BlockGenerationChecked.blockMinorIH_lift_ruleIH + (d : Nat) (r : RecArg) (m k p : Nat) + (hj : r.fieldIndex < m) : + (BlockGenerationChecked.blockMinorIH d m p r).liftN k (m+p) = + (BlockGenerationChecked.blockRuleIH d k m r).liftN p := by + rw [BlockGenerationChecked.blockMinorIH_shift d r m p hj] + rw [← VExpr.liftN_liftN_comm + (BlockGenerationChecked.blockMinorIH d m 0 r) + p k 0 m (Nat.zero_le _)] + rw [BlockGenerationChecked.blockMinorIH_zero_lift_ruleIH d r m k hj] + +theorem BlockGenerationChecked.blockRuleIHs_length (d k m : Nat) : + ∀ (rs : List RecArg) (p : Nat), + (BlockGenerationChecked.blockRuleIHs d k m rs p).length = rs.length + | [], _ => rfl + | _ :: rs, p => by + simp [BlockGenerationChecked.blockRuleIHs, + BlockGenerationChecked.blockRuleIHs_length d k m rs (p+1)] + +/-- Lift the complete mutual minor-IH telescope into rule context. -/ +theorem BlockGenerationChecked.blockIHs_liftN (d m k : Nat) : + ∀ (rs : List RecArg), + (∀ r ∈ rs, r.fieldIndex < m) → ∀ (p : Nat) (X : VExpr), + (VExpr.forallN + (BlockGenerationChecked.blockIHsFromRecArgs d m rs p) X).liftN + k (m+p) = + VExpr.forallN + (BlockGenerationChecked.blockRuleIHs d k m rs p) + (X.liftN k (m+p+rs.length)) + | [], _, _, _ => rfl + | r :: rs, hm, p, X => by + show VExpr.forallE _ _ = VExpr.forallE _ _ + congr 1 + · exact BlockGenerationChecked.blockMinorIH_lift_ruleIH + d r m k p (hm r (.head _)) + · rw [show m+p+1 = m+(p+1) by omega, + BlockGenerationChecked.blockIHs_liftN d m k rs + (fun q hq => hm q (.tail _ hq)) (p+1) X, + show m+(p+1)+rs.length = + m+p+(r :: rs).length from by simp; omega] + +theorem BlockGenerationChecked.blockIHs_liftN' + (d m k : Nat) (rs : List RecArg) + (hm : ∀ r ∈ rs, r.fieldIndex < m) + (p : Nat) (X : VExpr) {cut : Nat} (hcut : cut = m+p) : + (VExpr.forallN + (BlockGenerationChecked.blockIHsFromRecArgs d m rs p) X).liftN + k cut = + VExpr.forallN + (BlockGenerationChecked.blockRuleIHs d k m rs p) + (X.liftN k (m+p+rs.length)) := by + rw [hcut] + exact BlockGenerationChecked.blockIHs_liftN d m k rs hm p X + +theorem BlockGenerationChecked.blockRuleIHs_liftN1 (d k m : Nat) : + ∀ (rs : List RecArg) (p c : Nat), c ≤ p → ∀ (X : VExpr), + VExpr.forallN + (BlockGenerationChecked.blockRuleIHs d k m rs (p+1)) + (X.liftN 1 (c+rs.length)) = + (VExpr.forallN + (BlockGenerationChecked.blockRuleIHs d k m rs p) X).liftN 1 c + | [], p, c, _, X => by + simp [BlockGenerationChecked.blockRuleIHs, VExpr.forallN] + | r :: rs, p, c, hc, X => by + show VExpr.forallE _ _ = VExpr.forallE _ _ + congr 1 + · rw [VExpr.liftN'_liftN' (Nat.zero_le _) hc] + · rw [show c+(r :: rs).length = (c+1)+rs.length from by + simp + omega] + exact BlockGenerationChecked.blockRuleIHs_liftN1 + d k m rs (p+1) (c+1) (by omega) X + +/-- Consume one routed recursive-call term for every mutual rule IH. -/ +theorem hasType_appN_blockRuleIHs + {source : VInductDecl} {gen : BlockGenerationChecked source} + {env : VEnv} {Γ : List VExpr} {d m k : Nat} + {argOf : RecArg → VExpr} {Dfin : VExpr} : + ∀ {rs : List RecArg} {g : VExpr}, + (∀ r ∈ rs, env.HasType gen.recUvars Γ (argOf r) + (BlockGenerationChecked.blockRuleIH d k m r)) → + env.HasType gen.recUvars Γ g + (VExpr.forallN + (BlockGenerationChecked.blockRuleIHs d k m rs 0) + (Dfin.liftN rs.length)) → + env.HasType gen.recUvars Γ (g.appN (rs.map argOf)) Dfin + | [], g, _, hg => by + simpa [BlockGenerationChecked.blockRuleIHs] using hg + | r :: rs, g, hargs, hg => by + have happ := VEnv.HasType.app hg (by + simpa [BlockGenerationChecked.blockRuleIHs] using + hargs r (.head _)) + simp only [List.length_cons] at happ + rw [show Dfin.liftN (rs.length+1) = + (Dfin.liftN rs.length).liftN 1 (0+rs.length) from by + rw [Nat.zero_add, + VExpr.liftN'_liftN' (Nat.zero_le _) (by omega)], + BlockGenerationChecked.blockRuleIHs_liftN1 + d k m rs 0 0 (Nat.le_refl _) (Dfin.liftN rs.length), + VExpr.inst_liftN1] at happ + exact hasType_appN_blockRuleIHs + (rs := rs) (fun q hq => hargs q (.tail _ hq)) happ + +theorem BlockGenerationChecked.minorTypesAux_length + {source : VInductDecl} (gen : BlockGenerationChecked source) : + ∀ (constructors : List NormalizedBlockCtor) (i : Nat), + (gen.minorTypesAux constructors i).length = constructors.length + | [], _ => rfl + | _ :: constructors, i => by + simp [BlockGenerationChecked.minorTypesAux, + gen.minorTypesAux_length constructors (i + 1)] + +theorem BlockGenerationChecked.minorTypes_length + {source : VInductDecl} (gen : BlockGenerationChecked source) : + gen.minorTypes.length = gen.minorCount := by + simpa [BlockGenerationChecked.minorTypes] using + gen.minorTypesAux_length gen.flatCtors 0 + +/-- Positional lookup through the progressively weakened flattened mutual +minor telescope. -/ +theorem BlockGenerationChecked.minorTypesAux_getElem? + {source : VInductDecl} (gen : BlockGenerationChecked source) : + ∀ (constructors : List NormalizedBlockCtor) (i q : Nat), + (gen.minorTypesAux constructors i)[q]? = + constructors[q]?.map fun constructor => + (gen.minorType constructor).liftN (i+q) + | [], _, q => by simp [BlockGenerationChecked.minorTypesAux] + | _ :: _, _, 0 => by simp [BlockGenerationChecked.minorTypesAux] + | _ :: constructors, i, q+1 => by + simp only [BlockGenerationChecked.minorTypesAux, + List.getElem?_cons_succ] + rw [gen.minorTypesAux_getElem? constructors (i+1) q, + show i+1+q = i+(q+1) by omega] + +namespace BlockGenerationEnv + +variable {source : VInductDecl} {gen : BlockGenerationChecked source} + {env : VEnv} (S : BlockGenerationEnv gen env) +include S + +theorem paramsTel_onTel : + env.OnTel gen.recUvars [] gen.paramsTel := by + have h := S.generationParams_defeq.raw_onTel.instL + (U' := gen.recUvars) gen.sourceLevels_wf + simpa [BlockGenerationChecked.paramsTel] using h + +theorem motiveTypesAux_onTel + (families : List NormalizedFamily) + (hsub : ∀ family ∈ families, family ∈ gen.families) + (Δ : List VExpr) (i : Nat) (hΔ : Δ.length = i) : + env.OnTel gen.recUvars (Δ ++ gen.paramsTel.reverse) + (gen.motiveTypesAux families i) := by + induction families generalizing Δ i with + | nil => trivial + | cons family families ih => + exact ⟨by + rw [← hΔ] + exact (S.motive_isType (hsub family (.head _))).weakN S.ord + (.zero Δ), + ih (fun family hfamily => hsub family (.tail _ hfamily)) + (_ :: Δ) (i + 1) (by simp [hΔ])⟩ + +theorem motiveTypes_onTel : + env.OnTel gen.recUvars gen.paramsTel.reverse gen.motiveTypes := by + simpa [BlockGenerationChecked.motiveTypes] using + motiveTypesAux_onTel S gen.families (fun _ h => h) [] 0 rfl + +/-- Constructor fields instantiated for recursor generation are well typed +over the generation parameter telescope. -/ +theorem generationFields_onTel_rec + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) : + env.OnTel gen.recUvars gen.paramsTel.reverse + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) := by + have hemitted := (S.ctorWF constructor hconstructor).rawEmitted_onTel + have hfields₀ := (VEnv.OnTel.of_append + (As := gen.block.checked.params) hemitted).2 + have hfields₁ := hfields₀.instL + (U' := gen.recUvars) gen.sourceLevels_wf + have hfieldsChecked : env.OnTel gen.recUvars + (gen.block.checked.params.map + (VExpr.instL gen.sourceLevels)).reverse + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) := by + simpa [NormalizedCtor.fieldsR, List.map_reverse] using hfields₁ + exact hfieldsChecked.defeqDFC S.ord + (S.generationParams_ctx_rec.symm S.ord) + +/-- The checked and generation parameter contexts stay definitionally equal +beneath every instantiated constructor-field prefix. -/ +theorem generationFieldPrefix_ctx_rec + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) (j : Nat) : + env.IsDefEqCtx gen.recUvars [] + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination |>.take j).reverse ++ gen.paramsTel.reverse) + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination |>.take j).reverse ++ + (gen.block.checked.params.map + (VExpr.instL gen.sourceLevels)).reverse) := by + have hfields := S.generationFields_onTel_rec hconstructor + rw [← List.take_append_drop j + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination)] at hfields + exact (hfields.of_append.1).extendDefEqCtx + S.generationParams_ctx_rec + +/-- Definitionally equal raw/view contexts at any mutual constructor-field +prefix. -/ +theorem emittedPrefix_ctx {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) (j : Nat) : + env.IsDefEqCtx source.uvars [] + ((constructor.ctor.rawFields source.nparams |>.take j).reverse ++ + gen.block.checked.params.reverse) + ((constructor.ctor.view.fields.take j).reverse ++ + gen.block.checked.params.reverse) := by + have h := ((S.ctorWF constructor hconstructor).emittedTel.take + (source.nparams + j)).ctx + have hviewLen : + gen.block.checked.params.length = source.nparams := + gen.shape.2.1.symm.trans gen.shape.1 + have hraw : + (gen.block.checked.params ++ + constructor.ctor.rawFields source.nparams).take + (source.nparams + j) = + gen.block.checked.params ++ + (constructor.ctor.rawFields source.nparams).take j := by + rw [← hviewLen] + rw [List.take_append, List.take_of_length_le (by omega)] + simp + have hview : + (gen.block.checked.params ++ constructor.ctor.view.fields).take + (source.nparams + j) = + gen.block.checked.params ++ + constructor.ctor.view.fields.take j := by + rw [← hviewLen] + rw [List.take_append, List.take_of_length_le (by omega)] + simp + simp only [NormalizedBlockCtor.emittedBinders, + NormalizedBlockCtor.viewBinders] at h + rw [hraw, hview] at h + simpa [List.reverse_append] using h + +/-- Pointwise raw/view field-domain equality for a mutual constructor, in +the preceding raw context. -/ +theorem emittedField_defeq {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) + {j : Nat} {B B' : VExpr} + (hB : (constructor.ctor.rawFields source.nparams)[j]? = some B) + (hB' : constructor.ctor.view.fields[j]? = some B') : + ∃ u, env.IsDefEq source.uvars + ((constructor.ctor.rawFields source.nparams |>.take j).reverse ++ + gen.block.checked.params.reverse) + B B' (.sort u) := by + have hviewLen : + gen.block.checked.params.length = source.nparams := + gen.shape.2.1.symm.trans gen.shape.1 + have hraw : + getElem? + (gen.block.checked.params ++ + constructor.ctor.rawFields source.nparams) + (source.nparams + j) = some B := by + rw [List.getElem?_append_right (by rw [hviewLen]; omega), hviewLen] + simpa using hB + have hview : + getElem? + (gen.block.checked.params ++ constructor.ctor.view.fields) + (source.nparams + j) = some B' := by + rw [List.getElem?_append_right (by rw [hviewLen]; omega), hviewLen] + simpa using hB' + obtain ⟨u, h⟩ := + (S.ctorWF constructor hconstructor).emittedTel.getElem? hraw hview + have htake : + (gen.block.checked.params ++ + constructor.ctor.rawFields source.nparams).take + (source.nparams + j) = + gen.block.checked.params ++ + (constructor.ctor.rawFields source.nparams).take j := by + rw [← hviewLen] + rw [List.take_append, List.take_of_length_le (by omega)] + simp + simp only [NormalizedBlockCtor.emittedBinders] at h + rw [htake, List.reverse_append] at h + exact ⟨u, by simpa using h⟩ + +/-- The generated and checked index telescopes of every family are +definitionally equal after universe instantiation. -/ +theorem familyIndexTel_defeq_rec {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.TelDefEq gen.recUvars gen.paramsTel.reverse + (gen.idxTel family) + (family.view.indices.map (VExpr.instL gen.sourceLevels)) := by + have h := (S.familyWF family hfamily).familyTel.drop source.nparams + have hrawTake : + (family.rawParams source.nparams ++ + family.rawIndices source.nparams).take source.nparams = + family.rawParams source.nparams := by + let Ps := family.rawParams source.nparams + let Is := family.rawIndices source.nparams + have hlen : Ps.length = source.nparams := + (gen.shape.2.2.2.2 family hfamily).2.2.1 + change (Ps ++ Is).take source.nparams = Ps + rw [← hlen, List.take_append, List.take_length] + simp + have hrawDrop : + (family.rawParams source.nparams ++ + family.rawIndices source.nparams).drop source.nparams = + family.rawIndices source.nparams := by + let Ps := family.rawParams source.nparams + let Is := family.rawIndices source.nparams + have hlen : Ps.length = source.nparams := + (gen.shape.2.2.2.2 family hfamily).2.2.1 + change (Ps ++ Is).drop source.nparams = Is + rw [← hlen, List.drop_append] + simp + have hviewLen : gen.block.checked.params.length = source.nparams := + gen.shape.2.1.symm.trans gen.shape.1 + have hviewDrop : + (gen.block.checked.params ++ family.view.indices).drop + source.nparams = family.view.indices := by + rw [← hviewLen, List.drop_append] + simp + rw [hrawTake, hrawDrop, hviewDrop] at h + simp only [List.append_nil] at h + have hparams : env.IsDefEqCtx source.uvars [] + (family.rawParams source.nparams).reverse + gen.block.checked.params.reverse := by + simpa using (S.rawParams_defeq hfamily).ctx + have hemitted := h.defeqDFC S.ord hparams + have hgeneration := hemitted.defeqDFC S.ord + (S.generationParams_ctx.symm S.ord) + have hrec := hgeneration.instL + (U' := gen.recUvars) gen.sourceLevels_wf + simpa [BlockGenerationChecked.paramsTel, + BlockGenerationChecked.idxTel, List.map_reverse] using hrec + +/-- Transport the analyzer's recursive-argument certificate from checked +source syntax to the generated field and target-family index telescopes, then +weaken it beneath arbitrary motive/local prefixes. -/ +theorem recArg_transport + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) + {r₀ : RecArg} {family : NormalizedFamily} + (hfamily : family ∈ gen.families) + (hsem : r₀.WF source.uvars env gen.validated.resultLevel + family.view.indices + ((constructor.ctor.view.fields.take r₀.fieldIndex).reverse ++ + gen.block.checked.params.reverse)) + (hjlt : r₀.fieldIndex < constructor.ctor.view.fields.length) + (mid : List VExpr) {g : Nat} (hg : mid.length = g) + (As₂ : List VExpr) {d : Nat} (hd : As₂.length = d) : + let r := r₀.instL gen.sourceLevels + let As := VExpr.liftTelN d + (VExpr.liftTelN g r.binders r.fieldIndex) 0 + env.OnTel gen.recUvars + (As₂ ++ ((VExpr.liftTelN g + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).take r.fieldIndex) 0).reverse ++ + (mid ++ gen.paramsTel.reverse))) As ∧ + env.SpineWF gen.recUvars + (As.reverse ++ + (As₂ ++ ((VExpr.liftTelN g + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).take r.fieldIndex) 0).reverse ++ + (mid ++ gen.paramsTel.reverse)))) + (VExpr.forallN + (VExpr.liftTelN + (r.fieldIndex + r.binders.length + g + d) + (gen.idxTel family) 0) + (.sort (gen.validated.resultLevel.inst gen.sourceLevels))) + (r.indices.map fun e => + (e.liftN g (r.fieldIndex + r.binders.length)).liftN d + r.binders.length) + (.sort (gen.validated.resultLevel.inst gen.sourceLevels)) := by + dsimp only + let ls := gen.sourceLevels + have hjraw : + r₀.fieldIndex < + (constructor.ctor.rawFields source.nparams).length := by + rw [gen.flatCtor_fields_length hconstructor] + exact hjlt + have hraw := hsem.defeqDFC S.ord + ((S.emittedPrefix_ctx hconstructor r₀.fieldIndex).symm S.ord) + have htel₁ := hraw.1.instL + (U' := gen.recUvars) gen.sourceLevels_wf + have hsp₁ := hraw.2.instL + (U' := gen.recUvars) gen.sourceLevels_wf + have htelChecked : env.OnTel gen.recUvars + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination |>.take r₀.fieldIndex).reverse ++ + (gen.block.checked.params.map (VExpr.instL ls)).reverse) + (r₀.binders.map (VExpr.instL ls)) := by + simpa [NormalizedCtor.fieldsR, List.map_append, + List.map_reverse, List.map_take] using htel₁ + have hspChecked : env.SpineWF gen.recUvars + ((r₀.binders.map (VExpr.instL ls)).reverse ++ + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination |>.take r₀.fieldIndex).reverse ++ + (gen.block.checked.params.map (VExpr.instL ls)).reverse)) + (VExpr.instL ls + (VExpr.forallN + (VExpr.liftTelN + (r₀.fieldIndex + r₀.binders.length) + family.view.indices 0) + (.sort gen.validated.resultLevel))) + (r₀.indices.map (VExpr.instL ls)) + (VExpr.instL ls (.sort gen.validated.resultLevel)) := by + simpa [List.map_append, List.map_reverse, + NormalizedCtor.fieldsR, List.map_take] using hsp₁ + have hprefix := + S.generationFieldPrefix_ctx_rec hconstructor r₀.fieldIndex + have htelGeneration := htelChecked.defeqDFC S.ord + (hprefix.symm S.ord) + have hfull := htelGeneration.extendDefEqCtx hprefix + have hspGeneration := hspChecked.defeqDFC S.ord (hfull.symm S.ord) + simp only [VExpr.instL_forallN, + VExpr.liftTelN_instL] at htelGeneration hspGeneration + have hjlen : + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).take r₀.fieldIndex).length = r₀.fieldIndex := by + simp only [NormalizedCtor.fieldsR, List.length_take, + List.length_map] + omega + have hidxField := (S.familyIndexTel_defeq_rec hfamily).weakN S.ord + (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).take r₀.fieldIndex).reverse) + rw [List.length_reverse, hjlen] at hidxField + have hidxPrivate := hidxField.weakN S.ord + (Ctx.LiftN.zero + (Γ := ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).take r₀.fieldIndex).reverse ++ + gen.paramsTel.reverse) + (r₀.binders.map (VExpr.instL ls)).reverse) + simp only [List.length_reverse, List.length_map] at hidxPrivate + rw [VExpr.liftTelN_liftTelN, + VExpr.liftTelN_liftTelN] at hidxPrivate + have hidxLenView := hsem.2.forallN_sort_length + simp only [VExpr.liftTelN_length] at hidxLenView + have hidxLen : + (r₀.indices.map (VExpr.instL ls)).length = + (VExpr.liftTelN + (r₀.fieldIndex + r₀.binders.length) + (gen.idxTel family) 0).length := by + simp only [List.length_map, VExpr.liftTelN_length, + BlockGenerationChecked.idxTel] + exact hidxLenView.trans + (gen.shape.2.2.2.2 family hfamily).2.2.2.1.symm + have hspRaw := + hidxPrivate.spine_sort S.ord hspGeneration hidxLen + have W₁ := Ctx.LiftN.consTel (n := mid.length) + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).take r₀.fieldIndex) + (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) mid) + rw [hjlen, Nat.add_zero] at W₁ + have htel₂ := htelGeneration.weakN S.ord W₁ + have hsp₂ := hspRaw.weakN S.ord + (Ctx.LiftN.consTel + (r₀.binders.map (VExpr.instL ls)) W₁) + rw [hg] at htel₂ hsp₂ + have W₂ := Ctx.LiftN.zero + (Γ := (VExpr.liftTelN g + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).take r₀.fieldIndex) 0).reverse ++ + (mid ++ gen.paramsTel.reverse)) As₂ (h := hd) + have htel₃ := htel₂.weakN S.ord W₂ + have hsp₃ := hsp₂.weakN S.ord + (Ctx.LiftN.consTel + (VExpr.liftTelN g + (r₀.binders.map (VExpr.instL ls)) r₀.fieldIndex) W₂) + refine ⟨?_, ?_⟩ + · simpa [ls, RecArg.instL, List.append_assoc] using htel₃ + · simp only [List.length_map, VExpr.liftTelN_length, + Nat.add_zero] at hsp₃ + rw [VExpr.liftN_forallN, VExpr.liftN_forallN, + VExpr.liftTelN_liftTelN_hi' + (r₀.fieldIndex + r₀.binders.length) g _ 0 (by omega), + VExpr.liftTelN_liftTelN_mid + (r₀.fieldIndex + r₀.binders.length + g) d _ 0 + r₀.binders.length (Nat.zero_le _) (by omega)] at hsp₃ + rw [show r₀.binders.length + r₀.fieldIndex = + r₀.fieldIndex + r₀.binders.length from Nat.add_comm _ _] at hsp₃ + simpa [ls, RecArg.instL, VExpr.instL, VExpr.liftN, + List.map_map, Function.comp_def, List.append_assoc] using hsp₃ + +theorem recArgMinor_isType {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) {r : RecArg} + (hrmem : r ∈ constructor.ctor.recArgsR source.uvars gen.elimination) + (Δ : List VExpr) (p : Nat) (hΔ : Δ.length = p) : + env.IsType gen.recUvars + (Δ ++ + (VExpr.liftTelN gen.familyCount + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) 0).reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse)) + (BlockGenerationChecked.blockMinorIH gen.familyCount + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length p r) := by + obtain ⟨r₀, hr₀, rfl⟩ := + NormalizedCtor.recArgsR_mem hrmem + obtain ⟨family, hfamily, hord, ⟨Bview, hBview, hshape⟩, hsem⟩ := + (S.ctorWF constructor hconstructor).recursive r₀ hr₀ + let ls := gen.sourceLevels + let r := r₀.instL ls + let d := gen.familyCount + let Bs := constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination + let m := Bs.length + let j := r₀.fieldIndex + let Fs := VExpr.liftTelN d Bs 0 + let As := BlockGenerationChecked.blockMinorBinders d m p r + let idxs := r.indices.map fun e => + (e.liftN d (r.fieldIndex + r.binders.length)).liftN + (m - r.fieldIndex + p) r.binders.length + let Γ := Δ ++ Fs.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse) + let q := family.view.ordinal + let K := d - 1 - r.targetType + m + p + r.binders.length + have hjview : r₀.fieldIndex < constructor.ctor.view.fields.length := + (List.getElem?_eq_some_iff.1 hBview).1 + have hjm : j < m := by + have hfields := gen.flatCtor_fields_length hconstructor + simp only [j, m, Bs, NormalizedCtor.fieldsR_length] + omega + have hjraw : + r₀.fieldIndex < + (constructor.ctor.rawFields source.nparams).length := by + simpa [j, m, Bs, NormalizedCtor.fieldsR_length] using hjm + let Braw := + (constructor.ctor.rawFields source.nparams)[r₀.fieldIndex] + have hBraw : + (constructor.ctor.rawFields source.nparams)[r₀.fieldIndex]? = + some Braw := + List.getElem?_eq_getElem hjraw + have hd : gen.motiveTypes.reverse.length = d := by + simp [d, gen.motiveTypes_length] + have hd' : gen.motiveTypes.length = d := by + simpa using hd + have hFsLen : Fs.length = m := by + simp [Fs, m, VExpr.liftTelN_length] + have hstackLen : + (Δ ++ (Fs.drop j).reverse).length = m - j + p := by + simp only [List.length_append, List.length_reverse, + List.length_drop, hFsLen, hΔ] + omega + have ht := S.recArg_transport hconstructor hfamily hsem hjview + gen.motiveTypes.reverse hd + (Δ ++ (Fs.drop j).reverse) hstackLen + simp only [RecArg.instL] at ht + have hctx : + (Δ ++ (Fs.drop j).reverse) ++ + ((VExpr.liftTelN d (Bs.take j) 0).reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse)) = Γ := by + dsimp only [Γ, Fs] + rw [← VExpr.liftTelN_take, List.append_assoc, + ← List.append_assoc + ((VExpr.liftTelN d Bs 0).drop j).reverse, + ← List.reverse_append, List.take_append_drop, + ← List.append_assoc] + dsimp only [j] at ht hctx + have htel : env.OnTel gen.recUvars Γ As := by + rw [hctx] at ht + simpa [r, As, m, j, Bs, RecArg.instL, + BlockGenerationChecked.blockMinorBinders] using ht.1 + have hsp : env.SpineWF gen.recUvars + (As.reverse ++ Γ) + (VExpr.forallN + (VExpr.liftTelN + (m + p + r.binders.length + d) (gen.idxTel family) 0) + (.sort (gen.validated.resultLevel.inst ls))) + idxs + (.sort (gen.validated.resultLevel.inst ls)) := by + rw [hctx] at ht + simpa [r, As, idxs, m, j, Bs, d, ls, RecArg.instL, + BlockGenerationChecked.blockMinorBinders, + List.append_assoc, + show j + r₀.binders.length + d + (m - j + p) = + m + p + r₀.binders.length + d from by omega] using ht.2 + have hF : Γ[m - 1 - j + p]? = + some ((Braw.instL ls).liftN d j) := by + dsimp only [Γ, Fs] + rw [getElem?_stack_mid Δ + (VExpr.liftTelN d Bs 0).reverse + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse) + (i := m - 1 - j + p) (by rw [hΔ]; omega) + (by simp only [hΔ, List.length_reverse, + VExpr.liftTelN_length]; omega), + show m - 1 - j + p - Δ.length = m - 1 - j from by + rw [hΔ] + omega, + List.getElem?_reverse (by rw [hFsLen]; omega), + VExpr.liftTelN_length, + show m - 1 - (m - 1 - j) = j from by omega, + VExpr.liftTelN_getElem?, + NormalizedCtor.fieldsR_getElem?, hBraw] + simp [ls] + have hlu := Lookup.of_getElem? hF + rw [show m - 1 - j + p + 1 = m - j + p from by omega] at hlu + dsimp only [j, r] at hlu + have hf0 := VEnv.HasType.bvar + (env := env) (U := gen.recUvars) hlu + obtain ⟨u, hdom₀⟩ := + S.emittedField_defeq hconstructor hBraw hBview + have hdom₁ := hdom₀.instL + (U' := gen.recUvars) gen.sourceLevels_wf + have hdomChecked : env.IsDefEq gen.recUvars + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination |>.take r₀.fieldIndex).reverse ++ + (gen.block.checked.params.map (VExpr.instL ls)).reverse) + (Braw.instL ls) (Bview.instL ls) ((VExpr.sort u).instL ls) := by + simpa [NormalizedCtor.fieldsR, List.map_append, + List.map_reverse, List.map_take] using hdom₁ + have hprefix := + S.generationFieldPrefix_ctx_rec hconstructor r₀.fieldIndex + have hdomGeneration := hdomChecked.defeqDFC S.ord + (hprefix.symm S.ord) + have hjlen : (Bs.take r₀.fieldIndex).length = + r₀.fieldIndex := by + simp only [Bs, NormalizedCtor.fieldsR, + List.length_take, List.length_map] + omega + have Wmid := Ctx.LiftN.consTel (n := d) + (Bs.take r₀.fieldIndex) + (Ctx.LiftN.zero (n := d) (Γ := gen.paramsTel.reverse) + gen.motiveTypes.reverse (h := hd)) + rw [hjlen, Nat.add_zero] at Wmid + have hdom₂ := hdomGeneration.weakN S.ord Wmid + have Wstack := Ctx.LiftN.zero + (Γ := (VExpr.liftTelN d (Bs.take j) 0).reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse)) + (Δ ++ (Fs.drop j).reverse) (h := hstackLen) + have hdom₃ := hdom₂.weakN S.ord Wstack + rw [hctx] at hdom₃ + have hfView := hdom₃.defeq hf0 + have hfield := blockMinor_fieldType_of_eq hshape d m p + (by simpa [j] using hjm) gen.elimination + simp only [RecArg.instL] at hfield + rw [hfield] at hfView + have hf := hfView.weakN S.ord + (Ctx.LiftN.zero (Γ := Γ) As.reverse) + have hmajor := VEnv.HasType.appN_selfSpine + (env := env) (U := gen.recUvars) + (As := As) + (B := VExpr.appN + (.const family.raw.name ls) + (VExpr.bvarRevRange + (m + p + r.binders.length + d) source.nparams ++ idxs)) + (Δ := []) (Γ := Γ) (by + simpa [As, r, idxs, j, d, ls, RecArg.instL, + List.length_reverse, List.map_map, + Function.comp_def] using hf) + simp only [List.length_nil, VExpr.liftN_zero, + List.nil_append] at hmajor + have hAsLen : As.length = r.binders.length := by + simp [As, BlockGenerationChecked.blockMinorBinders, + VExpr.liftTelN_length] + have hmajor' : env.HasType gen.recUvars (As.reverse ++ Γ) + ((VExpr.bvar (m - 1 - r.fieldIndex + p + As.length)).appN + (VExpr.bvarRevRange 0 As.length)) + (VExpr.appN + (.const family.raw.name ls) + (VExpr.bvarRevRange + (m + p + r.binders.length + d) source.nparams ++ idxs)) := by + simpa [As, d, r, RecArg.instL, + BlockGenerationChecked.blockMinorBinders, + VExpr.liftN, liftVar_le, Nat.add_comm] using hmajor + rw [hAsLen] at hmajor' + have hq : q < d := by + simpa [q, d] using gen.family_ordinal_lt hfamily + have hmot : gen.motiveTypes.reverse[d - 1 - q]? = + some ((gen.motiveType family).liftN q) := by + rw [List.getElem?_reverse (by rw [hd']; omega), + show gen.motiveTypes.length - 1 - (d - 1 - q) = q from by + rw [hd'] + omega, + gen.motiveTypes_getElem?_ordinal hfamily] + have hM0 := getElem?_rstack_mid + (As.reverse ++ (Δ ++ Fs.reverse)) + gen.motiveTypes.reverse gen.paramsTel.reverse + (i := K) + (by + simp only [List.length_append, List.length_reverse, + hAsLen, hΔ, hFsLen] + dsimp only [K, q, d, r] + simp only [RecArg.instL] + omega) + (by + simp only [List.length_append, List.length_reverse, + hAsLen, hΔ, hFsLen, hd] + dsimp only [K, q, d, r] + simp only [RecArg.instL] + omega) + have hdiff : + K - (As.reverse ++ (Δ ++ Fs.reverse)).length = d - 1 - q := by + simp only [List.length_append, List.length_reverse, + hAsLen, hΔ, hFsLen] + dsimp only [K, q, d, r] + simp only [RecArg.instL] + omega + rw [hdiff, hmot] at hM0 + have hMget : (As.reverse ++ Γ)[K]? = + some ((gen.motiveType family).liftN q) := by + simpa [Γ, List.append_assoc] using hM0 + have hMraw := VEnv.HasType.bvar + (env := env) (U := gen.recUvars) + (Lookup.of_getElem? hMget) + have hM : env.HasType gen.recUvars (As.reverse ++ Γ) (.bvar K) + ((gen.motiveType family).liftN (q + K + 1)) := by + simpa [VExpr.liftN_liftN, Nat.add_assoc] using hMraw + have hlen : idxs.length = (gen.idxTel family).length := by + simp only [idxs, List.length_map, + BlockGenerationChecked.idxTel] + have hidx := hsem.2.forallN_sort_length + simp only [VExpr.liftTelN_length] at hidx + simpa [r, RecArg.instL] using hidx.trans + (gen.shape.2.2.2.2 family hfamily).2.2.2.1.symm + have hshift : q + K + 1 = m + p + r.binders.length + d := by + dsimp only [q, K, d, r] + simp only [RecArg.instL] + omega + have hbody := gen.motiveVarApp_hasType family + (q := q) (K := K) + hM (by simpa [hshift] using hsp) hlen + (by simpa [hshift] using hmajor') + refine VEnv.IsType.forallN htel ⟨gen.motiveLevel, ?_⟩ + simpa [BlockGenerationChecked.blockMinorIH, + r, As, idxs, m, d, K, q, Γ, Fs, Bs, + List.append_assoc] using hbody + +/-- The global mutual-IH telescope for one constructor is well formed at +every recursive suffix. -/ +theorem ihs_onTel {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) : + ∀ (rsSuf : List RecArg), + (∀ r ∈ rsSuf, + r ∈ constructor.ctor.recArgsR source.uvars gen.elimination) → + ∀ (Δ : List VExpr) (p : Nat), Δ.length = p → + env.OnTel gen.recUvars + (Δ ++ + (VExpr.liftTelN gen.familyCount + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) 0).reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse)) + (BlockGenerationChecked.blockIHsFromRecArgs gen.familyCount + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length rsSuf p) + | [], _, _, _, _ => trivial + | r :: rsSuf, hqs, Δ, p, hΔ => + ⟨S.recArgMinor_isType hconstructor + (hqs r (.head _)) Δ p hΔ, + BlockGenerationEnv.ihs_onTel hconstructor rsSuf + (fun q hq => hqs q (.tail _ hq)) + (_ :: Δ) (p + 1) (by simp [hΔ])⟩ + +theorem viewResultIndices_length + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) : + constructor.ctor.view.resultIndices.length = + constructor.familyIndices.length := by + have h := (S.ctorWF constructor hconstructor).resultSpine.forallN_sort_length + simpa only [VExpr.liftTelN_length] using h + +/-- Transport one mutual constructor's checked result spine to the selected +raw family-index telescope and through arbitrary middle/top binders. -/ +theorem result_transport + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) + {family : NormalizedFamily} (hfamily : family ∈ gen.families) + (hindices : family.view.indices = constructor.familyIndices) + (mid : List VExpr) {g : Nat} (hg : mid.length = g) + (As₂ : List VExpr) {d : Nat} (hd : As₂.length = d) : + env.SpineWF gen.recUvars + (As₂ ++ + ((VExpr.liftTelN g + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) 0).reverse ++ + (mid ++ gen.paramsTel.reverse))) + (VExpr.forallN + (VExpr.liftTelN + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length + g + d) + (gen.idxTel family) 0) + (.sort (gen.validated.resultLevel.inst gen.sourceLevels))) + ((constructor.ctor.resultIndicesR source.uvars gen.elimination).map + fun e => + (e.liftN g + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length).liftN d) + (.sort (gen.validated.resultLevel.inst gen.sourceLevels)) := by + let ls := gen.sourceLevels + have hview := (S.ctorWF constructor hconstructor).resultSpine + rw [← hindices] at hview + have hctx := (S.ctorWF constructor hconstructor).emittedTel.ctx + simp only [NormalizedBlockCtor.emittedBinders, + NormalizedBlockCtor.viewBinders, List.reverse_append, + List.append_nil] at hctx + have hraw := hview.defeqDFC S.ord (hctx.symm S.ord) + have hfields := gen.flatCtor_fields_length hconstructor + rw [← hfields] at hraw + have h1 := hraw.instL + (U' := gen.recUvars) gen.sourceLevels_wf + have h1Checked : env.SpineWF gen.recUvars + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).reverse ++ + (gen.block.checked.params.map (VExpr.instL ls)).reverse) + (VExpr.instL ls + (VExpr.forallN + (VExpr.liftTelN + (constructor.ctor.rawFields source.nparams).length + family.view.indices 0) + (.sort gen.validated.resultLevel))) + (constructor.ctor.view.resultIndices.map (VExpr.instL ls)) + ((VExpr.sort gen.validated.resultLevel).instL ls) := by + simpa [NormalizedCtor.fieldsR, List.map_append, + List.map_reverse] using h1 + have hfieldsCtx := + (S.generationFields_onTel_rec hconstructor).extendDefEqCtx + S.generationParams_ctx_rec + have h1Generation := h1Checked.defeqDFC S.ord + (hfieldsCtx.symm S.ord) + rw [VExpr.instL_forallN, VExpr.liftTelN_instL] at h1Generation + rw [← NormalizedCtor.fieldsR_length + (source := source) (mode := gen.elimination) constructor.ctor] at h1Generation + have hidx := (S.familyIndexTel_defeq_rec hfamily).weakN S.ord + (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).reverse) + rw [List.length_reverse] at hidx + have hlen : + (constructor.ctor.view.resultIndices.map (VExpr.instL ls)).length = + (VExpr.liftTelN + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length + (gen.idxTel family) 0).length := by + simp only [List.length_map, VExpr.liftTelN_length, + BlockGenerationChecked.idxTel] + exact (S.viewResultIndices_length hconstructor).trans + ((congrArg List.length hindices).symm.trans + (gen.shape.2.2.2.2 family hfamily).2.2.2.1.symm) + have h1Raw := hidx.spine_sort S.ord h1Generation hlen + have W₁ := Ctx.LiftN.consTel (n := mid.length) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) + (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) mid) + rw [Nat.add_zero] at W₁ + have h2 := h1Raw.weakN S.ord W₁ + rw [VExpr.liftN_forallN, hg] at h2 + have h3 := h2.weakN S.ord + (Ctx.LiftN.zero (Γ := _) As₂ (h := hd)) + rw [VExpr.liftN_forallN] at h3 + rw [VExpr.liftTelN_liftTelN_hi' + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length g _ 0 (by omega), + VExpr.liftTelN_liftTelN] at h3 + simpa [ls, NormalizedCtor.resultIndicesR, + VExpr.instL, VExpr.liftN, List.map_map, + Function.comp_def, List.append_assoc] using h3 + +/-- The raw mutual constructor applied to its emitted self-spine at source +universes. -/ +theorem ctorApp_emitted_decl + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) : + env.HasType source.uvars + ((constructor.ctor.rawFields source.nparams).reverse ++ + gen.block.checked.params.reverse) + (VExpr.appN + (.const constructor.ctor.raw.name (VLevel.params source.uvars)) + (VExpr.bvarRevRange + (constructor.ctor.rawFields source.nparams).length + source.nparams ++ + VExpr.bvarRevRange 0 + (constructor.ctor.rawFields source.nparams).length)) + (NormalizedBlockCtor.resultTarget gen constructor) := by + let E := NormalizedBlockCtor.emittedBinders gen constructor + let V := NormalizedBlockCtor.viewBinders gen constructor + have hc : env.HasType source.uvars [] + (.const constructor.ctor.raw.name (VLevel.params source.uvars)) + (VExpr.forallN + (NormalizedBlockCtor.declaredBinders + (source := source) constructor) + (NormalizedBlockCtor.rawResult + (source := source) constructor)) := by + rw [NormalizedBlockCtor.declaredBinders, + NormalizedBlockCtor.rawResult, + ← constructor.ctor.rawType_eq] + exact S.ctorConst_decl hconstructor + obtain ⟨_, hdecl⟩ := + (S.ctorWF constructor hconstructor).declaredTel.forallN_defeq + (by simpa using + (S.ctorWF constructor hconstructor).declaredResult) + have hview : env.HasType source.uvars [] + (.const constructor.ctor.raw.name (VLevel.params source.uvars)) + (VExpr.forallN V + (NormalizedBlockCtor.resultTarget gen constructor)) := by + simpa [V] using hdecl.defeq hc + have hresult : env.HasType source.uvars E.reverse + (NormalizedBlockCtor.resultTarget gen constructor) + (.sort gen.validated.resultLevel) := by + simpa [E] using + (S.ctorWF constructor hconstructor).emittedResult.hasType.2 + obtain ⟨_, hemit⟩ := + (S.ctorWF constructor hconstructor).emittedTel.forallN_defeq + (by simpa [E, VEnv.HasType] using hresult) + have hcE₀ : env.HasType source.uvars [] + (.const constructor.ctor.raw.name (VLevel.params source.uvars)) + (VExpr.forallN E + (NormalizedBlockCtor.resultTarget gen constructor)) := by + exact hemit.defeq' (by simpa [V] using hview) + have hclosed : + (VExpr.forallN E + (NormalizedBlockCtor.resultTarget gen constructor)).ClosedN 0 := + (hcE₀.closedN' S.ord.closed trivial).2.2 + have hcE : env.HasType source.uvars E.reverse + (.const constructor.ctor.raw.name (VLevel.params source.uvars)) + (VExpr.forallN E + (NormalizedBlockCtor.resultTarget gen constructor)) := + hcE₀.weak0 S.ord + have happ := VEnv.HasType.appN_selfSpine' + (As := E) + (B := NormalizedBlockCtor.resultTarget gen constructor) + (Δ := []) (Γ := []) hclosed (by simpa using hcE) + simp only [List.length_nil, VExpr.liftN_zero, + List.nil_append, List.append_nil] at happ + have hEctx : + E.reverse = + (constructor.ctor.rawFields source.nparams).reverse ++ + gen.block.checked.params.reverse := by + simp [E, NormalizedBlockCtor.emittedBinders, + List.reverse_append] + have hElen : + E.length = + (constructor.ctor.rawFields source.nparams).length + + source.nparams := by + have hp : gen.block.checked.params.length = source.nparams := + gen.shape.2.1.symm.trans gen.shape.1 + simp [E, NormalizedBlockCtor.emittedBinders, hp] + omega + rw [hEctx, hElen, + ← VExpr.bvarRevRange_append source.nparams + (constructor.ctor.rawFields source.nparams).length] at happ + exact happ + +/-- The exact emitted mutual-constructor application in recursor universes, +retargeted to its owner family. -/ +theorem ctorApp_emitted_rec + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) + {family : NormalizedFamily} + (hname : family.raw.name = constructor.familyName) : + env.HasType gen.recUvars + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).reverse ++ gen.paramsTel.reverse) + (VExpr.appN + (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length source.nparams ++ + VExpr.bvarRevRange 0 + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length)) + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length source.nparams ++ + constructor.ctor.resultIndicesR source.uvars gen.elimination)) := by + let ls := gen.sourceLevels + have h := (S.ctorApp_emitted_decl hconstructor).instL + (U' := gen.recUvars) gen.sourceLevels_wf + have hChecked : env.HasType gen.recUvars + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).reverse ++ + (gen.block.checked.params.map (VExpr.instL ls)).reverse) + ((VExpr.appN + (.const constructor.ctor.raw.name (VLevel.params source.uvars)) + (VExpr.bvarRevRange + (constructor.ctor.rawFields source.nparams).length + source.nparams ++ + VExpr.bvarRevRange 0 + (constructor.ctor.rawFields source.nparams).length)).instL ls) + ((NormalizedBlockCtor.resultTarget gen constructor).instL ls) := by + simpa [NormalizedCtor.fieldsR, List.map_append, + List.map_reverse] using h + have hfieldsCtx := + (S.generationFields_onTel_rec hconstructor).extendDefEqCtx + S.generationParams_ctx_rec + have hGeneration := hChecked.defeqDFC S.ord + (hfieldsCtx.symm S.ord) + rw [← NormalizedCtor.fieldsR_length + (source := source) (mode := gen.elimination) constructor.ctor] at hGeneration + simpa [ls, hname, NormalizedCtor.fieldsR, + BlockGenerationChecked.paramsTel, + NormalizedBlockCtor.resultTarget, + NormalizedCtor.resultIndicesR, + VExpr.instL_appN, List.map_append, + bvarRevRange_instL, List.map_reverse, + VExpr.instL, VLevel.params_map_inst_params'] using hGeneration + +/-- Transport the emitted mutual-constructor application beneath arbitrary +middle and top binders. -/ +theorem ctorApp_transport + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) + {family : NormalizedFamily} + (hname : family.raw.name = constructor.familyName) + (mid : List VExpr) {g : Nat} (hg : mid.length = g) + (As₂ : List VExpr) {d : Nat} (hd : As₂.length = d) : + env.HasType gen.recUvars + (As₂ ++ + ((VExpr.liftTelN g + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) 0).reverse ++ + (mid ++ gen.paramsTel.reverse))) + (VExpr.appN (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + (d + (g + + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length)) source.nparams ++ + VExpr.bvarRevRange d + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length)) + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + (d + (g + + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length)) source.nparams ++ + (constructor.ctor.resultIndicesR source.uvars gen.elimination).map + fun e => + (e.liftN g + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length).liftN d)) := by + let Bs := constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination + have W₁ := Ctx.LiftN.consTel (n := mid.length) Bs + (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) mid) + rw [Nat.add_zero] at W₁ + have h₁ := (S.ctorApp_emitted_rec hconstructor hname).weakN + S.ord W₁ + rw [hg] at h₁ + have hmid : env.HasType gen.recUvars + ((VExpr.liftTelN g Bs 0).reverse ++ + (mid ++ gen.paramsTel.reverse)) + (VExpr.appN (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (g + Bs.length) source.nparams ++ + VExpr.bvarRevRange 0 Bs.length)) + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (g + Bs.length) source.nparams ++ + (constructor.ctor.resultIndicesR source.uvars + gen.elimination).map (VExpr.liftN g · Bs.length))) := by + simpa [Bs, VExpr.liftN_appN, List.map_append, + bvarRevRange_liftN_ge _ _ _ _ (Nat.le_refl _), + VExpr.bvarRevRange_liftN_high Bs.length 0 g Bs.length (by omega), + VExpr.liftN] using h₁ + have htop := hmid.weakN S.ord + (Ctx.LiftN.zero (Γ := _) As₂ (h := hd)) + simpa [Bs, VExpr.liftN_appN, List.map_append, + bvarRevRange_liftN_ge _ _ _ _ (Nat.zero_le _), + VExpr.liftN, List.map_map, Function.comp_def, + List.append_assoc] using htop + +/-- The raw field telescope of a mutual constructor is well formed after +inserting all block motives. -/ +theorem fields_onTel_minor + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) : + env.OnTel gen.recUvars + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse) + (VExpr.liftTelN gen.familyCount + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) 0) := by + have hd : gen.motiveTypes.reverse.length = gen.familyCount := by + simp [gen.motiveTypes_length] + have hout := (S.generationFields_onTel_rec hconstructor).weakN S.ord + (Ctx.LiftN.zero (n := gen.familyCount) + (Γ := gen.paramsTel.reverse) gen.motiveTypes.reverse (h := hd)) + simpa using hout + +/-- Every flattened mutual constructor minor is a type over the global +motive telescope. -/ +theorem minor_isType + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) : + env.IsType gen.recUvars + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse) + (gen.minorType constructor) := by + obtain ⟨family, hfamily, howner, hname, hindices⟩ := + (S.ctorWF constructor hconstructor).owner + let d := gen.familyCount + let Bs := constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination + let m := Bs.length + let rs := constructor.ctor.recArgsR source.uvars gen.elimination + let IHs := BlockGenerationChecked.blockIHsFromRecArgs d m rs 0 + let Fs := VExpr.liftTelN d Bs 0 + let Γ := IHs.reverse ++ + (Fs.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse)) + let q := family.view.ordinal + let K := d - 1 - constructor.owner + m + rs.length + simp only [BlockGenerationChecked.minorType] + refine VEnv.IsType.forallN (by + simpa [Bs, d] using S.fields_onTel_minor hconstructor) ?_ + refine VEnv.IsType.forallN (by + simpa [Bs, m, rs, IHs, Fs, d, List.append_assoc] using + S.ihs_onTel hconstructor rs (fun r hr => hr) [] 0 rfl) ?_ + have hrlen : IHs.reverse.length = rs.length := by + simp [IHs, BlockGenerationChecked.blockIHsFromRecArgs_length] + have hd : gen.motiveTypes.reverse.length = d := by + simp [d, gen.motiveTypes_length] + have hd' : gen.motiveTypes.length = d := by + simpa using hd + have hFsLen : Fs.length = m := by + simp [Fs, m, VExpr.liftTelN_length] + have hq : q < d := by + simpa [q, d] using gen.family_ordinal_lt hfamily + have hmot : gen.motiveTypes.reverse[d - 1 - q]? = + some ((gen.motiveType family).liftN q) := by + rw [List.getElem?_reverse (by rw [hd']; omega), + show gen.motiveTypes.length - 1 - (d - 1 - q) = q from by + rw [hd'] + omega, + gen.motiveTypes_getElem?_ordinal hfamily] + have hM0 := getElem?_rstack_mid + (IHs.reverse ++ Fs.reverse) + gen.motiveTypes.reverse gen.paramsTel.reverse + (i := K) + (by + simp only [List.length_append, List.length_reverse, + hrlen, hFsLen] + dsimp only [K, q, d] + omega) + (by + simp only [List.length_append, List.length_reverse, + hrlen, hFsLen, hd] + dsimp only [K, q, d] + omega) + have hdiff : + K - (IHs.reverse ++ Fs.reverse).length = d - 1 - q := by + simp only [List.length_append, List.length_reverse, + hrlen, hFsLen] + dsimp only [K, q, d] + omega + rw [hdiff, hmot] at hM0 + have hMget : Γ[K]? = + some ((gen.motiveType family).liftN q) := by + simpa [Γ, List.append_assoc] using hM0 + have hMraw := VEnv.HasType.bvar + (env := env) (U := gen.recUvars) + (Lookup.of_getElem? hMget) + have hM : env.HasType gen.recUvars Γ (.bvar K) + ((gen.motiveType family).liftN (q + K + 1)) := by + simpa [VExpr.liftN_liftN, Nat.add_assoc] using hMraw + have hSp := S.result_transport hconstructor hfamily hindices + gen.motiveTypes.reverse hd IHs.reverse hrlen + have hSp' : env.SpineWF gen.recUvars Γ + (VExpr.forallN + (VExpr.liftTelN (m + d + rs.length) + (gen.idxTel family) 0) + (.sort (gen.validated.resultLevel.inst gen.sourceLevels))) + ((constructor.ctor.resultIndicesR source.uvars + gen.elimination).map fun e => + (e.liftN d m).liftN rs.length) + (.sort (gen.validated.resultLevel.inst gen.sourceLevels)) := by + simpa [Γ, Fs, Bs, m, d, List.append_assoc] using hSp + have hlen : + ((constructor.ctor.resultIndicesR source.uvars + gen.elimination).map fun e => + (e.liftN d m).liftN rs.length).length = + (gen.idxTel family).length := by + simp only [List.length_map, NormalizedCtor.resultIndicesR, + BlockGenerationChecked.idxTel] + exact (S.viewResultIndices_length hconstructor).trans + ((congrArg List.length hindices).symm.trans + (gen.shape.2.2.2.2 family hfamily).2.2.2.1.symm) + have hctorApp := S.ctorApp_transport hconstructor hname + gen.motiveTypes.reverse hd IHs.reverse hrlen + have hctorApp' : env.HasType gen.recUvars Γ + (VExpr.appN + (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (m + d + rs.length) source.nparams ++ + VExpr.bvarRevRange rs.length m)) + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (m + d + rs.length) source.nparams ++ + (constructor.ctor.resultIndicesR source.uvars + gen.elimination).map fun e => + (e.liftN d m).liftN rs.length)) := by + simpa [Γ, Fs, Bs, m, d, IHs, rs, + List.append_assoc, Nat.add_assoc, Nat.add_comm, + Nat.add_left_comm] using hctorApp + have hshift : q + K + 1 = m + d + rs.length := by + dsimp only [q, K, d] + omega + have hbody := gen.motiveVarApp_hasType family + (q := q) (K := K) + hM (by simpa [hshift, Nat.add_assoc, Nat.add_comm, + Nat.add_left_comm] using hSp') hlen + (by simpa [hshift, Nat.add_assoc, Nat.add_comm, + Nat.add_left_comm] using hctorApp') + exact ⟨gen.motiveLevel, by + simpa [Γ, Fs, Bs, m, rs, IHs, d, K, q, + BlockGenerationChecked.blockMinorIH, + List.append_assoc, Nat.add_assoc, Nat.add_comm, + Nat.add_left_comm] using hbody⟩ + +/-- Any suffix of the globally flattened constructor list generates a +well-formed minor telescope at its positional depth. -/ +theorem minorTypesAux_onTel : + ∀ (constructors : List NormalizedBlockCtor), + (∀ constructor ∈ constructors, constructor ∈ gen.flatCtors) → + ∀ (Δ : List VExpr) (i : Nat), Δ.length = i → + env.OnTel gen.recUvars + (Δ ++ (gen.motiveTypes.reverse ++ gen.paramsTel.reverse)) + (gen.minorTypesAux constructors i) + | [], _, _, _, _ => trivial + | constructor :: constructors, hsub, Δ, i, hΔ => + ⟨by + rw [← hΔ] + exact (S.minor_isType + (hsub constructor (.head _))).weakN S.ord (.zero Δ), + BlockGenerationEnv.minorTypesAux_onTel constructors + (fun constructor hconstructor => hsub constructor (.tail _ hconstructor)) + (_ :: Δ) (i + 1) (by simp [hΔ])⟩ + +/-- The complete global constructor-minor telescope is well formed beneath +all mutual motives. -/ +theorem minorTypes_onTel : + env.OnTel gen.recUvars + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse) + gen.minorTypes := by + simpa [BlockGenerationChecked.minorTypes] using + S.minorTypesAux_onTel gen.flatCtors + (fun _ h => h) [] 0 rfl + +theorem idxTel_onTel {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.OnTel gen.recUvars gen.paramsTel.reverse + (gen.idxTel family) := by + have h := (S.generationFamily_onTel hfamily).instL + (U' := gen.recUvars) gen.sourceLevels_wf + have h' : env.OnTel gen.recUvars [] + (gen.paramsTel ++ gen.idxTel family) := by + simpa [BlockGenerationChecked.paramsTel, + BlockGenerationChecked.idxTel] using h + simpa using h'.of_append.2 + +/-- Transport a selected family applied to its index self-spine beneath +arbitrary middle and top binders. -/ +theorem familyApp_transport {family : NormalizedFamily} + (hfamily : family ∈ gen.families) + (mid : List VExpr) {g : Nat} (hg : mid.length = g) + (As₂ : List VExpr) {d : Nat} (hd : As₂.length = d) : + env.HasType gen.recUvars + (As₂ ++ + ((VExpr.liftTelN g (gen.idxTel family) 0).reverse ++ + (mid ++ gen.paramsTel.reverse))) + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + (d + (g + (gen.idxTel family).length)) source.nparams ++ + VExpr.bvarRevRange d (gen.idxTel family).length)) + (.sort (gen.validated.resultLevel.inst gen.sourceLevels)) := by + have W₁ := Ctx.LiftN.consTel (n := mid.length) (gen.idxTel family) + (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) mid) + rw [Nat.add_zero] at W₁ + have h₁ := (S.familyApp_hasType hfamily).weakN S.ord W₁ + rw [hg] at h₁ + have hmid : env.HasType gen.recUvars + ((VExpr.liftTelN g (gen.idxTel family) 0).reverse ++ + (mid ++ gen.paramsTel.reverse)) + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + (g + (gen.idxTel family).length) source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)) + (.sort (gen.validated.resultLevel.inst gen.sourceLevels)) := by + simpa [VExpr.liftN_appN, List.map_append, + bvarRevRange_liftN_ge _ _ _ _ (Nat.le_refl _), + VExpr.bvarRevRange_liftN_high + (gen.idxTel family).length 0 g (gen.idxTel family).length + (by omega), + VExpr.liftN] using h₁ + have htop := hmid.weakN S.ord + (Ctx.LiftN.zero (Γ := _) As₂ (h := hd)) + simpa [VExpr.liftN_appN, List.map_append, + bvarRevRange_liftN_ge _ _ _ _ (Nat.zero_le _), + VExpr.liftN, List.append_assoc] using htop + +/-- The generated recursor type for every selected mutual family is well +formed over the empty context. -/ +theorem recType_isType {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + env.IsType gen.recUvars [] (gen.recType family) := by + let d := gen.familyCount + let k := gen.minorCount + let q := family.view.ordinal + let Is := gen.idxTel family + let ni := Is.length + let LiftedIs := VExpr.liftTelN (d + k) Is 0 + let A := VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (ni + d + k) source.nparams ++ + VExpr.bvarRevRange 0 ni) + let Base := gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse) + let Γ := A :: (LiftedIs.reverse ++ Base) + let K := d - 1 - q + k + ni + 1 + refine VEnv.IsType.forallN S.paramsTel_onTel ?_ + simp only [List.append_nil] + refine VEnv.IsType.forallN S.motiveTypes_onTel ?_ + refine VEnv.IsType.forallN S.minorTypes_onTel ?_ + have hdk : + (gen.minorTypes.reverse ++ gen.motiveTypes.reverse).length = d + k := by + simp only [List.length_append, List.length_reverse, + gen.minorTypes_length, gen.motiveTypes_length] + dsimp only [d, k] + omega + have hI : env.OnTel gen.recUvars Base LiftedIs := by + have h := (S.idxTel_onTel hfamily).weakN S.ord + (Ctx.LiftN.zero (n := d + k) + (Γ := gen.paramsTel.reverse) + (gen.minorTypes.reverse ++ gen.motiveTypes.reverse) + (h := hdk)) + simpa [Base, LiftedIs, Is, List.append_assoc] using h + refine VEnv.IsType.forallN hI ?_ + have hmaj₀ := S.familyApp_transport hfamily + (gen.minorTypes.reverse ++ gen.motiveTypes.reverse) + (g := d + k) hdk [] (d := 0) rfl + rw [VExpr.bvarRevRange_congr source.nparams + (show 0 + (d + k + Is.length) = ni + d + k by + dsimp only [ni] + omega)] at hmaj₀ + have hmaj : env.HasType gen.recUvars + (LiftedIs.reverse ++ Base) A + (.sort (gen.validated.resultLevel.inst gen.sourceLevels)) := by + simpa [A, Base, LiftedIs, Is, List.append_assoc] using hmaj₀ + refine VEnv.IsType.forallE ⟨_, hmaj⟩ ?_ + have hILen : LiftedIs.length = ni := by + simp [LiftedIs, ni, VExpr.liftTelN_length] + have hq : q < d := by + simpa [q, d] using gen.family_ordinal_lt hfamily + have hd : gen.motiveTypes.length = d := by + simpa [d] using gen.motiveTypes_length + have hmot : gen.motiveTypes.reverse[d - 1 - q]? = + some ((gen.motiveType family).liftN q) := by + rw [List.getElem?_reverse (by rw [hd]; omega), + show gen.motiveTypes.length - 1 - (d - 1 - q) = q from by + rw [hd] + omega, + gen.motiveTypes_getElem?_ordinal hfamily] + have hM0 := getElem?_rstack_mid + ([A] ++ LiftedIs.reverse ++ gen.minorTypes.reverse) + gen.motiveTypes.reverse gen.paramsTel.reverse + (i := K) + (by + simp only [List.length_append, List.length_singleton, + List.length_reverse, hILen, gen.minorTypes_length] + dsimp only [K, q, d, k, ni, Is] + omega) + (by + simp only [List.length_append, List.length_singleton, + List.length_reverse, hILen, gen.minorTypes_length] + rw [hd] + dsimp only [K, q, d, k, ni, Is] + omega) + have hdiff : + K - ([A] ++ LiftedIs.reverse ++ gen.minorTypes.reverse).length = + d - 1 - q := by + simp only [List.length_append, List.length_singleton, + List.length_reverse, hILen, gen.minorTypes_length] + dsimp only [K, q, d, k, ni, Is] + omega + rw [hdiff, hmot] at hM0 + have hMget : Γ[K]? = + some ((gen.motiveType family).liftN q) := by + simpa [Γ, Base, List.append_assoc] using hM0 + have hmlu := Lookup.of_getElem? hMget + rw [show ((gen.motiveType family).liftN q).liftN (K + 1) = + ((gen.motiveType family).liftN (d + k)).liftN (ni + 1) from by + rw [VExpr.liftN_liftN, VExpr.liftN_liftN] + congr 1 + dsimp only [K, q, d, k] + omega, + gen.motiveType_liftN family] at hmlu + have hfun : env.HasType gen.recUvars Γ (.bvar K) + ((VExpr.forallN LiftedIs + (.forallE + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (d + k + ni) source.nparams ++ + VExpr.bvarRevRange 0 ni)) + (.sort gen.motiveLevel))).liftN + (1 + LiftedIs.length)) := by + exact .bvar (by + simpa [Γ, Base, LiftedIs, Is, ni, + VExpr.liftTelN_length, List.append_assoc, + Nat.add_comm, Nat.add_left_comm, Nat.add_assoc] using hmlu) + have hMapp := VEnv.HasType.appN_selfSpine + (As := LiftedIs) + (Δ := [A]) + (Γ := Base) + (f := .bvar K) hfun + have hMapp' : env.HasType gen.recUvars Γ + ((VExpr.bvar K).appN (VExpr.bvarRevRange 1 ni)) + (.forallE (A.liftN 1) (.sort gen.motiveLevel)) := by + simpa [Γ, Base, A, LiftedIs, Is, ni, hILen, + VExpr.liftN, List.append_assoc, + Nat.add_comm, Nat.add_left_comm, Nat.add_assoc] using hMapp + have h0 : Γ[0]? = some A := rfl + have harg := VEnv.HasType.bvar + (env := env) (U := gen.recUvars) + (Lookup.of_getElem? h0) + have harg' : env.HasType gen.recUvars Γ (.bvar 0) (A.liftN 1) := by + simpa [Γ, List.append_assoc] using harg + have happ := VEnv.HasType.app hMapp' harg' + exact ⟨gen.motiveLevel, by + simpa [BlockGenerationChecked.recType, + Γ, Base, A, LiftedIs, Is, ni, d, k, q, K, + VExpr.liftTelN_length, VExpr.inst, List.append_assoc, + Nat.add_comm, Nat.add_left_comm, Nat.add_assoc] using happ⟩ + +/-- Every family-selected mutual recursor constant is well formed in the +environment containing the complete raw block. -/ +theorem recursor_wf {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + (gen.recursor family).WF env := + S.recType_isType hfamily + +theorem recType_levelWF {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + (gen.recType family).LevelWF gen.recUvars := by + obtain ⟨_, h⟩ := S.recType_isType hfamily + exact (h.levelWF trivial).1 + +theorem recType_closedN {family : NormalizedFamily} + (hfamily : family ∈ gen.families) : + (gen.recType family).ClosedN 0 := by + obtain ⟨_, h⟩ := S.recType_isType hfamily + exact VExpr.WF.closedN S.ord ⟨_, h⟩ trivial + +/-- The selected family recursor constant has its generated mutual recursor +type in every local context. -/ +theorem recursor_hasType {family : NormalizedFamily} + (hfamily : family ∈ gen.families) + (hrec : env.constants (.str family.raw.name "rec") = + some (gen.recursor family)) {Γ : List VExpr} : + env.HasType gen.recUvars Γ + (.const (.str family.raw.name "rec") gen.recLevels) + (gen.recType family) := by + have h := VEnv.HasType.const (Γ := Γ) hrec + VLevel.params_wf VLevel.params_length + rw [show (gen.recursor family).uvars = gen.recUvars from rfl, + show (gen.recursor family).type = gen.recType family from rfl] at h + rwa [(S.recType_levelWF hfamily).instL_id] at h + +/-- Applying a selected recursor to the shared parameters, motives, and +flattened minors exposes its index-and-major spine. -/ +theorem recBase_hasType {family : NormalizedFamily} + (hfamily : family ∈ gen.families) + (hrec : env.constants (.str family.raw.name "rec") = + some (gen.recursor family)) + (Δ : List VExpr) : + env.HasType gen.recUvars + (Δ ++ (gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse))) + (gen.recBase Δ.length family.view.ordinal) + ((VExpr.forallN + (VExpr.liftTelN + (gen.familyCount + gen.minorCount) + (gen.idxTel family) 0) + (.forallE + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((gen.idxTel family).length + + gen.familyCount + gen.minorCount) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)) + (.app + (VExpr.appN + (.bvar + (gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + (gen.idxTel family).length + 1)) + (VExpr.bvarRevRange 1 (gen.idxTel family).length)) + (.bvar 0)))).liftN Δ.length) := by + have hf : env.HasType gen.recUvars + (Δ ++ + (gen.paramsTel ++ gen.motiveTypes ++ gen.minorTypes).reverse ++ []) + (.const (.str family.raw.name "rec") gen.recLevels) + ((VExpr.forallN + (gen.paramsTel ++ gen.motiveTypes ++ gen.minorTypes) + (VExpr.forallN + (VExpr.liftTelN + (gen.familyCount + gen.minorCount) + (gen.idxTel family) 0) + (.forallE + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((gen.idxTel family).length + + gen.familyCount + gen.minorCount) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)) + (.app + (VExpr.appN + (.bvar + (gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + (gen.idxTel family).length + 1)) + (VExpr.bvarRevRange 1 (gen.idxTel family).length)) + (.bvar 0))))).liftN + (Δ.length + + (gen.paramsTel ++ gen.motiveTypes ++ gen.minorTypes).length)) := by + rw [show VExpr.forallN + (gen.paramsTel ++ gen.motiveTypes ++ gen.minorTypes) + (VExpr.forallN + (VExpr.liftTelN + (gen.familyCount + gen.minorCount) + (gen.idxTel family) 0) + (.forallE + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((gen.idxTel family).length + + gen.familyCount + gen.minorCount) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)) + (.app + (VExpr.appN + (.bvar + (gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + (gen.idxTel family).length + 1)) + (VExpr.bvarRevRange 1 (gen.idxTel family).length)) + (.bvar 0)))) = gen.recType family from by + rw [VExpr.forallN_append, VExpr.forallN_append] + rfl, + (S.recType_closedN hfamily).liftN_eq (Nat.zero_le _)] + exact S.recursor_hasType hfamily hrec + have hspine := VEnv.HasType.appN_selfSpine + (env := env) (U := gen.recUvars) hf + simp only [BlockGenerationChecked.recType, + List.reverse_append, List.append_nil, List.append_assoc, + List.length_append, List.length_reverse, + gen.minorTypes_length, gen.motiveTypes_length] at hspine + rw [show gen.paramsTel.length = source.nparams from by + simpa [BlockGenerationChecked.paramsTel] using + S.generationParams_length, + VExpr.bvarRevRange_congr' Δ.length + (show source.nparams + (gen.familyCount + gen.minorCount) = + source.nparams + gen.familyCount + gen.minorCount by omega)] at hspine + simpa [BlockGenerationChecked.recBase, + gen.familyNameAt_ordinal hfamily, + List.append_assoc] using hspine + +/-- Applying a selected family recursor to indices and a major premise +returns the correspondingly selected motive application. -/ +theorem recApp_hasType {family : NormalizedFamily} + (hfamily : family ∈ gen.families) + (hrec : env.constants (.str family.raw.name "rec") = + some (gen.recursor family)) + (Δ : List VExpr) {idxs : List VExpr} {a : VExpr} + (hidx : env.SpineWF gen.recUvars + (Δ ++ (gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse))) + (VExpr.forallN + (VExpr.liftTelN + (Δ.length + gen.familyCount + gen.minorCount) + (gen.idxTel family) 0) + (.sort (gen.validated.resultLevel.inst gen.sourceLevels))) + idxs (.sort (gen.validated.resultLevel.inst gen.sourceLevels))) + (hlen : idxs.length = (gen.idxTel family).length) + (ha : env.HasType gen.recUvars + (Δ ++ (gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse))) + a + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + (Δ.length + gen.familyCount + gen.minorCount) + source.nparams ++ idxs))) : + env.HasType gen.recUvars + (Δ ++ (gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse))) + (VExpr.appN (gen.recBase Δ.length family.view.ordinal) + (idxs ++ [a])) + (VExpr.appN + (.bvar + (gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + Δ.length)) + (idxs ++ [a])) := by + have hq := gen.family_ordinal_lt hfamily + have hb := S.recBase_hasType hfamily hrec Δ + rw [VExpr.liftN_forallN, VExpr.liftTelN_liftTelN, + liftTelN_congr _ _ + (show gen.familyCount + gen.minorCount + Δ.length = + Δ.length + gen.familyCount + gen.minorCount by omega)] at hb + have hcod : + (VExpr.forallE + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((gen.idxTel family).length + + gen.familyCount + gen.minorCount) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)) + (.app + (VExpr.appN + (.bvar + (gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + (gen.idxTel family).length + 1)) + (VExpr.bvarRevRange 1 (gen.idxTel family).length)) + (.bvar 0))).liftN Δ.length + (0 + (VExpr.liftTelN + (gen.familyCount + gen.minorCount) + (gen.idxTel family) 0).length) = + VExpr.forallE + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((gen.idxTel family).length + Δ.length + + gen.familyCount + gen.minorCount) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)) + (.app + (VExpr.appN + (.bvar + (gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + (gen.idxTel family).length + + Δ.length + 1)) + (VExpr.bvarRevRange 1 (gen.idxTel family).length)) + (.bvar 0)) := by + rw [VExpr.liftTelN_length, Nat.zero_add] + show VExpr.forallE _ _ = VExpr.forallE _ _ + congr 1 + · rw [VExpr.liftN_appN, List.map_append, + bvarRevRange_liftN_ge _ _ _ _ (by omega), + VExpr.bvarRevRange_liftN_high _ _ _ _ (by omega), + VExpr.bvarRevRange_congr source.nparams + (show Δ.length + + ((gen.idxTel family).length + + gen.familyCount + gen.minorCount) = + (gen.idxTel family).length + Δ.length + + gen.familyCount + gen.minorCount by omega)] + rfl + · show VExpr.app _ _ = VExpr.app _ _ + congr 1 + · rw [VExpr.liftN_appN, + VExpr.bvarRevRange_liftN_high _ _ _ _ (by omega)] + show VExpr.appN + (.bvar (liftVar Δ.length + (gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + (gen.idxTel family).length + 1) + ((gen.idxTel family).length + 1))) _ = _ + rw [liftVar_le (by omega)] + congr 1 + ac_rfl + rw [hcod] at hb + have hshape := hidx.retarget + (by simpa only [VExpr.liftTelN_length] using hlen) + (.forallE + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((gen.idxTel family).length + Δ.length + + gen.familyCount + gen.minorCount) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)) + (.sort gen.motiveLevel)) + rw [VExpr.instRev_forallE_sort, VExpr.instRev_appN, + VExpr.instRev_closedN _ + (C := .const family.raw.name gen.sourceLevels) trivial, + List.map_append, + VExpr.map_instRev_bvarRevRange_ge _ _ _ + (by rw [hlen]; omega), + show (gen.idxTel family).length + Δ.length + + gen.familyCount + gen.minorCount - idxs.length = + Δ.length + gen.familyCount + gen.minorCount from by + rw [hlen] + omega, + VExpr.bvarRevRange_congr' 0 hlen.symm, + VExpr.map_instRev_bvarRevRange] at hshape + rw [hlen] at hshape + have hfull := hshape.snoc ha + simp only [VExpr.inst] at hfull + change env.SpineWF gen.recUvars _ + (VExpr.forallN + (VExpr.liftTelN + (Δ.length + gen.familyCount + gen.minorCount) + (gen.idxTel family) 0) + (VExpr.forallN + [VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((gen.idxTel family).length + Δ.length + + gen.familyCount + gen.minorCount) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)] + (.sort gen.motiveLevel))) + (idxs ++ [a]) (.sort gen.motiveLevel) at hfull + rw [← VExpr.forallN_append] at hfull + have hfullLen : (idxs ++ [a]).length = + (VExpr.liftTelN + (Δ.length + gen.familyCount + gen.minorCount) + (gen.idxTel family) 0 ++ + [VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((gen.idxTel family).length + Δ.length + + gen.familyCount + gen.minorCount) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.idxTel family).length)]).length := by + simp only [List.length_append, List.length_singleton, + VExpr.liftTelN_length, hlen] + have hactual := hfull.retarget hfullLen + (VExpr.app + (VExpr.appN + (.bvar + (gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + (gen.idxTel family).length + + Δ.length + 1)) + (VExpr.bvarRevRange 1 (gen.idxTel family).length)) + (.bvar 0)) + rw [VExpr.forallN_append] at hactual + have happ := hactual.hasType_appN hb + rw [show VExpr.app + (VExpr.appN + (.bvar + (gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + (gen.idxTel family).length + + Δ.length + 1)) + (VExpr.bvarRevRange 1 (gen.idxTel family).length)) + (.bvar 0) = + VExpr.appN + (.bvar + (gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + (gen.idxTel family).length + + Δ.length + 1)) + (VExpr.bvarRevRange 0 ((gen.idxTel family).length + 1)) from by + rw [VExpr.bvarRevRange_congr' 0 + (show (gen.idxTel family).length + 1 = + 1 + (gen.idxTel family).length by omega), + ← VExpr.bvarRevRange_append (gen.idxTel family).length 1] + simpa [VExpr.bvarRevRange, VExpr.appN] using + (VExpr.appN_append + (.bvar + (gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + (gen.idxTel family).length + + Δ.length + 1)) + (VExpr.bvarRevRange 1 (gen.idxTel family).length) + [VExpr.bvar 0]).symm, + VExpr.instRev_appN, + VExpr.instRev_bvar_ge _ (by + simp only [List.length_append, List.length_singleton] + rw [hlen] + omega), + VExpr.bvarRevRange_congr' 0 + (show (gen.idxTel family).length + 1 = + (idxs ++ [a]).length by simp [hlen]), + VExpr.map_instRev_bvarRevRange] at happ + rw [show gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + (gen.idxTel family).length + Δ.length + 1 - + (idxs ++ [a]).length = + gen.familyCount - 1 - family.view.ordinal + + gen.minorCount + Δ.length from by + simp only [List.length_append, List.length_singleton] + rw [hlen] + omega] at happ + simpa [List.length_append, hlen, + BlockGenerationChecked.recBase, + gen.familyNameAt_ordinal hfamily] using happ + +/-- The constructor application appearing in a mutual rule has the selected +owner-family application as its type. -/ +theorem ctorAppRule_hasType + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) + {family : NormalizedFamily} (_hfamily : family ∈ gen.families) + (hname : family.raw.name = constructor.familyName) : + env.HasType gen.recUvars + ((VExpr.liftTelN + (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) 0).reverse ++ + (gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse))) + (VExpr.appN + (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length + + gen.familyCount + gen.minorCount) + source.nparams ++ + VExpr.bvarRevRange 0 + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length)) + (VExpr.appN (.const family.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length + + gen.familyCount + gen.minorCount) + source.nparams ++ + (constructor.ctor.resultIndicesR source.uvars + gen.elimination).map fun e => + e.liftN (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length)) := by + have h := S.ctorApp_transport hconstructor hname + (gen.minorTypes.reverse ++ gen.motiveTypes.reverse) + (g := gen.familyCount + gen.minorCount) + (by + simp only [List.length_append, List.length_reverse, + gen.minorTypes_length, gen.motiveTypes_length] + omega) + [] (d := 0) rfl + rw [VExpr.bvarRevRange_congr source.nparams + (show + 0 + (gen.familyCount + gen.minorCount + + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length) = + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length + + gen.familyCount + gen.minorCount by omega)] at h + simpa [List.append_assoc] using h + +/-- Parameters, every motive, every flattened minor, and the selected +constructor fields form the binder telescope of a mutual rule. -/ +theorem ruleBinders_onTel + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) : + env.OnTel gen.recUvars [] + (gen.paramsTel ++ gen.motiveTypes ++ gen.minorTypes ++ + VExpr.liftTelN + (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) 0) := by + have hF₀ := S.fields_onTel_minor hconstructor + have hF := hF₀.weakN S.ord + (Ctx.LiftN.zero + (Γ := gen.motiveTypes.reverse ++ gen.paramsTel.reverse) + gen.minorTypes.reverse) + rw [VExpr.liftTelN_liftTelN, + liftTelN_congr _ _ + (show gen.familyCount + gen.minorTypes.reverse.length = + gen.familyCount + gen.minorCount by + simp only [List.length_reverse, gen.minorTypes_length])] at hF + refine OnTel.append + (OnTel.append + (OnTel.append S.paramsTel_onTel + (by simpa only [List.append_nil] using S.motiveTypes_onTel)) + (by simpa only [List.append_nil, List.reverse_append, + List.append_assoc] using S.minorTypes_onTel)) ?_ + simpa only [List.append_nil, List.append_assoc, + List.reverse_append] using hF + +/-- The constructor-headed left side of a mutual iota rule has the owner +motive application as its type. -/ +theorem recRuleApp_hasType + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) + (hrecs : ∀ family ∈ gen.families, + env.constants (.str family.raw.name "rec") = + some (gen.recursor family)) : + env.HasType gen.recUvars + ((VExpr.liftTelN + (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) 0).reverse ++ + (gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse))) + (VExpr.appN + (gen.recBase + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length constructor.owner) + (((constructor.ctor.resultIndicesR source.uvars + gen.elimination).map fun e => + e.liftN (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length) ++ + [VExpr.appN + (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length + + gen.familyCount + gen.minorCount) + source.nparams ++ + VExpr.bvarRevRange 0 + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length)])) + (VExpr.appN + (.bvar + (gen.familyCount - 1 - constructor.owner + + gen.minorCount + + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length)) + (((constructor.ctor.resultIndicesR source.uvars + gen.elimination).map fun e => + e.liftN (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length) ++ + [VExpr.appN + (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length + + gen.familyCount + gen.minorCount) + source.nparams ++ + VExpr.bvarRevRange 0 + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length)])) := by + obtain ⟨family, hfamily, howner, hname, hindices⟩ := + (S.ctorWF constructor hconstructor).owner + let Bs := constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination + let common := gen.familyCount + gen.minorCount + let mid := gen.minorTypes.reverse ++ gen.motiveTypes.reverse + have hmid : mid.length = common := by + simp only [mid, common, List.length_append, List.length_reverse, + gen.minorTypes_length, gen.motiveTypes_length] + omega + have hSp₀ := S.result_transport hconstructor hfamily hindices + mid hmid [] (d := 0) rfl + have hSp : env.SpineWF gen.recUvars + ((VExpr.liftTelN common Bs 0).reverse ++ + (gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse))) + (VExpr.forallN + (VExpr.liftTelN (Bs.length + common) + (gen.idxTel family) 0) + (.sort (gen.validated.resultLevel.inst gen.sourceLevels))) + ((constructor.ctor.resultIndicesR source.uvars gen.elimination).map + fun e => e.liftN common Bs.length) + (.sort (gen.validated.resultLevel.inst gen.sourceLevels)) := by + simpa [Bs, common, mid, List.append_assoc, + Nat.add_assoc] using hSp₀ + have hidxLen : + ((constructor.ctor.resultIndicesR source.uvars gen.elimination).map + fun e => e.liftN common Bs.length).length = + (gen.idxTel family).length := by + have hlen := hSp.forallN_sort_length + simpa only [VExpr.liftTelN_length] using hlen + have ha := S.ctorAppRule_hasType hconstructor hfamily hname + have hout := S.recApp_hasType hfamily (hrecs family hfamily) + (VExpr.liftTelN common Bs 0).reverse + (by simpa [common, List.length_reverse, VExpr.liftTelN_length, + Nat.add_assoc] using hSp) + hidxLen + (by simpa only [Bs, common, List.length_reverse, + VExpr.liftTelN_length] using ha) + simpa only [Bs, common, howner, List.length_reverse, + VExpr.liftTelN_length] using hout + +/-- Every recursive field contributes a well-typed rule call to the +recursor selected by that field's certified target family. -/ +theorem blockRuleCall_hasType + {constructor : NormalizedBlockCtor} + (hconstructor : constructor ∈ gen.flatCtors) + (hrecs : ∀ family ∈ gen.families, + env.constants (.str family.raw.name "rec") = + some (gen.recursor family)) + {r : RecArg} + (hr : r ∈ constructor.ctor.recArgsR source.uvars gen.elimination) : + env.HasType gen.recUvars + ((VExpr.liftTelN + (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) 0).reverse ++ + (gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse))) + (BlockGenerationChecked.blockRuleCall + (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length + (gen.recBase + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length r.targetType) r) + (BlockGenerationChecked.blockRuleIH + gen.familyCount gen.minorCount + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length r) := by + obtain ⟨r₀, hr₀, rfl⟩ := NormalizedCtor.recArgsR_mem hr + obtain ⟨family, hfamily, hord, ⟨Bview, hBview, hshape⟩, hsem⟩ := + (S.ctorWF constructor hconstructor).recursive r₀ hr₀ + let ls := gen.sourceLevels + let r := r₀.instL ls + let d := gen.familyCount + let k := gen.minorCount + let common := d+k + let Bs := constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination + let m := Bs.length + let j := r₀.fieldIndex + let Fs := VExpr.liftTelN common Bs 0 + let As := BlockGenerationChecked.blockRuleBinders common m r + let idxs := r.indices.map fun e => + (e.liftN common (r.fieldIndex+r.binders.length)).liftN + (m-r.fieldIndex) r.binders.length + let Γ := Fs.reverse ++ + (gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse)) + have hjview : r₀.fieldIndex < constructor.ctor.view.fields.length := + (List.getElem?_eq_some_iff.1 hBview).1 + have hjm : j < m := by + have hfields := gen.flatCtor_fields_length hconstructor + simp only [j, m, Bs, NormalizedCtor.fieldsR_length] + omega + have hjraw : r₀.fieldIndex < + (constructor.ctor.rawFields source.nparams).length := by + simpa [j, m, Bs, NormalizedCtor.fieldsR_length] using hjm + let Braw := + (constructor.ctor.rawFields source.nparams)[r₀.fieldIndex] + have hBraw : + (constructor.ctor.rawFields source.nparams)[r₀.fieldIndex]? = + some Braw := + List.getElem?_eq_getElem hjraw + have hcommon : + (gen.minorTypes.reverse ++ gen.motiveTypes.reverse).length = + common := by + simp only [List.length_append, List.length_reverse, + gen.minorTypes_length, gen.motiveTypes_length] + dsimp only [common, d, k] + omega + have hFsLen : Fs.length = m := by + simp [Fs, m, VExpr.liftTelN_length] + have ht := S.recArg_transport hconstructor hfamily hsem hjview + (gen.minorTypes.reverse ++ gen.motiveTypes.reverse) hcommon + (Fs.drop j).reverse (d := m-j) (by + simp only [List.length_reverse, List.length_drop, hFsLen]) + dsimp only [r, j, RecArg.instL] at ht + have hctx : + (Fs.drop j).reverse ++ + ((VExpr.liftTelN common (Bs.take j) 0).reverse ++ + ((gen.minorTypes.reverse ++ gen.motiveTypes.reverse) ++ + gen.paramsTel.reverse)) = Γ := by + dsimp only [Γ, Fs] + rw [← VExpr.liftTelN_take, List.append_assoc, + ← List.append_assoc + (((VExpr.liftTelN common Bs 0).drop j).reverse), + ← List.reverse_append, List.take_append_drop, + ← List.append_assoc] + have htel : env.OnTel gen.recUvars Γ As := by + rw [hctx] at ht + simpa [r, As, m, common, j, RecArg.instL, + BlockGenerationChecked.blockRuleBinders] using ht.1 + have hsp : env.SpineWF gen.recUvars + (As.reverse ++ Γ) + (VExpr.forallN + (VExpr.liftTelN + (m + r.binders.length + common) + (gen.idxTel family) 0) + (.sort (gen.validated.resultLevel.inst ls))) + idxs + (.sort (gen.validated.resultLevel.inst ls)) := by + rw [hctx] at ht + simpa [r, As, idxs, m, common, j, ls, + RecArg.instL, BlockGenerationChecked.blockRuleBinders, + List.append_assoc, + show j + r₀.binders.length + common + (m-j) = + m + r₀.binders.length + common by omega] using ht.2 + have hF : Γ[m-1-j]? = + some ((Braw.instL ls).liftN common j) := by + dsimp only [Γ, Fs] + rw [List.getElem?_append_left + (by + simp only [List.length_reverse, VExpr.liftTelN_length] + omega), + List.getElem?_reverse (by rw [hFsLen]; omega), + VExpr.liftTelN_length, + show m - 1 - (m - 1 - j) = j by omega, + VExpr.liftTelN_getElem?, + NormalizedCtor.fieldsR_getElem?, hBraw] + simp [ls] + have hlu := Lookup.of_getElem? hF + rw [show m-1-j+1 = m-j by omega] at hlu + dsimp only [j, r] at hlu + have hf0 := VEnv.HasType.bvar + (env := env) (U := gen.recUvars) hlu + obtain ⟨u, hdom₀⟩ := + S.emittedField_defeq hconstructor hBraw hBview + have hdom₁ := hdom₀.instL + (U' := gen.recUvars) gen.sourceLevels_wf + have hdomChecked : env.IsDefEq gen.recUvars + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination |>.take r₀.fieldIndex).reverse ++ + (gen.block.checked.params.map (VExpr.instL ls)).reverse) + (Braw.instL ls) (Bview.instL ls) ((VExpr.sort u).instL ls) := by + simpa [NormalizedCtor.fieldsR, List.map_append, + List.map_reverse, List.map_take] using hdom₁ + have hprefix := + S.generationFieldPrefix_ctx_rec hconstructor r₀.fieldIndex + have hdomGeneration := hdomChecked.defeqDFC S.ord + (hprefix.symm S.ord) + have hjlen : (Bs.take r₀.fieldIndex).length = + r₀.fieldIndex := by + simp only [Bs, NormalizedCtor.fieldsR, + List.length_take, List.length_map] + omega + have Wmid := Ctx.LiftN.consTel (n := common) + (Bs.take r₀.fieldIndex) + (Ctx.LiftN.zero (n := common) (Γ := gen.paramsTel.reverse) + (gen.minorTypes.reverse ++ gen.motiveTypes.reverse) + (h := hcommon)) + rw [hjlen, Nat.add_zero] at Wmid + have hdom₂ := hdomGeneration.weakN S.ord Wmid + have Wstack := Ctx.LiftN.zero (n := m-j) + (Γ := (VExpr.liftTelN common (Bs.take j) 0).reverse ++ + ((gen.minorTypes.reverse ++ gen.motiveTypes.reverse) ++ + gen.paramsTel.reverse)) + (Fs.drop j).reverse + (h := by + simp only [List.length_reverse, List.length_drop, hFsLen]) + have hdom₃ := hdom₂.weakN S.ord Wstack + rw [hctx] at hdom₃ + have hfView := hdom₃.defeq hf0 + have hfield := blockMinor_fieldType_of_eq hshape common m 0 + (by simpa [j] using hjm) gen.elimination + simp only [RecArg.instL] at hfield + dsimp only [j] at hfView + simp only [Nat.add_zero] at hfield + rw [hfield] at hfView + have hf := hfView.weakN S.ord + (Ctx.LiftN.zero (Γ := Γ) As.reverse) + have hmajor := VEnv.HasType.appN_selfSpine + (env := env) (U := gen.recUvars) + (As := As) + (B := VExpr.appN (.const family.raw.name ls) + (VExpr.bvarRevRange + (m + r.binders.length + common) source.nparams ++ idxs)) + (Δ := []) (Γ := Γ) (by + simpa [As, r, idxs, j, common, ls, RecArg.instL, + BlockGenerationChecked.blockRuleBinders, + BlockGenerationChecked.blockMinorBinders, + List.length_reverse, List.map_map, + Function.comp_def] using hf) + simp only [List.length_nil, VExpr.liftN_zero, + List.nil_append] at hmajor + have hAsLen : As.length = r.binders.length := by + simp [As, BlockGenerationChecked.blockRuleBinders, + VExpr.liftTelN_length] + have hmajor' : env.HasType gen.recUvars (As.reverse ++ Γ) + ((VExpr.bvar (m-1-r.fieldIndex+As.length)).appN + (VExpr.bvarRevRange 0 As.length)) + (VExpr.appN (.const family.raw.name ls) + (VExpr.bvarRevRange + (m+r.binders.length+common) source.nparams ++ idxs)) := by + simpa [As, common, r, RecArg.instL, + BlockGenerationChecked.blockRuleBinders, + VExpr.liftN, liftVar_le, Nat.add_comm] using hmajor + rw [hAsLen] at hmajor' + have hlen : idxs.length = (gen.idxTel family).length := by + have hidx := hsem.2.forallN_sort_length + simp only [idxs, List.length_map, VExpr.liftTelN_length, + BlockGenerationChecked.idxTel] at hidx ⊢ + simpa [r, RecArg.instL] using hidx.trans + (gen.shape.2.2.2.2 family hfamily).2.2.2.1.symm + have hcall := S.recApp_hasType hfamily (hrecs family hfamily) + (As.reverse ++ Fs.reverse) + (by + simpa [Γ, List.append_assoc, hAsLen, hFsLen, + common, d, k, + Nat.add_comm, Nat.add_left_comm, + Nat.add_assoc] using hsp) + hlen + (by + simpa [Γ, List.append_assoc, hAsLen, hFsLen, + common, d, k, + Nat.add_comm, Nat.add_left_comm, + Nat.add_assoc] using hmajor') + have hbaseLift : + (gen.recBase m r.targetType).liftN r.binders.length = + gen.recBase (m+r.binders.length) r.targetType := by + simp only [BlockGenerationChecked.recBase, VExpr.liftN_appN, + VExpr.liftN, List.map_map] + rw [bvarRevRange_liftN_ge _ _ _ _ (Nat.zero_le _)] + apply congrArg (VExpr.appN _) + apply VExpr.bvarRevRange_congr + omega + have hlam := HasType.lamN htel (by + simpa [Γ, Fs, hAsLen, hFsLen, hbaseLift, + List.append_assoc, hord, r, RecArg.instL, + common, d, k, + Nat.add_comm, Nat.add_left_comm, + Nat.add_assoc] using hcall) + have hrecPos : r₀.binders.length + m = m + r₀.binders.length := by + omega + have hfieldPos : + r₀.binders.length + (m-1-r₀.fieldIndex) = + m-1-r₀.fieldIndex+r₀.binders.length := by + omega + have hmotivePos : + r₀.binders.length + + (gen.familyCount - 1 - r₀.targetType + (gen.minorCount+m)) = + gen.familyCount - 1 - r₀.targetType + gen.minorCount + m + + r₀.binders.length := by + ac_rfl + rw [hrecPos, hfieldPos, hmotivePos] at hlam + change env.HasType gen.recUvars Γ + (BlockGenerationChecked.blockRuleCall common m + (gen.recBase m r.targetType) r) + (VExpr.forallN As + (VExpr.appN + (.bvar (d - 1 - r.targetType + k + m + r.binders.length)) + (idxs ++ + [VExpr.appN + (.bvar (m - 1 - r.fieldIndex + r.binders.length)) + (VExpr.bvarRevRange 0 r.binders.length)]))) + have hcallEq : + BlockGenerationChecked.blockRuleCall common m + (gen.recBase m r.targetType) r = + VExpr.lamN As + (VExpr.appN + (gen.recBase (m+r.binders.length) r.targetType) + (idxs ++ + [VExpr.appN + (.bvar (m-1-r.fieldIndex+r.binders.length)) + (VExpr.bvarRevRange 0 r.binders.length)])) := by + simp [BlockGenerationChecked.blockRuleCall, As, idxs, hbaseLift] + rw [hcallEq] + simpa [r, RecArg.instL, List.length_map] using hlam + +/-- The selected flattened mutual minor applied to its fields and routed +recursive calls has the owner's motive as its result. -/ +theorem minorApp_hasType {i : Nat} + {constructor : NormalizedBlockCtor} + (hci : gen.flatCtors[i]? = some constructor) + (hrecs : ∀ family ∈ gen.families, + env.constants (.str family.raw.name "rec") = + some (gen.recursor family)) : + env.HasType gen.recUvars + ((VExpr.liftTelN + (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) 0).reverse ++ + (gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse))) + (VExpr.appN + (.bvar + (gen.minorCount - 1 - i + + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length)) + (VExpr.bvarRevRange 0 + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length ++ + (constructor.ctor.recArgsR source.uvars gen.elimination).map + fun r => + BlockGenerationChecked.blockRuleCall + (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length + (gen.recBase + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length r.targetType) r)) + (VExpr.appN + (.bvar + (gen.familyCount - 1 - constructor.owner + gen.minorCount + + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length)) + (((constructor.ctor.resultIndicesR source.uvars + gen.elimination).map fun e => + e.liftN (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length) ++ + [VExpr.appN + (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + ((constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length + gen.familyCount + + gen.minorCount) + source.nparams ++ + VExpr.bvarRevRange 0 + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination).length)])) := by + obtain ⟨hik, -⟩ := List.getElem?_eq_some_iff.1 hci + have hconstructor := List.mem_of_getElem? hci + obtain ⟨family, hfamily, howner, -, -⟩ := + (S.ctorWF constructor hconstructor).owner + let d := gen.familyCount + let k := gen.minorCount + let common := d+k + let Bs := constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination + let m := Bs.length + let rs := constructor.ctor.recArgsR source.uvars gen.elimination + let Fs := VExpr.liftTelN common Bs 0 + let D := VExpr.appN + (.bvar (d - 1 - constructor.owner + m + rs.length)) + (((constructor.ctor.resultIndicesR source.uvars + gen.elimination).map fun e => + (e.liftN d m).liftN rs.length) ++ + [VExpr.appN + (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (rs.length+m+d) source.nparams ++ + VExpr.bvarRevRange rs.length m)]) + let Dfin := VExpr.appN + (.bvar (d - 1 - constructor.owner + k + m)) + (((constructor.ctor.resultIndicesR source.uvars + gen.elimination).map fun e => e.liftN common m) ++ + [VExpr.appN + (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (m+common) source.nparams ++ + VExpr.bvarRevRange 0 m)]) + have hownerLt : constructor.owner < d := by + rw [← howner] + simpa [d] using gen.family_ordinal_lt hfamily + have hrsLt : ∀ r ∈ rs, r.fieldIndex < m := by + intro r hr + obtain ⟨r₀, hr₀, rfl⟩ := + NormalizedCtor.recArgsR_mem (show + r ∈ constructor.ctor.recArgsR source.uvars gen.elimination from + by simpa [rs] using hr) + obtain ⟨family₀, hfamily₀, htarget, + ⟨Bview, hfield, hshape⟩, hsem⟩ := + (S.ctorWF constructor hconstructor).recursive r₀ hr₀ + have hj := (List.getElem?_eq_some_iff.1 hfield).1 + simp only [RecArg.instL] + dsimp only [m, Bs] + rw [NormalizedCtor.fieldsR_length] + rw [gen.flatCtor_fields_length hconstructor] + exact hj + have hik' : i < k := by + simpa [k] using hik + rw [VExpr.appN_append] + have hminorAt : + gen.minorTypes[i]? = + some ((gen.minorType constructor).liftN i) := by + simpa [BlockGenerationChecked.minorTypes, hci] using + (gen.minorTypesAux_getElem? gen.flatCtors 0 i) + have hlu0 : + (Fs.reverse ++ + (gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse)))[ + k - 1 - i + m]? = + some ((gen.minorType constructor).liftN i) := by + rw [getElem?_rstack_mid _ _ _ + (by simp [Fs, m, VExpr.liftTelN_length] <;> omega) + (by simp [Fs, m, k, gen.minorTypes_length, + VExpr.liftTelN_length] <;> omega), + show k - 1 - i + m - Fs.reverse.length = k - 1 - i by + simp [Fs, m, VExpr.liftTelN_length], + List.getElem?_reverse (by + rw [gen.minorTypes_length] + omega), + show gen.minorTypes.length - 1 - (k - 1 - i) = i by + rw [gen.minorTypes_length] + dsimp only [k] + omega, + hminorAt] + have hlu := Lookup.of_getElem? hlu0 + rw [VExpr.liftN_liftN, + show i + (k - 1 - i + m + 1) = m+k by omega] at hlu + have hminorEq : + (gen.minorType constructor).liftN (m+k) = + (VExpr.forallN Fs + ((VExpr.forallN + (BlockGenerationChecked.blockIHsFromRecArgs d m rs 0) + D).liftN k m)).liftN m := by + simp only [BlockGenerationChecked.minorType] + conv => lhs; rw [VExpr.liftN_forallN, + VExpr.liftTelN_liftTelN, + liftTelN_congr _ _ + (show d + (m+k) = common+m by + dsimp only [common] + omega), + show 0 + (VExpr.liftTelN d Bs 0).length = m by + simp [m, VExpr.liftTelN_length]] + conv => rhs; rw [VExpr.liftN_forallN, + VExpr.liftTelN_liftTelN, + show 0 + Fs.length = m by + simp [Fs, m, VExpr.liftTelN_length], + VExpr.liftN'_liftN_hi, + Nat.add_comm k m] + have hfields := HasType.appN_selfSpine + (env := env) (U := gen.recUvars) + (As := Fs) + (B := (VExpr.forallN + (BlockGenerationChecked.blockIHsFromRecArgs d m rs 0) + D).liftN k m) + (Δ := []) + (Γ := gen.minorTypes.reverse ++ + (gen.motiveTypes.reverse ++ gen.paramsTel.reverse)) + (f := .bvar (k-1-i+m)) + (by + have hb := VEnv.HasType.bvar + (env := env) (U := gen.recUvars) hlu + rw [hminorEq] at hb + simpa [Fs, VExpr.liftTelN_length] using hb) + simp only [List.length_nil, VExpr.liftN_zero] at hfields + rw [BlockGenerationChecked.blockIHs_liftN' + d m k rs hrsLt 0 D (cut := m) rfl] at hfields + have hD : D.liftN k (m+0+rs.length) = + Dfin.liftN rs.length := by + dsimp only [D, Dfin] + rw [VExpr.liftN_appN, VExpr.liftN_appN, + List.map_append, List.map_append, + List.map_map, List.map_map] + show VExpr.appN _ (_ ++ [_]) = VExpr.appN _ (_ ++ [_]) + congr 1 + · show + VExpr.bvar + (liftVar k + (d - 1 - constructor.owner + m + rs.length) + (m+0+rs.length)) = + VExpr.bvar + (liftVar rs.length + (d - 1 - constructor.owner + k + m) 0) + rw [liftVar_le (by omega), liftVar_le (Nat.zero_le _)] + congr 1 + omega + · congr 1 + · apply List.map_congr_left + intro e _ + simp only [Function.comp_apply] + rw [show m+0+rs.length = m+rs.length by omega, + VExpr.liftN_liftN_midN e d k rs.length (Nat.zero_le _)] + · congr 1 + simp only [Function.comp_apply] + rw [show m+0+rs.length = m+rs.length by omega, + VExpr.liftN_appN, VExpr.liftN_appN, + List.map_append, List.map_append, + bvarRevRange_liftN_ge _ _ _ _ (by omega), + VExpr.bvarRevRange_liftN_high _ _ _ _ (by omega), + bvarRevRange_liftN_ge _ _ _ _ (Nat.zero_le _), + bvarRevRange_liftN_ge _ _ _ _ (Nat.zero_le _), + VExpr.bvarRevRange_congr source.nparams + (show k + (rs.length+m+d) = + rs.length + (m+common) by + dsimp only [common] + omega), + VExpr.bvarRevRange_congr m + (show rs.length = rs.length+0 by omega)] + rfl + rw [hD] at hfields + have hres := hasType_appN_blockRuleIHs + (env := env) (gen := gen) (d := d) (m := m) (k := k) + (rs := rs) + (argOf := fun r => + BlockGenerationChecked.blockRuleCall common m + (gen.recBase m r.targetType) r) + (Dfin := Dfin) + (fun r hr => by + simpa [d, k, common, m, Bs] using + S.blockRuleCall_hasType hconstructor hrecs + (show r ∈ constructor.ctor.recArgsR source.uvars + gen.elimination by simpa [rs] using hr)) + hfields + simpa [Fs, Bs, m, rs, d, k, common, Dfin, + VExpr.liftTelN_length, Nat.add_assoc] using hres + +/-- Every flattened mutual iota rule is well formed once all family +recursors are available. -/ +theorem rule_WF {i : Nat} + {constructor : NormalizedBlockCtor} + (hci : gen.flatCtors[i]? = some constructor) + (hrecs : ∀ family ∈ gen.families, + env.constants (.str family.raw.name "rec") = + some (gen.recursor family)) : + (gen.rule i constructor).WF env := by + have hconstructor := List.mem_of_getElem? hci + refine ⟨?_, ?_⟩ + · show env.HasType gen.recUvars [] + (VExpr.lamN + (gen.paramsTel ++ gen.motiveTypes ++ gen.minorTypes ++ + VExpr.liftTelN + (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) 0) + _) + (VExpr.forallN _ _) + refine HasType.lamN (S.ruleBinders_onTel hconstructor) ?_ + simp only [List.reverse_append, List.append_nil, + List.append_assoc] + simpa only [Nat.add_assoc] using + S.recRuleApp_hasType hconstructor hrecs + · show env.HasType gen.recUvars [] + (VExpr.lamN + (gen.paramsTel ++ gen.motiveTypes ++ gen.minorTypes ++ + VExpr.liftTelN + (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams + gen.elimination) 0) + _) + (VExpr.forallN _ _) + refine HasType.lamN (S.ruleBinders_onTel hconstructor) ?_ + simp only [List.reverse_append, List.append_nil, + List.append_assoc] + simpa only [Nat.add_assoc] using + S.minorApp_hasType hci hrecs + +end BlockGenerationEnv /-- The public inductive-declaration contract is monotone in its prefix environment. This lets replay fixtures prepend independently verified @@ -3058,22 +7047,22 @@ theorem emittedPrefix_ctx {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) (j : Nat) : env.IsDefEqCtx source.uvars [] ((ctor.rawFields source.nparams |>.take j).reverse ++ - gen.block.rawParams.reverse) + gen.block.checked.params.reverse) ((ctor.view.fields.take j).reverse ++ gen.block.checked.params.reverse) := by have h := ((S.ctorWF ctor hctor).emittedTel.take (source.nparams + j)).ctx + have hviewLen : + gen.block.checked.params.length = source.nparams := + gen.shape.2.1.symm.trans gen.shape.1 have hraw : - (gen.block.rawParams ++ ctor.rawFields source.nparams).take + (gen.block.checked.params ++ ctor.rawFields source.nparams).take (source.nparams + j) = - gen.block.rawParams ++ + gen.block.checked.params ++ (ctor.rawFields source.nparams).take j := by - rw [← gen.shape.1] + rw [← hviewLen] rw [List.take_append, List.take_of_length_le (by omega)] simp - have hviewLen : - gen.block.checked.params.length = source.nparams := - gen.shape.2.1.symm.trans gen.shape.1 have hview : (gen.block.checked.params ++ ctor.view.fields).take (source.nparams + j) = @@ -3094,19 +7083,19 @@ theorem emittedField_defeq {ctor : NormalizedCtor} (hB' : ctor.view.fields[j]? = some B') : ∃ u, env.IsDefEq source.uvars ((ctor.rawFields source.nparams |>.take j).reverse ++ - gen.block.rawParams.reverse) + gen.block.checked.params.reverse) B B' (.sort u) := by + have hviewLen : + gen.block.checked.params.length = source.nparams := + gen.shape.2.1.symm.trans gen.shape.1 have hraw : getElem? - (gen.block.rawParams ++ ctor.rawFields source.nparams) + (gen.block.checked.params ++ ctor.rawFields source.nparams) (source.nparams + j) = some B := by rw [List.getElem?_append_right (by - rw [gen.shape.1] - omega), gen.shape.1] + rw [hviewLen] + omega), hviewLen] simpa using hB - have hviewLen : - gen.block.checked.params.length = source.nparams := - gen.shape.2.1.symm.trans gen.shape.1 have hview : getElem? (gen.block.checked.params ++ ctor.view.fields) @@ -3118,11 +7107,11 @@ theorem emittedField_defeq {ctor : NormalizedCtor} obtain ⟨u, h⟩ := (S.ctorWF ctor hctor).emittedTel.getElem? hraw hview have htake : - (gen.block.rawParams ++ ctor.rawFields source.nparams).take + (gen.block.checked.params ++ ctor.rawFields source.nparams).take (source.nparams + j) = - gen.block.rawParams ++ + gen.block.checked.params ++ (ctor.rawFields source.nparams).take j := by - rw [← gen.shape.1] + rw [← hviewLen] rw [List.take_append, List.take_of_length_le (by omega)] simp simp only [NormalizedCtor.emittedBinders] at h @@ -3137,7 +7126,7 @@ theorem rawRecArg_WF {ctor : NormalizedCtor} r.WF source.uvars env gen.block.checked.resultLevel gen.block.checked.indices ((ctor.rawFields source.nparams |>.take r.fieldIndex).reverse ++ - gen.block.rawParams.reverse) := by + gen.block.checked.params.reverse) := by exact (S.viewRecArg_WF hctor hr).defeqDFC S.ord ((S.emittedPrefix_ctx hctor r.fieldIndex).symm S.ord) @@ -3168,14 +7157,23 @@ theorem rawIndexTel_defeq : rw [hrawTake, hrawDrop, hviewDrop] at h simpa using h +/-- The raw/view index relation transported to the checked parameter base +used by generated artifacts. -/ +theorem emittedIndexTel_defeq : + env.TelDefEq source.uvars gen.block.checked.params.reverse + gen.block.rawIndices gen.block.checked.indices := + S.rawIndexTel_defeq.defeqDFC S.ord S.rawParams_ctx + /-- The raw/view index telescope relation transported into recursor universes. -/ theorem rawIndexTel_defeq_rec : - env.TelDefEq (source.uvars + 1) gen.paramsTel.reverse gen.idxTel + env.TelDefEq (gen.recUvars) gen.paramsTel.reverse gen.idxTel (gen.block.checked.indices.map - (VExpr.instL (VLevel.params' source.uvars 1))) := by - have h := S.rawIndexTel_defeq.instL - (U' := source.uvars + 1) VLevel.params'_one_wf + (VExpr.instL (gen.sourceLevels))) := by + have hdecl := S.emittedIndexTel_defeq.defeqDFC S.ord + (S.generationParams_ctx.symm S.ord) + have h := hdecl.instL + (U' := gen.recUvars) gen.sourceLevels_wf simpa [GenerationChecked.paramsTel, GenerationChecked.idxTel, List.map_reverse] using h @@ -3188,32 +7186,32 @@ theorem recArg_transport {ctor : NormalizedCtor} (hr₀ : r₀ ∈ ctor.view.recursive) (mid : List VExpr) {g : Nat} (hg : mid.length = g) (As₂ : List VExpr) {d : Nat} (hd : As₂.length = d) : - let r := r₀.instL (VLevel.params' source.uvars 1) + let r := r₀.instL (gen.sourceLevels) let As := VExpr.liftTelN d (VExpr.liftTelN g r.binders r.fieldIndex) 0 - env.OnTel (source.uvars + 1) + env.OnTel (gen.recUvars) (As₂ ++ ((VExpr.liftTelN g - ((ctor.fieldsR source.uvars source.nparams).take + ((ctor.fieldsR source.uvars source.nparams gen.elimination).take r.fieldIndex) 0).reverse ++ (mid ++ gen.paramsTel.reverse))) As ∧ - env.SpineWF (source.uvars + 1) + env.SpineWF (gen.recUvars) (As.reverse ++ (As₂ ++ ((VExpr.liftTelN g - ((ctor.fieldsR source.uvars source.nparams).take + ((ctor.fieldsR source.uvars source.nparams gen.elimination).take r.fieldIndex) 0).reverse ++ (mid ++ gen.paramsTel.reverse)))) (VExpr.forallN (VExpr.liftTelN (r.fieldIndex + r.binders.length + g + d) gen.idxTel 0) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1)))) + (gen.sourceLevels)))) (r.indices.map fun e => (e.liftN g (r.fieldIndex + r.binders.length)).liftN d r.binders.length) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1))) := by + (gen.sourceLevels))) := by dsimp only - let ls := VLevel.params' source.uvars 1 + let ls := gen.sourceLevels have hjlt : r₀.fieldIndex < (ctor.rawFields source.nparams).length := by have hview := S.viewRecArg_lt hctor hr₀ @@ -3222,34 +7220,52 @@ theorem recArg_transport {ctor : NormalizedCtor} omega have hsem := S.rawRecArg_WF hctor hr₀ have htel₁ := hsem.1.instL - (U' := source.uvars + 1) VLevel.params'_one_wf + (U' := gen.recUvars) gen.sourceLevels_wf have hsp₁ := hsem.2.instL - (U' := source.uvars + 1) VLevel.params'_one_wf - have hctx : - (((ctor.rawFields source.nparams).take r₀.fieldIndex).reverse ++ - gen.block.rawParams.reverse).map (VExpr.instL ls) = - ((ctor.fieldsR source.uvars source.nparams).take - r₀.fieldIndex).reverse ++ gen.paramsTel.reverse := by - simp [ls, NormalizedCtor.fieldsR, GenerationChecked.paramsTel, - List.map_reverse, List.map_take] - rw [hctx] at htel₁ - rw [List.map_append, List.map_reverse, hctx] at hsp₁ + (U' := gen.recUvars) gen.sourceLevels_wf + have htelChecked : env.OnTel (gen.recUvars) + ((ctor.fieldsR source.uvars source.nparams gen.elimination |>.take + r₀.fieldIndex).reverse ++ + (gen.block.checked.params.map (VExpr.instL ls)).reverse) + (r₀.binders.map (VExpr.instL ls)) := by + simpa [NormalizedCtor.fieldsR, List.map_append, + List.map_reverse, List.map_take] using htel₁ + have hspChecked : env.SpineWF (gen.recUvars) + ((r₀.binders.map (VExpr.instL ls)).reverse ++ + ((ctor.fieldsR source.uvars source.nparams gen.elimination |>.take + r₀.fieldIndex).reverse ++ + (gen.block.checked.params.map (VExpr.instL ls)).reverse)) + (VExpr.instL ls + (VExpr.forallN + (VExpr.liftTelN + (r₀.fieldIndex + r₀.binders.length) + gen.block.checked.indices 0) + (.sort gen.block.checked.resultLevel))) + (r₀.indices.map (VExpr.instL ls)) + (VExpr.instL ls (.sort gen.block.checked.resultLevel)) := by + simpa [List.map_append, List.map_reverse, + NormalizedCtor.fieldsR, List.map_take] using hsp₁ + have hprefix := S.generationFieldPrefix_ctx_rec hctor r₀.fieldIndex + have htelGeneration := htelChecked.defeqDFC S.ord + (hprefix.symm S.ord) + have hfull := htelGeneration.extendDefEqCtx hprefix + have hspGeneration := hspChecked.defeqDFC S.ord (hfull.symm S.ord) simp only [RecArg.instL, VExpr.instL_forallN, - VExpr.liftTelN_instL, List.map_reverse] at htel₁ hsp₁ + VExpr.liftTelN_instL, List.map_reverse] at htelGeneration hspGeneration have hjlen : - ((ctor.fieldsR source.uvars source.nparams).take + ((ctor.fieldsR source.uvars source.nparams gen.elimination).take r₀.fieldIndex).length = r₀.fieldIndex := by simp only [NormalizedCtor.fieldsR, List.length_take, List.length_map] omega have hidxField := S.rawIndexTel_defeq_rec.weakN S.ord (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) - ((ctor.fieldsR source.uvars source.nparams).take + ((ctor.fieldsR source.uvars source.nparams gen.elimination).take r₀.fieldIndex).reverse) rw [List.length_reverse, hjlen] at hidxField have hidxPrivate := hidxField.weakN S.ord (Ctx.LiftN.zero - (Γ := ((ctor.fieldsR source.uvars source.nparams).take + (Γ := ((ctor.fieldsR source.uvars source.nparams gen.elimination).take r₀.fieldIndex).reverse ++ gen.paramsTel.reverse) (r₀.binders.map (VExpr.instL ls)).reverse) simp only [List.length_reverse, List.length_map] at hidxPrivate @@ -3264,20 +7280,20 @@ theorem recArg_transport {ctor : NormalizedCtor} exact (S.viewRecArg_indices_length hctor hr₀).trans gen.shape.2.2.1.symm have hspRaw := - hidxPrivate.spine_sort S.ord hsp₁ hidxLen + hidxPrivate.spine_sort S.ord hspGeneration hidxLen have W₁ := Ctx.LiftN.consTel (n := mid.length) - ((ctor.fieldsR source.uvars source.nparams).take + ((ctor.fieldsR source.uvars source.nparams gen.elimination).take r₀.fieldIndex) (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) mid) rw [hjlen, Nat.add_zero] at W₁ - have htel₂ := htel₁.weakN S.ord W₁ + have htel₂ := htelGeneration.weakN S.ord W₁ have hsp₂ := hspRaw.weakN S.ord (Ctx.LiftN.consTel (r₀.binders.map (VExpr.instL ls)) W₁) rw [hg] at htel₂ hsp₂ have W₂ := Ctx.LiftN.zero (Γ := (VExpr.liftTelN g - ((ctor.fieldsR source.uvars source.nparams).take + ((ctor.fieldsR source.uvars source.nparams gen.elimination).take r₀.fieldIndex) 0).reverse ++ (mid ++ gen.paramsTel.reverse)) As₂ (h := hd) have htel₃ := htel₂.weakN S.ord W₂ @@ -3302,32 +7318,6 @@ theorem recArg_transport {ctor : NormalizedCtor} end GenerationEnv -/-- Raw mixed fields preserve their arity under recursor-universe -instantiation. -/ -theorem NormalizedCtor.fieldsR_length {source : VInductDecl} - (ctor : NormalizedCtor) : - (ctor.fieldsR source.uvars source.nparams).length = - (ctor.rawFields source.nparams).length := - List.length_map .. - -/-- Pointwise lookup through the raw mixed field universe transport. -/ -theorem NormalizedCtor.fieldsR_getElem? {source : VInductDecl} - {ctor : NormalizedCtor} {q : Nat} : - (ctor.fieldsR source.uvars source.nparams)[q]? = - (ctor.rawFields source.nparams)[q]?.map - (VExpr.instL (VLevel.params' source.uvars 1)) := - List.getElem?_map .. - -/-- Unpack one mixed recursive descriptor to the retained declaration-level -descriptor from the checked view. -/ -theorem NormalizedCtor.recArgsR_mem {source : VInductDecl} - {ctor : NormalizedCtor} {r : RecArg} - (hr : r ∈ ctor.recArgsR source.uvars) : - ∃ r₀, r₀ ∈ ctor.view.recursive ∧ - r = r₀.instL (VLevel.params' source.uvars 1) := by - obtain ⟨r₀, hr₀, rfl⟩ := List.mem_map.1 hr - exact ⟨r₀, hr₀, rfl⟩ - /-- Syntactic lifting law for the mixed motive. -/ theorem GenerationChecked.motiveType_liftN {source : VInductDecl} (gen : GenerationChecked source) (n : Nat) : @@ -3336,20 +7326,20 @@ theorem GenerationChecked.motiveType_liftN {source : VInductDecl} (.forallE (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (n + gen.idxTel.length) source.nparams ++ VExpr.bvarRevRange 0 gen.idxTel.length)) - (.sort (.param 0))) := by + (.sort gen.motiveLevel)) := by rw [show gen.motiveType = VExpr.forallN gen.idxTel (.forallE (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange gen.idxTel.length source.nparams ++ VExpr.bvarRevRange 0 gen.idxTel.length)) - (.sort (.param 0))) from rfl, + (.sort gen.motiveLevel)) from rfl, VExpr.liftN_forallN] refine congrArg _ ?_ show VExpr.forallE _ _ = VExpr.forallE _ _ @@ -3364,35 +7354,35 @@ major. -/ theorem GenerationChecked.motiveVarApp_hasType {source : VInductDecl} (gen : GenerationChecked source) {env : VEnv} {l : VLevel} {Γ : List VExpr} {K : Nat} {idxs : List VExpr} {a : VExpr} - (hM : env.HasType (source.uvars + 1) Γ (.bvar K) + (hM : env.HasType (gen.recUvars) Γ (.bvar K) (gen.motiveType.liftN (K+1))) - (hidx : env.SpineWF (source.uvars + 1) Γ + (hidx : env.SpineWF (gen.recUvars) Γ (VExpr.forallN (VExpr.liftTelN (K+1) gen.idxTel 0) (.sort l)) idxs (.sort l)) (hlen : idxs.length = gen.idxTel.length) - (ha : env.HasType (source.uvars + 1) Γ a + (ha : env.HasType (gen.recUvars) Γ a (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (K+1) source.nparams ++ idxs))) : - env.HasType (source.uvars + 1) Γ - (VExpr.appN (.bvar K) (idxs ++ [a])) (.sort (.param 0)) := by + env.HasType (gen.recUvars) Γ + (VExpr.appN (.bvar K) (idxs ++ [a])) (.sort gen.motiveLevel) := by rw [gen.motiveType_liftN] at hM have hshape := hidx.retarget (by simpa only [VExpr.liftTelN_length] using hlen) (.forallE (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (K+1 + gen.idxTel.length) source.nparams ++ VExpr.bvarRevRange 0 gen.idxTel.length)) - (.sort (.param 0))) + (.sort gen.motiveLevel)) rw [VExpr.instRev_forallE_sort, VExpr.instRev_appN, VExpr.instRev_closedN _ (C := .const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) trivial, + (gen.sourceLevels)) trivial, List.map_append, VExpr.map_instRev_bvarRevRange_ge _ _ _ (by rw [hlen]; omega), show K+1+gen.idxTel.length-idxs.length = K+1 from by @@ -3431,7 +7421,7 @@ theorem GenerationChecked.minorTypesAux_getElem? ctors[q]?.map fun ctor => VExpr.liftN (i+q) (GenerationChecked.minorType - (source := source) ctor) + (source := source) ctor gen.elimination) | [], _, q => by simp [GenerationChecked.minorTypesAux] | _ :: _, _, 0 => by simp [GenerationChecked.minorTypesAux] | _ :: ctors, i, q+1 => by @@ -3451,22 +7441,22 @@ field keeps its raw domain; `emittedField_defeq` converts it to the retained recursive-Pi view only at the semantic application point. -/ theorem recArgMinor_isType {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) {r : RecArg} - (hrmem : r ∈ ctor.recArgsR source.uvars) + (hrmem : r ∈ ctor.recArgsR source.uvars gen.elimination) (Δ : List VExpr) (p : Nat) (hΔ : Δ.length = p) : - env.IsType (source.uvars + 1) + env.IsType (gen.recUvars) (Δ ++ (VExpr.liftTelN 1 - (ctor.fieldsR source.uvars source.nparams) 0).reverse ++ + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.motiveType :: gen.paramsTel.reverse)) (r.minorIH - (ctor.fieldsR source.uvars source.nparams).length p) := by + (ctor.fieldsR source.uvars source.nparams gen.elimination).length p) := by obtain ⟨r₀, hr₀, rfl⟩ := NormalizedCtor.recArgsR_mem hrmem obtain ⟨Bview, hBview, hrec⟩ := S.viewRecArg_data hctor hr₀ - let ls := VLevel.params' source.uvars 1 + let ls := gen.sourceLevels let r := r₀.instL ls - let Bs := ctor.fieldsR source.uvars source.nparams + let Bs := ctor.fieldsR source.uvars source.nparams gen.elimination let m := Bs.length let j := r₀.fieldIndex let Fs := VExpr.liftTelN 1 Bs 0 @@ -3511,11 +7501,11 @@ theorem recArgMinor_isType {ctor : NormalizedCtor} ← List.reverse_append, List.take_append_drop, List.singleton_append, ← List.append_assoc] dsimp only [j] at ht hctx - have htel : env.OnTel (source.uvars + 1) Γ As := by + have htel : env.OnTel (gen.recUvars) Γ As := by rw [hctx] at ht simpa [r, As, m, j, Bs, RecArg.instL, RecArg.minorBinders] using ht.1 - have hsp : env.SpineWF (source.uvars + 1) + have hsp : env.SpineWF (gen.recUvars) (As.reverse ++ Γ) (VExpr.forallN (VExpr.liftTelN @@ -3551,19 +7541,21 @@ theorem recArgMinor_isType {ctor : NormalizedCtor} rw [show m-1-j+p+1 = m-j+p from by omega] at hlu dsimp only [j, r] at hlu have hf0 := VEnv.HasType.bvar - (env := env) (U := source.uvars + 1) hlu + (env := env) (U := gen.recUvars) hlu obtain ⟨u, hdom₀⟩ := S.emittedField_defeq hctor hBraw hBview have hdom₁ := hdom₀.instL - (U' := source.uvars + 1) VLevel.params'_one_wf - have hprefix : - (((ctor.rawFields source.nparams).take r₀.fieldIndex).reverse ++ - gen.block.rawParams.reverse).map (VExpr.instL ls) = - (Bs.take r₀.fieldIndex).reverse ++ - gen.paramsTel.reverse := by - simp [Bs, ls, NormalizedCtor.fieldsR, - GenerationChecked.paramsTel, List.map_reverse, List.map_take] - rw [hprefix] at hdom₁ + (U' := gen.recUvars) gen.sourceLevels_wf + have hdomChecked : env.IsDefEq (gen.recUvars) + ((ctor.fieldsR source.uvars source.nparams gen.elimination |>.take + r₀.fieldIndex).reverse ++ + (gen.block.checked.params.map (VExpr.instL ls)).reverse) + (Braw.instL ls) (Bview.instL ls) ((VExpr.sort u).instL ls) := by + simpa [NormalizedCtor.fieldsR, List.map_append, + List.map_reverse, List.map_take] using hdom₁ + have hprefix := S.generationFieldPrefix_ctx_rec hctor r₀.fieldIndex + have hdomGeneration := hdomChecked.defeqDFC S.ord + (hprefix.symm S.ord) have hjlen : (Bs.take r₀.fieldIndex).length = r₀.fieldIndex := by simp only [Bs, NormalizedCtor.fieldsR, @@ -3574,7 +7566,7 @@ theorem recArgMinor_isType {ctor : NormalizedCtor} (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) [gen.motiveType]) rw [hjlen, Nat.add_zero] at Wmid - have hdom₂ := hdom₁.weakN S.ord Wmid + have hdom₂ := hdomGeneration.weakN S.ord Wmid have Wstack := Ctx.LiftN.zero (Γ := (VExpr.liftTelN 1 (Bs.take j) 0).reverse ++ ([gen.motiveType] ++ gen.paramsTel.reverse)) @@ -3583,13 +7575,13 @@ theorem recArgMinor_isType {ctor : NormalizedCtor} rw [hctx] at hdom₃ have hfView := hdom₃.defeq hf0 have hfield := recArg_minor_fieldType hrec m p - (by simpa [j] using hjm) + (by simpa [j] using hjm) gen.elimination simp only [RecArg.instL] at hfield rw [hfield] at hfView have hf := hfView.weakN S.ord (Ctx.LiftN.zero (Γ := Γ) As.reverse) have hmajor := VEnv.HasType.appN_selfSpine - (env := env) (U := source.uvars + 1) + (env := env) (U := gen.recUvars) (As := As) (B := VExpr.appN (.const gen.block.sourceType.name ls) @@ -3603,7 +7595,7 @@ theorem recArgMinor_isType {ctor : NormalizedCtor} List.nil_append] at hmajor have hAsLen : As.length = r.binders.length := by simp [As, RecArg.minorBinders, VExpr.liftTelN_length] - change env.HasType (source.uvars + 1) (As.reverse ++ Γ) + change env.HasType (gen.recUvars) (As.reverse ++ Γ) ((VExpr.bvar (m-1-r.fieldIndex+p+As.length)).appN (VExpr.bvarRevRange 0 As.length)) (VExpr.appN @@ -3623,7 +7615,7 @@ theorem recArgMinor_isType {ctor : NormalizedCtor} omega) simpa [Γ, List.append_assoc] using hM0 have hM := VEnv.HasType.bvar - (env := env) (U := source.uvars + 1) + (env := env) (U := gen.recUvars) (Lookup.of_getElem? hMget) have hlen : idxs.length = gen.idxTel.length := by simpa [idxs, r, RecArg.instL, @@ -3633,7 +7625,7 @@ theorem recArgMinor_isType {ctor : NormalizedCtor} have hbody := gen.motiveVarApp_hasType (l := gen.block.checked.resultLevel.inst ls) hM hsp hlen hmajor - refine IsType.forallN htel ⟨VLevel.param 0, ?_⟩ + refine IsType.forallN htel ⟨gen.motiveLevel, ?_⟩ simpa [RecArg.minorIH, r, As, idxs, m, Γ, Fs, Bs, List.append_assoc] using hbody @@ -3642,15 +7634,15 @@ and depth. -/ theorem ihs_onTel {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) : ∀ (rsSuf : List RecArg), - (∀ r ∈ rsSuf, r ∈ ctor.recArgsR source.uvars) → + (∀ r ∈ rsSuf, r ∈ ctor.recArgsR source.uvars gen.elimination) → ∀ (Δ : List VExpr) (p : Nat), Δ.length = p → - env.OnTel (source.uvars + 1) + env.OnTel (gen.recUvars) (Δ ++ (VExpr.liftTelN 1 - (ctor.fieldsR source.uvars source.nparams) 0).reverse ++ + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.motiveType :: gen.paramsTel.reverse)) (ihsFromRecArgs - (ctor.fieldsR source.uvars source.nparams).length rsSuf p) + (ctor.fieldsR source.uvars source.nparams gen.elimination).length rsSuf p) | [], _, _, _, _ => trivial | r :: rsSuf, hqs, Δ, p, hΔ => ⟨S.recArgMinor_isType hctor @@ -3691,13 +7683,13 @@ theorem viewResultSpine {ctor : NormalizedCtor} simpa [CheckedCtor.ofDirect, gen.block.uvars_eq, gen.block.nparams_eq] using h -/-- Constructor-result semantics transported to the exact raw emitted -field/parameter context and raw family-index telescope. -/ +/-- Constructor-result semantics transported to the exact emitted +checked-parameter/raw-field context and raw family-index telescope. -/ theorem rawResultSpine {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) : env.SpineWF source.uvars ((ctor.rawFields source.nparams).reverse ++ - gen.block.rawParams.reverse) + gen.block.checked.params.reverse) (VExpr.forallN (VExpr.liftTelN (ctor.rawFields source.nparams).length @@ -3714,8 +7706,8 @@ theorem rawResultSpine {ctor : NormalizedCtor} have hfields := (gen.shape.2.2.2.2.2 ctor hctor).2.2.2 rw [← hfields] at hsp - have hidx := S.rawIndexTel_defeq.weakN S.ord - (Ctx.LiftN.zero (Γ := gen.block.rawParams.reverse) + have hidx := S.emittedIndexTel_defeq.weakN S.ord + (Ctx.LiftN.zero (Γ := gen.block.checked.params.reverse) (ctor.rawFields source.nparams).reverse) rw [List.length_reverse] at hidx have hlen : @@ -3734,49 +7726,58 @@ theorem result_transport {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) (mid : List VExpr) {g : Nat} (hg : mid.length = g) (As₂ : List VExpr) {d : Nat} (hd : As₂.length = d) : - env.SpineWF (source.uvars + 1) + env.SpineWF (gen.recUvars) (As₂ ++ ((VExpr.liftTelN g - (ctor.fieldsR source.uvars source.nparams) 0).reverse ++ + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (mid ++ gen.paramsTel.reverse))) (VExpr.forallN (VExpr.liftTelN - ((ctor.fieldsR source.uvars source.nparams).length + g + d) + ((ctor.fieldsR source.uvars source.nparams gen.elimination).length + g + d) gen.idxTel 0) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1)))) - ((ctor.resultIndicesR source.uvars).map fun e => + (gen.sourceLevels)))) + ((ctor.resultIndicesR source.uvars gen.elimination).map fun e => (e.liftN g - (ctor.fieldsR source.uvars source.nparams).length).liftN d) + (ctor.fieldsR source.uvars source.nparams gen.elimination).length).liftN d) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1))) := by - let ls := VLevel.params' source.uvars 1 + (gen.sourceLevels))) := by + let ls := gen.sourceLevels have h1 := (S.rawResultSpine hctor).instL - (U' := source.uvars + 1) VLevel.params'_one_wf + (U' := gen.recUvars) gen.sourceLevels_wf + have h1Checked : env.SpineWF (gen.recUvars) + ((ctor.fieldsR source.uvars source.nparams gen.elimination).reverse ++ + (gen.block.checked.params.map (VExpr.instL ls)).reverse) + (VExpr.instL ls + (VExpr.forallN + (VExpr.liftTelN (ctor.rawFields source.nparams).length + gen.block.rawIndices 0) + (.sort gen.block.checked.resultLevel))) + (ctor.view.resultIndices.map (VExpr.instL ls)) + ((VExpr.sort gen.block.checked.resultLevel).instL ls) := by + simpa [NormalizedCtor.fieldsR, List.map_append, + List.map_reverse] using h1 + have hfieldsCtx := (S.generationFields_onTel_rec hctor).extendDefEqCtx + S.generationParams_ctx_rec + have h1Generation := h1Checked.defeqDFC S.ord + (hfieldsCtx.symm S.ord) rw [VExpr.instL_forallN, VExpr.liftTelN_instL, - show - (((ctor.rawFields source.nparams).reverse ++ - gen.block.rawParams.reverse).map (VExpr.instL ls)) = - (ctor.fieldsR source.uvars source.nparams).reverse ++ - gen.paramsTel.reverse by - simp [ls, NormalizedCtor.fieldsR, - GenerationChecked.paramsTel, List.map_reverse], show (gen.block.rawIndices.map (VExpr.instL ls)) = - gen.idxTel by rfl] at h1 + gen.idxTel by rfl] at h1Generation rw [← NormalizedCtor.fieldsR_length - (source := source) ctor] at h1 + (source := source) (mode := gen.elimination) ctor] at h1Generation have W₁ := Ctx.LiftN.consTel (n := mid.length) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) mid) rw [Nat.add_zero] at W₁ - have h2 := h1.weakN S.ord W₁ + have h2 := h1Generation.weakN S.ord W₁ rw [VExpr.liftN_forallN, hg] at h2 have h3 := h2.weakN S.ord (Ctx.LiftN.zero (Γ := _) As₂ (h := hd)) rw [VExpr.liftN_forallN] at h3 rw [VExpr.liftTelN_liftTelN_hi' - (ctor.fieldsR source.uvars source.nparams).length + (ctor.fieldsR source.uvars source.nparams gen.elimination).length g _ 0 (by omega), VExpr.liftTelN_liftTelN] at h3 simpa [ls, NormalizedCtor.resultIndicesR, @@ -3787,36 +7788,52 @@ theorem result_transport {ctor : NormalizedCtor} universes, before inserting the motive or any induction-hypothesis stack. -/ theorem ctorApp_emitted_rec {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) : - env.HasType (source.uvars + 1) - ((ctor.fieldsR source.uvars source.nparams).reverse ++ + env.HasType (gen.recUvars) + ((ctor.fieldsR source.uvars source.nparams gen.elimination).reverse ++ gen.paramsTel.reverse) (VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange - (ctor.fieldsR source.uvars source.nparams).length + (ctor.fieldsR source.uvars source.nparams gen.elimination).length source.nparams ++ VExpr.bvarRevRange 0 - (ctor.fieldsR source.uvars source.nparams).length)) + (ctor.fieldsR source.uvars source.nparams gen.elimination).length)) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange - (ctor.fieldsR source.uvars source.nparams).length + (ctor.fieldsR source.uvars source.nparams gen.elimination).length source.nparams ++ - ctor.resultIndicesR source.uvars)) := by - let ls := VLevel.params' source.uvars 1 + ctor.resultIndicesR source.uvars gen.elimination)) := by + let ls := gen.sourceLevels have h := (S.ctorApp_emitted_decl hctor).instL - (U' := source.uvars + 1) VLevel.params'_one_wf + (U' := gen.recUvars) gen.sourceLevels_wf + have hChecked : env.HasType (gen.recUvars) + ((ctor.fieldsR source.uvars source.nparams gen.elimination).reverse ++ + (gen.block.checked.params.map (VExpr.instL ls)).reverse) + ((VExpr.appN + (.const ctor.raw.name (VLevel.params source.uvars)) + (VExpr.bvarRevRange + (ctor.rawFields source.nparams).length source.nparams ++ + VExpr.bvarRevRange 0 + (ctor.rawFields source.nparams).length)).instL ls) + ((ctor.resultTarget gen.block).instL ls) := by + simpa [NormalizedCtor.fieldsR, List.map_append, + List.map_reverse] using h + have hfieldsCtx := (S.generationFields_onTel_rec hctor).extendDefEqCtx + S.generationParams_ctx_rec + have hGeneration := hChecked.defeqDFC S.ord + (hfieldsCtx.symm S.ord) rw [← NormalizedCtor.fieldsR_length - (source := source) ctor] at h + (source := source) (mode := gen.elimination) ctor] at hGeneration simpa [ls, NormalizedCtor.fieldsR, GenerationChecked.paramsTel, NormalizedCtor.resultTarget, NormalizedCtor.resultIndicesR, VExpr.instL_appN, List.map_append, bvarRevRange_instL, List.map_reverse, - VExpr.instL, VLevel.params_map_inst_params'] using h + VExpr.instL, VLevel.params_map_inst_params'] using hGeneration /-- Transport the emitted constructor application under binders inserted between parameters and fields, then under an arbitrary top stack. -/ @@ -3824,49 +7841,49 @@ theorem ctorApp_transport {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) (mid : List VExpr) {g : Nat} (hg : mid.length = g) (As₂ : List VExpr) {d : Nat} (hd : As₂.length = d) : - env.HasType (source.uvars + 1) + env.HasType (gen.recUvars) (As₂ ++ ((VExpr.liftTelN g - (ctor.fieldsR source.uvars source.nparams) 0).reverse ++ + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (mid ++ gen.paramsTel.reverse))) (VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (d + (g + - (ctor.fieldsR source.uvars source.nparams).length)) + (ctor.fieldsR source.uvars source.nparams gen.elimination).length)) source.nparams ++ VExpr.bvarRevRange d - (ctor.fieldsR source.uvars source.nparams).length)) + (ctor.fieldsR source.uvars source.nparams gen.elimination).length)) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (d + (g + - (ctor.fieldsR source.uvars source.nparams).length)) + (ctor.fieldsR source.uvars source.nparams gen.elimination).length)) source.nparams ++ - (ctor.resultIndicesR source.uvars).map fun e => + (ctor.resultIndicesR source.uvars gen.elimination).map fun e => (e.liftN g - (ctor.fieldsR source.uvars source.nparams).length).liftN d)) := by - let Bs := ctor.fieldsR source.uvars source.nparams + (ctor.fieldsR source.uvars source.nparams gen.elimination).length).liftN d)) := by + let Bs := ctor.fieldsR source.uvars source.nparams gen.elimination have W₁ := Ctx.LiftN.consTel (n := mid.length) Bs (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) mid) rw [Nat.add_zero] at W₁ have h₁ := (S.ctorApp_emitted_rec hctor).weakN S.ord W₁ rw [hg] at h₁ - have hmid : env.HasType (source.uvars + 1) + have hmid : env.HasType (gen.recUvars) ((VExpr.liftTelN g Bs 0).reverse ++ (mid ++ gen.paramsTel.reverse)) (VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (g + Bs.length) source.nparams ++ VExpr.bvarRevRange 0 Bs.length)) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (g + Bs.length) source.nparams ++ - (ctor.resultIndicesR source.uvars).map + (ctor.resultIndicesR source.uvars gen.elimination).map (VExpr.liftN g · Bs.length))) := by simpa [Bs, VExpr.liftN_appN, List.map_append, bvarRevRange_liftN_ge _ _ _ _ (Nat.le_refl _), @@ -3883,30 +7900,30 @@ theorem ctorApp_transport {ctor : NormalizedCtor} /-- Constructor application in the exact mixed minor-premise context. -/ theorem ctorAppMinor_hasType {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) (Δ : List VExpr) : - env.HasType (source.uvars + 1) + env.HasType (gen.recUvars) (Δ ++ (VExpr.liftTelN 1 - (ctor.fieldsR source.uvars source.nparams) 0).reverse ++ + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.motiveType :: gen.paramsTel.reverse)) (VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (Δ.length + - (ctor.fieldsR source.uvars source.nparams).length + 1) + (ctor.fieldsR source.uvars source.nparams gen.elimination).length + 1) source.nparams ++ VExpr.bvarRevRange Δ.length - (ctor.fieldsR source.uvars source.nparams).length)) + (ctor.fieldsR source.uvars source.nparams gen.elimination).length)) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (Δ.length + - (ctor.fieldsR source.uvars source.nparams).length + 1) + (ctor.fieldsR source.uvars source.nparams gen.elimination).length + 1) source.nparams ++ - (ctor.resultIndicesR source.uvars).map fun e => + (ctor.resultIndicesR source.uvars gen.elimination).map fun e => (e.liftN 1 - (ctor.fieldsR source.uvars source.nparams).length).liftN + (ctor.fieldsR source.uvars source.nparams gen.elimination).length).liftN Δ.length)) := by have h := S.ctorApp_transport hctor [gen.motiveType] (g := 1) rfl Δ (d := Δ.length) rfl @@ -3914,9 +7931,9 @@ theorem ctorAppMinor_hasType {ctor : NormalizedCtor} (show Δ.length + (1 + - (ctor.fieldsR source.uvars source.nparams).length) = + (ctor.fieldsR source.uvars source.nparams gen.elimination).length) = Δ.length + - (ctor.fieldsR source.uvars source.nparams).length + 1 by + (ctor.fieldsR source.uvars source.nparams gen.elimination).length + 1 by omega)] at h simpa [List.append_assoc] using h @@ -3924,41 +7941,27 @@ theorem ctorAppMinor_hasType {ctor : NormalizedCtor} universe instantiation and insertion of the motive. -/ theorem fields_onTel_minor {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) : - env.OnTel (source.uvars + 1) + env.OnTel (gen.recUvars) (gen.motiveType :: gen.paramsTel.reverse) (VExpr.liftTelN 1 - (ctor.fieldsR source.uvars source.nparams) 0) := by - have hemitted : env.OnTel source.uvars [] - (gen.block.rawParams ++ - ctor.rawFields source.nparams) := by - simpa [NormalizedCtor.emittedBinders] using - (S.ctorWF ctor hctor).rawEmitted_onTel - have hfields₀ := (OnTel.of_append - (As := gen.block.rawParams) hemitted).2 - have hfields₁ := hfields₀.instL - (U' := source.uvars + 1) VLevel.params'_one_wf - have hfields₂ : env.OnTel (source.uvars + 1) - gen.paramsTel.reverse - (ctor.fieldsR source.uvars source.nparams) := by - simpa [GenerationChecked.paramsTel, - NormalizedCtor.fieldsR, List.map_reverse] using hfields₁ - have hout := hfields₂.weakN S.ord + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0) := by + have hout := (S.generationFields_onTel_rec hctor).weakN S.ord (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) [gen.motiveType]) simpa using hout -/-- Every mixed constructor minor is a type over the raw parameter telescope +/-- Every mixed constructor minor is a type over the checked parameter telescope and mixed motive. Raw field syntax is preserved; recursive classifications and result indices come from the checked view. -/ theorem minor_isType {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) : - env.IsType (source.uvars + 1) + env.IsType (gen.recUvars) (gen.motiveType :: gen.paramsTel.reverse) (GenerationChecked.minorType - (source := source) ctor) := by - let Bs := ctor.fieldsR source.uvars source.nparams + (source := source) ctor gen.elimination) := by + let Bs := ctor.fieldsR source.uvars source.nparams gen.elimination let m := Bs.length - let rs := ctor.recArgsR source.uvars + let rs := ctor.recArgsR source.uvars gen.elimination let IHs := ihsFromRecArgs m rs 0 let Fs := VExpr.liftTelN 1 Bs 0 let Γ := IHs.reverse ++ @@ -3982,7 +7985,7 @@ theorem minor_isType {ctor : NormalizedCtor} VExpr.liftTelN_length] omega) simpa [Γ] using h - have hM : env.HasType (source.uvars + 1) Γ + have hM : env.HasType (gen.recUvars) Γ (.bvar (m + rs.length)) (gen.motiveType.liftN (m + rs.length + 1)) := VEnv.HasType.bvar (Lookup.of_getElem? hMget) @@ -3991,19 +7994,19 @@ theorem minor_isType {ctor : NormalizedCtor} (d := rs.length) hrlen rw [show m + 1 + rs.length = m + rs.length + 1 by omega] at hSp - have hSp' : env.SpineWF (source.uvars + 1) Γ + have hSp' : env.SpineWF (gen.recUvars) Γ (VExpr.forallN (VExpr.liftTelN (m + rs.length + 1) gen.idxTel 0) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1)))) - ((ctor.resultIndicesR source.uvars).map fun e => + (gen.sourceLevels)))) + ((ctor.resultIndicesR source.uvars gen.elimination).map fun e => (e.liftN 1 m).liftN rs.length) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1))) := by + (gen.sourceLevels))) := by simpa [Γ, Fs, Bs, m, List.append_assoc] using hSp have hlen : - ((ctor.resultIndicesR source.uvars).map fun e => + ((ctor.resultIndicesR source.uvars gen.elimination).map fun e => (e.liftN 1 m).liftN rs.length).length = gen.idxTel.length := by simp only [List.length_map, NormalizedCtor.resultIndicesR, @@ -4014,19 +8017,19 @@ theorem minor_isType {ctor : NormalizedCtor} rw [hrlen, VExpr.bvarRevRange_congr source.nparams (show rs.length + m + 1 = m + rs.length + 1 by omega)] at hctorApp - have hctorApp' : env.HasType (source.uvars + 1) Γ + have hctorApp' : env.HasType (gen.recUvars) Γ (VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (m + rs.length + 1) source.nparams ++ VExpr.bvarRevRange rs.length m)) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (m + rs.length + 1) source.nparams ++ - (ctor.resultIndicesR source.uvars).map fun e => + (ctor.resultIndicesR source.uvars gen.elimination).map fun e => (e.liftN 1 m).liftN rs.length)) := by simpa [Γ, Fs, Bs, m, IHs, rs, List.append_assoc] using hctorApp @@ -4034,28 +8037,28 @@ theorem minor_isType {ctor : NormalizedCtor} rw [VExpr.bvarRevRange_congr source.nparams (show m + rs.length + 1 = rs.length + m + 1 by omega)] at hbody - exact ⟨.param 0, by + exact ⟨gen.motiveLevel, by simpa [Γ, Fs, Bs, m, rs, IHs, List.append_assoc] using hbody⟩ -/-- The mixed raw parameter telescope is well formed in recursor universes. -/ +/-- The checked parameter telescope is well formed in recursor universes. -/ theorem paramsTel_onTel : - env.OnTel (source.uvars + 1) [] gen.paramsTel := by - have h := S.rawFamily_onTel.instL - (U' := source.uvars + 1) VLevel.params'_one_wf - have h' : env.OnTel (source.uvars + 1) [] + env.OnTel (gen.recUvars) [] gen.paramsTel := by + have h := S.generationFamily_onTel.instL + (U' := gen.recUvars) gen.sourceLevels_wf + have h' : env.OnTel (gen.recUvars) [] (gen.paramsTel ++ gen.idxTel) := by simpa [GenerationChecked.paramsTel, GenerationChecked.idxTel] using h exact h'.of_append.1 -/-- The mixed raw index telescope is well formed over the mixed parameters. -/ +/-- The raw index telescope is well formed over the checked parameters. -/ theorem idxTel_onTel : - env.OnTel (source.uvars + 1) + env.OnTel (gen.recUvars) gen.paramsTel.reverse gen.idxTel := by - have h := S.rawFamily_onTel.instL - (U' := source.uvars + 1) VLevel.params'_one_wf - have h' : env.OnTel (source.uvars + 1) [] + have h := S.generationFamily_onTel.instL + (U' := gen.recUvars) gen.sourceLevels_wf + have h' : env.OnTel (gen.recUvars) [] (gen.paramsTel ++ gen.idxTel) := by simpa [GenerationChecked.paramsTel, GenerationChecked.idxTel] using h @@ -4067,7 +8070,7 @@ theorem minorTypesAux_onTel : ∀ (ctors : List NormalizedCtor), (∀ ctor ∈ ctors, ctor ∈ gen.block.ctorPairs) → ∀ (Δ : List VExpr) (i : Nat), Δ.length = i → - env.OnTel (source.uvars + 1) + env.OnTel (gen.recUvars) (Δ ++ (gen.motiveType :: gen.paramsTel.reverse)) (gen.minorTypesAux ctors i) @@ -4085,7 +8088,7 @@ theorem minorTypesAux_onTel : /-- The complete mixed minor telescope is well formed over parameters and motive. -/ theorem minorTypes_onTel : - env.OnTel (source.uvars + 1) + env.OnTel (gen.recUvars) (gen.motiveType :: gen.paramsTel.reverse) gen.minorTypes := by simpa [GenerationChecked.minorTypes] using @@ -4097,35 +8100,35 @@ indices and then under an arbitrary top stack. -/ theorem familyApp_transport (mid : List VExpr) {g : Nat} (hg : mid.length = g) (As₂ : List VExpr) {d : Nat} (hd : As₂.length = d) : - env.HasType (source.uvars + 1) + env.HasType (gen.recUvars) (As₂ ++ ((VExpr.liftTelN g gen.idxTel 0).reverse ++ (mid ++ gen.paramsTel.reverse))) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (d + (g + gen.idxTel.length)) source.nparams ++ VExpr.bvarRevRange d gen.idxTel.length)) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1))) := by + (gen.sourceLevels))) := by have W₁ := Ctx.LiftN.consTel (n := mid.length) gen.idxTel (Ctx.LiftN.zero (Γ := gen.paramsTel.reverse) mid) rw [Nat.add_zero] at W₁ have h₁ := S.familyApp_hasType.weakN S.ord W₁ rw [hg] at h₁ - have hmid : env.HasType (source.uvars + 1) + have hmid : env.HasType (gen.recUvars) ((VExpr.liftTelN g gen.idxTel 0).reverse ++ (mid ++ gen.paramsTel.reverse)) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (g + gen.idxTel.length) source.nparams ++ VExpr.bvarRevRange 0 gen.idxTel.length)) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1))) := by + (gen.sourceLevels))) := by simpa [VExpr.liftN_appN, List.map_append, bvarRevRange_liftN_ge _ _ _ _ (Nat.le_refl _), VExpr.bvarRevRange_liftN_high @@ -4141,12 +8144,12 @@ theorem familyApp_transport parameter and index syntax while its motive and minors use the checked recursive classification. -/ theorem recType_isType : - env.IsType (source.uvars + 1) [] gen.recType := by + env.IsType (gen.recUvars) [] gen.recType := by refine IsType.forallN S.paramsTel_onTel ?_ simp only [List.append_nil] refine IsType.forallE S.motive_isType ?_ refine IsType.forallN S.minorTypes_onTel ?_ - have hI : env.OnTel (source.uvars + 1) + have hI : env.OnTel (gen.recUvars) (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse)) (VExpr.liftTelN (gen.block.ctorPairs.length + 1) @@ -4169,27 +8172,27 @@ theorem recType_isType : 0 + ((gen.block.ctorPairs.length + 1) + gen.idxTel.length) = gen.idxTel.length + gen.block.ctorPairs.length + 1 by omega)] at hmaj₀ - have hmaj : env.HasType (source.uvars + 1) + have hmaj : env.HasType (gen.recUvars) ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) gen.idxTel 0).reverse ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + gen.block.ctorPairs.length + 1) source.nparams ++ VExpr.bvarRevRange 0 gen.idxTel.length)) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1))) := by + (gen.sourceLevels))) := by simpa [List.append_assoc] using hmaj₀ refine IsType.forallE ⟨_, hmaj⟩ ?_ have hM := getElem?_rstack3 [VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + gen.block.ctorPairs.length + 1) @@ -4219,10 +8222,10 @@ theorem recType_isType : congr 1 omega, gen.motiveType_liftN] at hmlu - have hfun : env.HasType (source.uvars + 1) + have hfun : env.HasType (gen.recUvars) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + gen.block.ctorPairs.length + 1) @@ -4243,13 +8246,13 @@ theorem recType_isType : (.forallE (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.block.ctorPairs.length + 1 + gen.idxTel.length) source.nparams ++ VExpr.bvarRevRange 0 gen.idxTel.length)) - (.sort (.param 0)))).liftN + (.sort gen.motiveLevel))).liftN (1 + (VExpr.liftTelN (gen.block.ctorPairs.length + 1) gen.idxTel 0).length)) := by @@ -4262,7 +8265,7 @@ theorem recType_isType : gen.idxTel 0) (Δ := [VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + gen.block.ctorPairs.length + 1) @@ -4277,7 +8280,7 @@ theorem recType_isType : have h0 : (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + gen.block.ctorPairs.length + 1) @@ -4290,19 +8293,19 @@ theorem recType_isType : (gen.motiveType :: gen.paramsTel.reverse))))[0]? = some (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + gen.block.ctorPairs.length + 1) source.nparams ++ VExpr.bvarRevRange 0 gen.idxTel.length)) := rfl have harg := HasType.bvar - (env := env) (U := source.uvars + 1) + (env := env) (U := gen.recUvars) (Lookup.of_getElem? h0) - have harg' : env.HasType (source.uvars + 1) + have harg' : env.HasType (gen.recUvars) ([VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + gen.block.ctorPairs.length + 1) @@ -4316,7 +8319,7 @@ theorem recType_isType : (.bvar 0) ((VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.block.ctorPairs.length + 1 + gen.idxTel.length) @@ -4404,7 +8407,9 @@ theorem recPairsR_mem {U : Nat} {T : Name} {np ni : Nat} {c : VConstVal} {q} q.2 = (recFieldIdxs np B).map (VExpr.instL (VLevel.params' U 1)) := by obtain ⟨⟨j, idxs⟩, hmem, rfl⟩ := List.mem_map.1 hq obtain ⟨B, hB, hrec, hidx⟩ := recPairs_getElem _ hmem - exact ⟨B, by simpa using hB, hrec, by simp only []; rw [show idxs = recFieldIdxs np B from hidx]⟩ + exact ⟨B, by simpa using hB, hrec, by + simpa using congrArg + (List.map (VExpr.instL (ElimMode.large.sourceLevels U))) hidx⟩ /-- Recursor-universe transport preserves each recursive argument's source field position. -/ @@ -4644,9 +8649,6 @@ theorem hasType_appN_ruleIHs {env : VEnv} {U : Nat} {Γ : List VExpr} {m k : Nat exact hasType_appN_ruleIHs (rs := rs) (fun q hq => hargs q (.tail _ hq)) happ -theorem liftTelN_congr {a a' : Nat} (tel : List VExpr) (k : Nat) (h : a = a') : - VExpr.liftTelN a tel k = VExpr.liftTelN a' tel k := h ▸ rfl - namespace GenerationEnv variable {source : VInductDecl} {gen : GenerationChecked source} @@ -4658,7 +8660,7 @@ include S /-- Syntactic universe well-formedness follows from semantic well-formedness of the closed mixed recursor type. -/ theorem recType_levelWF : - gen.recType.LevelWF (source.uvars + 1) := by + gen.recType.LevelWF (gen.recUvars) := by obtain ⟨_, h⟩ := S.recType_isType exact (h.levelWF trivial).1 @@ -4672,14 +8674,14 @@ theorem recursor_hasType (hrec : env.constants (.str gen.block.sourceType.name "rec") = some gen.recursor) {Γ} : - env.HasType (source.uvars + 1) Γ + env.HasType (gen.recUvars) Γ (.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars + 1))) + (gen.recLevels)) gen.recType := by have h := HasType.const (Γ := Γ) hrec VLevel.params_wf VLevel.params_length rw [show gen.recursor.uvars = - source.uvars + 1 from rfl, + gen.recUvars from rfl, show gen.recursor.type = gen.recType from rfl] at h rwa [S.recType_levelWF.instL_id] at h @@ -4690,12 +8692,12 @@ theorem recBase_hasType (.str gen.block.sourceType.name "rec") = some gen.recursor) (Δ : List VExpr) : - env.HasType (source.uvars + 1) + env.HasType (gen.recUvars) (Δ ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) (VExpr.appN (.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars + 1))) + (gen.recLevels)) (VExpr.bvarRevRange Δ.length (source.nparams + gen.block.ctorPairs.length + 1))) @@ -4706,7 +8708,7 @@ theorem recBase_hasType (.forallE (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + gen.block.ctorPairs.length + 1) @@ -4719,12 +8721,12 @@ theorem recBase_hasType gen.block.ctorPairs.length + 1)) (VExpr.bvarRevRange 1 gen.idxTel.length)) (.bvar 0)))).liftN Δ.length) := by - have hf : env.HasType (source.uvars + 1) + have hf : env.HasType (gen.recUvars) (Δ ++ (gen.paramsTel ++ gen.motiveType :: gen.minorTypes).reverse ++ []) (.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars + 1))) + (gen.recLevels)) ((VExpr.forallN (gen.paramsTel ++ gen.motiveType :: gen.minorTypes) @@ -4735,7 +8737,7 @@ theorem recBase_hasType (.forallE (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + gen.block.ctorPairs.length + 1) @@ -4761,7 +8763,7 @@ theorem recBase_hasType (.forallE (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + gen.block.ctorPairs.length + 1) @@ -4780,7 +8782,7 @@ theorem recBase_hasType S.recType_closedN.liftN_eq (Nat.zero_le _)] exact S.recursor_hasType hrec have hspine := HasType.appN_selfSpine - (env := env) (U := source.uvars + 1) hf + (env := env) (U := gen.recUvars) hf simp only [GenerationChecked.recType, List.reverse_append, List.reverse_cons, List.append_nil, List.append_assoc, @@ -4788,7 +8790,8 @@ theorem recBase_hasType List.length_cons, List.length_reverse, gen.minorTypes_length] at hspine rw [show gen.paramsTel.length = source.nparams from by - simp [GenerationChecked.paramsTel, gen.shape.1], + simp [GenerationChecked.paramsTel, + S.generationParams_length], VExpr.bvarRevRange_congr' Δ.length (show source.nparams + (gen.block.ctorPairs.length + 1) = @@ -4802,7 +8805,7 @@ theorem recApp_hasType (.str gen.block.sourceType.name "rec") = some gen.recursor) (Δ : List VExpr) {idxs : List VExpr} {a : VExpr} - (hidx : env.SpineWF (source.uvars + 1) + (hidx : env.SpineWF (gen.recUvars) (Δ ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) (VExpr.forallN @@ -4811,30 +8814,30 @@ theorem recApp_hasType gen.block.ctorPairs.length + 1) gen.idxTel 0) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1)))) + (gen.sourceLevels)))) idxs (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1)))) + (gen.sourceLevels)))) (hlen : idxs.length = gen.idxTel.length) - (ha : env.HasType (source.uvars + 1) + (ha : env.HasType (gen.recUvars) (Δ ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) a (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (Δ.length + gen.block.ctorPairs.length + 1) source.nparams ++ idxs))) : - env.HasType (source.uvars + 1) + env.HasType (gen.recUvars) (Δ ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) (VExpr.appN (VExpr.appN (.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars + 1))) + (gen.recLevels)) (VExpr.bvarRevRange Δ.length (source.nparams + gen.block.ctorPairs.length + 1))) @@ -4855,7 +8858,7 @@ theorem recApp_hasType (VExpr.forallE (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + gen.block.ctorPairs.length + 1) @@ -4874,7 +8877,7 @@ theorem recApp_hasType VExpr.forallE (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + Δ.length + gen.block.ctorPairs.length + 1) @@ -4921,17 +8924,17 @@ theorem recApp_hasType (.forallE (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + Δ.length + gen.block.ctorPairs.length + 1) source.nparams ++ VExpr.bvarRevRange 0 gen.idxTel.length)) - (.sort (.param 0))) + (.sort gen.motiveLevel)) rw [VExpr.instRev_forallE_sort, VExpr.instRev_appN, VExpr.instRev_closedN _ (C := .const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) trivial, + (gen.sourceLevels)) trivial, List.map_append, VExpr.map_instRev_bvarRevRange_ge _ _ _ (by rw [hlen]; omega), @@ -4945,7 +8948,7 @@ theorem recApp_hasType rw [hlen] at hshape have hfull := hshape.snoc ha simp only [VExpr.inst] at hfull - change env.SpineWF (source.uvars + 1) _ + change env.SpineWF (gen.recUvars) _ (VExpr.forallN (VExpr.liftTelN (Δ.length + gen.block.ctorPairs.length + 1) @@ -4953,14 +8956,14 @@ theorem recApp_hasType (VExpr.forallN [VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + Δ.length + gen.block.ctorPairs.length + 1) source.nparams ++ VExpr.bvarRevRange 0 gen.idxTel.length)] - (.sort (.param 0)))) - (idxs ++ [a]) (.sort (.param 0)) at hfull + (.sort gen.motiveLevel))) + (idxs ++ [a]) (.sort gen.motiveLevel) at hfull rw [← VExpr.forallN_append] at hfull have hfullLen : (idxs ++ [a]).length = (VExpr.liftTelN @@ -4969,7 +8972,7 @@ theorem recApp_hasType gen.idxTel 0 ++ [VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (gen.idxTel.length + Δ.length + gen.block.ctorPairs.length + 1) @@ -5035,7 +9038,7 @@ theorem recApp_hasType /-- The mixed motive variable applied to an index spine and major. -/ theorem motiveApp_hasType (Δ : List VExpr) {idxs : List VExpr} {a : VExpr} - (hidx : env.SpineWF (source.uvars + 1) + (hidx : env.SpineWF (gen.recUvars) (Δ ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) (VExpr.forallN @@ -5044,24 +9047,24 @@ theorem motiveApp_hasType gen.block.ctorPairs.length + 1) gen.idxTel 0) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1)))) + (gen.sourceLevels)))) idxs (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1)))) + (gen.sourceLevels)))) (hlen : idxs.length = gen.idxTel.length) - (ha : env.HasType (source.uvars + 1) + (ha : env.HasType (gen.recUvars) (Δ ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) a (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (Δ.length + gen.block.ctorPairs.length + 1) source.nparams ++ idxs))) : - env.HasType (source.uvars + 1) + env.HasType (gen.recUvars) (Δ ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) (VExpr.appN @@ -5069,7 +9072,7 @@ theorem motiveApp_hasType (Δ.length + gen.block.ctorPairs.length)) (idxs ++ [a])) - (.sort (.param 0)) := by + (.sort gen.motiveLevel) := by have hM := getElem?_rstack3 Δ gen.minorTypes.reverse gen.motiveType gen.paramsTel.reverse @@ -5083,37 +9086,37 @@ theorem motiveApp_hasType /-- The raw constructor-headed major in the complete mixed rule context. -/ theorem ctorAppRule_hasType {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) : - env.HasType (source.uvars + 1) + env.HasType (gen.recUvars) ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) (VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1) source.nparams ++ VExpr.bvarRevRange 0 (ctor.fieldsR - source.uvars source.nparams).length)) + source.uvars source.nparams gen.elimination).length)) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1) source.nparams ++ - (ctor.resultIndicesR source.uvars).map fun e => + (ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length)) := by + source.uvars source.nparams gen.elimination).length)) := by have h := S.ctorApp_transport hctor (gen.minorTypes.reverse ++ [gen.motiveType]) (g := gen.block.ctorPairs.length + 1) @@ -5123,21 +9126,21 @@ theorem ctorAppRule_hasType {ctor : NormalizedCtor} (show 0 + (gen.block.ctorPairs.length + 1 + (ctor.fieldsR - source.uvars source.nparams).length) = + source.uvars source.nparams gen.elimination).length) = (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1 by omega)] at h simpa [List.append_assoc] using h /-- The complete mixed rule binder telescope is well formed. -/ theorem ruleBinders_onTel {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) : - env.OnTel (source.uvars + 1) [] + env.OnTel (gen.recUvars) [] (gen.paramsTel ++ gen.motiveType :: gen.minorTypes ++ VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0) := by have hF₀ := S.fields_onTel_minor hctor have hF := hF₀.weakN S.ord @@ -5160,37 +9163,37 @@ theorem ruleBinders_onTel {ctor : NormalizedCtor} /-- The type recorded on every mixed iota rule is itself a type. -/ theorem ruleType_isType {i : Nat} {ctor : NormalizedCtor} (hctor : ctor ∈ gen.block.ctorPairs) : - env.IsType (source.uvars + 1) [] + env.IsType (gen.recUvars) [] ((gen.rule i ctor).type) := by - show env.IsType (source.uvars + 1) [] + show env.IsType (gen.recUvars) [] (VExpr.forallN (gen.paramsTel ++ gen.motiveType :: gen.minorTypes ++ VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0) (VExpr.appN (.bvar (gen.block.ctorPairs.length + (ctor.fieldsR - source.uvars source.nparams).length)) - (((ctor.resultIndicesR source.uvars).map fun e => + source.uvars source.nparams gen.elimination).length)) + (((ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length) ++ + source.uvars source.nparams gen.elimination).length) ++ [VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1) source.nparams ++ VExpr.bvarRevRange 0 (ctor.fieldsR - source.uvars source.nparams).length)]))) + source.uvars source.nparams gen.elimination).length)]))) refine IsType.forallN (S.ruleBinders_onTel hctor) ?_ simp only [List.reverse_append, List.reverse_cons, List.append_nil, List.append_assoc, @@ -5200,35 +9203,35 @@ theorem ruleType_isType {i : Nat} {ctor : NormalizedCtor} (g := gen.block.ctorPairs.length + 1) (by simp [gen.minorTypes_length]) [] (d := 0) rfl - have hSp : env.SpineWF (source.uvars + 1) + have hSp : env.SpineWF (gen.recUvars) ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) (VExpr.forallN (VExpr.liftTelN ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1) gen.idxTel 0) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1)))) - ((ctor.resultIndicesR source.uvars).map fun e => + (gen.sourceLevels)))) + ((ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length) + source.uvars source.nparams gen.elimination).length) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1))) := by + (gen.sourceLevels))) := by simpa [List.append_assoc, Nat.add_assoc] using hSp₀ have hidxLen : - ((ctor.resultIndicesR source.uvars).map fun e => + ((ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length).length = + source.uvars source.nparams gen.elimination).length).length = gen.idxTel.length := by simp only [List.length_map, NormalizedCtor.resultIndicesR, @@ -5236,10 +9239,10 @@ theorem ruleType_isType {i : Nat} {ctor : NormalizedCtor} exact (S.viewResultIndices_length hctor).trans gen.shape.2.2.1.symm have hctorApp := S.ctorAppRule_hasType hctor - have hSp' : env.SpineWF (source.uvars + 1) + have hSp' : env.SpineWF (gen.recUvars) ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) @@ -5248,78 +9251,78 @@ theorem ruleType_isType {i : Nat} {ctor : NormalizedCtor} ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams) + source.uvars source.nparams gen.elimination) 0).reverse.length + gen.block.ctorPairs.length + 1) gen.idxTel 0) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1)))) - ((ctor.resultIndicesR source.uvars).map fun e => + (gen.sourceLevels)))) + ((ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length) + source.uvars source.nparams gen.elimination).length) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1))) := by + (gen.sourceLevels))) := by simpa only [List.length_reverse, VExpr.liftTelN_length] using hSp - have hctorApp' : env.HasType (source.uvars + 1) + have hctorApp' : env.HasType (gen.recUvars) ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) (VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1) source.nparams ++ VExpr.bvarRevRange 0 (ctor.fieldsR - source.uvars source.nparams).length)) + source.uvars source.nparams gen.elimination).length)) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams) + source.uvars source.nparams gen.elimination) 0).reverse.length + gen.block.ctorPairs.length + 1) source.nparams ++ - (ctor.resultIndicesR source.uvars).map fun e => + (ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length)) := by + source.uvars source.nparams gen.elimination).length)) := by simpa only [List.length_reverse, VExpr.liftTelN_length] using hctorApp - refine ⟨.param 0, ?_⟩ + refine ⟨gen.motiveLevel, ?_⟩ have hm := S.motiveApp_hasType (VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse hSp' hidxLen hctorApp' rw [List.length_reverse, VExpr.liftTelN_length, show (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length = gen.block.ctorPairs.length + (ctor.fieldsR - source.uvars source.nparams).length by omega, + source.uvars source.nparams gen.elimination).length by omega, show gen.block.ctorPairs.length + (ctor.fieldsR - source.uvars source.nparams).length + 1 = + source.uvars source.nparams gen.elimination).length + 1 = (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1 by omega] at hm exact hm @@ -5331,36 +9334,36 @@ theorem ruleCall_hasType {ctor : NormalizedCtor} (.str gen.block.sourceType.name "rec") = some gen.recursor) {r : RecArg} - (hr : r ∈ ctor.recArgsR source.uvars) : - env.HasType (source.uvars + 1) + (hr : r ∈ ctor.recArgsR source.uvars gen.elimination) : + env.HasType (gen.recUvars) ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) (r.ruleCall - (ctor.fieldsR source.uvars source.nparams).length + (ctor.fieldsR source.uvars source.nparams gen.elimination).length gen.block.ctorPairs.length (VExpr.appN (.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars + 1))) + (gen.recLevels)) (VExpr.bvarRevRange (ctor.fieldsR - source.uvars source.nparams).length + source.uvars source.nparams gen.elimination).length (source.nparams + gen.block.ctorPairs.length + 1)))) (r.ruleIH - (ctor.fieldsR source.uvars source.nparams).length + (ctor.fieldsR source.uvars source.nparams gen.elimination).length gen.block.ctorPairs.length) := by obtain ⟨r₀, hr₀, rfl⟩ := NormalizedCtor.recArgsR_mem hr obtain ⟨Bview, hBview, hrecArg⟩ := S.viewRecArg_data hctor hr₀ - let ls := VLevel.params' source.uvars 1 + let ls := gen.sourceLevels let r := r₀.instL ls - let Bs := ctor.fieldsR source.uvars source.nparams + let Bs := ctor.fieldsR source.uvars source.nparams gen.elimination let m := Bs.length let k := gen.block.ctorPairs.length let j := r₀.fieldIndex @@ -5413,11 +9416,11 @@ theorem ruleCall_hasType {ctor : NormalizedCtor} ← List.reverse_append, List.take_append_drop, List.singleton_append, ← List.append_assoc] have htel : env.OnTel - (source.uvars + 1) Γ As := by + (gen.recUvars) Γ As := by rw [hctx] at ht simpa [r, As, m, k, j, RecArg.instL, RecArg.ruleBinders] using ht.1 - have hsp : env.SpineWF (source.uvars + 1) + have hsp : env.SpineWF (gen.recUvars) (As.reverse ++ Γ) (VExpr.forallN (VExpr.liftTelN @@ -5451,23 +9454,22 @@ theorem ruleCall_hasType {ctor : NormalizedCtor} rw [show m-1-r₀.fieldIndex+1 = m-r₀.fieldIndex by omega] at hlu have hf0 := VEnv.HasType.bvar - (env := env) (U := source.uvars + 1) hlu + (env := env) (U := gen.recUvars) hlu obtain ⟨u, hdom₀⟩ := S.emittedField_defeq hctor hBraw hBview have hdom₁ := hdom₀.instL - (U' := source.uvars + 1) - VLevel.params'_one_wf - have hprefix : - (((ctor.rawFields source.nparams).take + (U' := gen.recUvars) + gen.sourceLevels_wf + have hdomChecked : env.IsDefEq (gen.recUvars) + ((ctor.fieldsR source.uvars source.nparams gen.elimination |>.take r₀.fieldIndex).reverse ++ - gen.block.rawParams.reverse).map - (VExpr.instL ls) = - (Bs.take r₀.fieldIndex).reverse ++ - gen.paramsTel.reverse := by - simp [Bs, ls, NormalizedCtor.fieldsR, - GenerationChecked.paramsTel, - List.map_reverse, List.map_take] - rw [hprefix] at hdom₁ + (gen.block.checked.params.map (VExpr.instL ls)).reverse) + (Braw.instL ls) (Bview.instL ls) ((VExpr.sort u).instL ls) := by + simpa [NormalizedCtor.fieldsR, List.map_append, + List.map_reverse, List.map_take] using hdom₁ + have hprefix := S.generationFieldPrefix_ctx_rec hctor r₀.fieldIndex + have hdomGeneration := hdomChecked.defeqDFC S.ord + (hprefix.symm S.ord) have hjlen : (Bs.take r₀.fieldIndex).length = r₀.fieldIndex := by @@ -5484,7 +9486,7 @@ theorem ruleCall_hasType {ctor : NormalizedCtor} [gen.motiveType]) (h := by simp [k, gen.minorTypes_length])) rw [hjlen, Nat.add_zero] at Wmid - have hdom₂ := hdom₁.weakN S.ord Wmid + have hdom₂ := hdomGeneration.weakN S.ord Wmid have Wstack := Ctx.LiftN.zero (n := m-j) (Γ := (VExpr.liftTelN (k+1) @@ -5500,7 +9502,7 @@ theorem ruleCall_hasType {ctor : NormalizedCtor} rw [hctx] at hdom₃ have hfView := hdom₃.defeq hf0 have hfield := recArg_rule_fieldType - hrecArg m k (by simpa [j] using hjm) + hrecArg m k (by simpa [j] using hjm) gen.elimination simp only [RecArg.instL] at hfield dsimp only [j] at hfView simp only [Nat.add_zero] at hfView @@ -5508,7 +9510,7 @@ theorem ruleCall_hasType {ctor : NormalizedCtor} have hf := hfView.weakN S.ord (Ctx.LiftN.zero (Γ := Γ) As.reverse) have hmajor := VEnv.HasType.appN_selfSpine - (env := env) (U := source.uvars + 1) + (env := env) (U := gen.recUvars) (As := As) (B := VExpr.appN (.const gen.block.sourceType.name ls) @@ -5527,7 +9529,7 @@ theorem ruleCall_hasType {ctor : NormalizedCtor} As.length = r.binders.length := by simp [As, RecArg.ruleBinders, VExpr.liftTelN_length] - change env.HasType (source.uvars + 1) + change env.HasType (gen.recUvars) (As.reverse ++ Γ) ((VExpr.bvar (m-1-r.fieldIndex+As.length)).appN @@ -5559,14 +9561,14 @@ theorem ruleCall_hasType {ctor : NormalizedCtor} (VExpr.appN (.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars + 1))) + (gen.recLevels)) (VExpr.bvarRevRange m (source.nparams+(k+1)))).liftN r.binders.length = VExpr.appN (.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars + 1))) + (gen.recLevels)) (VExpr.bvarRevRange (m+r.binders.length) (source.nparams+(1+k))) := by @@ -5583,7 +9585,7 @@ theorem ruleCall_hasType {ctor : NormalizedCtor} VExpr.appN ((VExpr.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars + 1))).app + (gen.recLevels)).app (VExpr.bvar (source.nparams + (k + (m + r.binders.length))))) @@ -5593,7 +9595,7 @@ theorem ruleCall_hasType {ctor : NormalizedCtor} VExpr.appN (.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars + 1))) + (gen.recLevels)) (VExpr.bvarRevRange (m+r.binders.length) (source.nparams+(1+k))) := by @@ -5622,10 +9624,10 @@ theorem minorApp_hasType {i : Nat} {ctor : NormalizedCtor} (hrec : env.constants (.str gen.block.sourceType.name "rec") = some gen.recursor) : - env.HasType (source.uvars + 1) + env.HasType (gen.recUvars) ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) @@ -5633,55 +9635,55 @@ theorem minorApp_hasType {i : Nat} {ctor : NormalizedCtor} (.bvar (gen.block.ctorPairs.length - 1 - i + (ctor.fieldsR - source.uvars source.nparams).length)) + source.uvars source.nparams gen.elimination).length)) (VExpr.bvarRevRange 0 - (ctor.fieldsR source.uvars source.nparams).length ++ + (ctor.fieldsR source.uvars source.nparams gen.elimination).length ++ List.map (fun r => r.ruleCall (ctor.fieldsR - source.uvars source.nparams).length + source.uvars source.nparams gen.elimination).length gen.block.ctorPairs.length (VExpr.appN (.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars + 1))) + (gen.recLevels)) (VExpr.bvarRevRange (ctor.fieldsR - source.uvars source.nparams).length + source.uvars source.nparams gen.elimination).length (source.nparams + gen.block.ctorPairs.length + 1)))) - (ctor.recArgsR source.uvars))) + (ctor.recArgsR source.uvars gen.elimination))) (VExpr.appN (.bvar (gen.block.ctorPairs.length + (ctor.fieldsR - source.uvars source.nparams).length)) - (((ctor.resultIndicesR source.uvars).map fun e => + source.uvars source.nparams gen.elimination).length)) + (((ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length) ++ + source.uvars source.nparams gen.elimination).length) ++ [VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1) source.nparams ++ VExpr.bvarRevRange 0 (ctor.fieldsR - source.uvars source.nparams).length)])) := by + source.uvars source.nparams gen.elimination).length)])) := by obtain ⟨hik, -⟩ := List.getElem?_eq_some_iff.1 hci have hctor := List.mem_of_getElem? hci - let rs := ctor.recArgsR source.uvars + let rs := ctor.recArgsR source.uvars gen.elimination have hrs : - rs = ctor.recArgsR source.uvars := rfl + rs = ctor.recArgsR source.uvars gen.elimination := rfl have hrsLt : ∀ r ∈ rs, r.fieldIndex < (ctor.fieldsR - source.uvars source.nparams).length := by + source.uvars source.nparams gen.elimination).length := by intro r hr obtain ⟨r₀, hr₀, rfl⟩ := NormalizedCtor.recArgsR_mem (hrs ▸ hr) @@ -5697,24 +9699,24 @@ theorem minorApp_hasType {i : Nat} {ctor : NormalizedCtor} some (VExpr.liftN i (GenerationChecked.minorType - (source := source) ctor)) := by + (source := source) ctor gen.elimination)) := by simpa [GenerationChecked.minorTypes, hci] using gen.minorTypesAux_getElem? gen.block.ctorPairs 0 i have hlu0 : ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse)))[ gen.block.ctorPairs.length - 1 - i + (ctor.fieldsR - source.uvars source.nparams).length]? = + source.uvars source.nparams gen.elimination).length]? = some (VExpr.liftN i (GenerationChecked.minorType - (source := source) ctor)) := by + (source := source) ctor gen.elimination)) := by rw [getElem?_rstack_mid _ _ _ (by simp only [List.length_reverse, @@ -5728,11 +9730,11 @@ theorem minorApp_hasType {i : Nat} {ctor : NormalizedCtor} show gen.block.ctorPairs.length - 1 - i + (ctor.fieldsR - source.uvars source.nparams).length - + source.uvars source.nparams gen.elimination).length - (VExpr.liftTelN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams) + source.uvars source.nparams gen.elimination) 0).reverse.length = gen.block.ctorPairs.length - 1 - i by simp only [List.length_reverse, @@ -5755,55 +9757,55 @@ theorem minorApp_hasType {i : Nat} {ctor : NormalizedCtor} i + (gen.block.ctorPairs.length - 1 - i + (ctor.fieldsR - source.uvars source.nparams).length + 1) = + source.uvars source.nparams gen.elimination).length + 1) = (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length by omega] at hlu have hminorEq : (GenerationChecked.minorType - (source := source) ctor).liftN + (source := source) ctor gen.elimination).liftN ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length) = (VExpr.forallN (VExpr.liftTelN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams) + source.uvars source.nparams gen.elimination) 0) ((VExpr.forallN (ihsFromRecArgs (ctor.fieldsR - source.uvars source.nparams).length + source.uvars source.nparams gen.elimination).length rs 0) (VExpr.appN (.bvar ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + rs.length)) - (((ctor.resultIndicesR source.uvars).map + (((ctor.resultIndicesR source.uvars gen.elimination).map fun e => (e.liftN 1 (ctor.fieldsR - source.uvars source.nparams).length).liftN + source.uvars source.nparams gen.elimination).length).liftN rs.length) ++ [VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (rs.length + (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + 1) source.nparams ++ VExpr.bvarRevRange rs.length (ctor.fieldsR - source.uvars source.nparams).length)]))).liftN + source.uvars source.nparams gen.elimination).length)]))).liftN gen.block.ctorPairs.length (ctor.fieldsR - source.uvars source.nparams).length)).liftN + source.uvars source.nparams gen.elimination).length)).liftN (ctor.fieldsR - source.uvars source.nparams).length := by + source.uvars source.nparams gen.elimination).length := by simp only [GenerationChecked.minorType, rs, hrs] conv => lhs; rw [VExpr.liftN_forallN, @@ -5812,20 +9814,20 @@ theorem minorApp_hasType {i : Nat} {ctor : NormalizedCtor} (show (1 : Nat) + ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length) = gen.block.ctorPairs.length + 1 + (ctor.fieldsR - source.uvars source.nparams).length by + source.uvars source.nparams gen.elimination).length by omega), show (0 : Nat) + (VExpr.liftTelN 1 (ctor.fieldsR - source.uvars source.nparams) + source.uvars source.nparams gen.elimination) 0).length = (ctor.fieldsR - source.uvars source.nparams).length by + source.uvars source.nparams gen.elimination).length by simp [VExpr.liftTelN_length]] conv => rhs; rw [VExpr.liftN_forallN, VExpr.liftTelN_liftTelN, @@ -5834,143 +9836,143 @@ theorem minorApp_hasType {i : Nat} {ctor : NormalizedCtor} (VExpr.liftTelN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams) + source.uvars source.nparams gen.elimination) 0).length = (ctor.fieldsR - source.uvars source.nparams).length by + source.uvars source.nparams gen.elimination).length by simp [VExpr.liftTelN_length], VExpr.liftN'_liftN_hi, Nat.add_comm gen.block.ctorPairs.length (ctor.fieldsR - source.uvars source.nparams).length] + source.uvars source.nparams gen.elimination).length] have hfields := HasType.appN_selfSpine - (env := env) (U := source.uvars + 1) + (env := env) (U := gen.recUvars) (As := VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0) (B := (VExpr.forallN (ihsFromRecArgs (ctor.fieldsR - source.uvars source.nparams).length + source.uvars source.nparams gen.elimination).length rs 0) (VExpr.appN (.bvar ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + rs.length)) - (((ctor.resultIndicesR source.uvars).map + (((ctor.resultIndicesR source.uvars gen.elimination).map fun e => (e.liftN 1 (ctor.fieldsR - source.uvars source.nparams).length).liftN + source.uvars source.nparams gen.elimination).length).liftN rs.length) ++ [VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (rs.length + (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + 1) source.nparams ++ VExpr.bvarRevRange rs.length (ctor.fieldsR - source.uvars source.nparams).length)]))).liftN + source.uvars source.nparams gen.elimination).length)]))).liftN gen.block.ctorPairs.length (ctor.fieldsR - source.uvars source.nparams).length) + source.uvars source.nparams gen.elimination).length) (Δ := []) (Γ := gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse)) (f := .bvar (gen.block.ctorPairs.length - 1 - i + (ctor.fieldsR - source.uvars source.nparams).length)) + source.uvars source.nparams gen.elimination).length)) (by have hb := VEnv.HasType.bvar - (env := env) (U := source.uvars + 1) hlu + (env := env) (U := gen.recUvars) hlu rw [hminorEq] at hb simpa [VExpr.liftTelN_length] using hb) simp only [List.length_nil, VExpr.liftTelN_length, VExpr.liftN_zero] at hfields rw [ihsFromRecArgs_liftN' - (ctor.fieldsR source.uvars source.nparams).length + (ctor.fieldsR source.uvars source.nparams gen.elimination).length gen.block.ctorPairs.length rs hrsLt 0 (VExpr.appN (.bvar ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + rs.length)) - (((ctor.resultIndicesR source.uvars).map fun e => + (((ctor.resultIndicesR source.uvars gen.elimination).map fun e => (e.liftN 1 (ctor.fieldsR - source.uvars source.nparams).length).liftN + source.uvars source.nparams gen.elimination).length).liftN rs.length) ++ [VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (rs.length + (ctor.fieldsR - source.uvars source.nparams).length + 1) + source.uvars source.nparams gen.elimination).length + 1) source.nparams ++ VExpr.bvarRevRange rs.length (ctor.fieldsR - source.uvars source.nparams).length)])) + source.uvars source.nparams gen.elimination).length)])) (cut := (ctor.fieldsR - source.uvars source.nparams).length) + source.uvars source.nparams gen.elimination).length) rfl] at hfields have hD : (VExpr.appN (.bvar ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + rs.length)) - (((ctor.resultIndicesR source.uvars).map fun e => + (((ctor.resultIndicesR source.uvars gen.elimination).map fun e => (e.liftN 1 (ctor.fieldsR - source.uvars source.nparams).length).liftN + source.uvars source.nparams gen.elimination).length).liftN rs.length) ++ [VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange (rs.length + (ctor.fieldsR - source.uvars source.nparams).length + 1) + source.uvars source.nparams gen.elimination).length + 1) source.nparams ++ VExpr.bvarRevRange rs.length (ctor.fieldsR - source.uvars source.nparams).length)])).liftN + source.uvars source.nparams gen.elimination).length)])).liftN gen.block.ctorPairs.length ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + 0 + rs.length) = (VExpr.appN (.bvar (gen.block.ctorPairs.length + (ctor.fieldsR - source.uvars source.nparams).length)) - (((ctor.resultIndicesR source.uvars).map fun e => + source.uvars source.nparams gen.elimination).length)) + (((ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length) ++ + source.uvars source.nparams gen.elimination).length) ++ [VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1) source.nparams ++ VExpr.bvarRevRange 0 (ctor.fieldsR - source.uvars source.nparams).length)])).liftN + source.uvars source.nparams gen.elimination).length)])).liftN rs.length := by rw [VExpr.liftN_appN, VExpr.liftN_appN, List.map_append, List.map_append, @@ -5982,16 +9984,16 @@ theorem minorApp_hasType {i : Nat} {ctor : NormalizedCtor} VExpr.bvar (liftVar gen.block.ctorPairs.length ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + rs.length) ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + 0 + rs.length)) = VExpr.bvar (liftVar rs.length (gen.block.ctorPairs.length + (ctor.fieldsR - source.uvars source.nparams).length) + source.uvars source.nparams gen.elimination).length) 0) rw [liftVar_le (by omega), liftVar_le (Nat.zero_le _)] @@ -6003,10 +10005,10 @@ theorem minorApp_hasType {i : Nat} {ctor : NormalizedCtor} simp only [Function.comp_apply] rw [show (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + 0 + rs.length = (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + rs.length by omega, VExpr.liftN_liftN_mid e gen.block.ctorPairs.length rs.length @@ -6015,10 +10017,10 @@ theorem minorApp_hasType {i : Nat} {ctor : NormalizedCtor} simp only [Function.comp_apply] rw [show (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + 0 + rs.length = (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + rs.length by omega] rw [VExpr.liftN_appN, VExpr.liftN_appN, @@ -6035,11 +10037,11 @@ theorem minorApp_hasType {i : Nat} {ctor : NormalizedCtor} gen.block.ctorPairs.length + (rs.length + (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + 1) = rs.length + ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1) by omega), VExpr.bvarRevRange_congr _ @@ -6047,24 +10049,24 @@ theorem minorApp_hasType {i : Nat} {ctor : NormalizedCtor} rfl rw [hD] at hfields have hres := hasType_appN_ruleIHs - (env := env) (U := source.uvars + 1) + (env := env) (U := gen.recUvars) (m := (ctor.fieldsR - source.uvars source.nparams).length) + source.uvars source.nparams gen.elimination).length) (k := gen.block.ctorPairs.length) (rs := rs) (argOf := fun r => r.ruleCall (ctor.fieldsR - source.uvars source.nparams).length + source.uvars source.nparams gen.elimination).length gen.block.ctorPairs.length (VExpr.appN (.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars + 1))) + (gen.recLevels)) (VExpr.bvarRevRange (ctor.fieldsR - source.uvars source.nparams).length + source.uvars source.nparams gen.elimination).length (source.nparams + gen.block.ctorPairs.length + 1)))) (fun r hr => @@ -6078,10 +10080,10 @@ theorem recRuleApp_hasType {ctor : NormalizedCtor} (hrec : env.constants (.str gen.block.sourceType.name "rec") = some gen.recursor) : - env.HasType (source.uvars + 1) + env.HasType (gen.recUvars) ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) @@ -6089,58 +10091,58 @@ theorem recRuleApp_hasType {ctor : NormalizedCtor} (VExpr.appN (.const (.str gen.block.sourceType.name "rec") - (VLevel.params (source.uvars + 1))) + (gen.recLevels)) (VExpr.bvarRevRange (ctor.fieldsR - source.uvars source.nparams).length + source.uvars source.nparams gen.elimination).length (source.nparams + gen.block.ctorPairs.length + 1))) - (((ctor.resultIndicesR source.uvars).map fun e => + (((ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length) ++ + source.uvars source.nparams gen.elimination).length) ++ [VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1) source.nparams ++ VExpr.bvarRevRange 0 (ctor.fieldsR - source.uvars source.nparams).length)])) + source.uvars source.nparams gen.elimination).length)])) (VExpr.appN (.bvar (gen.block.ctorPairs.length + (ctor.fieldsR - source.uvars source.nparams).length)) - (((ctor.resultIndicesR source.uvars).map fun e => + source.uvars source.nparams gen.elimination).length)) + (((ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length) ++ + source.uvars source.nparams gen.elimination).length) ++ [VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1) source.nparams ++ VExpr.bvarRevRange 0 (ctor.fieldsR - source.uvars source.nparams).length)])) := by + source.uvars source.nparams gen.elimination).length)])) := by have hSp₀ := S.result_transport hctor (gen.minorTypes.reverse ++ [gen.motiveType]) (g := gen.block.ctorPairs.length + 1) (by simp [gen.minorTypes_length]) [] (d := 0) rfl - have hSp : env.SpineWF (source.uvars + 1) + have hSp : env.SpineWF (gen.recUvars) ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) @@ -6149,30 +10151,30 @@ theorem recRuleApp_hasType {ctor : NormalizedCtor} ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams) + source.uvars source.nparams gen.elimination) 0).reverse.length + gen.block.ctorPairs.length + 1) gen.idxTel 0) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1)))) - ((ctor.resultIndicesR source.uvars).map fun e => + (gen.sourceLevels)))) + ((ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length) + source.uvars source.nparams gen.elimination).length) (.sort (gen.block.checked.resultLevel.inst - (VLevel.params' source.uvars 1))) := by + (gen.sourceLevels))) := by simpa [List.append_assoc, Nat.add_assoc, List.length_reverse, VExpr.liftTelN_length] using hSp₀ have hidxLen : - ((ctor.resultIndicesR source.uvars).map fun e => + ((ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length).length = + source.uvars source.nparams gen.elimination).length).length = gen.idxTel.length := by simp only [List.length_map, NormalizedCtor.resultIndicesR, @@ -6180,63 +10182,63 @@ theorem recRuleApp_hasType {ctor : NormalizedCtor} exact (S.viewResultIndices_length hctor).trans gen.shape.2.2.1.symm have ha₀ := S.ctorAppRule_hasType hctor - have ha : env.HasType (source.uvars + 1) + have ha : env.HasType (gen.recUvars) ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse ++ (gen.minorTypes.reverse ++ (gen.motiveType :: gen.paramsTel.reverse))) (VExpr.appN (.const ctor.raw.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange ((ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1) source.nparams ++ VExpr.bvarRevRange 0 (ctor.fieldsR - source.uvars source.nparams).length)) + source.uvars source.nparams gen.elimination).length)) (VExpr.appN (.const gen.block.sourceType.name - (VLevel.params' source.uvars 1)) + (gen.sourceLevels)) (VExpr.bvarRevRange ((VExpr.liftTelN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams) + source.uvars source.nparams gen.elimination) 0).reverse.length + gen.block.ctorPairs.length + 1) source.nparams ++ - (ctor.resultIndicesR source.uvars).map fun e => + (ctor.resultIndicesR source.uvars gen.elimination).map fun e => e.liftN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams).length)) := by + source.uvars source.nparams gen.elimination).length)) := by simpa only [List.length_reverse, VExpr.liftTelN_length] using ha₀ have hr := S.recApp_hasType hrec (VExpr.liftTelN (gen.block.ctorPairs.length + 1) - (ctor.fieldsR source.uvars source.nparams) + (ctor.fieldsR source.uvars source.nparams gen.elimination) 0).reverse hSp hidxLen ha rw [List.length_reverse, VExpr.liftTelN_length, show (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length = gen.block.ctorPairs.length + (ctor.fieldsR - source.uvars source.nparams).length by + source.uvars source.nparams gen.elimination).length by omega, show gen.block.ctorPairs.length + (ctor.fieldsR - source.uvars source.nparams).length + 1 = + source.uvars source.nparams gen.elimination).length + 1 = (ctor.fieldsR - source.uvars source.nparams).length + + source.uvars source.nparams gen.elimination).length + gen.block.ctorPairs.length + 1 by omega] at hr exact hr @@ -6251,14 +10253,14 @@ theorem rule_WF {i : Nat} {ctor : NormalizedCtor} (gen.rule i ctor).WF env := by have hctor := List.mem_of_getElem? hci refine ⟨?_, ?_⟩ - · show env.HasType (source.uvars + 1) [] + · show env.HasType (gen.recUvars) [] (VExpr.lamN (gen.paramsTel ++ gen.motiveType :: gen.minorTypes ++ VExpr.liftTelN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams) + source.uvars source.nparams gen.elimination) 0) _) (VExpr.forallN _ _) @@ -6268,14 +10270,14 @@ theorem rule_WF {i : Nat} {ctor : NormalizedCtor} List.reverse_cons, List.append_nil, List.append_assoc, List.singleton_append] exact S.recRuleApp_hasType hctor hrec - · show env.HasType (source.uvars + 1) [] + · show env.HasType (gen.recUvars) [] (VExpr.lamN (gen.paramsTel ++ gen.motiveType :: gen.minorTypes ++ VExpr.liftTelN (gen.block.ctorPairs.length + 1) (ctor.fieldsR - source.uvars source.nparams) + source.uvars source.nparams gen.elimination) 0) _) (VExpr.forallN _ _) @@ -6973,7 +10975,7 @@ theorem Stage3Env.recArgMinor_isType {c : VConstVal} (hc : c ∈ ty.ctors) rw [show m-1-j+p+1 = m-j+p from by omega] at hlu dsimp only [j, r] at hlu have hfield := recArg_minor_fieldType hr₀ m p (by simpa [j] using hjm) - simp only [RecArg.instL] at hfield + simp only [RecArg.instL, ElimMode.large_sourceLevels] at hfield rw [hfield] at hlu have hf0 := VEnv.HasType.bvar (env := env) (U := U+1) hlu have hf := hf0.weakN S.ord (Ctx.LiftN.zero (Γ := Γ) As.reverse) @@ -8836,7 +12838,7 @@ theorem Stage3Env.ruleCallRec_hasType {c : VConstVal} (hc : c ∈ ty.ctors) rw [show m-1-r₀.fieldIndex+1 = m-r₀.fieldIndex from by omega] at hlu have hfield := recArg_rule_fieldType hr₀ m k (by simpa [j] using hjm) - simp only [RecArg.instL] at hfield + simp only [RecArg.instL, ElimMode.large_sourceLevels] at hfield rw [hfield] at hlu have hf0 := VEnv.HasType.bvar (env := env) (U := U+1) hlu have hf := hf0.weakN S.ord (Ctx.LiftN.zero (Γ := Γ) As.reverse) @@ -8971,7 +12973,7 @@ theorem Stage3Env.minorApp_hasType {i : Nat} {c : VConstVal} VExpr.bvarRevRange rs.length (ctorFieldsR U np c).length)]))).liftN ty.ctors.length (ctorFieldsR U np c).length)).liftN (ctorFieldsR U np c).length := by - simp only [minorType, rs, hrs] + simp only [minorType, rs, hrs, ElimMode.large_sourceLevels] conv => lhs; rw [VExpr.liftN_forallN, VExpr.liftTelN_liftTelN, liftTelN_congr _ _ (show (1:Nat) + ((ctorFieldsR U np c).length + ty.ctors.length) = @@ -9164,7 +13166,7 @@ theorem Stage3Env.minorAppRec_hasType {i : Nat} {c : VConstVal} VExpr.bvarRevRange rs.length (ctorFieldsR U np c).length)]))).liftN ty.ctors.length (ctorFieldsR U np c).length)).liftN (ctorFieldsR U np c).length := by - simp only [minorTypeRec, rs, hrs] + simp only [minorTypeRec, rs, hrs, ElimMode.large_sourceLevels] conv => lhs; rw [VExpr.liftN_forallN, VExpr.liftTelN_liftTelN, liftTelN_congr _ _ (show (1:Nat) + ((ctorFieldsR U np c).length + ty.ctors.length) = @@ -9773,6 +13775,37 @@ theorem GenerationEnv.generatedRulesFold_ordered rulesFold_WF gen.generatedRules S.ord (S.generatedRules_WF hrec) +/-- Every rule emitted from the flattened mutual constructor list is well +formed in an environment containing every generated family recursor. -/ +theorem BlockGenerationEnv.generatedRules_WF + {source : VInductDecl} + {gen : BlockGenerationChecked source} {env : VEnv} + (S : BlockGenerationEnv gen env) + (hrecs : ∀ family ∈ gen.families, + env.constants (.str family.raw.name "rec") = + some (gen.recursor family)) : + ∀ df ∈ gen.generatedRules, df.WF env := by + intro df hdf + change df ∈ + gen.flatCtors.zipIdx.map + (fun (constructor, i) => gen.rule i constructor) at hdf + obtain ⟨⟨constructor, i⟩, hmem, rfl⟩ := List.mem_map.1 hdf + obtain ⟨-, hci⟩ := List.mem_zipIdx_getElem? hmem + rw [Nat.sub_zero] at hci + exact S.rule_WF hci hrecs + +/-- Folding every generated mutual rule preserves environment ordering. -/ +theorem BlockGenerationEnv.generatedRulesFold_ordered + {source : VInductDecl} + {gen : BlockGenerationChecked source} {env : VEnv} + (S : BlockGenerationEnv gen env) + (hrecs : ∀ family ∈ gen.families, + env.constants (.str family.raw.name "rec") = + some (gen.recursor family)) : + (gen.generatedRules.foldl VEnv.addDefEq env).Ordered := + rulesFold_WF gen.generatedRules S.ord + (S.generatedRules_WF hrecs) + /-- Folding definitional equations only grows the environment and registers every equation in the input list. -/ theorem rulesFold_spec : ∀ (dfs : List VDefEq) (env : VEnv), @@ -10012,23 +14045,306 @@ theorem AddInductGenerationTrace.rule_mem {source : VInductDecl} simpa only [H.addRules] using (rulesFold_spec gen.generatedRules H.recEnv).2 df hdf -/-- The normalized transaction preserves environment ordering from the -semantic raw/view generation certificate. Stored constants are checked in -their exact raw syntax; the mixed recursor and rules are checked only after -all raw constants are present. -/ -theorem addInductGeneration_WF {source : VInductDecl} - {gen : source.GenerationChecked} - (henv : env.Ordered) (hgen : gen.WF env) - (hadd : addInductGeneration env gen = some env') : +/-! ### Block-wide transaction facts -/ + +/-- Recover every phase boundary from a successful block-wide transaction. -/ +theorem addInductBlockGeneration_trace {source : VInductDecl} + {gen : source.BlockGenerationChecked} + (hadd : addInductBlockGeneration env gen = some env') : + Nonempty (AddInductBlockGenerationTrace env env' gen) := by + unfold addInductBlockGeneration 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 block-wide transaction is atomic at its public `Option` boundary. -/ +theorem addInductBlockGeneration_atomic {source : VInductDecl} + (env : VEnv) (gen : source.BlockGenerationChecked) : + addInductBlockGeneration env gen = none ∨ + ∃ env', addInductBlockGeneration env gen = some env' ∧ + Nonempty (AddInductBlockGenerationTrace env env' gen) := by + cases hadd : addInductBlockGeneration env gen with + | none => exact .inl rfl + | some env' => + exact .inr ⟨env', rfl, addInductBlockGeneration_trace hadd⟩ + +/-- Every phase of a successful block transaction only grows the Theory +environment. -/ +theorem AddInductBlockGenerationTrace.le {source : VInductDecl} + {gen : source.BlockGenerationChecked} + (H : AddInductBlockGenerationTrace env env' gen) : 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 gen.recursors H.addRecs).1 + have hrules : H.recEnv ≤ env' := by + simpa only [H.addRules] using + (rulesFold_spec gen.generatedRules H.recEnv).1 + exact htypes.trans (hctors.trans (hrecs.trans hrules)) + +/-- Every source family name was fresh before a successful block +transaction. -/ +theorem AddInductBlockGenerationTrace.family_fresh + {source : VInductDecl} {gen : source.BlockGenerationChecked} + (H : AddInductBlockGenerationTrace env env' gen) + {type : VInductiveType} (htype : type ∈ source.types) : + env.constants type.name = none := by + have hmem : type.toVConstVal ∈ source.blockTypeConstants := by + exact 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 contains every exact raw family constant. -/ +theorem AddInductBlockGenerationTrace.family_lookup + {source : VInductDecl} {gen : source.BlockGenerationChecked} + (H : AddInductBlockGenerationTrace env env' gen) + {type : VInductiveType} (htype : type ∈ source.types) : + env'.constants type.name = some type.toVConstant := by + have hmem : type.toVConstVal ∈ source.blockTypeConstants := by + exact 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 gen.recursors H.addRecs).1 + have hrules : H.recEnv ≤ env' := by + simpa only [H.addRules] using + (rulesFold_spec gen.generatedRules H.recEnv).1 + exact (hctors.trans (hrecs.trans hrules)).constants hlookup + +/-- Every flattened raw constructor name was fresh in the transaction's +input environment. -/ +theorem AddInductBlockGenerationTrace.ctor_fresh + {source : VInductDecl} {gen : source.BlockGenerationChecked} + (H : AddInductBlockGenerationTrace env env' gen) + {constructor : VConstVal} + (hconstructor : constructor ∈ source.blockConstructorConstants) : + env.constants constructor.name = none := by + have htypes := + (ctorFold_spec source.blockTypeConstants H.addTypes).1 + have hfresh := + (ctorFold_spec source.blockConstructorConstants H.addCtors).2.2 + constructor hconstructor + exact htypes.constants_none hfresh + +/-- The final environment contains every exact raw constructor constant. -/ +theorem AddInductBlockGenerationTrace.ctor_lookup + {source : VInductDecl} {gen : source.BlockGenerationChecked} + (H : AddInductBlockGenerationTrace env env' gen) + {constructor : VConstVal} + (hconstructor : constructor ∈ source.blockConstructorConstants) : + env'.constants constructor.name = some constructor.toVConstant := by + have hlookup := + (ctorFold_spec source.blockConstructorConstants H.addCtors).2.1 + constructor hconstructor + have hrecs := (ctorFold_spec gen.recursors H.addRecs).1 + have hrules : H.recEnv ≤ env' := by + simpa only [H.addRules] using + (rulesFold_spec gen.generatedRules H.recEnv).1 + exact (hrecs.trans hrules).constants hlookup + +/-- Every generated recursor name was fresh before the block transaction. -/ +theorem AddInductBlockGenerationTrace.rec_fresh + {source : VInductDecl} {gen : source.BlockGenerationChecked} + (H : AddInductBlockGenerationTrace env env' gen) + {recursor : VConstVal} (hrecursor : recursor ∈ gen.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 gen.recursors H.addRecs).2.2 recursor hrecursor + exact (htypes.trans hctors).constants_none hfresh + +/-- The final environment contains every generated recursor. -/ +theorem AddInductBlockGenerationTrace.rec_lookup + {source : VInductDecl} {gen : source.BlockGenerationChecked} + (H : AddInductBlockGenerationTrace env env' gen) + {recursor : VConstVal} (hrecursor : recursor ∈ gen.recursors) : + env'.constants recursor.name = some recursor.toVConstant := by + have hlookup := + (ctorFold_spec gen.recursors H.addRecs).2.1 recursor hrecursor + have hrules : H.recEnv ≤ env' := by + simpa only [H.addRules] using + (rulesFold_spec gen.generatedRules H.recEnv).1 + exact hrules.constants hlookup + +/-- The final environment registers every block-generated iota rule. -/ +theorem AddInductBlockGenerationTrace.rule_mem + {source : VInductDecl} {gen : source.BlockGenerationChecked} + (H : AddInductBlockGenerationTrace env env' gen) + {df : VDefEq} (hdf : df ∈ gen.generatedRules) : + env'.defeqs df := by + simpa only [H.addRules] using + (rulesFold_spec gen.generatedRules H.recEnv).2 df hdf + +/-- Preserve ordering through the all-families phase. -/ +private theorem addInductBlockGeneration_families_ordered + {source : VInductDecl} {gen : source.BlockGenerationChecked} + {blockEnv : VEnv} + (H : AddInductBlockGenerationTrace env env' gen) + (henv : env.Ordered) (hgen : gen.WF env blockEnv) : + H.typeEnv.Ordered := by + apply constFold_ordered source.blockTypeConstants henv ?_ H.addTypes + intro type htype + simp only [VInductDecl.blockTypeConstants, List.mem_map] at htype + obtain ⟨raw, hraw, rfl⟩ := htype + have hraw' : raw ∈ gen.families.map (·.raw) := by + rw [gen.families_map_raw] + exact hraw + obtain ⟨family, hfamily, rfl⟩ := List.mem_map.1 hraw' + show env.IsType family.raw.uvars [] family.raw.type + rw [gen.family_uvars hfamily] + exact hgen.rawFamily_isType hfamily + +/-- Preserve ordering through the globally flattened constructor phase. -/ +private theorem addInductBlockGeneration_constructors_ordered + {source : VInductDecl} {gen : source.BlockGenerationChecked} + {blockEnv : VEnv} + (H : AddInductBlockGenerationTrace env env' gen) + (hgen : gen.WF env blockEnv) (ordT : H.typeEnv.Ordered) : + H.ctorEnv.Ordered := by + have hstage : env.stageInductiveTypes source.types = some blockEnv := + hgen.blockWF.1.1 + rw [← blockTypeConstants_foldlM_eq_stageInductiveTypes env source, + H.addTypes] at hstage + have htypeEnv : H.typeEnv = blockEnv := Option.some.inj hstage + subst blockEnv + apply constFold_ordered source.blockConstructorConstants ordT ?_ H.addCtors + intro ctor hctor + have hctor' : ctor ∈ gen.flatCtors.map (·.ctor.raw) := by + rw [gen.flatCtors_map_raw] + exact hctor + obtain ⟨constructor, hconstructor, rfl⟩ := List.mem_map.1 hctor' + show H.typeEnv.IsType constructor.ctor.raw.uvars [] + constructor.ctor.raw.type + rw [gen.flatCtor_uvars hconstructor] + exact hgen.rawCtor_isType hconstructor + +/-- Assemble the mutual generation invariant once every raw family and every +globally flattened constructor has been inserted. -/ +private theorem addInductBlockGeneration_constructor_generationEnv + {source : VInductDecl} {gen : source.BlockGenerationChecked} + {blockEnv : VEnv} + (H : AddInductBlockGenerationTrace env env' gen) + (hgen : gen.WF env blockEnv) (ordC : H.ctorEnv.Ordered) : + BlockGenerationEnv gen H.ctorEnv := by + obtain ⟨hleET, hfamilyLookup, -⟩ := + ctorFold_spec source.blockTypeConstants H.addTypes + obtain ⟨hleTC, hctorLookup, -⟩ := + ctorFold_spec source.blockConstructorConstants H.addCtors + have hstage : env.stageInductiveTypes source.types = some blockEnv := + hgen.blockWF.1.1 + rw [← blockTypeConstants_foldlM_eq_stageInductiveTypes env source, + H.addTypes] at hstage + have htypeEnv : H.typeEnv = blockEnv := Option.some.inj hstage + rw [htypeEnv] at hleET hfamilyLookup hleTC + have hfamilies : ∀ family ∈ gen.families, + H.ctorEnv.constants family.raw.name = + some family.raw.toVConstant := by + intro family hfamily + apply hleTC.constants + apply hfamilyLookup family.raw.toVConstVal + simp only [VInductDecl.blockTypeConstants, List.mem_map] + refine ⟨family.raw, ?_, rfl⟩ + rw [← gen.families_map_raw] + exact List.mem_map.2 ⟨family, hfamily, rfl⟩ + have hctors : ∀ constructor ∈ gen.flatCtors, + H.ctorEnv.constants constructor.ctor.raw.name = + some constructor.ctor.raw.toVConstant := by + intro constructor hconstructor + apply hctorLookup constructor.ctor.raw + rw [← gen.flatCtors_map_raw] + exact List.mem_map.2 ⟨constructor, hconstructor, rfl⟩ + exact hgen.toBlockGenerationEnv (hleET.trans hleTC) hleTC ordC + hfamilies hctors + +/-- Preserve ordering while inserting the family-indexed recursor list. -/ +private theorem addInductBlockGeneration_recursors_ordered + {source : VInductDecl} {gen : source.BlockGenerationChecked} + (H : AddInductBlockGenerationTrace env env' gen) + (S : BlockGenerationEnv gen H.ctorEnv) : + H.recEnv.Ordered := by + apply constFold_ordered gen.recursors S.ord ?_ H.addRecs + intro recursor hrecursor + simp only [BlockGenerationChecked.recursors, List.mem_map] at hrecursor + obtain ⟨family, hfamily, rfl⟩ := hrecursor + exact S.recursor_wf hfamily + +/-- The recursor fold stores the exact generated recursor selected by every +family ordinal. -/ +private theorem addInductBlockGeneration_recursor_lookup + {source : VInductDecl} {gen : source.BlockGenerationChecked} + (H : AddInductBlockGenerationTrace env env' gen) + {family : NormalizedFamily} (hfamily : family ∈ gen.families) : + H.recEnv.constants (.str family.raw.name "rec") = + some (gen.recursor family) := by + let recursor : VConstVal := + ⟨gen.recursor family, .str family.raw.name "rec"⟩ + have hrecursor : recursor ∈ gen.recursors := + List.mem_map.2 ⟨family, hfamily, rfl⟩ + simpa [recursor] using + (ctorFold_spec gen.recursors H.addRecs).2.1 recursor hrecursor + +/-- Preserve ordering through the block-wide generated-rule fold. -/ +private theorem addInductBlockGeneration_rules_ordered + {source : VInductDecl} {gen : source.BlockGenerationChecked} + (H : AddInductBlockGenerationTrace env env' gen) + (S : BlockGenerationEnv gen H.recEnv) : env'.Ordered := by + have hout := S.generatedRulesFold_ordered + (fun family hfamily => + addInductBlockGeneration_recursor_lookup H hfamily) + simpa only [H.addRules] using hout + +/-- The block-wide transaction preserves ordering through all families, +constructors, family-indexed recursors, and flattened iota rules. -/ +theorem addInductBlockGeneration_WF + {source : VInductDecl} {gen : source.BlockGenerationChecked} + {blockEnv : VEnv} + (henv : env.Ordered) (hgen : gen.WF env blockEnv) + (hadd : addInductBlockGeneration env gen = some env') : env'.Ordered := by - rcases addInductGeneration_trace hadd with ⟨H⟩ + rcases addInductBlockGeneration_trace hadd with ⟨H⟩ + have ordT : H.typeEnv.Ordered := + addInductBlockGeneration_families_ordered H henv hgen + have ordC : H.ctorEnv.Ordered := + addInductBlockGeneration_constructors_ordered H hgen ordT + have S : BlockGenerationEnv gen H.ctorEnv := + addInductBlockGeneration_constructor_generationEnv H hgen ordC + have ordR : H.recEnv.Ordered := + addInductBlockGeneration_recursors_ordered H S + have hleCR := (ctorFold_spec gen.recursors H.addRecs).1 + have SR : BlockGenerationEnv gen H.recEnv := + S.mono hleCR ordR + exact addInductBlockGeneration_rules_ordered H SR + +/-- Preserve ordering across the raw family insertion, the first generated +component of an inductive transaction. -/ +private theorem addInductGeneration_family_ordered {source : VInductDecl} + {gen : source.GenerationChecked} + (H : AddInductGenerationTrace env env' gen) + (henv : env.Ordered) (hgen : gen.WF env) : H.typeEnv.Ordered := by have hfamilyWF : gen.block.sourceType.toVConstant.WF env := by show env.IsType gen.block.sourceType.uvars [] gen.block.sourceType.type rw [gen.block.sourceType_uvars_eq] exact hgen.rawFamily_isType - have ordT : H.typeEnv.Ordered := - .const henv hfamilyWF H.addType + exact .const henv hfamilyWF H.addType + +/-- Preserve ordering across the complete raw constructor fold. The proof is +uniform in the source list, so the empty-constructor case is the ordinary +zero-step fold rather than a separate preservation path. -/ +private theorem addInductGeneration_constructors_ordered + {source : VInductDecl} {gen : source.GenerationChecked} + (H : AddInductGenerationTrace env env' gen) + (hgen : gen.WF env) (ordT : H.typeEnv.Ordered) : + H.ctorEnv.Ordered := by have hctorWF : ∀ c ∈ gen.block.sourceType.ctors, c.toVConstant.WF H.typeEnv := by @@ -10040,8 +14356,16 @@ theorem addInductGeneration_WF {source : VInductDecl} show H.typeEnv.IsType ctor.raw.uvars [] ctor.raw.type rw [gen.ctor_uvars_eq hctor] exact hgen.rawCtor_isType H.addType hctor - have ordC : H.ctorEnv.Ordered := - constFold_ordered gen.block.sourceType.ctors ordT hctorWF H.addCtors + exact constFold_ordered gen.block.sourceType.ctors ordT hctorWF + H.addCtors + +/-- Assemble the mixed-generation invariant after the exact family and +constructor components have been inserted. -/ +private theorem addInductGeneration_constructor_generationEnv + {source : VInductDecl} {gen : source.GenerationChecked} + (H : AddInductGenerationTrace env env' gen) + (hgen : gen.WF env) (ordC : H.ctorEnv.Ordered) : + GenerationEnv gen H.ctorEnv := by obtain ⟨hleTC, hctorLookup, -⟩ := ctorFold_spec gen.block.sourceType.ctors H.addCtors have hlePreT := addConst_le H.addType @@ -10058,16 +14382,48 @@ theorem addInductGeneration_WF {source : VInductDecl} apply hctorLookup ctor.raw rw [← gen.rawCtors_eq] exact List.mem_map.2 ⟨ctor, hctor, rfl⟩ + exact hgen.toGenerationEnv H.addType hlePreC hleTC ordC hfamily + hctors + +/-- Preserve ordering across the single generated recursor component. -/ +private theorem addInductGeneration_recursor_ordered + {source : VInductDecl} {gen : source.GenerationChecked} + (H : AddInductGenerationTrace env env' gen) + (S : GenerationEnv gen H.ctorEnv) : H.recEnv.Ordered := + .const S.ord S.recursor_wf H.addRec + +/-- Preserve ordering across the generated rule fold. Empty families supply +no rules, so this is again the same zero-step component fold used generally. -/ +private theorem addInductGeneration_rules_ordered + {source : VInductDecl} {gen : source.GenerationChecked} + (H : AddInductGenerationTrace env env' gen) + (S : GenerationEnv gen H.recEnv) : env'.Ordered := by + have hout := + S.generatedRulesFold_ordered (addConst_self H.addRec) + simpa only [H.addRules] using hout + +/-- The normalized transaction preserves environment ordering from the +semantic raw/view generation certificate. Stored constants are checked in +their exact raw syntax; the mixed recursor and rules are checked only after +all raw constants are present. -/ +theorem addInductGeneration_WF {source : VInductDecl} + {gen : source.GenerationChecked} + (henv : env.Ordered) (hgen : gen.WF env) + (hadd : addInductGeneration env gen = some env') : + env'.Ordered := by + rcases addInductGeneration_trace hadd with ⟨H⟩ + have ordT : H.typeEnv.Ordered := + addInductGeneration_family_ordered H henv hgen + have ordC : H.ctorEnv.Ordered := + addInductGeneration_constructors_ordered H hgen ordT have S : GenerationEnv gen H.ctorEnv := - hgen.toGenerationEnv H.addType hlePreC hleTC ordC hfamily hctors + addInductGeneration_constructor_generationEnv H hgen ordC have ordR : H.recEnv.Ordered := - .const ordC S.recursor_wf H.addRec + addInductGeneration_recursor_ordered H S have hleCR := addConst_le H.addRec have SR : GenerationEnv gen H.recEnv := S.mono hleCR ordR - have hout := - SR.generatedRulesFold_ordered (addConst_self H.addRec) - simpa only [H.addRules] using hout + exact addInductGeneration_rules_ordered H SR /-- Recover the ordinary normalized transaction trace from the proof-carrying public entry point. The conclusion contains only Theory data; @@ -10102,6 +14458,111 @@ theorem addInductCertified_WF {source : VInductDecl} apply addInductGeneration_WF henv certificate.wf simpa only [addInductCertified_eq_addInductGeneration] using hadd +/-- Recover the exact block-wide transaction phases through the public +proof-carrying entry point. -/ +theorem addInductBlockCertified_trace {source : VInductDecl} + {certificate : source.BlockGenerationCertificate env} + (hadd : addInductBlockCertified env certificate = some env') : + Nonempty + (AddInductBlockGenerationTrace env env' + certificate.generation) := by + apply addInductBlockGeneration_trace + simpa only [addInductBlockCertified_eq_addInductBlockGeneration] using hadd + +/-- The public block certificate wrapper has the same atomic behavior as its +underlying block transaction. -/ +theorem addInductBlockCertified_atomic {source : VInductDecl} + (env : VEnv) (certificate : source.BlockGenerationCertificate env) : + addInductBlockCertified env certificate = none ∨ + ∃ env', addInductBlockCertified env certificate = some env' ∧ + Nonempty + (AddInductBlockGenerationTrace env env' + certificate.generation) := by + simpa only [addInductBlockCertified_eq_addInductBlockGeneration] using + addInductBlockGeneration_atomic env certificate.generation + +/-- Ordering preservation for the public proof-carrying mutual-block +transaction. -/ +theorem addInductBlockCertified_WF {source : VInductDecl} + {certificate : source.BlockGenerationCertificate env} + (henv : env.Ordered) + (hadd : addInductBlockCertified env certificate = some env') : + env'.Ordered := by + apply addInductBlockGeneration_WF henv certificate.wf + simpa only [addInductBlockCertified_eq_addInductBlockGeneration] using hadd + +/-- +info: 'Lean4Lean.VEnv.addInductBlockGeneration_trace' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms addInductBlockGeneration_trace + +/-- +info: 'Lean4Lean.VEnv.addInductBlockGeneration_atomic' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms addInductBlockGeneration_atomic + +/-- +info: 'Lean4Lean.VEnv.AddInductBlockGenerationTrace.le' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms AddInductBlockGenerationTrace.le + +/-- +info: 'Lean4Lean.VEnv.AddInductBlockGenerationTrace.family_lookup' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms AddInductBlockGenerationTrace.family_lookup + +/-- +info: 'Lean4Lean.VEnv.AddInductBlockGenerationTrace.ctor_lookup' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms AddInductBlockGenerationTrace.ctor_lookup + +/-- +info: 'Lean4Lean.VEnv.AddInductBlockGenerationTrace.rec_lookup' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms AddInductBlockGenerationTrace.rec_lookup + +/-- +info: 'Lean4Lean.VEnv.AddInductBlockGenerationTrace.rule_mem' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms AddInductBlockGenerationTrace.rule_mem + +/-- +info: 'Lean4Lean.VEnv.addInductBlockGeneration_WF' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms addInductBlockGeneration_WF + +/-- +info: 'Lean4Lean.VEnv.addInductBlockCertified_eq_addInductBlockGeneration' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms addInductBlockCertified_eq_addInductBlockGeneration + +/-- +info: 'Lean4Lean.VEnv.addInductBlockCertified_trace' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms addInductBlockCertified_trace + +/-- +info: 'Lean4Lean.VEnv.addInductBlockCertified_atomic' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms addInductBlockCertified_atomic + +/-- +info: 'Lean4Lean.VEnv.addInductBlockCertified_WF' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms addInductBlockCertified_WF + /-- info: 'Lean4Lean.VEnv.addInductGeneration_trace' depends on axioms: [propext, Quot.sound] -/ @@ -10175,23 +14636,22 @@ info: 'Lean4Lean.VEnv.addInductCertified_WF' depends on axioms: [propext, Classi #print axioms addInductCertified_WF /-- -info: 'Lean4Lean.VEnv.addInduct_eq_addInductGeneration' depends on axioms: [propext, Classical.choice, Quot.sound] +info: 'Lean4Lean.VEnv.addInduct_eq_addInductBlockGeneration' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in -#print axioms addInduct_eq_addInductGeneration +#print axioms addInduct_eq_addInductBlockGeneration /-- Elimination of a successful `addInduct` transaction into its stable consumer-facing postcondition. -/ theorem addInduct_success (hadd : addInduct env decl = some env') : AddInductSuccess env env' decl := by unfold addInduct at hadd - obtain ⟨checked, hchecked, hgen⟩ := + obtain ⟨generation, hgeneration, hgen⟩ := Option.bind_eq_some_iff.1 hadd - rcases addInductGeneration_trace hgen with ⟨H⟩ + rcases addInductBlockGeneration_trace hgen with ⟨H⟩ refine { - checked := ⟨checked, hchecked⟩ - accepted := by simp [stage3, hchecked] - singleton := ⟨checked.type, checked.types_eq⟩ + generation := ⟨generation, hgeneration⟩ + accepted := by simp [stage3, hgeneration] le := H.le type_fresh := ?_ type_lookup := ?_ @@ -10202,50 +14662,39 @@ theorem addInduct_success (hadd : addInduct env decl = some env') : rule_mem := ?_ } · intro ty hty - rw [checked.types_eq] at hty - obtain rfl := List.mem_singleton.1 hty - exact H.family_fresh + exact H.family_fresh hty · intro ty hty - rw [checked.types_eq] at hty - obtain rfl := List.mem_singleton.1 hty - exact H.family_lookup + exact H.family_lookup hty · intro ty hty c hc - rw [checked.types_eq] at hty - obtain rfl := List.mem_singleton.1 hty - exact H.ctor_fresh hc + apply H.ctor_fresh + simp only [VInductDecl.blockConstructorConstants, List.mem_flatMap] + exact ⟨ty, hty, hc⟩ · intro ty hty c hc - rw [checked.types_eq] at hty - obtain rfl := List.mem_singleton.1 hty - exact H.ctor_lookup hc - · intro ty hty - rw [checked.types_eq] at hty - obtain rfl := List.mem_singleton.1 hty - exact H.rec_fresh - · intro ty hty - rw [checked.types_eq] at hty - obtain rfl := List.mem_singleton.1 hty - have hout := H.rec_lookup - change env'.constants (.str checked.type.name "rec") = - some checked.recursor at hout - rw [checked.recursor_eq_legacy] at hout - exact hout - · intro ty hty df hdf - rw [checked.types_eq] at hty - obtain rfl := List.mem_singleton.1 hty - apply H.rule_mem - change df ∈ checked.generatedRules - rw [checked.generatedRules_eq_legacy] - exact hdf + apply H.ctor_lookup + simp only [VInductDecl.blockConstructorConstants, List.mem_flatMap] + exact ⟨ty, hty, hc⟩ + · intro generation' hgeneration' recursor hrecursor + have heq : generation = generation' := + Option.some.inj (hgeneration.symm.trans hgeneration') + exact H.rec_fresh (by simpa [heq] using hrecursor) + · intro generation' hgeneration' recursor hrecursor + have heq : generation = generation' := + Option.some.inj (hgeneration.symm.trans hgeneration') + exact H.rec_lookup (by simpa [heq] using hrecursor) + · intro generation' hgeneration' df hdf + have heq : generation = generation' := + Option.some.inj (hgeneration.symm.trans hgeneration') + exact H.rule_mem (by simpa [heq] using hdf) /-- Successful inductive addition is monotone. -/ theorem addInduct_le (hadd : addInduct env decl = some env') : env ≤ env' := (addInduct_success hadd).le -/-- Successful environment extension exposes the exact checked descriptor that +/-- Successful environment extension exposes the exact block descriptor that drove generation, so consumers never need to re-run acceptance analysis. -/ -theorem addInduct_checked (hadd : addInduct env decl = some env') : - ∃ checked, decl.checked? = some checked := - (addInduct_success hadd).checked +theorem addInduct_generation (hadd : addInduct env decl = some env') : + ∃ generation, decl.identityBlockGeneration? = some generation := + (addInduct_success hadd).generation theorem addInduct_type_fresh (hadd : addInduct env decl = some env') (hty : ty ∈ decl.types) : env.constants ty.name = none := @@ -10265,19 +14714,25 @@ theorem addInduct_ctor_lookup (hadd : addInduct env decl = some env') (addInduct_success hadd).ctor_lookup ty hty c hc theorem addInduct_rec_fresh (hadd : addInduct env decl = some env') - (hty : ty ∈ decl.types) : env.constants (.str ty.name "rec") = none := - (addInduct_success hadd).rec_fresh ty hty + {generation : decl.BlockGenerationChecked} + (hgeneration : decl.identityBlockGeneration? = some generation) + {recursor : VConstVal} (hrecursor : recursor ∈ generation.recursors) : + env.constants recursor.name = none := + (addInduct_success hadd).rec_fresh generation hgeneration recursor hrecursor theorem addInduct_rec_lookup (hadd : addInduct env decl = some env') - (hty : ty ∈ decl.types) : - env'.constants (.str ty.name "rec") = - some (recConstRec decl.uvars ty.name decl.nparams ty) := - (addInduct_success hadd).rec_lookup ty hty + {generation : decl.BlockGenerationChecked} + (hgeneration : decl.identityBlockGeneration? = some generation) + {recursor : VConstVal} (hrecursor : recursor ∈ generation.recursors) : + env'.constants recursor.name = some recursor.toVConstant := + (addInduct_success hadd).rec_lookup generation hgeneration recursor hrecursor theorem addInduct_rule_mem (hadd : addInduct env decl = some env') - (hty : ty ∈ decl.types) (hdf : df ∈ rulesRec decl.uvars ty.name decl.nparams ty) : + {generation : decl.BlockGenerationChecked} + (hgeneration : decl.identityBlockGeneration? = some generation) + (hdf : df ∈ generation.generatedRules) : env'.defeqs df := - (addInduct_success hadd).rule_mem ty hty df hdf + (addInduct_success hadd).rule_mem generation hgeneration df hdf /-- `addInduct` is an all-or-nothing transaction: every evaluation either returns no environment or returns an environment satisfying the complete @@ -10292,35 +14747,31 @@ theorem addInduct_atomic : /-- The Stage-3 guard is an exact early-rejection condition. -/ theorem addInduct_eq_none_of_stage3_false (h : decl.stage3 = false) : addInduct env decl = none := by - have hchecked : decl.checked? = none := checked?_eq_none_iff.2 h - simp [addInduct, hchecked] + have hgeneration : decl.identityBlockGeneration? = none := + identityBlockGeneration?_eq_none_iff.2 h + simp [addInduct, hgeneration] /-- A pre-existing type name rejects the transaction before any generated object is observable. -/ -theorem addInduct_eq_none_of_type_present (htypes : decl.types = [ty]) +theorem addInduct_eq_none_of_type_present (hty : ty ∈ decl.types) (hcontains : env.contains ty.name) : addInduct env decl = none := by - obtain ⟨ci, hci⟩ := hcontains - cases hstage : decl.stage3 with - | false => exact addInduct_eq_none_of_stage3_false hstage - | true => - obtain ⟨checked, hchecked⟩ := exists_checked_of_stage3 hstage - have htype : checked.type = ty := by - simpa using checked.types_eq.symm.trans htypes - unfold addInduct - rw [hchecked] - simp [addInductGeneration, Checked.identityGeneration, - Checked.identityBlock, htype, VEnv.addConst, hci] + cases hadd : addInduct env decl with + | none => rfl + | some env' => + have hfresh := (addInduct_success hadd).type_fresh ty hty + obtain ⟨ci, hci⟩ := hcontains + rw [hci] at hfresh + contradiction /-- A pre-existing constructor name rejects the complete transaction. The proof is stated through the stable success certificate, not the position of the constructor in the internal `foldlM`. -/ -theorem addInduct_eq_none_of_ctor_present (htypes : decl.types = [ty]) +theorem addInduct_eq_none_of_ctor_present (hty : ty ∈ decl.types) (hctor : ctor ∈ ty.ctors) (hcontains : env.contains ctor.name) : addInduct env decl = none := by cases hadd : addInduct env decl with | none => rfl | some env' => - have hty : ty ∈ decl.types := by rw [htypes]; exact .head _ have hfresh := (addInduct_success hadd).ctor_fresh ty hty ctor hctor obtain ⟨ci, hci⟩ := hcontains rw [hci] at hfresh @@ -10328,24 +14779,28 @@ theorem addInduct_eq_none_of_ctor_present (htypes : decl.types = [ty]) /-- A pre-existing generated recursor name likewise rejects the complete transaction. -/ -theorem addInduct_eq_none_of_rec_present (htypes : decl.types = [ty]) - (hcontains : env.contains (.str ty.name "rec")) : addInduct env decl = none := by +theorem addInduct_eq_none_of_rec_present + {generation : decl.BlockGenerationChecked} + (hgeneration : decl.identityBlockGeneration? = some generation) + (hrecursor : recursor ∈ generation.recursors) + (hcontains : env.contains recursor.name) : addInduct env decl = none := by cases hadd : addInduct env decl with | none => rfl | some env' => - have hty : ty ∈ decl.types := by rw [htypes]; exact .head _ - have hfresh := (addInduct_success hadd).rec_fresh ty hty + have success := addInduct_success hadd + have hfresh := success.rec_fresh generation hgeneration recursor hrecursor obtain ⟨ci, hci⟩ := hcontains rw [hci] at hfresh contradiction -theorem addInduct_WF (henv : Ordered env) (hdecl : decl.WF env) - (henv' : addInduct env decl = some env') : Ordered env' := by - unfold addInduct at henv' - obtain ⟨checked, -, hadd⟩ := - Option.bind_eq_some_iff.1 henv' - exact addInductGeneration_WF henv - ((checked.wf_of_decl hdecl).identityGeneration henv) hadd +theorem addInduct_WF {generation : decl.BlockGenerationChecked} + {blockEnv : VEnv} (henv : Ordered env) + (hgeneration : decl.identityBlockGeneration? = some generation) + (hgen : generation.WF env blockEnv) + (hadd : addInduct env decl = some env') : Ordered env' := by + unfold addInduct at hadd + rw [hgeneration] at hadd + exact addInductBlockGeneration_WF henv hgen hadd end VEnv @@ -10463,10 +14918,10 @@ info: 'Lean4Lean.VEnv.addInduct_success' depends on axioms: [propext, Classical. #print axioms VEnv.addInduct_success /-- -info: 'Lean4Lean.VEnv.addInduct_checked' depends on axioms: [propext, Classical.choice, Quot.sound] +info: 'Lean4Lean.VEnv.addInduct_generation' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in -#print axioms VEnv.addInduct_checked +#print axioms VEnv.addInduct_generation /-- info: 'Lean4Lean.VEnv.addInduct_eq_none_of_ctor_present' depends on axioms: [propext, Classical.choice, Quot.sound] diff --git a/Lean4Lean/TypeChecker.lean b/Lean4Lean/TypeChecker.lean index 3182efcf..c71b1d61 100644 --- a/Lean4Lean/TypeChecker.lean +++ b/Lean4Lean/TypeChecker.lean @@ -336,7 +336,7 @@ def whnfCore' (e : Expr) (cheapRec := false) (cheapProj := false) : RecM Expr := else cont else cont loop 1 body - else if f == f0 then + else if Expr.structuralEq f f0 then if let some r ← reduceRecursor e cheapRec cheapProj then whnfCore r cheapRec cheapProj else @@ -383,9 +383,9 @@ def unfoldDefinition (e : Expr) : RecM (Option Expr) := do def reduceNative (_env : Environment) (e : Expr) : Except Exception (Option Expr) := do let .app f (.const c _) := e | return none - if f == .const ``reduceBool [] then + if Expr.structuralEq f (.const ``reduceBool []) then throw <| .other s!"lean4lean does not support 'reduceBool {c}' reduction" - else if f == .const ``reduceNat [] then + else if Expr.structuralEq f (.const ``reduceNat []) then throw <| .other s!"lean4lean does not support 'reduceNat {c}' reduction" return none @@ -413,7 +413,7 @@ def reduceNat (e : Expr) : RecM (Option Expr) := do let nargs := e.getAppNumArgs if nargs == 1 then let f := e.appFn! - if f == .const ``Nat.succ [] then + if Expr.structuralEq f (.const ``Nat.succ []) then let some v := rawNatLitExt? (← whnf e.appArg!) | return none return some <| .lit <| .natVal <| v + 1 else if nargs == 2 then @@ -500,7 +500,7 @@ def quickIsDefEq (t s : Expr) (useHash := false) : RecM LBool := do match t, s with | .lam .., .lam .. => toLBoolM <| isDefEqLambda t s | .forallE .., .forallE .. => toLBoolM <| isDefEqForall t s - | .sort a1, .sort a2 => pure (a1.isEquiv a2).toLBool + | .sort a1, .sort a2 => pure (a1.isEquiv' a2).toLBool | .mdata _ a1, .mdata _ a2 => toLBoolM <| isDefEq a1 a2 | .mvar .., .mvar .. => unreachable! | .lit a1, .lit a2 => pure (a1 == a2).toLBool diff --git a/Lean4Lean/Verify/Environment/Basic.lean b/Lean4Lean/Verify/Environment/Basic.lean index 439c9c06..c5102ead 100644 --- a/Lean4Lean/Verify/Environment/Basic.lean +++ b/Lean4Lean/Verify/Environment/Basic.lean @@ -118,6 +118,19 @@ def inductGenerationRecVal {decl : VInductDecl} (generation : decl.GenerationChecked) : VConstVal := ⟨generation.recursor, .str generation.block.sourceType.name "rec"⟩ +/-- The implementation recursor metadata carries the same K-like reduction +flag retained by Theory generation. Keeping this separate from `TrConstant` +prevents a type-correct recursor with the wrong reduction behavior from +satisfying an inductive alignment trace. -/ +def RecursorKMatches (info : ConstantInfo) (kTarget : Bool) : Prop := + match info with + | .recInfo rec => rec.k = kTarget + | _ => False + +instance (info : ConstantInfo) (kTarget : Bool) : + Decidable (RecursorKMatches info kTarget) := by + cases info <;> simp [RecursorKMatches] <;> infer_instance + /-- Data-bearing trace of a complete normalized inductive transaction: one `inductInfo`, the constructor `ctorInfo`s in declaration order, one `recInfo`, and finally the generated Theory iota equations. The retained generation @@ -138,6 +151,7 @@ structure AddInductTrace (m₁ : ConstMap) (env₁ : VEnv) (decl : VInductDecl) generation.block.sourceType.ctors ctorMap ctorEnv addRec : AddInductConstant .recursor ctorMap ctorEnv (inductGenerationRecVal generation) m₂ recEnv + recK : RecursorKMatches addRec.info generation.kTarget addRules : AddDefEqs recEnv generation.generatedRules env₂ /-- Proposition-valued environment alignment, preserving the public shape of @@ -146,6 +160,42 @@ def AddInduct (m₁ : ConstMap) (env₁ : VEnv) (decl : VInductDecl) (m₂ : ConstMap) (env₂ : VEnv) : Prop := Nonempty (AddInductTrace m₁ env₁ decl m₂ env₂) +/-- Every implementation recursor stored by a block replay retains the +K-like flag computed by the block generator. -/ +def RecursorMapKMatches (m : ConstMap) (recursors : List VConstVal) + (kTarget : Bool) : Prop := + ∀ recursor ∈ recursors, ∃ info, + m.find? recursor.name = some info ∧ RecursorKMatches info kTarget + +/-- Data-bearing alignment trace for a complete mutual inductive block. +Families, globally flattened constructors, and recursors are each inserted +as a list phase, followed only after all recursors exist by the flattened +rule phase. -/ +structure AddInductBlockTrace + (m₁ : ConstMap) (env₁ : VEnv) (decl : VInductDecl) + (m₂ : ConstMap) (env₂ : VEnv) where + generation : decl.BlockGenerationChecked + blockEnv : VEnv + generation_wf : generation.WF env₁ blockEnv + 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 + generation.recursors m₂ recEnv + recK : RecursorMapKMatches m₂ generation.recursors generation.kTarget + addRules : AddDefEqs recEnv generation.generatedRules env₂ + +/-- Proposition-valued alignment for a complete mutual block. -/ +def AddInductBlock (m₁ : ConstMap) (env₁ : VEnv) (decl : VInductDecl) + (m₂ : ConstMap) (env₂ : VEnv) : Prop := + Nonempty (AddInductBlockTrace 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 = @@ -214,6 +264,12 @@ theorem AddInductTrace.to_addInductGeneration simp [VEnv.addInductGeneration, H.addType.env_add, H.addCtors.to_foldlM, hrec, H.addRules.to_add] +theorem AddInductBlockTrace.to_addInductBlockGeneration + (H : AddInductBlockTrace m₁ env₁ decl m₂ env₂) : + env₁.addInductBlockGeneration H.generation = some env₂ := by + simp [VEnv.addInductBlockGeneration, 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. -/ @@ -230,6 +286,23 @@ nonrec theorem AddInduct.le (H : AddInduct m₁ env₁ decl m₂ env₂) : env rcases VEnv.addInductGeneration_trace hadd with ⟨trace⟩ exact trace.le +/-- Recover the exact block-wide Theory transaction represented by an +implementation metadata replay. -/ +theorem AddInductBlock.to_addInductBlock + (H : AddInductBlock m₁ env₁ decl m₂ env₂) : + ∃ (generation : decl.BlockGenerationChecked) (blockEnv : VEnv), + generation.WF env₁ blockEnv ∧ + env₁.addInductBlockGeneration generation = some env₂ := by + rcases H with ⟨H⟩ + exact ⟨H.generation, H.blockEnv, H.generation_wf, + H.to_addInductBlockGeneration⟩ + +theorem AddInductBlock.le + (H : AddInductBlock m₁ env₁ decl m₂ env₂) : env₁ ≤ env₂ := by + obtain ⟨generation, -, -, hadd⟩ := H.to_addInductBlock + 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`. -/ @@ -251,6 +324,27 @@ info: 'Lean4Lean.AddInduct.le' depends on axioms: [propext, sorryAx, Classical.c #guard_msgs in #print axioms AddInduct.le +/-- +info: 'Lean4Lean.AddInductBlockTrace.to_addInductBlockGeneration' depends on axioms: [propext, + sorryAx, + 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] +-/ +#guard_msgs in +#print axioms AddInductBlock.to_addInductBlock + +/-- +info: 'Lean4Lean.AddInductBlock.le' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms AddInductBlock.le + variable (safety : DefinitionSafety) in inductive TrEnv' : ConstMap → Bool → VEnv → Prop where | empty : TrEnv' {} false .empty @@ -292,6 +386,10 @@ inductive TrEnv' : ConstMap → Bool → VEnv → Prop where AddInduct C env decl C' env' → TrEnv' C Q env → TrEnv' C' Q env' + | inductBlock : + AddInductBlock C env decl C' env' → + TrEnv' C Q env → + TrEnv' C' Q env' def TrEnv (safety : DefinitionSafety) (env : Environment) (venv : VEnv) : Prop := TrEnv' safety env.constants env.quotInit venv @@ -320,6 +418,11 @@ theorem TrEnv'.wf (H : TrEnv' safety C Q venv) : venv.WF := by have ⟨_, H⟩ := ih obtain ⟨generation, hgen, hadd⟩ := h1.to_addInduct exact ⟨_, H.decl <| .induct hgen hadd⟩ + | inductBlock h1 _ ih => + have ⟨_, H⟩ := ih + obtain ⟨generation, blockEnv, hgen, hadd⟩ := + h1.to_addInductBlock + exact ⟨_, H.decl <| .inductBlock (blockEnv := blockEnv) hgen hadd⟩ /-- info: 'Lean4Lean.TrEnv'.wf' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] diff --git a/Lean4Lean/Verify/Environment/CandidateIdentityReplay.lean b/Lean4Lean/Verify/Environment/CandidateIdentityReplay.lean new file mode 100644 index 00000000..50f01b7e --- /dev/null +++ b/Lean4Lean/Verify/Environment/CandidateIdentityReplay.lean @@ -0,0 +1,1011 @@ +import Lean4Lean.Verify.Environment.Normalization +import Std.Data.HashMap.Lemmas + +/-! +# Structural identity replay for normalization candidates + +This module proves identity normalization from the ordinary producer's exact +recursive executions. The replay description is structural: it supplies the +WHNF behavior of each source node and the transparent annotation build, then +recovers the producer-owned `CandidateExprTrace`. It does not evaluate a +proof-only Boolean with `native_decide`. +-/ + +namespace Lean4Lean.TypeChecker + +open Lean Meta +open Lean4Lean + +theorem localContextFindNew + (lctx : LocalContext) (id : FVarId) (name : Name) + (type : Expr) (bi : BinderInfo) (kind : LocalDeclKind) + (hwf : lctx.WF) (hfresh : lctx.find? id = none) : + (lctx.mkLocalDecl id name type bi kind).find? id = + some (.cdecl lctx.decls.size id name type bi kind) := by + have hwf' := LocalContext.WF.mkLocalDecl + (name := name) (ty := type) (bi := bi) (kind := kind) hwf hfresh + rw [hwf'.find?_eq_find?_toList] + rw [LocalContext.mkLocalDecl_toList] + simp [LocalDecl.fvarId] + +theorem emptyLocalContextFindNone (id : FVarId) : + (⟨.empty, .empty, .empty⟩ : LocalContext).find? id = none := by + have h := LocalContext.WF.find?_eq_find?_toList + (fv := id) LocalContext.WF.nil + rw [h] + simp [LocalContext.toList] + +theorem localContextFindOld + (lctx : LocalContext) (oldId newId : FVarId) + (name : Name) (type : Expr) (bi : BinderInfo) + (kind : LocalDeclKind) (decl : LocalDecl) + (hwf : lctx.WF) (hfresh : lctx.find? newId = none) + (hfind : lctx.find? oldId = some decl) : + (lctx.mkLocalDecl newId name type bi kind).find? oldId = some decl := by + have hwf' := LocalContext.WF.mkLocalDecl + (name := name) (ty := type) (bi := bi) (kind := kind) hwf hfresh + rw [hwf'.find?_eq_find?_toList] + rw [LocalContext.mkLocalDecl_toList] + have hne : oldId ≠ newId := by + intro heq + rw [heq, hfresh] at hfind + contradiction + simp only [List.find?_cons, LocalDecl.fvarId] + rw [show (oldId == newId) = false by simp [hne]] + simpa only [hwf.find?_eq_find?_toList, LocalDecl.fvarId] using hfind + +/-- A candidate local context built entirely from fresh ordinary +declarations, with the name-generator invariant needed by structural replay. -/ +structure CandidateLocalContextRun + (context : AddInductive.Context) : Prop where + wf : context.lctx.WF + reserves : ∀ decl ∈ context.lctx.toList, + context.ngen.Reserves decl.fvarId + +namespace CandidateLocalContextRun + +def empty (context : AddInductive.Context) + (h : context.lctx = ({} : LocalContext)) : + CandidateLocalContextRun context where + wf := by rw [h]; exact LocalContext.WF.nil + reserves := by + intro decl membership + rw [h] at membership + rw [show ({} : LocalContext).toList = [] by rfl] at membership + contradiction + +theorem fresh (run : CandidateLocalContextRun context) : + context.lctx.find? context.freshFVarId = none := by + rw [run.wf.find?_eq_find?_toList, List.find?_eq_none] + intro decl membership equal + have reserved := run.reserves decl membership + have idEq : context.freshFVarId = decl.fvarId := + beq_iff_eq.mp equal + rw [← idEq] at reserved + exact NameGenerator.not_reserves_self (by + simpa [AddInductive.Context.freshFVarId] using reserved) + +def push (run : CandidateLocalContextRun context) + (name : Name) (binderInfo : BinderInfo) (type : Expr) : + CandidateLocalContextRun + (context.pushLocalDecl name binderInfo type) where + wf := by + simpa [AddInductive.Context.pushLocalDecl] using + LocalContext.WF.mkLocalDecl run.wf run.fresh + reserves := by + intro decl membership + simp only [AddInductive.Context.pushLocalDecl, + LocalContext.mkLocalDecl_toList, List.mem_cons] at membership ⊢ + rcases membership with rfl | membership + · simpa [LocalDecl.fvarId, AddInductive.Context.freshFVarId] using + (NameGenerator.next_reserves_self (ngen := context.ngen)) + · exact NameGenerator.Reserves.mono NameGenerator.LE.next + (run.reserves decl membership) + +theorem push_findNew (run : CandidateLocalContextRun context) + (name : Name) (binderInfo : BinderInfo) (type : Expr) : + (context.pushLocalDecl name binderInfo type).lctx.find? + context.freshFVarId = + some (.cdecl context.lctx.decls.size context.freshFVarId + name type binderInfo .default) := by + simpa [AddInductive.Context.pushLocalDecl] using + localContextFindNew context.lctx context.freshFVarId name type + binderInfo .default run.wf run.fresh + +theorem push_findOld (run : CandidateLocalContextRun context) + (name : Name) (binderInfo : BinderInfo) (type : Expr) + {id : FVarId} {decl : LocalDecl} + (hfind : context.lctx.find? id = some decl) : + (context.pushLocalDecl name binderInfo type).lctx.find? id = + some decl := by + simpa [AddInductive.Context.pushLocalDecl] using + localContextFindOld context.lctx id context.freshFVarId + name type binderInfo .default decl run.wf run.fresh hfind + +end CandidateLocalContextRun + +/-- A recursively identity-normalizing candidate reconstructs its exact stored +kernel expression when every source free variable belongs to the candidate's +fresh-local context. + +The scope premise is operational: it is the same implementation-context +condition retained by candidate checking. `CandidateLocalContextRun` proves +that each generated identifier is fresh, so abstracting the instantiated body +recovers the original stored binder body rather than merely an alpha-equivalent +expression. -/ +theorem CandidateExprIdentity.view_eq_source + {context : AddInductive.Context} {source : Expr} + {trace : AddInductive.CandidateExprTrace context source} + (identity : CandidateExprIdentity trace) + (localRun : CandidateLocalContextRun context) + (scope : source.FVarsIn + (fun fv => (context.lctx.find? fv).isSome = true)) : + trace.view = source := by + induction identity with + | terminal result_eq => + simpa [AddInductive.CandidateExprTrace.view] using result_eq + | forallE domainCandidate bodyCandidate source_eq consumed_eq + domainIdentity bodyIdentity domainIH bodyIH => + rename_i traceContext domain name binderInfo traceSource inferred body + fresh annotations annotationsEq checked normalized + rw [source_eq] at scope + simp only [FVarsIn] at scope + have domainEq := domainIH localRun scope.1 + let pushedRun := localRun.push name binderInfo annotations.consumed + have oldScope : body.FVarsIn (fun fv => + ((traceContext.pushLocalDecl name binderInfo + annotations.consumed).lctx.find? fv).isSome = true) := by + apply scope.2.mono + intro fv present + obtain ⟨decl, find⟩ := Option.isSome_iff_exists.mp present + apply Option.isSome_iff_exists.mpr + exact ⟨decl, localRun.push_findOld name binderInfo + annotations.consumed find⟩ + have freshScope : traceContext.freshExpr.FVarsIn (fun fv => + ((traceContext.pushLocalDecl name binderInfo + annotations.consumed).lctx.find? fv).isSome = true) := by + simp only [AddInductive.Context.freshExpr, FVarsIn] + rw [localRun.push_findNew name binderInfo annotations.consumed] + rfl + have bodyScope := oldScope.instantiate1 freshScope + have bodyScope' : (body.instantiate1 traceContext.freshExpr).FVarsIn + (fun fv => ((traceContext.pushLocalDecl name binderInfo + annotations.consumed).lctx.find? fv).isSome = true) := by + simpa only [Expr.instantiate1_eq] using bodyScope + have bodyEq := bodyIH pushedRun bodyScope' + have bodyAvoid : body.FVarsIn (· ≠ traceContext.freshFVarId) := by + apply scope.2.mono + intro fv present equal + subst fv + rw [localRun.fresh] at present + contradiction + calc + (AddInductive.CandidateExprTrace.forallE traceContext traceSource + inferred name domain body binderInfo fresh annotations annotationsEq + checked normalized domainCandidate bodyCandidate).view = + .forallE name domainCandidate.view + (bodyCandidate.view.abstract #[traceContext.freshExpr]) + binderInfo := rfl + _ = .forallE name domain body binderInfo := by + rw [domainEq, bodyEq] + congr 1 + rw [show #[traceContext.freshExpr] = + ⟨[traceContext.freshFVarId].map Expr.fvar⟩ by rfl] + rw [Expr.abstract_eq] + change (body.instantiate1 traceContext.freshExpr).abstract1 + traceContext.freshFVarId = body + simpa only [Expr.instantiate1_eq, + AddInductive.Context.freshExpr] using + (bodyAvoid.abstract_instantiate1 (k := 0)) + _ = traceSource := source_eq.symm + +/- The structural reconstruction bridge has only the expected standard and +kernel-expression infrastructure closure; in particular, it does not depend +on a fixture computation oracle. -/ +/-- +info: 'Lean4Lean.TypeChecker.CandidateExprIdentity.view_eq_source' depends on axioms: [propext, + Classical.choice, + Quot.sound, + Expr.abstract_eq, + Expr.instantiate1_eq, + PersistentArray.toList'_push, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms CandidateExprIdentity.view_eq_source + +@[simp] theorem candidateLiftLooseBVarsFVar + (id : FVarId) (s d : Nat) : + (Expr.fvar id).liftLooseBVars' s d = .fvar id := by + rfl + +@[simp] theorem candidateInstantiateFVar + (id : FVarId) (a : Expr) (k : Nat) : + (Expr.fvar id).instantiate1' a k = .fvar id := by + rfl + +theorem candidateWhnfFVar_refl + (context : AddInductive.Context) (id : FVarId) + (recursionFuel : Nat) + (hdepth : context.fuel.recDepth = recursionFuel + 1) + (hnotlet : TypeChecker.Inner.isLetFVar context.lctx id = false) : + AddInductive.CandidateWhnfStep.Valid + ⟨context, .fvar id, .fvar id⟩ := by + unfold AddInductive.CandidateWhnfStep.Valid + change TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel (TypeChecker.whnf (.fvar id)) = + .ok (.fvar id) + unfold TypeChecker.M.run TypeChecker.whnf TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rw [hdepth] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.whnf' (.fvar id) + (TypeChecker.Methods.withFuel recursionFuel) + context.toTypeChecker ({} : TypeChecker.State)) = + .ok (.fvar id) + unfold TypeChecker.Inner.whnf' + simp only [ReaderT.bind, StateT.bind, Except.bind, Bind.bind] + rw [show (getLCtx : TypeChecker.RecM LocalContext) + (TypeChecker.Methods.withFuel recursionFuel) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (context.lctx, ({} : TypeChecker.State)) by rfl] + simp [hnotlet, ReaderT.pure, StateT.pure, + Except.pure, Pure.pure, Except.map] + +theorem candidateWhnfPushedFVar_refl + (context : AddInductive.Context) (name : Name) (type : Expr) + (binderInfo : BinderInfo) (recursionFuel : Nat) + (hdepth : context.fuel.recDepth = recursionFuel + 1) + (hwf : context.lctx.WF) + (hfresh : context.lctx.find? context.freshFVarId = none) : + AddInductive.CandidateWhnfStep.Valid + ⟨context.pushLocalDecl name binderInfo type, + context.freshExpr, context.freshExpr⟩ := by + apply candidateWhnfFVar_refl _ context.freshFVarId recursionFuel + · simpa [AddInductive.Context.pushLocalDecl] using hdepth + · unfold TypeChecker.Inner.isLetFVar + simp only [AddInductive.Context.pushLocalDecl] + rw [localContextFindNew context.lctx context.freshFVarId + name type binderInfo .default hwf hfresh] + +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.Methods.withFuel 9999) + context.toTypeChecker state = + .ok (.fvar id, state) := by + change TypeChecker.Inner.whnfCore' (.fvar id) false false + (TypeChecker.Methods.withFuel 9998) + context.toTypeChecker state = + .ok (.fvar id, state) + unfold TypeChecker.Inner.whnfCore' + simp only [ReaderT.bind, StateT.bind, Except.bind, Bind.bind] + rw [show (getLCtx : TypeChecker.RecM LocalContext) + (TypeChecker.Methods.withFuel 9998) + context.toTypeChecker state = + .ok (context.lctx, state) by rfl] + simp [hnotlet, ReaderT.pure, StateT.pure, + Except.pure, Pure.pure] + +private theorem candidateReduceRecursorFVarApp_none + (context : AddInductive.Context) (fnId argId : FVarId) + (state : TypeChecker.State) + (hquot : context.env.quotInit = false) : + TypeChecker.Inner.reduceRecursor + (.app (.fvar fnId) (.fvar argId)) false false + (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] + rw [show (liftM TypeChecker.getEnv : + TypeChecker.RecM Lean.Kernel.Environment) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker state = + .ok (context.env, state) by rfl] + simp only [Except.bind] + rw [hquot] + have hfn : (.app (.fvar fnId) (.fvar argId) : Expr).getAppFn = + .fvar fnId := by rfl + simp [inductiveReduceRec, hfn, ReaderT.bind, StateT.bind, + Except.bind, Bind.bind, ReaderT.pure, StateT.pure, + Except.pure, Pure.pure] + +private theorem candidateWhnfCoreFVarAppFVar_refl + (context : AddInductive.Context) (fnId argId : FVarId) + (hquot : context.env.quotInit = false) + (hnotlet : TypeChecker.Inner.isLetFVar context.lctx fnId = false) : + TypeChecker.Inner.whnfCore' + (.app (.fvar fnId) (.fvar argId)) false false + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (.app (.fvar fnId) (.fvar argId), + ({} : TypeChecker.State)) := by + unfold TypeChecker.Inner.whnfCore' + simp [ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + rw [show (get : TypeChecker.RecM TypeChecker.State) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (({} : TypeChecker.State), ({} : TypeChecker.State)) by rfl] + simp only [Except.bind, Std.HashMap.getElem?_empty] + simp [ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + have hfn : (.app (.fvar fnId) (.fvar argId) : Expr).getAppFn = + .fvar fnId := by rfl + have hargs : (.app (.fvar fnId) (.fvar argId) : Expr).getAppRevArgs = + #[.fvar argId] := by rfl + rw [hfn, hargs] + rw [candidateWhnfCoreFVar_refl context fnId + ({} : TypeChecker.State) hnotlet] + simp [candidateReduceRecursorFVarApp_none context fnId argId + ({} : TypeChecker.State) hquot, + Expr.structuralEq, ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + +private theorem candidateReduceNativeFVarAppFVar_none + (context : AddInductive.Context) (fnId argId : FVarId) + (state : TypeChecker.State) : + (liftM (TypeChecker.Inner.reduceNative context.env + (.app (.fvar fnId) (.fvar argId))) : + TypeChecker.RecM (Option Expr)) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker state = .ok (none, state) := by + rfl + +private theorem candidateReduceNatFVarAppFVar_none + (context : AddInductive.Context) (fnId argId : FVarId) + (state : TypeChecker.State) : + TypeChecker.Inner.reduceNat (.app (.fvar fnId) (.fvar argId)) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker state = .ok (none, state) := by + unfold TypeChecker.Inner.reduceNat + have hnargs : (.app (.fvar fnId) (.fvar argId) : Expr).getAppNumArgs = + 1 := by rfl + have hfn : (.app (.fvar fnId) (.fvar argId) : Expr).appFn! = + .fvar fnId := by rfl + rw [hnargs, hfn] + simp only [show (1 == 1) = true by decide, if_true] + rw [show Expr.structuralEq (.fvar fnId) (.const ``Nat.succ []) = false by + rfl] + rfl + +private theorem candidateUnfoldDefinitionFVarAppFVar_none + (context : AddInductive.Context) (fnId argId : FVarId) + (state : TypeChecker.State) : + TypeChecker.Inner.unfoldDefinition + (.app (.fvar fnId) (.fvar argId)) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker state = .ok (none, state) := by + unfold TypeChecker.Inner.unfoldDefinition + have hisApp : (.app (.fvar fnId) (.fvar argId) : Expr).isApp = true := + rfl + have hfn : (.app (.fvar fnId) (.fvar argId) : Expr).getAppFn = + .fvar fnId := by rfl + rw [hisApp, hfn] + simp [TypeChecker.Inner.unfoldDefinitionCore, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + +private theorem candidateWhnfLoopFVarAppFVar_refl + (context : AddInductive.Context) (fnId argId : FVarId) + (hquot : context.env.quotInit = false) + (hnotlet : TypeChecker.Inner.isLetFVar context.lctx fnId = false) : + TypeChecker.Inner.whnf'.loop + (.app (.fvar fnId) (.fvar argId)) 100000 + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (.app (.fvar fnId) (.fvar argId), + ({} : TypeChecker.State)) := by + rw [show 100000 = 99999 + 1 by rfl] + unfold TypeChecker.Inner.whnf'.loop + simp only [ReaderT.bind, StateT.bind, Except.bind, Bind.bind] + rw [show (liftM TypeChecker.getEnv : + TypeChecker.RecM Lean.Kernel.Environment) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (context.env, ({} : TypeChecker.State)) by rfl] + simp only [Except.bind] + rw [candidateWhnfCoreFVarAppFVar_refl context fnId argId + hquot hnotlet] + simp only [Except.bind] + rw [candidateReduceNativeFVarAppFVar_none context fnId argId + ({} : TypeChecker.State)] + simp [ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + rw [candidateReduceNatFVarAppFVar_none context fnId argId + ({} : TypeChecker.State)] + simp [ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + rw [candidateUnfoldDefinitionFVarAppFVar_none context fnId argId + ({} : TypeChecker.State)] + rfl + +set_option maxRecDepth 10000 in +theorem candidateWhnfFVarAppFVar_refl + (context : AddInductive.Context) (fnId argId : FVarId) + (hdepth : context.fuel.recDepth = 10000) + (hwhnf : context.fuel.whnf = 100000) + (hquot : context.env.quotInit = false) + (hnotlet : TypeChecker.Inner.isLetFVar context.lctx fnId = false) : + AddInductive.CandidateWhnfStep.Valid + ⟨context, .app (.fvar fnId) (.fvar argId), + .app (.fvar fnId) (.fvar argId)⟩ := by + unfold AddInductive.CandidateWhnfStep.Valid + unfold TypeChecker.M.run TypeChecker.whnf TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rw [hdepth] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.whnf' + (.app (.fvar fnId) (.fvar argId)) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State)) = + .ok (.app (.fvar fnId) (.fvar argId)) + unfold TypeChecker.Inner.whnf' + simp only [ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + rw [show (get : TypeChecker.RecM TypeChecker.State) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (({} : TypeChecker.State), ({} : TypeChecker.State)) by rfl] + simp only [Except.bind, Std.HashMap.getElem?_empty] + simp only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + rw [show (liftM read : TypeChecker.RecM TypeChecker.Context) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (context.toTypeChecker, ({} : TypeChecker.State)) by rfl] + simp only [Except.bind] + rw [show context.toTypeChecker.eagerReduce = false by rfl] + simp only [Bool.false_eq_true, ↓reduceIte] + rw [show context.toTypeChecker.fuel.whnf = 100000 by + simpa [AddInductive.Context.toTypeChecker] using hwhnf] + rw [candidateWhnfLoopFVarAppFVar_refl context fnId argId + hquot hnotlet] + rfl + +private theorem candidateWhnfCoreConst_refl + (context : AddInductive.Context) (constName : Name) + (levels : List Level) (state : TypeChecker.State) : + TypeChecker.Inner.whnfCore (.const constName levels) false false + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker state = + .ok (.const constName levels, state) := by + rfl + +private theorem candidateReduceRecursorConstFVarFVar_none + (context : AddInductive.Context) (constName : Name) + (levels : List Level) (arg1 arg2 : FVarId) + (state : TypeChecker.State) (info : InductiveVal) + (hquot : context.env.quotInit = false) + (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) + context.toTypeChecker state = .ok (none, state) := by + unfold TypeChecker.Inner.reduceRecursor + simp only [ReaderT.bind, StateT.bind, Except.bind, Bind.bind] + rw [show (liftM TypeChecker.getEnv : + TypeChecker.RecM Lean.Kernel.Environment) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker state = + .ok (context.env, state) by rfl] + simp only [Except.bind] + rw [hquot] + have hfn : + (.app (.app (.const constName levels) (.fvar arg1)) + (.fvar arg2) : Expr).getAppFn = .const constName levels := by + rfl + simp [inductiveReduceRec, hfn, hfind, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + +private theorem candidateWhnfCoreConstFVarFVar_refl + (context : AddInductive.Context) (constName : Name) + (levels : List Level) (arg1 arg2 : FVarId) + (info : InductiveVal) + (hquot : context.env.quotInit = false) + (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) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (.app (.app (.const constName levels) (.fvar arg1)) + (.fvar arg2), ({} : TypeChecker.State)) := by + unfold TypeChecker.Inner.whnfCore' + simp [ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + rw [show (get : TypeChecker.RecM TypeChecker.State) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (({} : TypeChecker.State), ({} : TypeChecker.State)) by rfl] + simp only [Except.bind, Std.HashMap.getElem?_empty] + simp [ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + have hfn : + (.app (.app (.const constName levels) (.fvar arg1)) + (.fvar arg2) : Expr).getAppFn = .const constName levels := by + rfl + have hargs : + (.app (.app (.const constName levels) (.fvar arg1)) + (.fvar arg2) : Expr).getAppRevArgs = + #[.fvar arg2, .fvar arg1] := by + rfl + rw [hfn, hargs] + rw [candidateWhnfCoreConst_refl context constName levels + ({} : TypeChecker.State)] + simp [candidateReduceRecursorConstFVarFVar_none context constName levels + arg1 arg2 ({} : TypeChecker.State) info hquot hfind, + Expr.structuralEq_refl, ReaderT.bind, StateT.bind, Except.bind, + Bind.bind, ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + +private theorem candidateReduceNativeConstFVarFVar_none + (context : AddInductive.Context) (constName : Name) + (levels : List Level) (arg1 arg2 : FVarId) + (state : TypeChecker.State) : + (liftM (TypeChecker.Inner.reduceNative context.env + (.app (.app (.const constName levels) (.fvar arg1)) (.fvar arg2))) : + TypeChecker.RecM (Option Expr)) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker state = .ok (none, state) := by + rfl + +private theorem candidateUnfoldDefinitionCoreConst_none + (context : AddInductive.Context) (constName : Name) + (levels : List Level) (state : TypeChecker.State) + (info : InductiveVal) + (hfind : context.env.find? constName = some (.inductInfo info)) : + TypeChecker.Inner.unfoldDefinitionCore (.const constName levels) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker state = .ok (none, state) := by + unfold TypeChecker.Inner.unfoldDefinitionCore + simp only [ReaderT.bind, StateT.bind, Except.bind, Bind.bind] + rw [show (liftM TypeChecker.getEnv : + TypeChecker.RecM Lean.Kernel.Environment) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker state = + .ok (context.env, state) by rfl] + simp only [Except.bind] + unfold TypeChecker.Inner.isDelta + rw [show (Expr.const constName levels).getAppFn = + .const constName levels by rfl] + simp only + rw [hfind] + rfl + +private theorem candidateUnfoldDefinitionConstFVarFVar_none + (context : AddInductive.Context) (constName : Name) + (levels : List Level) (arg1 arg2 : FVarId) + (state : TypeChecker.State) (info : InductiveVal) + (hfind : context.env.find? constName = some (.inductInfo info)) : + TypeChecker.Inner.unfoldDefinition + (.app (.app (.const constName levels) (.fvar arg1)) (.fvar arg2)) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker state = .ok (none, state) := by + unfold TypeChecker.Inner.unfoldDefinition + have hisApp : + (.app (.app (.const constName levels) (.fvar arg1)) + (.fvar arg2) : Expr).isApp = true := by + rfl + have hfn : + (.app (.app (.const constName levels) (.fvar arg1)) + (.fvar arg2) : Expr).getAppFn = .const constName levels := by + rfl + rw [hisApp, hfn] + simp only [if_true, ReaderT.bind, StateT.bind, Except.bind, Bind.bind] + rw [candidateUnfoldDefinitionCoreConst_none context constName levels + state info hfind] + simp [ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + +private theorem candidateWhnfLoopConstFVarFVar_refl + (context : AddInductive.Context) (constName : Name) + (levels : List Level) (arg1 arg2 : FVarId) + (info : InductiveVal) + (hquot : context.env.quotInit = false) + (hfind : context.env.find? constName = some (.inductInfo info)) + (hreduceNat : TypeChecker.Inner.reduceNat + (.app (.app (.const constName levels) (.fvar arg1)) (.fvar arg2)) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (none, ({} : TypeChecker.State))) : + TypeChecker.Inner.whnf'.loop + (.app (.app (.const constName levels) (.fvar arg1)) (.fvar arg2)) + 100000 (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (.app (.app (.const constName levels) (.fvar arg1)) + (.fvar arg2), ({} : TypeChecker.State)) := by + rw [show 100000 = 99999 + 1 by rfl] + unfold TypeChecker.Inner.whnf'.loop + simp only [ReaderT.bind, StateT.bind, Except.bind, Bind.bind] + rw [show (liftM TypeChecker.getEnv : + TypeChecker.RecM Lean.Kernel.Environment) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (context.env, ({} : TypeChecker.State)) by rfl] + simp only [Except.bind] + rw [candidateWhnfCoreConstFVarFVar_refl context constName levels + arg1 arg2 info hquot hfind] + simp only [Except.bind] + rw [candidateReduceNativeConstFVarFVar_none context constName levels + arg1 arg2 ({} : TypeChecker.State)] + simp [ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + rw [hreduceNat] + simp [ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + rw [candidateUnfoldDefinitionConstFVarFVar_none context constName levels + arg1 arg2 ({} : TypeChecker.State) info hfind] + rfl + +set_option maxRecDepth 10000 in +theorem candidateWhnfConstFVarFVar_refl + (context : AddInductive.Context) (constName : Name) + (levels : List Level) (arg1 arg2 : FVarId) + (info : InductiveVal) + (hdepth : context.fuel.recDepth = 10000) + (hwhnf : context.fuel.whnf = 100000) + (hquot : context.env.quotInit = false) + (hfind : context.env.find? constName = some (.inductInfo info)) + (hreduceNat : TypeChecker.Inner.reduceNat + (.app (.app (.const constName levels) (.fvar arg1)) (.fvar arg2)) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (none, ({} : TypeChecker.State))) : + AddInductive.CandidateWhnfStep.Valid + ⟨context, + .app (.app (.const constName levels) (.fvar arg1)) (.fvar arg2), + .app (.app (.const constName levels) (.fvar arg1)) (.fvar arg2)⟩ := by + unfold AddInductive.CandidateWhnfStep.Valid + unfold TypeChecker.M.run TypeChecker.whnf TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rw [hdepth] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.whnf' + (.app (.app (.const constName levels) (.fvar arg1)) (.fvar arg2)) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State)) = + .ok (.app (.app (.const constName levels) (.fvar arg1)) + (.fvar arg2)) + unfold TypeChecker.Inner.whnf' + simp only [ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + rw [show (get : TypeChecker.RecM TypeChecker.State) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (({} : TypeChecker.State), ({} : TypeChecker.State)) by rfl] + simp only [Except.bind, Std.HashMap.getElem?_empty] + simp only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + rw [show (liftM read : TypeChecker.RecM TypeChecker.Context) + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (context.toTypeChecker, ({} : TypeChecker.State)) by rfl] + simp only [Except.bind] + rw [show context.toTypeChecker.eagerReduce = false by rfl] + simp only [Bool.false_eq_true, ↓reduceIte] + rw [show context.toTypeChecker.fuel.whnf = 100000 by + simpa [AddInductive.Context.toTypeChecker] using hwhnf] + rw [candidateWhnfLoopConstFVarFVar_refl context constName levels + arg1 arg2 info hquot hfind hreduceNat] + rfl + +/-- A syntactic identity-WHNF tree for every node inspected by the ordinary +candidate producer. -/ +inductive CandidateExprIdentityReplay : + (context : AddInductive.Context) → (source : Expr) → Type where + | terminal (context : AddInductive.Context) (source : Expr) + (whnf : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, source⟩) + (notForall : source.isForall = false) : + CandidateExprIdentityReplay context source + | forallE (context : AddInductive.Context) + (name : Name) (domain body : Expr) (binderInfo : BinderInfo) + (whnf : AddInductive.CandidateWhnfStep.Valid + ⟨context, .forallE name domain body binderInfo, + .forallE name domain body binderInfo⟩) + (annotations : AddInductive.CandidateTypeAnnotations domain) + (annotationsBuild : + AddInductive.buildCandidateTypeAnnotations domain = .ok annotations) + (consume : AddInductive.consumeTypeAnnotations domain = domain) + (domainReplay : CandidateExprIdentityReplay context domain) + (bodyReplay : CandidateExprIdentityReplay + (context.pushLocalDecl name binderInfo annotations.consumed) + (body.instantiate1 context.freshExpr)) : + CandidateExprIdentityReplay context + (.forallE name domain body binderInfo) + +namespace CandidateExprIdentityReplay + +def spineLength : CandidateExprIdentityReplay context source → Nat + | .terminal .. => 0 + | .forallE _ _ _ _ _ _ _ _ _ _ bodyReplay => bodyReplay.spineLength + 1 + +def terminalSource : CandidateExprIdentityReplay context source → Expr + | .terminal _ source _ _ => source + | .forallE _ _ _ _ _ _ _ _ _ _ bodyReplay => bodyReplay.terminalSource + +/-- A replay tree packaged with the exact main-spine length and terminal +source. -/ +structure Shaped + (context : AddInductive.Context) (source : Expr) + (expectedSpineLength : Nat) (expectedTerminalSource : Expr) where + replay : CandidateExprIdentityReplay context source + spineLength_eq : replay.spineLength = expectedSpineLength + terminalSource_eq : replay.terminalSource = expectedTerminalSource + +namespace Shaped + +def terminal + (context : AddInductive.Context) (source : Expr) + (whnf : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, source⟩) + (notForall : source.isForall = false) : + Shaped context source 0 source := + ⟨CandidateExprIdentityReplay.terminal context source whnf notForall, + rfl, rfl⟩ + +def forallE + (context : AddInductive.Context) (name : Name) + (domain body : Expr) (binderInfo : BinderInfo) + (whnf : AddInductive.CandidateWhnfStep.Valid + ⟨context, .forallE name domain body binderInfo, + .forallE name domain body binderInfo⟩) + (annotations : AddInductive.CandidateTypeAnnotations domain) + (annotationsBuild : + AddInductive.buildCandidateTypeAnnotations domain = .ok annotations) + (consume : AddInductive.consumeTypeAnnotations domain = domain) + (domainReplay : CandidateExprIdentityReplay context domain) + (bodyReplay : Shaped + (context.pushLocalDecl name binderInfo annotations.consumed) + (body.instantiate1 context.freshExpr) + expectedSpineLength expectedTerminalSource) : + Shaped context (.forallE name domain body binderInfo) + (expectedSpineLength + 1) expectedTerminalSource := by + refine ⟨CandidateExprIdentityReplay.forallE context name domain body + binderInfo whnf annotations annotationsBuild consume domainReplay + bodyReplay.replay, ?_, ?_⟩ + · simpa [CandidateExprIdentityReplay.spineLength] using + bodyReplay.spineLength_eq + · simpa [CandidateExprIdentityReplay.terminalSource] using + bodyReplay.terminalSource_eq + +def forallEBuilt + (context : AddInductive.Context) (name : Name) + (domain body : Expr) (binderInfo : BinderInfo) + (whnf : AddInductive.CandidateWhnfStep.Valid + ⟨context, .forallE name domain body binderInfo, + .forallE name domain body binderInfo⟩) + (consume : AddInductive.consumeTypeAnnotations domain = domain) + (domainReplay : CandidateExprIdentityReplay context domain) + (bodyReplay : Shaped + (context.pushLocalDecl name binderInfo domain) + (body.instantiate1 context.freshExpr) + expectedSpineLength expectedTerminalSource) : + Shaped context (.forallE name domain body binderInfo) + (expectedSpineLength + 1) expectedTerminalSource := by + let annotations : AddInductive.CandidateTypeAnnotations domain := + let ⟨consumed, trace⟩ := + AddInductive.CandidateTypeAnnotationTrace.build domain + ⟨consumed, trace⟩ + have annotationsBuild : + AddInductive.buildCandidateTypeAnnotations domain = + .ok annotations := by + rfl + have annotationsConsumed : annotations.consumed = domain := + (AddInductive.CandidateTypeAnnotations.matches_of_build annotations + annotationsBuild).trans consume + have bodyReplay' : Shaped + (context.pushLocalDecl name binderInfo annotations.consumed) + (body.instantiate1 context.freshExpr) + expectedSpineLength expectedTerminalSource := by + rw [annotationsConsumed] + exact bodyReplay + exact Shaped.forallE context name domain body binderInfo whnf annotations + annotationsBuild consume domainReplay bodyReplay' + +theorem expr_eq_forallE_of_isForall + (source : Expr) (h : source.isForall = true) : + source = .forallE source.bindingName! source.bindingDomain! + source.bindingBody! source.bindingInfo! := by + cases source <;> simp_all [Expr.isForall, Expr.bindingName!, + Expr.bindingDomain!, Expr.bindingBody!, Expr.bindingInfo!] + +theorem candidateWhnfForallSource_refl + (context : AddInductive.Context) (source : Expr) + (recursionFuel : Nat) + (hdepth : context.fuel.recDepth = recursionFuel + 1) + (h : source.isForall = true) : + AddInductive.CandidateWhnfStep.Valid ⟨context, source, source⟩ := by + rw [expr_eq_forallE_of_isForall source h] + unfold AddInductive.CandidateWhnfStep.Valid + change TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel + (TypeChecker.whnf (.forallE source.bindingName! + source.bindingDomain! source.bindingBody! source.bindingInfo!)) = + .ok (.forallE source.bindingName! source.bindingDomain! + source.bindingBody! source.bindingInfo!) + unfold TypeChecker.M.run TypeChecker.whnf TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rw [hdepth] + rfl + +def forallEBuiltOfSource + (context : AddInductive.Context) (source : Expr) + (isForall : source.isForall = true) + (whnf : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, source⟩) + (consume : AddInductive.consumeTypeAnnotations + source.bindingDomain! = source.bindingDomain!) + (domainReplay : CandidateExprIdentityReplay context + source.bindingDomain!) + (bodyReplay : Shaped + (context.pushLocalDecl source.bindingName! source.bindingInfo! + source.bindingDomain!) + (source.bindingBody!.instantiate1 context.freshExpr) + expectedSpineLength expectedTerminalSource) : + Shaped context source (expectedSpineLength + 1) + expectedTerminalSource := by + rw [expr_eq_forallE_of_isForall source isForall] at whnf ⊢ + exact forallEBuilt context source.bindingName! source.bindingDomain! + source.bindingBody! source.bindingInfo! whnf consume domainReplay + bodyReplay + +end Shaped + +structure Evidence + (replay : CandidateExprIdentityReplay context source) + (trace : AddInductive.CandidateExprTrace traceContext source) : Prop where + identity : CandidateExprIdentity trace + spineLength_eq : trace.spineLength = replay.spineLength + terminalResult_eq : trace.terminalResult = replay.terminalSource + +theorem evidence_of_loop + (replay : CandidateExprIdentityReplay context source) + (run : AddInductive.buildCandidateExpr.loop context source fuel = + .ok candidateTrace) : Evidence replay candidateTrace := by + induction replay generalizing fuel with + | terminal context source whnf notForall => + cases fuel with + | zero => + simp [AddInductive.buildCandidateExpr.loop] at run + | succ fuel => + have inspected := run + unfold AddInductive.buildCandidateExpr.loop at inspected + cases hcheck : AddInductive.observeCandidateCheckType context source with + | error error => simp [hcheck] at inspected + | ok observation => + rcases observation with ⟨inferred, checked⟩ + have expected := + AddInductive.buildCandidateExpr_loop_of_whnf_nonForall + context source inferred source fuel checked whnf notForall + rw [expected] at run + cases run + exact ⟨.terminal rfl, rfl, rfl⟩ + | forallE context name domain body binderInfo whnf annotations + annotationsBuild consume domainReplay bodyReplay domainIH bodyIH => + cases fuel with + | zero => + simp [AddInductive.buildCandidateExpr.loop] at run + | succ fuel => + unfold AddInductive.buildCandidateExpr.loop at run + cases hcheck : AddInductive.observeCandidateCheckType context + (.forallE name domain body binderInfo) with + | error error => simp [hcheck] at run + | ok observation => + rcases observation with ⟨inferred, checked⟩ + simp only [hcheck, Bind.bind, Except.bind] at run + simp only [AddInductive.observeCandidateWhnf_of_run context + (.forallE name domain body binderInfo) + (.forallE name domain body binderInfo) whnf] at run + simp only [annotationsBuild] at run + repeat' split at run + all_goals try simp_all [Pure.pure, Except.pure] + rename_i freshEq isDefEqResult isDefEqObservation hisDefEq + domainResult domainTrace hdomain bodyResult bodyTrace hbody + cases run + have domainEvidence := domainIH hdomain + have bodyEvidence := bodyIH hbody + have annotationsConsumed : annotations.consumed = domain := + (AddInductive.CandidateTypeAnnotations.matches_of_build + annotations annotationsBuild).trans consume + refine ⟨.forallE domainTrace bodyTrace rfl annotationsConsumed + domainEvidence.identity bodyEvidence.identity, ?_, ?_⟩ + · simpa [AddInductive.CandidateExprTrace.spineLength, + spineLength] using bodyEvidence.spineLength_eq + · simpa [AddInductive.CandidateExprTrace.terminalResult, + terminalSource] using bodyEvidence.terminalResult_eq + +theorem evidence_of_build + (replay : CandidateExprIdentityReplay context source) + (run : AddInductive.buildCandidateExpr source context = .ok candidate) : + Evidence replay candidate.trace := by + unfold AddInductive.buildCandidateExpr at run + simp only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] at run + cases hloop : AddInductive.buildCandidateExpr.loop context source + context.fuel.inductiveFuel with + | error error => simp [hloop] at run + | ok trace => + simp [hloop] at run + subst candidate + exact replay.evidence_of_loop hloop + +theorem identity_of_build + (replay : CandidateExprIdentityReplay context source) + (run : AddInductive.buildCandidateExpr source context = .ok candidate) : + CandidateExprIdentity candidate.trace := + (replay.evidence_of_build run).identity + +end CandidateExprIdentityReplay +end Lean4Lean.TypeChecker + +namespace Lean4Lean.AddInductive + +def builtCandidateTypeAnnotations (source : Lean.Expr) : + CandidateTypeAnnotations source := + let ⟨consumed, trace⟩ := CandidateTypeAnnotationTrace.build source + ⟨consumed, trace⟩ + +theorem buildCandidateTypeAnnotations_built (source : Lean.Expr) : + buildCandidateTypeAnnotations source = + .ok (builtCandidateTypeAnnotations source) := by + rfl + +theorem CandidateFamilyTypeListProduced.singleton_build + {context : Context} {source : Lean.InductiveType} + {candidates : CandidateList CandidateFamilyType [source]} + (run : CandidateFamilyTypeListProduced context candidates) : + buildCandidateExpr source.type context = + .ok candidates.singleton.type := by + cases run with + | cons head tail => + cases tail + unfold normalizeCandidateFamilyType at head + simp only [ReaderT.bind, Bind.bind] at head + cases hbuild : buildCandidateExpr source.type context with + | error error => simp [Except.bind, hbuild] at head + | ok candidate => + simp [Except.bind, hbuild, ReaderT.pure, + Pure.pure, Except.pure] at head + cases head + rfl + +theorem CandidateConstructorListProduced.singleton_build + {context : Context} {source : Lean.Constructor} + {candidates : CandidateList CandidateConstructor [source]} + (run : CandidateConstructorListProduced context candidates) : + buildCandidateExpr source.type context = + .ok candidates.singleton.type := by + cases run with + | cons head tail => + cases tail + unfold normalizeCandidateConstructor at head + simp only [ReaderT.bind, Bind.bind] at head + cases hbuild : buildCandidateExpr source.type context with + | error error => simp [Except.bind, hbuild] at head + | ok candidate => + simp [Except.bind, hbuild, ReaderT.pure, + Pure.pure, Except.pure] at head + cases head + rfl + +end Lean4Lean.AddInductive diff --git a/Lean4Lean/Verify/Environment/ConstructorValidation.lean b/Lean4Lean/Verify/Environment/ConstructorValidation.lean new file mode 100644 index 00000000..305bde7d --- /dev/null +++ b/Lean4Lean/Verify/Environment/ConstructorValidation.lean @@ -0,0 +1,9005 @@ +import Lean4Lean.Verify.Environment.Normalization + +namespace Lean4Lean +open Lean hiding Environment Exception +open Kernel + +namespace AddInductive +open TypeChecker + +/-! +# Semantic interpretation of constructor validation + +This module interprets the operational trace retained by +`Inductive.ValidationTrace`. It deliberately sits above both the verified +checker and candidate normalization: validation supplies the accepted kernel +path, while normalization supplies the exact analyzer-owned Theory view. +-/ + +/-- Structural equality of kernel levels is sound after strict translation. -/ +theorem levelStructEq_ofLevel + (equal : levelStructEq lhs rhs = true) + (lhs_tr : VLevel.ofLevel Us lhs = some lhs') + (rhs_tr : VLevel.ofLevel Us rhs = some rhs') : + lhs' = rhs' := by + induction lhs generalizing rhs lhs' rhs' with + | zero => + cases rhs <;> simp_all [levelStructEq, VLevel.ofLevel] + | succ lhs ih => + cases rhs with + | succ rhs => + simp only [levelStructEq] at equal + simp only [VLevel.ofLevel, Option.bind_eq_bind] at lhs_tr rhs_tr + obtain ⟨lhs'', lhs_inner_tr, lhs'_eq⟩ := + Option.bind_eq_some_iff.mp lhs_tr + obtain ⟨rhs'', rhs_inner_tr, rhs'_eq⟩ := + Option.bind_eq_some_iff.mp rhs_tr + change some lhs''.succ = some lhs' at lhs'_eq + change some rhs''.succ = some rhs' at rhs'_eq + injection lhs'_eq with lhs'_eq + injection rhs'_eq with rhs'_eq + subst lhs' + subst rhs' + rw [ih equal lhs_inner_tr rhs_inner_tr] + | zero | max _ _ | imax _ _ | param _ | mvar _ => + simp_all [levelStructEq] + | max lhs₁ lhs₂ ih₁ ih₂ => + cases rhs with + | max rhs₁ rhs₂ => + simp only [levelStructEq, Bool.and_eq_true] at equal + simp only [VLevel.ofLevel, Option.bind_eq_bind] at lhs_tr rhs_tr + obtain ⟨lhs₁', lhs₁_tr, lhsTail⟩ := + Option.bind_eq_some_iff.mp lhs_tr + obtain ⟨lhs₂', lhs₂_tr, lhs'_eq⟩ := + Option.bind_eq_some_iff.mp lhsTail + obtain ⟨rhs₁', rhs₁_tr, rhsTail⟩ := + Option.bind_eq_some_iff.mp rhs_tr + obtain ⟨rhs₂', rhs₂_tr, rhs'_eq⟩ := + Option.bind_eq_some_iff.mp rhsTail + change some (.max lhs₁' lhs₂') = some lhs' at lhs'_eq + change some (.max rhs₁' rhs₂') = some rhs' at rhs'_eq + injection lhs'_eq with lhs'_eq + injection rhs'_eq with rhs'_eq + subst lhs' + subst rhs' + rw [ih₁ equal.1 lhs₁_tr rhs₁_tr, + ih₂ equal.2 lhs₂_tr rhs₂_tr] + | zero | succ _ | imax _ _ | param _ | mvar _ => + simp_all [levelStructEq] + | imax lhs₁ lhs₂ ih₁ ih₂ => + cases rhs with + | imax rhs₁ rhs₂ => + simp only [levelStructEq, Bool.and_eq_true] at equal + simp only [VLevel.ofLevel, Option.bind_eq_bind] at lhs_tr rhs_tr + obtain ⟨lhs₁', lhs₁_tr, lhsTail⟩ := + Option.bind_eq_some_iff.mp lhs_tr + obtain ⟨lhs₂', lhs₂_tr, lhs'_eq⟩ := + Option.bind_eq_some_iff.mp lhsTail + obtain ⟨rhs₁', rhs₁_tr, rhsTail⟩ := + Option.bind_eq_some_iff.mp rhs_tr + obtain ⟨rhs₂', rhs₂_tr, rhs'_eq⟩ := + Option.bind_eq_some_iff.mp rhsTail + change some (.imax lhs₁' lhs₂') = some lhs' at lhs'_eq + change some (.imax rhs₁' rhs₂') = some rhs' at rhs'_eq + injection lhs'_eq with lhs'_eq + injection rhs'_eq with rhs'_eq + subst lhs' + subst rhs' + rw [ih₁ equal.1 lhs₁_tr rhs₁_tr, + ih₂ equal.2 lhs₂_tr rhs₂_tr] + | zero | succ _ | max _ _ | param _ | mvar _ => + simp_all [levelStructEq] + | param lhsName => + cases rhs <;> simp_all [levelStructEq, VLevel.ofLevel] + | mvar lhsId => + simp [VLevel.ofLevel] at lhs_tr + +/-- The transparent fast path used by constructor validation implies the +Theory universe inequality required by `fieldsWF`. -/ +theorem levelStructGe_ofLevel + (greater : levelStructGe result field = true) + (result_tr : VLevel.ofLevel Us result = some result') + (field_tr : VLevel.ofLevel Us field = some field') : + field' ≤ result' := by + induction result generalizing field result' field' with + | zero => + cases field with + | zero => + change some (.zero : VLevel) = some result' at result_tr + change some (.zero : VLevel) = some field' at field_tr + injection result_tr with result_tr + injection field_tr with field_tr + subst result' + subst field' + exact VLevel.le_refl _ + | succ _ | max _ _ | imax _ _ | param _ | mvar _ => + simp_all [levelStructGe, levelStructEq] + | succ result ih => + cases field with + | zero => + change some (.zero : VLevel) = some field' at field_tr + injection field_tr with field_tr + subst field' + exact VLevel.zero_le + | succ field => + simp only [levelStructGe] at greater + simp only [VLevel.ofLevel, Option.bind_eq_bind] at result_tr field_tr + obtain ⟨result'', result_inner_tr, result'_eq⟩ := + Option.bind_eq_some_iff.mp result_tr + obtain ⟨field'', field_inner_tr, field'_eq⟩ := + Option.bind_eq_some_iff.mp field_tr + change some result''.succ = some result' at result'_eq + change some field''.succ = some field' at field'_eq + injection result'_eq with result'_eq + injection field'_eq with field'_eq + subst result' + subst field' + exact VLevel.succ_le_succ + (ih greater result_inner_tr field_inner_tr) + | max _ _ | imax _ _ | param _ | mvar _ => + have equal := levelStructEq_ofLevel (Us := Us) + (by simpa [levelStructGe] using greater) result_tr field_tr + cases equal + exact VLevel.le_refl _ + | max result₁ result₂ ih₁ ih₂ => + cases field with + | zero => + change some (.zero : VLevel) = some field' at field_tr + injection field_tr with field_tr + subst field' + exact VLevel.zero_le + | succ _ | max _ _ | imax _ _ | param _ | mvar _ => + have equal := levelStructEq_ofLevel (Us := Us) + (by simpa [levelStructGe] using greater) result_tr field_tr + cases equal + exact VLevel.le_refl _ + | imax result₁ result₂ ih₁ ih₂ => + cases field with + | zero => + change some (.zero : VLevel) = some field' at field_tr + injection field_tr with field_tr + subst field' + exact VLevel.zero_le + | succ _ | max _ _ | imax _ _ | param _ | mvar _ => + have equal := levelStructEq_ofLevel (Us := Us) + (by simpa [levelStructGe] using greater) result_tr field_tr + cases equal + exact VLevel.le_refl _ + | param resultName => + cases field with + | zero => + change some (.zero : VLevel) = some field' at field_tr + injection field_tr with field_tr + subst field' + exact VLevel.zero_le + | succ _ | max _ _ | imax _ _ | param _ | mvar _ => + have equal := levelStructEq_ofLevel (Us := Us) + (by simpa [levelStructGe] using greater) result_tr field_tr + cases equal + exact VLevel.le_refl _ + | mvar resultId => + simp [VLevel.ofLevel] at result_tr + +/-- The impredicative fallback is exact: a kernel level recognized as zero +translates to Theory's zero level. -/ +theorem ofLevel_eq_zero_of_isZero + (zero : level.isZero = true) + (level_tr : VLevel.ofLevel Us level = some level') : + level' = .zero := by + cases level <;> simp_all [Level.isZero, VLevel.ofLevel] + +/-- Executable universe comparison supported by the semantic proof. + +The structural and impredicative `Prop` branches mirror the ordinary +validator directly. A normalized non-`Prop` comparison is admitted only +when Lean's ordinary `Level.geq` decision and the verified project `geq'` +decision both succeed. The former preserves the kernel-facing acceptance +boundary; the latter supplies the semantic inequality without trusting +Lean's opaque normalizer. -/ +def constructorUniverseSemanticGe (resultLevel fieldLevel : Level) : Bool := + levelStructGe resultLevel fieldLevel || + (resultLevel.isZero || + (resultLevel.geq fieldLevel && resultLevel.geq' fieldLevel)) + +/-- Replay just the universe-bearing part of one constructor telescope. + +The traversal deliberately follows the validator's parameter substitution, +ordinary-field local contexts, annotation consumption, and recursion fuel. +Unlike `checkConstructorType`, its normalized fallback also requires the +proved project comparison above. Running this audit in addition to the +ordinary validator is therefore an executable verified intersection, not a +replacement validator and not a proof-only semantic premise. -/ +def checkConstructorUniverseSemantics (stats : InductiveStats) (t : Expr) : + M Unit := do + loop t 0 (← readThe Context).fuel.inductiveFuel +where + loop (t : Expr) (i : Nat) : Nat → M Unit + | 0 => throw .deepRecursion + | fuel + 1 => do + if let .forallE name domain body binderInfo := t then + if let some parameter := stats.params[i]? then + loop (body.instantiate1 parameter) (i + 1) fuel + else + let sortResult ← ensureType domain + unless constructorUniverseSemanticGe stats.resultLevel + sortResult.sortLevel! do + throw <| .other + "constructor universe lies outside the verified semantic subset" + withLocalDecl name binderInfo (consumeTypeAnnotations domain) fun arg => + loop (body.instantiate1 arg) (i + 1) fuel + +/-- Source-ordered universe audit for every constructor in one singleton +family. Constructor names and types come from the same indexed source list +as `ConstructorListValidationTrace`; all non-universe validation remains in +that retained ordinary trace. -/ +def checkConstructorUniverseListSemantics (stats : InductiveStats) : + List Constructor → M Unit + | [] => pure () + | constructor :: constructors => do + checkConstructorUniverseSemantics stats constructor.type + checkConstructorUniverseListSemantics stats constructors + +/-- The executable semantic decision at the exact universe node retained by +ordinary constructor validation. -/ +def ConstructorUniverseTrace.semantic + (_trace : ConstructorUniverseTrace resultLevel fieldLevel) : Bool := + constructorUniverseSemanticGe resultLevel fieldLevel + +/-- Conjunction of the semantic universe decisions in one exact constructor +telescope. Parameter and terminal nodes contribute no universe obligation. -/ +def ConstructorTypeValidationTrace.universeSemantics + (trace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx fuel) : Bool := + match trace with + | .parameter _ _ _ _ _ _ _ _ _ _ _ _ tail => + tail.universeSemantics + | .ordinary _ _ _ _ _ _ _ _ _ _ universeTrace _ tail => + universeTrace.semantic && tail.universeSemantics + | .terminal _ _ _ _ _ _ => true + +/-- Source-ordered conjunction of every constructor telescope's semantic +universe decisions. -/ +def ConstructorListValidationTrace.universeSemantics + (trace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors) : Bool := + match trace with + | .nil _ => true + | .cons _ _ _ _ _ _ typeTrace tailTrace => + typeTrace.universeSemantics && tailTrace.universeSemantics + +/-- The complete semantic-universe gate attached to one retained ordinary +constructor-validation run. -/ +def ConstructorValidationRun.universeSemantics + (validation : ConstructorValidationRun indType stats isUnsafe context) : + Bool := + validation.trace.universeSemantics + +/-- Recover the state-bearing verified-checker execution erased by the +ordinary constructor validator's `ensureType` observation. -/ +theorem ConstructorEnsureTypeStep.innerRun + (step : ConstructorEnsureTypeStep) (hvalid : step.Valid) : + ∃ state : TypeChecker.State, + TypeChecker.ensureType step.source step.context.toTypeChecker + ({} : TypeChecker.State) = .ok (step.result, state) := by + unfold ConstructorEnsureTypeStep.Valid TypeChecker.M.run at hvalid + cases hrun : TypeChecker.ensureType step.source + { env := step.context.env + lctx := step.context.lctx + safety := step.context.safety + lparams := step.context.lparams + fuel := step.context.fuel } + ({} : TypeChecker.State) with + | error err => + simp [StateT.run', Functor.map, Except.map, hrun] at hvalid + | ok pair => + rcases pair with ⟨result, state⟩ + have result_eq : result = step.result := by + simpa [StateT.run', Functor.map, Except.map, hrun] using hvalid + subst result + exact ⟨state, by simpa [Context.toTypeChecker] using hrun⟩ + +/-- Theory interpretation of the exact `ensureType` execution retained for +an ordinary constructor field. -/ +structure TypeChecker.EnsureTypeRun (env : VEnv) (Us : List Name) + (Δ : VLCtx) (source result : Expr) (source' : VExpr) where + context : VContext + venv_eq : context.venv = env + lparams_eq : context.lparams = Us + vlctx_eq : context.vlctx = Δ + state_wf : VState.WF context {} + source_tr : TrExprS env Us Δ source source' + resultLevel : Level + resultLevel' : VLevel + result_eq : result = .sort resultLevel + resultLevel_tr : VLevel.ofLevel Us resultLevel = some resultLevel' + source_type : env.HasType Us.length Δ.toCtx source' (.sort resultLevel') + run_eq : ∃ state : State, + ensureType source context.toContext ({} : State) = .ok (result, state) + +/-- Attach verified Theory meaning to one retained ordinary-field +`ensureType` step in its exact post-family context. -/ +theorem TypeChecker.EnsureTypeRun.exists_ofConstructorStep + (step : ConstructorEnsureTypeStep) (hvalid : step.Valid) + (contextRun : CandidateContextRun step.context) + (source' : VExpr) + (source_tr : contextRun.context.TrExprS step.source source') : + Nonempty (EnsureTypeRun contextRun.context.venv + contextRun.context.lparams contextRun.context.vlctx + step.source step.result source') := by + obtain ⟨state, run⟩ := step.innerRun hvalid + rw [← contextRun.context_eq] at run + obtain ⟨_, _, _, _, translated, translated_tr, u, u', result_eq, + level_tr, source_type⟩ := + (ensureType.WF source_tr) contextRun.state_wf step.result state run + have translated_def := translated_tr.uniq contextRun.context.Ewf + (.refl contextRun.context.Ewf contextRun.context.Δwf) source_tr + have source_type' := source_type.defeqU_l contextRun.context.Ewf + contextRun.context.Δwf translated_def + exact ⟨{ + context := contextRun.context + venv_eq := rfl + lparams_eq := rfl + vlctx_eq := rfl + state_wf := contextRun.state_wf + source_tr := source_tr + resultLevel := u + resultLevel' := u' + result_eq := result_eq + resultLevel_tr := level_tr + source_type := source_type' + run_eq := ⟨state, run⟩ }⟩ + +/-! +## Exact post-family view alignment + +Constructor validation and constructor-candidate construction deliberately +allocate their ordinary-field free variables from different reader states. +The following audit therefore never compares those identifiers. It follows +the already-retained validation trace and instantiates the exact candidate +view with the *validation* parameter/field expression at each position. +Every comparison consequently happens in the real post-family local context, +while the candidate itself still owns the view being inspected. +-/ + +/-- Number of parameter/ordinary binders consumed by one exact constructor +validation trace. -/ +def ConstructorTypeValidationTrace.spineLength + (trace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx fuel) : Nat := + match trace with + | .parameter _ _ _ _ _ _ _ _ _ _ _ _ tail => tail.spineLength + 1 + | .ordinary _ _ _ _ _ _ _ _ _ _ _ _ tail => tail.spineLength + 1 + | .terminal .. => 0 + +/-- Every local declaration entered by a retained positivity traversal uses +an identifier absent from the exact incoming local context. This is an +executable structural condition, not a semantic premise. -/ +def ConstructorPositivityTrace.freshNames + (trace : ConstructorPositivityTrace stats ctor argIdx context source fuel) : + Bool := + match trace with + | .absent .. => true + | .forallE context _ _ _ _ _ _ _ _ _ tail => + (context.lctx.find? context.freshFVarId).isNone && tail.freshNames + | .target .. => true + +def ConstructorPositivityModeTrace.freshNames + (trace : ConstructorPositivityModeTrace stats isUnsafe ctor argIdx + context source) : Bool := + match trace with + | .skipped .. => true + | .safe _ trace => trace.freshNames + +/-- One exact full-check observation together with the syntactic premise used +by the verified checker refinement. Keeping the premise at the operational +boundary avoids reconstructing free-variable membership later from binder +names or from a parallel telescope. -/ +structure ConstructorCheckedExpr (context : Context) (source : Expr) where + fvars : source.FVarsIn + (fun fv => (context.lctx.find? fv).isSome = true) + observation : CandidateCheckTypeObservation context source + +/-- Retain an already verified full-check execution together with a structural +scope proof for its exact source expression. -/ +def ConstructorCheckedExpr.ofRun + (fvars : source.FVarsIn + (fun fv => (context.lctx.find? fv).isSome = true)) + (run : CandidateCheckTypeStep.Valid ⟨context, source, inferred⟩) : + ConstructorCheckedExpr context source := + ⟨fvars, ⟨inferred, run⟩⟩ + +private theorem constructorClosed_hasMVar_false + {env : Kernel.Environment} {name : Name} {source : Expr} + (closed : env.checkNoMVarNoFVar name source = .ok ()) : + source.hasMVar = false := by + unfold Kernel.Environment.checkNoMVarNoFVar + Kernel.Environment.checkNoMVar Kernel.Environment.checkNoFVar at closed + cases hmvars : source.hasMVar + · rfl + · simp [hmvars, Bind.bind, Except.bind] at closed + +private theorem constructorClosed_hasFVar_false + {env : Kernel.Environment} {name : Name} {source : Expr} + (closed : env.checkNoMVarNoFVar name source = .ok ()) : + source.hasFVar = false := by + have hmvars := constructorClosed_hasMVar_false closed + unfold Kernel.Environment.checkNoMVarNoFVar + Kernel.Environment.checkNoMVar Kernel.Environment.checkNoFVar at closed + cases hfvars : source.hasFVar + · rfl + · simp [hmvars, hfvars, Bind.bind, Except.bind, Pure.pure, + Except.pure] at closed + +/-- Constructor metadata accepted by the validator is closed, so its retained +empty-context full-check observation directly supplies the D2 root scope. -/ +def ConstructorCheckedExpr.ofClosedRoot + {context : Context} {name : Name} {source : Expr} + (closed : context.env.checkNoMVarNoFVar name source = .ok ()) + (observation : CandidateCheckTypeObservation + context.withEmptyLocalContext source) : + ConstructorCheckedExpr context.withEmptyLocalContext source where + fvars := fvarsIn_iff.2 ⟨by + intro fv present + have empty := fvarsList_eq_nil.mpr + (constructorClosed_hasFVar_false closed) + rw [empty] at present + contradiction, + fvarsIn_iff_hasMVar.2 (constructorClosed_hasMVar_false closed)⟩ + observation := observation + +/-- Execute a full check only after confirming that every free variable of +the exact source belongs to the retained implementation context. -/ +def checkConstructorAlignedExpr (context : Context) (source : Expr) : + Except Exception (ConstructorCheckedExpr context source) := do + if hfvars : source.fvarsList.all + (fun fv => (context.lctx.find? fv).isSome) = true then + if hmvars : source.hasMVar = false then + have fvars : source.FVarsIn + (fun fv => (context.lctx.find? fv).isSome = true) := + fvarsIn_iff.2 ⟨by + intro fv hfv + have h := List.all_eq_true.mp hfvars fv hfv + exact h, + fvarsIn_iff_hasMVar.2 hmvars⟩ + let observation ← observeCandidateCheckType context source + pure ⟨fvars, observation⟩ + else + throw <| .other "constructor alignment source contains a metavariable" + else + throw <| .other "constructor alignment source escaped its local context" + +/-- Reuse an exact full-check execution to expose the successful result of +the supplemental scope-aware checker boundary. -/ +theorem checkConstructorAlignedExpr.exists_of_run + (hfvars : source.fvarsList.all + (fun fv => (context.lctx.find? fv).isSome) = true) + (hmvars : source.hasMVar = false) + (hrun : CandidateCheckTypeStep.Valid ⟨context, source, inferred⟩) : + ∃ checked : ConstructorCheckedExpr context source, + checkConstructorAlignedExpr context source = .ok checked := by + unfold checkConstructorAlignedExpr + rw [dif_pos hfvars, dif_pos hmvars] + rw [observeCandidateCheckType_of_run context source inferred hrun] + exact ⟨_, rfl⟩ + +/-- Re-executing the supplemental scope/full-check boundary reproduces any +retained successful observation. The only reconstructed fields are proofs, +so proof irrelevance identifies the executable result with the retained +value itself. -/ +theorem ConstructorCheckedExpr.check_eq + (checked : ConstructorCheckedExpr context source) : + checkConstructorAlignedExpr context source = .ok checked := by + have hfvars : source.fvarsList.all + (fun fv => (context.lctx.find? fv).isSome) = true := by + apply List.all_eq_true.mpr + intro fv present + exact (fvarsIn_iff.mp checked.fvars).1 fv present + have hmvars : source.hasMVar = false := + fvarsIn_iff_hasMVar.mp (fvarsIn_iff.mp checked.fvars).2 + unfold checkConstructorAlignedExpr + rw [dif_pos hfvars, dif_pos hmvars] + rw [observeCandidateCheckType_of_run context source + checked.observation.inferred checked.observation.valid] + cases checked + rfl + +/-- Determinism of the erased implementation run pins a retained full-check +observation to any independently proved result of that same exact check. -/ +theorem ConstructorCheckedExpr.inferred_eq_of_run + (checked : ConstructorCheckedExpr context source) + (hrun : CandidateCheckTypeStep.Valid ⟨context, source, inferred⟩) : + checked.observation.inferred = inferred := by + have retained := checked.observation.valid + unfold CandidateCheckTypeStep.Valid at retained hrun + rw [hrun] at retained + exact (Except.ok.inj retained).symm + +/-- Re-executing a retained equality observation returns that same +observation; its sole field is proof-valued. -/ +theorem CandidateIsDefEqObservation.observe_eq + (observation : CandidateIsDefEqObservation context lhs rhs) : + observeCandidateIsDefEq context lhs rhs = .ok observation := by + rw [observeCandidateIsDefEq_of_run context lhs rhs observation.valid] + +/-- The verified implementation equality checker accepts a syntactically +identical pair without inspecting or mutating its equivalence manager. -/ +theorem candidateIsDefEqRefl + (context : Context) (source : Expr) : + CandidateIsDefEqStep.Valid ⟨context, source, source⟩ := by + unfold CandidateIsDefEqStep.Valid TypeChecker.M.run TypeChecker.isDefEq + TypeChecker.RecM.run TypeChecker.Inner.isDefEq + simp [readThe, MonadReaderOf.read, ReaderT.read, ReaderT.bind, Bind.bind, + StateT.bind, Except.bind, StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rfl + +/-- Convert the executable implementation-context scope check to the exact +Theory free-variable premise used by verified `checkType` refinement. -/ +theorem ConstructorCheckedExpr.fvarsIn + (checked : ConstructorCheckedExpr context source) + (contextRun : TypeChecker.CandidateContextRun context) : + source.FVarsIn (· ∈ contextRun.context.vlctx.fvars) := by + apply checked.fvars.mono + intro fv present + have implementationPresent : + ∃ declaration, context.lctx.find? fv = some declaration := by + simpa only [Option.isSome_iff_exists] using present + have verifiedPresent : + ∃ declaration, contextRun.context.lctx.find? fv = some declaration := by + simpa only [contextRun.context_lctx] using implementationPresent + apply contextRun.context.trlctx.find?_eq_some.mp + change ∃ declaration, + contextRun.context.mlctx.lctx.find? fv = some declaration + rw [contextRun.context.lctx_eq] + exact verifiedPresent + +/-- Verified meaning of one full check retained by the alignment audit. Both +Theory endpoints are selected by the checker refinement; callers cannot +substitute an unrelated translation for the exact source position. -/ +structure ConstructorCheckedExpr.Run + (checked : ConstructorCheckedExpr context source) + (contextRun : TypeChecker.CandidateContextRun context) where + source' : VExpr + inferred' : VExpr + check : TypeChecker.CheckTypeRun contextRun.context.venv + contextRun.context.lparams contextRun.context.vlctx source + checked.observation.inferred source' inferred' + +/-- Interpret an aligned full-check observation in its exact verified +post-family context. -/ +theorem ConstructorCheckedExpr.Run.exists + (checked : ConstructorCheckedExpr context source) + (contextRun : TypeChecker.CandidateContextRun context) : + Nonempty (ConstructorCheckedExpr.Run checked contextRun) := by + obtain ⟨source', inferred', ⟨check⟩⟩ := + TypeChecker.CheckTypeRun.exists_ofCandidateStepFVars + ⟨context, source, checked.observation.inferred⟩ + checked.observation.valid contextRun (checked.fvarsIn contextRun) + exact ⟨⟨source', inferred', check⟩⟩ + +/-- A retained full check whose implementation result is syntactically a +sort supplies the exact Theory `IsType` premise needed to extend the local +context. -/ +theorem ConstructorCheckedExpr.Run.isType_of_inferredSort + (run : ConstructorCheckedExpr.Run checked contextRun) + (inferred_eq : checked.observation.inferred = .sort u) : + contextRun.context.IsType run.source' := by + rcases run with ⟨source', inferred', check⟩ + have inferred_tr := check.inferred_tr + rw [inferred_eq] at inferred_tr + cases inferred_tr + exact check.isType + +/-- Reuse a proved scope boundary with the exact full-check observation owned +by another retained execution of the same source expression. -/ +def ConstructorCheckedExpr.withObservation + (scope : ConstructorCheckedExpr context source) + (observation : CandidateCheckTypeObservation context source) : + ConstructorCheckedExpr context source := + ⟨scope.fvars, observation⟩ + +/-- Interpret one retained equality observation at the exact Theory +translations selected by the two aligned full checks. -/ +def ConstructorCheckedExpr.Run.isDefEq + {context : Context} {lhs rhs : Expr} + {lhsCheck : ConstructorCheckedExpr context lhs} + {rhsCheck : ConstructorCheckedExpr context rhs} + {contextRun : TypeChecker.CandidateContextRun context} + (lhsRun : ConstructorCheckedExpr.Run lhsCheck contextRun) + (rhsRun : ConstructorCheckedExpr.Run rhsCheck contextRun) + (observation : CandidateIsDefEqObservation context lhs rhs) : + TypeChecker.IsDefEqRun contextRun.context.venv + contextRun.context.lparams contextRun.context.vlctx lhs rhs + lhsRun.source' rhsRun.source' := + TypeChecker.IsDefEqRun.ofCandidateStep + ⟨context, lhs, rhs⟩ observation.valid contextRun.context + contextRun.context_eq rfl rfl rfl contextRun.state_wf + lhsRun.check.expr_tr rhsRun.check.expr_tr context.fuel.recDepth rfl + +/-- A validation-local verified context pinned to the one post-family Theory +environment and universe-parameter list used by the whole constructor list. -/ +structure ConstructorContextRun (env : VEnv) (Us : List Name) + (context : Context) where + candidate : TypeChecker.CandidateContextRun context + venv_eq : candidate.context.venv = env + lparams_eq : candidate.context.lparams = Us + +def ConstructorContextRun.withEmptyLocalContext + (run : ConstructorContextRun env Us context) : + ConstructorContextRun env Us context.withEmptyLocalContext where + candidate := run.candidate.withEmptyLocalContext + venv_eq := run.venv_eq + lparams_eq := run.lparams_eq + +/-- Extend the actual post-family verified context by exactly one retained +validation local declaration. -/ +def ConstructorContextRun.pushLocalDecl + (run : ConstructorContextRun env Us context) + (name : Name) (binderInfo : BinderInfo) (domain : Expr) + (fresh : context.lctx.find? context.freshFVarId = none) + (domain' : VExpr) + (domain_tr : run.candidate.context.TrExprS domain domain') + (domain_type : run.candidate.context.IsType domain') : + ConstructorContextRun env Us + (context.pushLocalDecl name binderInfo domain) := by + let candidate := run.candidate.pushLocalDecl name binderInfo domain fresh + domain' domain_tr domain_type + refine ⟨candidate, ?_, ?_⟩ + · calc + candidate.context.venv = run.candidate.context.venv := by + simp [candidate] + _ = env := run.venv_eq + · calc + candidate.context.lparams = run.candidate.context.lparams := by + simp [candidate, AddInductive.Context.pushLocalDecl] + _ = Us := run.lparams_eq + +/-- Verified interpretation of one exact retained WHNF operation, sharing the +source translation already selected by its aligned full check. -/ +structure ConstructorWhnfRun + {context : Context} {source : Expr} + {sourceCheck : ConstructorCheckedExpr context source} + (contextRun : TypeChecker.CandidateContextRun context) + (sourceRun : ConstructorCheckedExpr.Run sourceCheck contextRun) + (result : Expr) where + result' : VExpr + result_tr : contextRun.context.TrExprS result result' + whnf : TypeChecker.WhnfRun contextRun.context.venv + contextRun.context.lparams contextRun.context.vlctx source result + sourceRun.source' result' + +theorem ConstructorWhnfRun.exists + {context : Context} {source result : Expr} + {sourceCheck : ConstructorCheckedExpr context source} + (contextRun : TypeChecker.CandidateContextRun context) + (sourceRun : ConstructorCheckedExpr.Run sourceCheck contextRun) + (valid : CandidateWhnfStep.Valid ⟨context, source, result⟩) + (recursionFuel : Nat) + (depth : context.fuel.recDepth = recursionFuel + 1) : + Nonempty (ConstructorWhnfRun contextRun sourceRun result) := by + obtain ⟨result', result_tr, ⟨whnf⟩⟩ := + TypeChecker.WhnfRun.exists_ofCandidateStep + ⟨context, source, result⟩ valid contextRun sourceRun.source' + sourceRun.check.expr_tr recursionFuel depth + exact ⟨⟨result', result_tr, whnf⟩⟩ + +/-- Retained operational evidence for the supplemental nested-positivity +alignment. The ordinary positivity trace continues to own every WHNF, +occurrence decision, and accepted recursive target. This trace adds the full +checks and annotation equality needed to interpret those exact operations in +the verified checker. -/ +inductive ConstructorPositivityAlignmentTrace : + {stats : InductiveStats} → {ctor : Name} → {argIdx : Nat} → + {context : Context} → {source : Expr} → {fuel : Nat} → + ConstructorPositivityTrace stats ctor argIdx context source fuel → Type where + | absent + (sourceCheck : ConstructorCheckedExpr context source) : + ConstructorPositivityAlignmentTrace + (.absent context source result fuel whnfStep occurs) + | forallE + (sourceCheck : ConstructorCheckedExpr context source) + (domainCheck : ConstructorCheckedExpr context domain) + (consumedCheck : ConstructorCheckedExpr context + (consumeTypeAnnotations domain)) + (consumedLevel : Level) + (consumedInferred : consumedCheck.observation.inferred = + .sort consumedLevel) + (fresh : context.lctx.find? context.freshFVarId = none) + (annotations : CandidateIsDefEqObservation context domain + (consumeTypeAnnotations domain)) + (tailTrace : ConstructorPositivityTrace stats ctor argIdx + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) fuel) + (tail : ConstructorPositivityAlignmentTrace tailTrace) : + ConstructorPositivityAlignmentTrace + (.forallE context source fuel name domain body binderInfo whnfStep occurs + domainFree tailTrace) + | target + (sourceCheck : ConstructorCheckedExpr context source) : + ConstructorPositivityAlignmentTrace + (.target context source result fuel targetIdx whnfStep occurs terminal + valid) + +namespace ConstructorPositivityAlignmentTrace + +def build : + (positivityTrace : ConstructorPositivityTrace stats ctor argIdx context + source fuel) → + Except Exception (ConstructorPositivityAlignmentTrace positivityTrace) + | .absent context source result fuel whnfStep occurs => do + let sourceCheck ← checkConstructorAlignedExpr context source + pure <| .absent sourceCheck + | .forallE context source fuel name domain body binderInfo whnfStep occurs + domainFree tailTrace => do + let sourceCheck ← checkConstructorAlignedExpr context source + let domainCheck ← checkConstructorAlignedExpr context domain + let consumedCheck ← checkConstructorAlignedExpr context + (consumeTypeAnnotations domain) + match consumedInferred : consumedCheck.observation.inferred with + | .sort consumedLevel => + if fresh : context.lctx.find? context.freshFVarId = none then + let annotations ← observeCandidateIsDefEq context domain + (consumeTypeAnnotations domain) + let tail ← build tailTrace + pure <| .forallE sourceCheck domainCheck consumedCheck consumedLevel + consumedInferred fresh annotations tailTrace tail + else + throw <| .other "positivity traversal reused a local identifier" + | _ => + throw <| .other + "consumed positivity domain did not check as a type" + | .target context source result fuel targetIdx whnfStep occurs terminal + valid => do + let sourceCheck ← checkConstructorAlignedExpr context source + pure <| .target sourceCheck + +/-- Executable erasure of the retained positivity alignment. -/ +def check (positivityTrace : ConstructorPositivityTrace stats ctor argIdx + context source fuel) : M Unit := fun _ => + (ConstructorPositivityAlignmentTrace.build positivityTrace).map fun _ => () + +theorem nonempty_of_check + {positivityTrace : ConstructorPositivityTrace stats ctor argIdx context + source fuel} + (success : ConstructorPositivityAlignmentTrace.check positivityTrace + context = .ok ()) : + Nonempty (ConstructorPositivityAlignmentTrace positivityTrace) := by + unfold check at success + cases h : ConstructorPositivityAlignmentTrace.build positivityTrace with + | error error => + rw [h] at success + change Except.error error = Except.ok () at success + contradiction + | ok alignment => exact ⟨alignment⟩ + +end ConstructorPositivityAlignmentTrace + +inductive ConstructorPositivityModeAlignmentTrace : + {stats : InductiveStats} → {isUnsafe : Bool} → {ctor : Name} → + {argIdx : Nat} → {context : Context} → {source : Expr} → + ConstructorPositivityModeTrace stats isUnsafe ctor argIdx context source → + Type where + | skipped : ConstructorPositivityModeAlignmentTrace (.skipped unsafeEq) + | safe (alignment : ConstructorPositivityAlignmentTrace positivityTrace) : + ConstructorPositivityModeAlignmentTrace (.safe unsafeEq positivityTrace) + +namespace ConstructorPositivityModeAlignmentTrace + +def build : + (positivityTrace : ConstructorPositivityModeTrace stats isUnsafe ctor + argIdx context source) → + Except Exception + (ConstructorPositivityModeAlignmentTrace positivityTrace) + | .skipped unsafeEq => pure <| .skipped + | .safe unsafeEq positivityTrace => do + let alignment ← ConstructorPositivityAlignmentTrace.build + positivityTrace + pure <| .safe alignment + +def check (positivityTrace : ConstructorPositivityModeTrace stats isUnsafe + ctor argIdx context source) : M Unit := fun _ => + (ConstructorPositivityModeAlignmentTrace.build positivityTrace).map fun _ => () + +theorem nonempty_of_check + {positivityTrace : ConstructorPositivityModeTrace stats isUnsafe ctor + argIdx context source} + (success : ConstructorPositivityModeAlignmentTrace.check positivityTrace + context = .ok ()) : + Nonempty (ConstructorPositivityModeAlignmentTrace positivityTrace) := by + unfold check at success + cases h : ConstructorPositivityModeAlignmentTrace.build positivityTrace with + | error error => + rw [h] at success + change Except.error error = Except.ok () at success + contradiction + | ok alignment => exact ⟨alignment⟩ + +end ConstructorPositivityModeAlignmentTrace + +/-- Exact operational alignment between one retained validation telescope and +the analyzer-owned kernel view. The recursive indices instantiate the view +with validation-owned parameters and fields, so no equality between the +producer's and validator's fresh free-variable identifiers is assumed. -/ +inductive ConstructorViewAlignmentTrace : + {stats : InductiveStats} → {isUnsafe : Bool} → {familyIdx : Nat} → + {ctor : Name} → {context : Context} → {source : Expr} → + {argIdx fuel : Nat} → + ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor context + source argIdx fuel → + (view : Expr) → Type where + | parameter + (domainCheck : ConstructorCheckedExpr context domain) + (viewDomainCheck : ConstructorCheckedExpr context viewDomain) + (parameterTypeCheck : ConstructorCheckedExpr context parameterType) + (parameterShape : param = .fvar fv) + (parameterPresent : (context.lctx.find? fv).isSome = true) + (tailTrace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context (body.instantiate1 param) (argIdx + 1) fuel) + (tail : ConstructorViewAlignmentTrace tailTrace + (viewBody.instantiate1 param)) : + ConstructorViewAlignmentTrace + (.parameter context fuel argIdx name domain body binderInfo param + parameterType parameterAt parameterTypeRun validationDefEq tailTrace) + (.forallE viewName viewDomain viewBody viewBinderInfo) + | ordinary + (domainCheck : ConstructorCheckedExpr context domain) + (viewDomainCheck : ConstructorCheckedExpr context viewDomain) + (viewEquality : CandidateIsDefEqObservation context domain viewDomain) + (consumedCheck : ConstructorCheckedExpr context + (consumeTypeAnnotations domain)) + (positivityTrace : ConstructorPositivityModeTrace stats isUnsafe ctor + argIdx context domain) + (positivityAlignment : + ConstructorPositivityModeAlignmentTrace positivityTrace) + (fresh : context.lctx.find? context.freshFVarId = none) + (annotations : CandidateIsDefEqObservation context domain + (consumeTypeAnnotations domain)) + (tailTrace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) fuel) + (tail : ConstructorViewAlignmentTrace tailTrace + (viewBody.instantiate1 context.freshExpr)) : + ConstructorViewAlignmentTrace + (.ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureTypeStep universeTrace positivityTrace tailTrace) + (.forallE viewName viewDomain viewBody viewBinderInfo) + | terminal + (sourceCheck : ConstructorCheckedExpr context source) + (viewCheck : ConstructorCheckedExpr context view) + (viewTerminal : view.isForall = false) + (viewValid : isValidIndAppIdx stats view familyIdx = true) : + ConstructorViewAlignmentTrace + (.terminal context source fuel argIdx sourceTerminal sourceValid) view + +namespace ConstructorViewAlignmentTrace + +/-- Execute the exact component audit and retain every successful checker +observation. This is intentionally not a second `checkConstructors` run: the +raw branch shape, parameter selection, universe decision, positivity target, +and raw terminal acceptance remain owned by the ordinary validation trace. -/ +def build : + (validationTrace : ConstructorTypeValidationTrace stats isUnsafe familyIdx + ctor context source argIdx fuel) → + (view : Expr) → + Except Exception (ConstructorViewAlignmentTrace validationTrace view) + | .parameter context parameterFuel parameterArgIdx parameterName domain + parameterBody parameterBinderInfo param parameterType parameterAt + parameterTypeRun validationDefEq tailTrace, + .forallE viewName viewDomain viewBody viewBinderInfo => do + let domainCheck ← checkConstructorAlignedExpr context domain + let viewDomainCheck ← checkConstructorAlignedExpr context viewDomain + let parameterTypeCheck ← checkConstructorAlignedExpr context + parameterType + match param with + | .fvar fv => + if parameterPresent : (context.lctx.find? fv).isSome = true then + let tail ← build tailTrace + (viewBody.instantiate1 (.fvar fv)) + pure <| .parameter domainCheck viewDomainCheck parameterTypeCheck + rfl parameterPresent tailTrace tail + else + throw <| .other + "constructor parameter is absent from validation context" + | _ => + throw <| .other "constructor parameter is not a local variable" + | .parameter .., _ => + throw <| .other "candidate and validation constructor telescopes differ" + | .ordinary context ordinaryFuel ordinaryArgIdx name domain body binderInfo + sortResult noParameter ensureType universeTrace positivityTrace tailTrace, + .forallE viewName viewDomain viewBody viewBinderInfo => do + let domainCheck ← checkConstructorAlignedExpr context domain + let viewDomainCheck ← checkConstructorAlignedExpr context viewDomain + let viewEquality ← observeCandidateIsDefEq context domain viewDomain + let consumedCheck ← checkConstructorAlignedExpr context + (consumeTypeAnnotations domain) + let positivityAlignment ← + ConstructorPositivityModeAlignmentTrace.build positivityTrace + if fresh : context.lctx.find? context.freshFVarId = none then + let annotations ← observeCandidateIsDefEq context domain + (consumeTypeAnnotations domain) + let tail ← build tailTrace + (viewBody.instantiate1 context.freshExpr) + pure <| .ordinary domainCheck viewDomainCheck viewEquality consumedCheck + positivityTrace positivityAlignment fresh annotations tailTrace tail + else + throw <| .other "constructor validation reused a local identifier" + | .ordinary .., _ => + throw <| .other "candidate and validation constructor telescopes differ" + | .terminal context source fuel argIdx sourceTerminal sourceValid, view => do + let sourceCheck ← checkConstructorAlignedExpr context source + let viewCheck ← checkConstructorAlignedExpr context view + if viewTerminal : view.isForall = false then + if viewValid : isValidIndAppIdx stats view familyIdx = true then + pure <| .terminal sourceCheck viewCheck viewTerminal viewValid + else + throw <| .other + "candidate view changed the terminal family application" + else + throw <| .other "candidate view has an extra constructor field" + +def check (validationTrace : ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) (view : Expr) : M Unit := + fun _ => (build validationTrace view).map fun _ => () + +theorem nonempty_of_check + {validationTrace : ConstructorTypeValidationTrace stats isUnsafe familyIdx + ctor context source argIdx fuel} + (success : check validationTrace view context = .ok ()) : + Nonempty (ConstructorViewAlignmentTrace validationTrace view) := by + unfold check at success + cases h : build validationTrace view with + | error error => + rw [h] at success + change Except.error error = Except.ok () at success + contradiction + | ok alignment => exact ⟨alignment⟩ + +end ConstructorViewAlignmentTrace + +/-- Supplemental checker audit for the exact analyzer-owned view of one +constructor. It follows the validation telescope and instantiates the view +with validation-owned locals; successful execution retains no rewritten +declaration and claims no independent view acceptance. -/ +def ConstructorTypeValidationTrace.checkViewAlignment + (trace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx fuel) (view : Expr) : M Unit := + ConstructorViewAlignmentTrace.check trace view + +/-- Source-ordered retained alignment for the complete constructor list. +The source indices make omission, duplication, and reordering unrepresentable. +Each node also retains the closed-root scope check needed to interpret the +validator's original empty-local-context `checkType` observation. -/ +inductive ConstructorCandidateAlignmentTrace + (stats : InductiveStats) (isUnsafe : Bool) (familyIdx : Nat) + (context : Context) : + {seen : NameSet} → {constructors : List Constructor} → + (validationTrace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors) → + AddInductive.CandidateList AddInductive.CandidateConstructor constructors → + Type where + | nil (seen : NameSet) : + ConstructorCandidateAlignmentTrace stats isUnsafe familyIdx context + (.nil seen) .nil + | cons + {seen : NameSet} {head : Constructor} {tail : List Constructor} + {fresh : seen.contains head.name = false} + {closed : context.env.checkNoMVarNoFVar head.name head.type = .ok ()} + {rootCheck : CandidateCheckTypeObservation + context.withEmptyLocalContext head.type} + {typeTrace : ConstructorTypeValidationTrace stats isUnsafe familyIdx + head.name context head.type 0 context.fuel.inductiveFuel} + {tailTrace : ConstructorListValidationTrace stats isUnsafe familyIdx + context (seen.insert head.name) tail} + {candidate : AddInductive.CandidateConstructor head} + {candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor tail} + (rootScope : ConstructorCheckedExpr context.withEmptyLocalContext + head.type) + (storedSpine : candidate.type.trace.storedSpine = true) + (spineLength : candidate.type.trace.spineLength = + typeTrace.spineLength) + (candidateDepth : candidate.type.context.fuel.recDepth = + context.fuel.recDepth) + (headAlignment : ConstructorViewAlignmentTrace typeTrace + candidate.type.view) + (tailAlignment : ConstructorCandidateAlignmentTrace stats isUnsafe + familyIdx context tailTrace candidates) : + ConstructorCandidateAlignmentTrace stats isUnsafe familyIdx context + (.cons seen head tail fresh closed rootCheck typeTrace tailTrace) + (.cons candidate candidates) + +namespace ConstructorCandidateAlignmentTrace + +/-- Execute the source-ordered constructor alignment and retain all successful +component checks. The candidate list's dependent source index selects the +same constructor at every recursive position as the validation trace. -/ +def build : + (validationTrace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors) → + (candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors) → + Except Exception + (ConstructorCandidateAlignmentTrace stats isUnsafe familyIdx context + validationTrace candidates) + | .nil seen, .nil => pure <| .nil seen + | .cons seen head tail fresh closed rootCheck typeTrace tailTrace, + .cons candidate candidates => do + let rootScope ← checkConstructorAlignedExpr + context.withEmptyLocalContext head.type + if storedSpine : candidate.type.trace.storedSpine = true then + if spineLength : candidate.type.trace.spineLength = + typeTrace.spineLength then + if candidateDepth : candidate.type.context.fuel.recDepth = + context.fuel.recDepth then + let headAlignment ← ConstructorViewAlignmentTrace.build typeTrace + candidate.type.view + let tailAlignment ← build tailTrace candidates + pure <| .cons rootScope storedSpine spineLength candidateDepth + headAlignment tailAlignment + else + throw <| .other + "candidate and validation checker depths differ" + else + throw <| .other + "candidate and validation constructor lengths differ" + else + throw <| .other + "candidate constructor did not preserve its stored spine" + +def check + (validationTrace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors) + (candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors) : M Unit := + fun _ => (build validationTrace candidates).map fun _ => () + +theorem nonempty_of_check + {validationTrace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors} + {candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors} + (success : check validationTrace candidates context = .ok ()) : + Nonempty (ConstructorCandidateAlignmentTrace stats isUnsafe familyIdx + context validationTrace candidates) := 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⟩ + +end ConstructorCandidateAlignmentTrace + +/-- Source-ordered supplemental alignment audit for every exact constructor +candidate selected by the producer. The dependent list indices rule out +truncation, reordering, duplication, or a view from another source position. +The Boolean gates additionally pin the candidate main-spine length to the +retained validation telescope. -/ +def ConstructorListValidationTrace.checkCandidateAlignment + (trace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors) + (candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors) : M Unit := + ConstructorCandidateAlignmentTrace.check trace candidates + +/-! +## Verified interpretation of the aligned validation telescope + +The following semantic traces contain only executions refined by the verified +checker. Their indices still carry the ordinary validator's branch choices +and exact candidate view, while `ConstructorContextRun` fixes every recursive +local context to the actual post-family Theory environment. +-/ + +/-- Verified interpretation of every exact WHNF and nested binder visited by +one retained positivity traversal. -/ +inductive ConstructorPositivitySemanticRun + (env : VEnv) (Us : List Name) (whnfFuel : Nat) : + {stats : InductiveStats} → {ctor : Name} → {argIdx : Nat} → + {context : Context} → {source : Expr} → {fuel : Nat} → + (contextRun : ConstructorContextRun env Us context) → + ConstructorPositivityTrace stats ctor argIdx context source fuel → Type where + | absent + {stats : InductiveStats} {ctor : Name} {argIdx : Nat} + {context : Context} {source result : Expr} {fuel : Nat} + {whnfStep : CandidateWhnfStep.Valid ⟨context, source, result⟩} + {occurs : hasIndOcc stats.indConsts result = false} + {sourceCheck : ConstructorCheckedExpr context source} + {contextRun : ConstructorContextRun env Us context} + (depth : context.fuel.recDepth = whnfFuel + 1) + (sourceRun : ConstructorCheckedExpr.Run sourceCheck + contextRun.candidate) + (whnfRun : ConstructorWhnfRun contextRun.candidate sourceRun result) : + ConstructorPositivitySemanticRun env Us whnfFuel contextRun + (.absent context source result fuel whnfStep occurs) + | forallE + {stats : InductiveStats} {ctor : Name} {argIdx : Nat} + {context : Context} {source : Expr} {fuel : Nat} + {name : Name} {domain body : Expr} {binderInfo : BinderInfo} + {whnfStep : CandidateWhnfStep.Valid + ⟨context, source, .forallE name domain body binderInfo⟩} + {occurs : hasIndOcc stats.indConsts + (.forallE name domain body binderInfo) = true} + {domainFree : hasIndOcc stats.indConsts domain = false} + {tailTrace : ConstructorPositivityTrace stats ctor argIdx + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) fuel} + {sourceCheck : ConstructorCheckedExpr context source} + {domainCheck : ConstructorCheckedExpr context domain} + {consumedCheck : ConstructorCheckedExpr context + (consumeTypeAnnotations domain)} + {consumedLevel : Level} + {consumedInferred : consumedCheck.observation.inferred = + .sort consumedLevel} + {fresh : context.lctx.find? context.freshFVarId = none} + {contextRun : ConstructorContextRun env Us context} + (depth : context.fuel.recDepth = whnfFuel + 1) + (sourceRun : ConstructorCheckedExpr.Run sourceCheck + contextRun.candidate) + (whnfRun : ConstructorWhnfRun contextRun.candidate sourceRun + (.forallE name domain body binderInfo)) + (domainRun : ConstructorCheckedExpr.Run domainCheck + contextRun.candidate) + (consumedRun : ConstructorCheckedExpr.Run consumedCheck + contextRun.candidate) + (annotationsRun : TypeChecker.IsDefEqRun + contextRun.candidate.context.venv + contextRun.candidate.context.lparams + contextRun.candidate.context.vlctx domain + (consumeTypeAnnotations domain) domainRun.source' + consumedRun.source') + (consumedType : contextRun.candidate.context.IsType + consumedRun.source') + (tail : ConstructorPositivitySemanticRun env Us whnfFuel + (contextRun.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain) fresh consumedRun.source' + consumedRun.check.expr_tr consumedType) + tailTrace) : + ConstructorPositivitySemanticRun env Us whnfFuel contextRun + (.forallE context source fuel name domain body binderInfo whnfStep + occurs domainFree tailTrace) + | target + {stats : InductiveStats} {ctor : Name} {argIdx : Nat} + {context : Context} {source result : Expr} {fuel targetIdx : Nat} + {whnfStep : CandidateWhnfStep.Valid ⟨context, source, result⟩} + {occurs : hasIndOcc stats.indConsts result = true} + {terminal : result.isForall = false} + {valid : isValidIndApp? stats result = some targetIdx} + {sourceCheck : ConstructorCheckedExpr context source} + {contextRun : ConstructorContextRun env Us context} + (depth : context.fuel.recDepth = whnfFuel + 1) + (sourceRun : ConstructorCheckedExpr.Run sourceCheck + contextRun.candidate) + (whnfRun : ConstructorWhnfRun contextRun.candidate sourceRun result) : + ConstructorPositivitySemanticRun env Us whnfFuel contextRun + (.target context source result fuel targetIdx whnfStep occurs terminal + valid) + +namespace ConstructorPositivitySemanticRun + +theorem nonempty_of_alignment + (contextRun : ConstructorContextRun env Us context) + (depth : context.fuel.recDepth = whnfFuel + 1) + {trace : ConstructorPositivityTrace stats ctor argIdx context source fuel} + (alignment : ConstructorPositivityAlignmentTrace trace) : + Nonempty (ConstructorPositivitySemanticRun env Us whnfFuel contextRun + trace) := by + induction trace with + | absent context source result fuel whnfStep occurs => + cases alignment with + | absent sourceCheck => + obtain ⟨sourceRun⟩ := + ConstructorCheckedExpr.Run.exists sourceCheck contextRun.candidate + obtain ⟨whnfRun⟩ := ConstructorWhnfRun.exists + contextRun.candidate sourceRun whnfStep whnfFuel depth + exact ⟨ConstructorPositivitySemanticRun.absent + (stats := stats) (ctor := ctor) (argIdx := argIdx) + depth sourceRun whnfRun⟩ + | forallE context source fuel name domain body binderInfo whnfStep occurs + domainFree tailTrace ih => + cases alignment with + | forallE sourceCheck domainCheck consumedCheck consumedLevel + consumedInferred fresh annotations _ tailAlignment => + obtain ⟨sourceRun⟩ := + ConstructorCheckedExpr.Run.exists sourceCheck contextRun.candidate + obtain ⟨whnfRun⟩ := ConstructorWhnfRun.exists + contextRun.candidate sourceRun whnfStep whnfFuel depth + obtain ⟨domainRun⟩ := + ConstructorCheckedExpr.Run.exists domainCheck contextRun.candidate + obtain ⟨consumedRun⟩ := + ConstructorCheckedExpr.Run.exists consumedCheck + contextRun.candidate + let annotationsRun := domainRun.isDefEq consumedRun annotations + have consumedType : contextRun.candidate.context.IsType + consumedRun.source' := + consumedRun.isType_of_inferredSort consumedInferred + let tailContext := contextRun.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain) fresh consumedRun.source' + consumedRun.check.expr_tr consumedType + have tailDepth : + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)).fuel.recDepth = + whnfFuel + 1 := by + simpa [AddInductive.Context.pushLocalDecl] using depth + obtain ⟨tail⟩ := ih tailContext tailDepth tailAlignment + exact ⟨ConstructorPositivitySemanticRun.forallE + (stats := stats) (ctor := ctor) (argIdx := argIdx) + (consumedLevel := consumedLevel) + (consumedInferred := consumedInferred) + depth sourceRun whnfRun domainRun consumedRun annotationsRun + consumedType tail⟩ + | target context source result fuel targetIdx whnfStep occurs terminal valid => + cases alignment with + | target sourceCheck => + obtain ⟨sourceRun⟩ := + ConstructorCheckedExpr.Run.exists sourceCheck contextRun.candidate + obtain ⟨whnfRun⟩ := ConstructorWhnfRun.exists + contextRun.candidate sourceRun whnfStep whnfFuel depth + exact ⟨ConstructorPositivitySemanticRun.target + (stats := stats) (ctor := ctor) (argIdx := argIdx) + depth sourceRun whnfRun⟩ + +end ConstructorPositivitySemanticRun + +/-- Verified meaning of the exact safe/unsafe positivity branch retained by +ordinary constructor validation. -/ +inductive ConstructorPositivityModeSemanticRun + (env : VEnv) (Us : List Name) (whnfFuel : Nat) : + {stats : InductiveStats} → {isUnsafe : Bool} → {ctor : Name} → + {argIdx : Nat} → {context : Context} → {source : Expr} → + (contextRun : ConstructorContextRun env Us context) → + ConstructorPositivityModeTrace stats isUnsafe ctor argIdx context source → + Type where + | skipped : + {stats : InductiveStats} → {isUnsafe : Bool} → {ctor : Name} → + {argIdx : Nat} → {context : Context} → {source : Expr} → + {unsafeEq : isUnsafe = true} → + {contextRun : ConstructorContextRun env Us context} → + ConstructorPositivityModeSemanticRun env Us whnfFuel contextRun + (@ConstructorPositivityModeTrace.skipped stats isUnsafe ctor argIdx + context source unsafeEq) + | safe + {stats : InductiveStats} {isUnsafe : Bool} {ctor : Name} + {argIdx : Nat} {context : Context} {source : Expr} + {unsafeEq : isUnsafe = false} + {positivityTrace : ConstructorPositivityTrace stats ctor argIdx context + source context.fuel.inductiveFuel} + {contextRun : ConstructorContextRun env Us context} + (semantic : ConstructorPositivitySemanticRun env Us whnfFuel contextRun + positivityTrace) : + ConstructorPositivityModeSemanticRun env Us whnfFuel contextRun + (@ConstructorPositivityModeTrace.safe stats isUnsafe ctor argIdx + context source unsafeEq positivityTrace) + +namespace ConstructorPositivityModeSemanticRun + +theorem nonempty_of_alignment + (contextRun : ConstructorContextRun env Us context) + (depth : context.fuel.recDepth = whnfFuel + 1) + {trace : ConstructorPositivityModeTrace stats isUnsafe ctor argIdx + context source} + (alignment : ConstructorPositivityModeAlignmentTrace trace) : + Nonempty (ConstructorPositivityModeSemanticRun env Us whnfFuel contextRun + trace) := by + cases alignment with + | @skipped unsafeEq => + exact ⟨ConstructorPositivityModeSemanticRun.skipped + (env := env) (Us := Us) (whnfFuel := whnfFuel) + (stats := stats) (isUnsafe := isUnsafe) (ctor := ctor) + (argIdx := argIdx) (context := context) (source := source) + (unsafeEq := unsafeEq) (contextRun := contextRun)⟩ + | safe positivityAlignment => + obtain ⟨semantic⟩ := + ConstructorPositivitySemanticRun.nonempty_of_alignment contextRun depth + positivityAlignment + exact ⟨.safe semantic⟩ + +end ConstructorPositivityModeSemanticRun + +/-- Verified, componentwise interpretation of one aligned constructor +telescope. The view is followed at validation-owned parameter and field +locals; no equality between candidate and validator fresh identifiers is +required or asserted. -/ +inductive ConstructorViewSemanticRun + (env : VEnv) (Us : List Name) (whnfFuel : Nat) : + {stats : InductiveStats} → {isUnsafe : Bool} → {familyIdx : Nat} → + {ctor : Name} → {context : Context} → {source : Expr} → + {argIdx fuel : Nat} → + (contextRun : ConstructorContextRun env Us context) → + ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor context + source argIdx fuel → + (view : Expr) → Type where + | parameter + {stats : InductiveStats} {isUnsafe : Bool} {familyIdx : Nat} + {ctor : Name} {context : Context} {fuel argIdx : Nat} + {name : Name} {domain body : Expr} {binderInfo : BinderInfo} + {param parameterType : Expr} + {parameterAt : stats.params[argIdx]? = some param} + {parameterTypeGet : getType param context = .ok parameterType} + {validationDefEq : CandidateIsDefEqStep.Valid + ⟨context, domain, parameterType⟩} + {tailTrace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context (body.instantiate1 param) (argIdx + 1) fuel} + {viewName : Name} {viewDomain viewBody : Expr} + {viewBinderInfo : BinderInfo} + {domainCheck : ConstructorCheckedExpr context domain} + {viewDomainCheck : ConstructorCheckedExpr context viewDomain} + {parameterTypeCheck : ConstructorCheckedExpr context parameterType} + {contextRun : ConstructorContextRun env Us context} + (domainRun : ConstructorCheckedExpr.Run domainCheck + contextRun.candidate) + (viewDomainRun : ConstructorCheckedExpr.Run viewDomainCheck + contextRun.candidate) + (parameterTypeSemantic : ConstructorCheckedExpr.Run parameterTypeCheck + contextRun.candidate) + (validationRun : TypeChecker.IsDefEqRun + contextRun.candidate.context.venv + contextRun.candidate.context.lparams + contextRun.candidate.context.vlctx domain parameterType + domainRun.source' parameterTypeSemantic.source') + (tail : ConstructorViewSemanticRun env Us whnfFuel contextRun tailTrace + (viewBody.instantiate1 param)) : + ConstructorViewSemanticRun env Us whnfFuel contextRun + (.parameter context fuel argIdx name domain body binderInfo param + parameterType parameterAt parameterTypeGet validationDefEq tailTrace) + (.forallE viewName viewDomain viewBody viewBinderInfo) + | ordinary + {stats : InductiveStats} {isUnsafe : Bool} {familyIdx : Nat} + {ctor : Name} {context : Context} {fuel argIdx : Nat} + {name : Name} {domain body : Expr} {binderInfo : BinderInfo} + {sortResult : Expr} {noParameter : stats.params[argIdx]? = none} + {ensureTypeStep : ConstructorEnsureTypeStep.Valid + ⟨context, domain, sortResult⟩} + {universeTrace : ConstructorUniverseTrace stats.resultLevel + sortResult.sortLevel!} + {positivityTrace : ConstructorPositivityModeTrace stats isUnsafe ctor + argIdx context domain} + {tailTrace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) fuel} + {viewName : Name} {viewDomain viewBody : Expr} + {viewBinderInfo : BinderInfo} + {domainCheck : ConstructorCheckedExpr context domain} + {viewDomainCheck : ConstructorCheckedExpr context viewDomain} + {viewEquality : CandidateIsDefEqObservation context domain viewDomain} + {consumedCheck : ConstructorCheckedExpr context + (consumeTypeAnnotations domain)} + {fresh : context.lctx.find? context.freshFVarId = none} + {contextRun : ConstructorContextRun env Us context} + (domainRun : ConstructorCheckedExpr.Run domainCheck + contextRun.candidate) + (viewDomainRun : ConstructorCheckedExpr.Run viewDomainCheck + contextRun.candidate) + (viewEqualityRun : TypeChecker.IsDefEqRun + contextRun.candidate.context.venv + contextRun.candidate.context.lparams + contextRun.candidate.context.vlctx domain viewDomain + domainRun.source' viewDomainRun.source') + (consumedRun : ConstructorCheckedExpr.Run consumedCheck + contextRun.candidate) + (ensureTypeRun : TypeChecker.EnsureTypeRun + contextRun.candidate.context.venv + contextRun.candidate.context.lparams + contextRun.candidate.context.vlctx domain sortResult + domainRun.source') + (positivity : ConstructorPositivityModeSemanticRun env Us whnfFuel + contextRun positivityTrace) + (annotationsRun : TypeChecker.IsDefEqRun + contextRun.candidate.context.venv + contextRun.candidate.context.lparams + contextRun.candidate.context.vlctx domain + (consumeTypeAnnotations domain) domainRun.source' + consumedRun.source') + (consumedType : contextRun.candidate.context.IsType + consumedRun.source') + (tail : ConstructorViewSemanticRun env Us whnfFuel + (contextRun.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain) fresh consumedRun.source' + consumedRun.check.expr_tr consumedType) + tailTrace (viewBody.instantiate1 context.freshExpr)) : + ConstructorViewSemanticRun env Us whnfFuel contextRun + (.ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureTypeStep universeTrace positivityTrace tailTrace) + (.forallE viewName viewDomain viewBody viewBinderInfo) + | terminal + {stats : InductiveStats} {isUnsafe : Bool} {familyIdx : Nat} + {ctor : Name} {context : Context} {source view : Expr} + {fuel argIdx : Nat} {sourceTerminal : source.isForall = false} + {sourceValid : isValidIndAppIdx stats source familyIdx = true} + {sourceCheck : ConstructorCheckedExpr context source} + {viewCheck : ConstructorCheckedExpr context view} + {contextRun : ConstructorContextRun env Us context} + (sourceRun : ConstructorCheckedExpr.Run sourceCheck + contextRun.candidate) + (viewRun : ConstructorCheckedExpr.Run viewCheck contextRun.candidate) : + ConstructorViewSemanticRun env Us whnfFuel contextRun + (.terminal context source fuel argIdx sourceTerminal sourceValid) view + +namespace ConstructorViewSemanticRun + +theorem nonempty_of_alignment + (contextRun : ConstructorContextRun env Us context) + (depth : context.fuel.recDepth = whnfFuel + 1) + {validationTrace : ConstructorTypeValidationTrace stats isUnsafe familyIdx + ctor context source argIdx fuel} + {view : Expr} + (alignment : ConstructorViewAlignmentTrace validationTrace view) : + Nonempty (ConstructorViewSemanticRun env Us whnfFuel contextRun + validationTrace view) := by + induction validationTrace generalizing view with + | parameter context fuel argIdx name domain body binderInfo param + parameterType parameterAt parameterTypeGet validationDefEq tailTrace ih => + cases alignment with + | parameter domainCheck viewDomainCheck parameterTypeCheck + parameterShape parameterPresent _ tailAlignment => + obtain ⟨domainRun⟩ := + ConstructorCheckedExpr.Run.exists domainCheck contextRun.candidate + obtain ⟨viewDomainRun⟩ := + ConstructorCheckedExpr.Run.exists viewDomainCheck + contextRun.candidate + obtain ⟨parameterTypeSemantic⟩ := + ConstructorCheckedExpr.Run.exists parameterTypeCheck + contextRun.candidate + let validationRun := TypeChecker.IsDefEqRun.ofCandidateStep + ⟨context, domain, parameterType⟩ validationDefEq + contextRun.candidate.context contextRun.candidate.context_eq + rfl rfl rfl contextRun.candidate.state_wf + domainRun.check.expr_tr parameterTypeSemantic.check.expr_tr + context.fuel.recDepth rfl + obtain ⟨tail⟩ := ih contextRun depth tailAlignment + exact ⟨ConstructorViewSemanticRun.parameter + domainRun viewDomainRun parameterTypeSemantic validationRun tail⟩ + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureTypeStep universeTrace positivityTrace tailTrace ih => + cases alignment with + | ordinary domainCheck viewDomainCheck viewEquality consumedCheck _ + positivityAlignment fresh annotations _ tailAlignment => + obtain ⟨domainRun⟩ := + ConstructorCheckedExpr.Run.exists domainCheck contextRun.candidate + obtain ⟨viewDomainRun⟩ := + ConstructorCheckedExpr.Run.exists viewDomainCheck + contextRun.candidate + let viewEqualityRun := domainRun.isDefEq viewDomainRun viewEquality + obtain ⟨consumedRun⟩ := + ConstructorCheckedExpr.Run.exists consumedCheck + contextRun.candidate + obtain ⟨ensureTypeRun⟩ := + TypeChecker.EnsureTypeRun.exists_ofConstructorStep + ⟨context, domain, sortResult⟩ ensureTypeStep + contextRun.candidate domainRun.source' domainRun.check.expr_tr + obtain ⟨positivity⟩ := + ConstructorPositivityModeSemanticRun.nonempty_of_alignment + contextRun depth positivityAlignment + let annotationsRun := domainRun.isDefEq consumedRun annotations + have consumedType : contextRun.candidate.context.IsType + consumedRun.source' := by + have annotationDef := annotationsRun.isDefEqU.of_l + contextRun.candidate.context.Ewf + contextRun.candidate.context.Δwf.toCtx + ensureTypeRun.source_type + exact ⟨ensureTypeRun.resultLevel', annotationDef.hasType.2⟩ + let tailContext := contextRun.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain) fresh consumedRun.source' + consumedRun.check.expr_tr consumedType + have tailDepth : + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)).fuel.recDepth = + whnfFuel + 1 := by + simpa [AddInductive.Context.pushLocalDecl] using depth + obtain ⟨tail⟩ := ih tailContext tailDepth tailAlignment + exact ⟨ConstructorViewSemanticRun.ordinary + (viewEquality := viewEquality) + domainRun viewDomainRun viewEqualityRun consumedRun ensureTypeRun + positivity annotationsRun consumedType tail⟩ + | terminal context source fuel argIdx sourceTerminal sourceValid => + cases alignment with + | terminal sourceCheck viewCheck viewTerminal viewValid => + obtain ⟨sourceRun⟩ := + ConstructorCheckedExpr.Run.exists sourceCheck contextRun.candidate + obtain ⟨viewRun⟩ := + ConstructorCheckedExpr.Run.exists viewCheck contextRun.candidate + exact ⟨ConstructorViewSemanticRun.terminal + (stats := stats) (isUnsafe := isUnsafe) + (familyIdx := familyIdx) (ctor := ctor) + sourceRun viewRun⟩ + +end ConstructorViewSemanticRun + +/-! +## Source-ordered post-family constructor semantics + +The alignment trace connects the validator's exact source telescope to the +analyzer-owned candidate view. The semantic list below interprets that trace +alongside the already-produced constructor semantic hierarchy. Its indices +keep source order, raw constructor order, and the exact candidate view fixed; +its payload retains both validation-local checks and Theory telescope/result +evidence selected by the candidate's recursive checker run. +-/ + +/-- Complete post-family meaning for every constructor position selected by +one exact validation/candidate alignment. + +`root` interprets the validator-owned root `checkType` observation (the +supplemental audit contributes only its scope proof). `telescope` interprets +parameter equality, ordinary-field typing, positivity, and the terminal +family application while following the exact candidate view at +validation-owned locals. `spine` exposes the exact Theory view binders and +terminal result selected by the candidate semantic root. -/ +inductive ConstructorPostFamilySemanticListRun + (env : VEnv) (Us : List Name) + (stats : InductiveStats) (isUnsafe : Bool) (familyIdx : Nat) + (context : Context) (contextRun : ConstructorContextRun env Us context) : + {seen : NameSet} → {constructors : List Constructor} → + (validationTrace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors) → + (candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors) → + {raws : List VConstVal} → + ConstructorCandidateAlignmentTrace stats isUnsafe familyIdx context + validationTrace candidates → + VInductDecl.CandidateConstructorSemanticListRun env Us candidates raws → + Type where + | nil (seen : NameSet) : + ConstructorPostFamilySemanticListRun env Us stats isUnsafe familyIdx + context contextRun (.nil seen) .nil (.nil seen) .nil + | cons + {seen : NameSet} {head : Constructor} {tail : List Constructor} + {freshName : seen.contains head.name = false} + {closed : context.env.checkNoMVarNoFVar head.name head.type = .ok ()} + {rootCheck : CandidateCheckTypeObservation + context.withEmptyLocalContext head.type} + {typeTrace : ConstructorTypeValidationTrace stats isUnsafe familyIdx + head.name context head.type 0 context.fuel.inductiveFuel} + {tailTrace : ConstructorListValidationTrace stats isUnsafe familyIdx + context (seen.insert head.name) tail} + {candidate : AddInductive.CandidateConstructor head} + {candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor tail} + {raw : VConstVal} {raws : List VConstVal} + {rootScope : ConstructorCheckedExpr context.withEmptyLocalContext + head.type} + {storedSpine : candidate.type.trace.storedSpine = true} + {spineLength : candidate.type.trace.spineLength = + typeTrace.spineLength} + {candidateDepth : candidate.type.context.fuel.recDepth = + context.fuel.recDepth} + {headAlignment : ConstructorViewAlignmentTrace typeTrace + candidate.type.view} + {tailAlignment : ConstructorCandidateAlignmentTrace stats isUnsafe + familyIdx context tailTrace candidates} + {headSemantic : VInductDecl.CandidateConstructorSemanticRun env Us + candidate raw} + {tailSemantic : VInductDecl.CandidateConstructorSemanticListRun env Us + candidates raws} + (root : ConstructorCheckedExpr.Run + (rootScope.withObservation rootCheck) + contextRun.withEmptyLocalContext.candidate) + (telescope : ConstructorViewSemanticRun env Us + headSemantic.type.whnfFuel contextRun typeTrace candidate.type.view) + (spine : ∃ resultType, + TypeChecker.TelResultDefEqEvidence env Us.length [] + (VExpr.telN candidate.type.trace.spineLength raw.type) + (VExpr.telN candidate.type.trace.spineLength + headSemantic.type.view) + (VExpr.dropN candidate.type.trace.spineLength raw.type) + (VExpr.dropN candidate.type.trace.spineLength + headSemantic.type.view) + resultType) + (tailRun : ConstructorPostFamilySemanticListRun env Us stats isUnsafe + familyIdx context contextRun tailTrace candidates + tailAlignment tailSemantic) : + ConstructorPostFamilySemanticListRun env Us stats isUnsafe familyIdx + context contextRun + (.cons seen head tail freshName closed rootCheck typeTrace tailTrace) + (.cons candidate candidates) + (.cons rootScope storedSpine spineLength candidateDepth headAlignment + tailAlignment) + (.cons headSemantic tailSemantic) + +namespace ConstructorPostFamilySemanticListRun + +/-- Interpret an exact source-ordered alignment together with the exact +candidate semantic list produced for the same raw constructor positions. -/ +theorem nonempty_of_alignment + (contextRun : ConstructorContextRun env Us context) + {validationTrace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors} + {candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors} + {raws : List VConstVal} + (alignment : ConstructorCandidateAlignmentTrace stats isUnsafe familyIdx + context validationTrace candidates) + (semantics : VInductDecl.CandidateConstructorSemanticListRun env Us + candidates raws) : + Nonempty (ConstructorPostFamilySemanticListRun env Us stats isUnsafe + familyIdx context contextRun validationTrace candidates alignment + semantics) := by + induction alignment generalizing raws with + | nil seen => + cases semantics + exact ⟨.nil seen⟩ + | @cons seen head tail freshName closed rootCheck typeTrace tailTrace + candidate candidates rootScope storedSpine spineLength candidateDepth + headAlignment tailAlignment ih => + cases semantics with + | cons headSemantic tailSemantic => + obtain ⟨root⟩ := ConstructorCheckedExpr.Run.exists + (rootScope.withObservation rootCheck) + contextRun.withEmptyLocalContext.candidate + have depth : context.fuel.recDepth = + headSemantic.type.whnfFuel + 1 := by + calc + context.fuel.recDepth = + candidate.type.context.fuel.recDepth := candidateDepth.symm + _ = headSemantic.type.whnfFuel + 1 := + headSemantic.type.whnfDepth + obtain ⟨telescope⟩ := + ConstructorViewSemanticRun.nonempty_of_alignment contextRun depth + headAlignment + have spine := TypeChecker.CandidateExprSpineRun.evidence + (headSemantic.type.spine storedSpine) + obtain ⟨tailRun⟩ := ih tailSemantic + exact ⟨.cons root telescope spine tailRun⟩ + +end ConstructorPostFamilySemanticListRun + +/-- A retained constructor telescope whose strengthened universe decisions are +all true replays the exact executable universe traversal. This is the +converse of `universeSemantics_of_loop`: the trace supplies the same parameter +choices and `ensureType` results, while the Boolean supplies only the +additional verified comparison at ordinary fields. -/ +theorem ConstructorTypeValidationTrace.universeLoop_of_semantics + (trace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx fuel) + (semantic : trace.universeSemantics = true) : + checkConstructorUniverseSemantics.loop stats source argIdx fuel context = + .ok () := by + induction trace with + | parameter context fuel argIdx name domain body binderInfo parameter + parameterType parameterAt parameterTypeRun defeq tail ih => + simp only [universeSemantics] at semantic + rw [show fuel + 1 = Nat.succ fuel by rfl] + rw [checkConstructorUniverseSemantics.loop.eq_2] + rw [parameterAt] + exact ih semantic + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity tail ih => + simp only [universeSemantics, Bool.and_eq_true] at semantic + rw [show fuel + 1 = Nat.succ fuel by rfl] + rw [checkConstructorUniverseSemantics.loop.eq_2] + rw [noParameter] + simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply] + rw [ensureType] + simp only [Except.bind] + have valid : constructorUniverseSemanticGe stats.resultLevel + sortResult.sortLevel! = true := by + simpa only [ConstructorUniverseTrace.semantic] using semantic.1 + rw [valid] + simp only [Pure.pure] + exact ih semantic.2 + | terminal context source fuel argIdx terminal valid => + cases source <;> try rfl + case forallE => + change true = false at terminal + contradiction + +/-- Root form of `universeLoop_of_semantics`, initialized from the same +context fuel as ordinary constructor validation. -/ +theorem ConstructorTypeValidationTrace.universeRun_of_semantics + (trace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source 0 context.fuel.inductiveFuel) + (semantic : trace.universeSemantics = true) : + checkConstructorUniverseSemantics stats source context = .ok () := by + unfold checkConstructorUniverseSemantics + simpa only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] using trace.universeLoop_of_semantics semantic + +/-- A retained source-ordered constructor list whose strengthened universe +decisions are all true replays the exact executable list audit. -/ +theorem ConstructorListValidationTrace.universeRun_of_semantics + (trace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors) + (semantic : trace.universeSemantics = true) : + checkConstructorUniverseListSemantics stats constructors context = + .ok () := by + induction trace with + | nil => rfl + | cons seen head tail fresh closed rootCheck typeTrace tailTrace ih => + simp only [universeSemantics, Bool.and_eq_true] at semantic + simp only [checkConstructorUniverseListSemantics, + ReaderT.bind, Bind.bind] + rw [typeTrace.universeRun_of_semantics semantic.1] + simp only [Except.bind] + exact ih semantic.2 + +/-- Impredicative `Prop` makes every strengthened constructor-universe node +true, independently of the field level selected by the retained checker run. -/ +theorem ConstructorUniverseTrace.semantic_of_resultLevel_isZero + (trace : ConstructorUniverseTrace resultLevel fieldLevel) + (zero : resultLevel.isZero = true) : trace.semantic = true := by + simp [ConstructorUniverseTrace.semantic, constructorUniverseSemanticGe, + zero] + +/-- Every universe node in a retained constructor telescope is admitted by +the strengthened audit when the family result is `Prop`. -/ +theorem ConstructorTypeValidationTrace.universeSemantics_of_resultLevel_isZero + (trace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx fuel) + (zero : stats.resultLevel.isZero = true) : + trace.universeSemantics = true := by + induction trace with + | parameter context fuel argIdx name domain body binderInfo parameter + parameterType parameterAt parameterTypeRun defeq tail ih => + simpa only [universeSemantics] using ih + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity tail ih => + simp only [universeSemantics, Bool.and_eq_true] + exact ⟨universeTrace.semantic_of_resultLevel_isZero zero, ih⟩ + | terminal => rfl + +/-- Source-list form of +`ConstructorTypeValidationTrace.universeSemantics_of_resultLevel_isZero`. -/ +theorem ConstructorListValidationTrace.universeSemantics_of_resultLevel_isZero + (trace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors) + (zero : stats.resultLevel.isZero = true) : + trace.universeSemantics = true := by + induction trace with + | nil => rfl + | cons seen head tail fresh closed rootCheck typeTrace tailTrace ih => + simp only [universeSemantics, Bool.and_eq_true] + exact ⟨typeTrace.universeSemantics_of_resultLevel_isZero zero, ih⟩ + +/-- A successful executable universe audit marks every universe node in an +arbitrary retained constructor telescope. The proof uses determinism of the +same `ensureType` execution retained by the ordinary trace; it cannot change a +field level or skip a source position. -/ +theorem ConstructorTypeValidationTrace.universeSemantics_of_loop + (trace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx fuel) + (success : checkConstructorUniverseSemantics.loop stats source argIdx fuel + context = .ok ()) : + trace.universeSemantics = true := by + induction trace with + | parameter context fuel argIdx name domain body binderInfo parameter + parameterType parameterAt parameterTypeRun defeq tail ih => + simp only [universeSemantics] + rw [show fuel + 1 = Nat.succ fuel by rfl] at success + rw [checkConstructorUniverseSemantics.loop.eq_2] at success + rw [parameterAt] at success + exact ih success + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity tail ih => + simp only [universeSemantics, Bool.and_eq_true] + rw [show fuel + 1 = Nat.succ fuel by rfl] at success + rw [checkConstructorUniverseSemantics.loop.eq_2] at success + rw [noParameter] at success + simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply] at success + rw [ensureType] at success + simp only [Except.bind] at success + cases valid : constructorUniverseSemanticGe stats.resultLevel + sortResult.sortLevel! with + | false => + rw [valid] at success + change Except.error _ = Except.ok () at success + cases success + | true => + rw [valid] at success + simp only [Pure.pure] at success + exact ⟨valid, ih success⟩ + | terminal => rfl + +/-- Root form of `universeSemantics_of_loop`, with the audit initialized from +the exact context fuel just like ordinary constructor validation. -/ +theorem ConstructorTypeValidationTrace.universeSemantics_of_run + (trace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source 0 context.fuel.inductiveFuel) + (success : checkConstructorUniverseSemantics stats source context = + .ok ()) : + trace.universeSemantics = true := by + apply trace.universeSemantics_of_loop + simpa only [checkConstructorUniverseSemantics, readThe, + MonadReaderOf.read, ReaderT.read, ReaderT.bind, Bind.bind, + ReaderT.pure, Pure.pure, Except.bind, Except.pure] using success + +/-- A successful source-list audit marks every retained constructor position; +the dependent list indices prevent omission, duplication, or reordering. -/ +theorem ConstructorListValidationTrace.universeSemantics_of_run + (trace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors) + (success : checkConstructorUniverseListSemantics stats constructors + context = .ok ()) : + trace.universeSemantics = true := by + induction trace with + | nil => rfl + | cons seen head tail fresh closed rootCheck typeTrace tailTrace ih => + simp only [universeSemantics, Bool.and_eq_true] + simp only [checkConstructorUniverseListSemantics, + ReaderT.bind, Bind.bind] at success + cases headRun : checkConstructorUniverseSemantics stats head.type + context with + | error error => + rw [headRun] at success + cases success + | ok result => + cases result + rw [headRun] at success + simp only [Except.bind] at success + exact ⟨typeTrace.universeSemantics_of_run headRun, ih success⟩ + +/-- Ordinary constructor validation paired with the executable semantic +universe audit over the identical singleton source list. This record narrows +the accepted package boundary while preserving the ordinary validator result +and every retained non-universe check unchanged. -/ +structure ConstructorSemanticValidationRun + (indType : InductiveType) (stats : InductiveStats) + (isUnsafe : Bool) (context : Context) where + validation : ConstructorValidationRun indType stats isUnsafe context + universeRun : checkConstructorUniverseListSemantics stats indType.ctors + context = .ok () + +namespace ConstructorSemanticValidationRun + +/-- Forgetting the semantic audit replays the exact ordinary validator, so +the strengthened run cannot widen kernel acceptance. -/ +theorem run + (semantic : ConstructorSemanticValidationRun indType stats isUnsafe + context) : + checkConstructors #[indType] stats isUnsafe context = .ok () := + semantic.validation.run + +/-- Every universe-bearing node of the retained ordinary trace passed the +executable verified universe gate. -/ +theorem universeSemantics + (semantic : ConstructorSemanticValidationRun indType stats isUnsafe + context) : + semantic.validation.universeSemantics = true := + semantic.validation.trace.universeSemantics_of_run semantic.universeRun + +end ConstructorSemanticValidationRun + +/-- The semantic universe gate only accepts branches already accepted by the +ordinary constructor validator. It therefore narrows package construction +without widening kernel validation behavior. -/ +theorem ConstructorUniverseTrace.nonempty_of_semanticGe + (valid : constructorUniverseSemanticGe resultLevel fieldLevel = true) : + Nonempty (ConstructorUniverseTrace resultLevel fieldLevel) := by + unfold constructorUniverseSemanticGe at valid + simp only [Bool.or_eq_true, Bool.and_eq_true] at valid + rcases valid with structural | prop | ⟨core, _verified⟩ + · exact ⟨.structural structural⟩ + · cases hstruct : levelStructGe resultLevel fieldLevel with + | true => exact ⟨.structural hstruct⟩ + | false => + exact ⟨.fallback hstruct (by simp [prop])⟩ + · cases hstruct : levelStructGe resultLevel fieldLevel with + | true => exact ⟨.structural hstruct⟩ + | false => + exact ⟨.fallback hstruct (by simp [core])⟩ + +/-- The executable semantic subset implies exactly the disjunct required for +a non-recursive field in `VInductDecl.fieldsWF`: either the family is Prop or +the field universe is bounded by the family universe. -/ +theorem constructorUniverseSemanticGe_ofLevel + (valid : constructorUniverseSemanticGe resultLevel fieldLevel = true) + (result_tr : VLevel.ofLevel Us resultLevel = some result') + (field_tr : VLevel.ofLevel Us fieldLevel = some field') : + result' = .zero ∨ field' ≤ result' := by + unfold constructorUniverseSemanticGe at valid + simp only [Bool.or_eq_true, Bool.and_eq_true] at valid + 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) + +/-- Agreement between the ordinary and verified normalized comparisons opens +the semantic fallback without weakening the ordinary acceptance boundary. -/ +theorem constructorUniverseSemanticGe_eq_true_of_geq_agreement + (core : resultLevel.geq fieldLevel = true) + (verified : resultLevel.geq' fieldLevel = true) : + constructorUniverseSemanticGe resultLevel fieldLevel = true := by + simp [constructorUniverseSemanticGe, core, verified] + +private def constructorUniverseComparisonSamples : List Level := + [.zero, + .succ .zero, + .succ (.succ .zero), + .param `u, + .param `v, + .succ (.param `u), + .max (.param `u) (.param `v), + .max (.succ (.param `u)) (.param `v), + .imax (.param `u) (.param `v), + .imax (.param `u) (.succ (.param `v)), + .imax (.max (.param `u) (.param `v)) (.succ .zero), + .max (.imax (.param `u) (.param `v)) (.succ (.param `v))] + +/- Differential audit for the mvar-free surface accepted by constructors. +Every pair in this matrix compares Lean v4.31's core decision with the proved +project decision; the samples exercise zero, successor, maximum, impredicative +maximum, parameters, and nested combinations. -/ +#guard constructorUniverseComparisonSamples.all fun resultLevel => + constructorUniverseComparisonSamples.all fun fieldLevel => + resultLevel.geq fieldLevel == resultLevel.geq' fieldLevel + +/- Regression for the former D1 gap: the structural and `Prop` branches both +miss a parameter below a `max`, while core/project normalized comparison +agrees and the verified semantic fallback now accepts it. -/ +private def constructorUniverseNormalizedResult : Level := + .max (.param `u) (.param `v) + +#guard !levelStructGe constructorUniverseNormalizedResult (.param `u) +#guard !constructorUniverseNormalizedResult.isZero +#guard constructorUniverseNormalizedResult.geq (.param `u) +#guard constructorUniverseNormalizedResult.geq' (.param `u) +#guard constructorUniverseSemanticGe constructorUniverseNormalizedResult + (.param `u) + +/- The universe bridge stays within Lean's standard logical basis. In +particular it does not inherit the project's pending sorries, a custom axiom, +or a semantic premise for Lean's opaque `Level.geq` implementation. -/ +/-- +info: 'Lean4Lean.AddInductive.levelStructEq_ofLevel' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms levelStructEq_ofLevel + +/-- +info: 'Lean4Lean.AddInductive.levelStructGe_ofLevel' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms levelStructGe_ofLevel + +/-- +info: 'Lean4Lean.AddInductive.constructorUniverseSemanticGe_ofLevel' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms constructorUniverseSemanticGe_ofLevel + +/-- +info: 'Lean4Lean.AddInductive.ConstructorUniverseTrace.nonempty_of_semanticGe' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorUniverseTrace.nonempty_of_semanticGe + +/-- +info: 'Lean4Lean.AddInductive.ConstructorSemanticValidationRun.universeSemantics' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorSemanticValidationRun.universeSemantics + +/- The reverse executable bridge and its impredicative-Prop specialization +have the same standard-only closure as the forward universe interpretation. +In particular, replaying a retained validator trace does not inherit a +fixture computation oracle. -/ +/-- +info: 'Lean4Lean.AddInductive.ConstructorTypeValidationTrace.universeLoop_of_semantics' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorTypeValidationTrace.universeLoop_of_semantics + +/-- +info: 'Lean4Lean.AddInductive.ConstructorTypeValidationTrace.universeRun_of_semantics' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorTypeValidationTrace.universeRun_of_semantics + +/-- +info: 'Lean4Lean.AddInductive.ConstructorListValidationTrace.universeRun_of_semantics' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorListValidationTrace.universeRun_of_semantics + +/-- +info: 'Lean4Lean.AddInductive.ConstructorUniverseTrace.semantic_of_resultLevel_isZero' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorUniverseTrace.semantic_of_resultLevel_isZero + +/-- +info: 'Lean4Lean.AddInductive.ConstructorTypeValidationTrace.universeSemantics_of_resultLevel_isZero' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorTypeValidationTrace.universeSemantics_of_resultLevel_isZero + +/-- +info: 'Lean4Lean.AddInductive.ConstructorListValidationTrace.universeSemantics_of_resultLevel_isZero' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms ConstructorListValidationTrace.universeSemantics_of_resultLevel_isZero + +/-! +## Executable pre-family safety and replay + +The post-family validator introduces a local declaration for every constructor +field. A recursive field's local type mentions the family being defined, so +that declaration cannot be reproduced in the pre-family verifier context. +For the current singleton subset we omit such locals, advance the validator's +fresh-name supply, and permit later checks only when their source expressions +do not mention an omitted identifier. Independent ordinary fields may still +follow recursive fields; genuinely dependent uses remain outside this replay. + +The traces below are outputs of executable builders. Their proof fields are +exact `checkType`, `ensureType`, and `isDefEq` executions; they are operational +evidence, not caller-supplied Theory judgments. +-/ + +/-- Executable fragment on which strict kernel-to-Theory translation has a +syntactically unique endpoint. Projections are excluded because the current +`TrProj` contract determines their result only up to definitional equality; +projection-bearing inductives remain outside the singleton subset until the +projection milestones establish an exact structural API. -/ +def theoryTranslationUnique : Expr → Bool + | .bvar _ + | .fvar _ + | .sort _ + | .const .. + | .mvar .. + | .lit _ => true + | .app fn argument => + theoryTranslationUnique fn && theoryTranslationUnique argument + | .lam _ domain body _ + | .forallE _ domain body _ => + theoryTranslationUnique domain && theoryTranslationUnique body + | .letE _ _ value body _ => + theoryTranslationUnique value && theoryTranslationUnique body + | .mdata _ expression => theoryTranslationUnique expression + | .proj .. => false + +/-- The executable predicate is exactly the structural proposition used by +strict-translation uniqueness. -/ +theorem theoryTranslationUnique_sound + (success : theoryTranslationUnique expression = true) : + TrExprS.IsUnique expression := by + induction expression <;> + simp_all [theoryTranslationUnique, TrExprS.IsUnique] + +/-- Abstracting one free variable preserves the projection-free fragment: +the operation changes only free/bound-variable identities and recursively +retains every expression constructor. -/ +theorem theoryTranslationUnique_abstract1 + (expression : Expr) (id : FVarId) (depth : Nat) : + theoryTranslationUnique (Expr.abstract1 id expression depth) = + theoryTranslationUnique expression := by + induction expression generalizing depth <;> + simp [Expr.abstract1, theoryTranslationUnique, *] + split <;> rfl + +/-- Iterated free-variable abstraction likewise preserves the executable +strict-translation fragment. -/ +theorem theoryTranslationUnique_abstractList + (expression : Expr) (ids : List FVarId) (depth : Nat) : + theoryTranslationUnique (Expr.abstractList expression ids depth) = + theoryTranslationUnique expression := by + induction ids generalizing expression with + | nil => rfl + | cons id ids ih => + simp only [Expr.abstractList, ih, + theoryTranslationUnique_abstract1] + +/-- Array-form abstraction over an explicit list of free variables preserves +the projection-free fragment. -/ +theorem theoryTranslationUnique_abstractFVars + (expression : Expr) (ids : List FVarId) : + theoryTranslationUnique + (expression.abstract ⟨ids.map Expr.fvar⟩) = + theoryTranslationUnique expression := by + rw [Expr.abstract_eq] + exact theoryTranslationUnique_abstractList expression ids 0 + +/-- Every syntax fragment contributing to a recursively reconstructed +candidate view has a unique strict Theory endpoint. Checking recursive body +views as well as their stored abstractions supplies precisely the induction +hypotheses consumed by `CandidateExprRun.view_tr_strict`. -/ +def CandidateExprTrace.viewTranslationUnique : + {context : Context} → {source : Expr} → + CandidateExprTrace context source → Bool + | _, _, .terminal _ _ _ result _ _ => theoryTranslationUnique result + | _, _, .forallE context _ _ _ _ _ _ _ _ _ _ _ domain body => + domain.viewTranslationUnique && + (body.viewTranslationUnique && + theoryTranslationUnique + (body.view.abstract #[context.freshExpr])) + +/-- The recursive check is extensionally the projection-free check on the +reconstructed analyzer view. Its explicit body clause supplies the induction +hypothesis consumed by the strict-view proof. -/ +theorem CandidateExprTrace.viewTranslationUnique_eq + (trace : CandidateExprTrace context source) : + trace.viewTranslationUnique = theoryTranslationUnique trace.view := by + induction trace with + | terminal => rfl + | forallE context source inferred name domain body binderInfo fresh + annotations annotationsEq checked normalized domainTrace bodyTrace + domainIH bodyIH => + simp only [viewTranslationUnique, CandidateExprTrace.view, + theoryTranslationUnique, domainIH, bodyIH] + rw [show #[context.freshExpr] = + ⟨[context.freshFVarId].map Expr.fvar⟩ by rfl, + theoryTranslationUnique_abstractFVars] + simp + +/-- A successful recursive executable check supplies the exact proposition +required by strict candidate-view translation. -/ +theorem CandidateExprTrace.viewTranslationUnique_sound + (trace : CandidateExprTrace context source) + (success : trace.viewTranslationUnique = true) : + TypeChecker.CandidateExprTraceViewIsUnique trace := by + induction trace with + | terminal => exact theoryTranslationUnique_sound success + | forallE context source inferred name domain body binderInfo fresh + annotations annotationsEq checked normalized domainTrace bodyTrace + domainIH bodyIH => + simp only [viewTranslationUnique, Bool.and_eq_true] at success + exact ⟨domainIH success.1, bodyIH success.2.1, + theoryTranslationUnique_sound success.2.2⟩ + +/-- Source-ordered strict-view check for an exact dependent constructor +candidate list. -/ +def CandidateList.viewTranslationUnique : + {constructors : List Constructor} → + CandidateList CandidateConstructor constructors → Bool + | _, .nil => true + | _, .cons candidate candidates => + candidate.type.trace.viewTranslationUnique && + candidates.viewTranslationUnique + +/-- Proof-level source-ordered counterpart of +`CandidateList.viewTranslationUnique`. -/ +def CandidateList.ViewTranslationUnique : + {constructors : List Constructor} → + CandidateList CandidateConstructor constructors → Prop + | _, .nil => True + | _, .cons candidate candidates => + TypeChecker.CandidateExprTraceViewIsUnique candidate.type.trace ∧ + candidates.ViewTranslationUnique + +theorem CandidateList.viewTranslationUnique_sound + (candidates : CandidateList CandidateConstructor constructors) + (success : candidates.viewTranslationUnique = true) : + candidates.ViewTranslationUnique := by + induction candidates with + | nil => trivial + | cons candidate candidates ih => + simp only [viewTranslationUnique, Bool.and_eq_true] at success + exact ⟨candidate.type.trace.viewTranslationUnique_sound success.1, + ih success.2⟩ + +/-- Advance the constructor traversal's fresh-name supply without adding the +family-dependent local declaration for a recursive outer field. -/ +def Context.advanceFresh (context : Context) : Context := + { context with ngen := context.ngen.next } + +/-- Advancing an omitted recursive field changes only the candidate name +generator. The verified checker context and its empty-state certificate remain +the same because `Context.toTypeChecker` deliberately has no name-generator +field. -/ +def advanceCandidateContextRun + (run : TypeChecker.CandidateContextRun context) : + TypeChecker.CandidateContextRun context.advanceFresh := by + refine ⟨run.context, ?_, run.state_wf, ?_⟩ + · simpa [Context.advanceFresh, Context.toTypeChecker] using run.context_eq + · simpa [Context.advanceFresh, NameGenerator.next] using run.namePrefix_ne + +/-- Keep the fixed pre-family Theory environment/universe indices while the +operational traversal advances past an omitted recursive outer field. -/ +def ConstructorContextRun.advanceFresh + (run : ConstructorContextRun env Us context) : + ConstructorContextRun env Us context.advanceFresh where + candidate := advanceCandidateContextRun run.candidate + venv_eq := run.venv_eq + lparams_eq := run.lparams_eq + +/-- Syntactic independence from the recursive outer-field locals omitted by +the pre-family replay context. -/ +def constructorIndependentOf (source : Expr) (removed : List FVarId) : Bool := + source.fvarsList.all fun fv => !removed.contains fv + +/-- Instantiate the analyzer-owned family view with the exact parameter FVars +selected by family validation, leaving the index telescope exposed. -/ +def instantiateFamilyParameters : Expr → List Expr → Except Exception Expr + | familyType, [] => pure familyType + | .forallE _ _ body _, parameter :: parameters => + instantiateFamilyParameters (body.instantiate1 parameter) parameters + | _, _ :: _ => + throw <| .other + "candidate family view has fewer binders than retained parameters" + +/-- Exact successful pre-family `ensureType` observation. -/ +structure ConstructorEnsureTypeObservation + (context : Context) (source : Expr) where + result : Expr + valid : ConstructorEnsureTypeStep.Valid ⟨context, source, result⟩ + +def observeConstructorEnsureType (context : Context) (source : Expr) : + Except Exception (ConstructorEnsureTypeObservation context source) := + match hrun : TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel (TypeChecker.ensureType source) with + | .error error => .error error + | .ok result => .ok ⟨result, hrun⟩ + +theorem observeConstructorEnsureType_of_run + (run : ConstructorEnsureTypeStep.Valid ⟨context, source, result⟩) : + observeConstructorEnsureType context source = .ok ⟨result, run⟩ := by + change TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel (TypeChecker.ensureType source) = + .ok result at run + unfold observeConstructorEnsureType + split + · simp_all + · rename_i observed hobserved + have : observed = result := by simp_all + subst observed + rfl + +theorem ConstructorEnsureTypeObservation.observe_eq + (observation : ConstructorEnsureTypeObservation context source) : + observeConstructorEnsureType context source = .ok observation := by + rw [observeConstructorEnsureType_of_run observation.valid] + +/-- One pre-family index argument checked against the corresponding binder of +the parameter-instantiated family view. -/ +structure ConstructorPreFamilyIndexStep + (context : Context) (argument expected : Expr) where + argumentCheck : ConstructorCheckedExpr context argument + expectedCheck : ConstructorCheckedExpr context expected + comparison : CandidateIsDefEqObservation context + argumentCheck.observation.inferred expected + +/-- Source-ordered executable replay of a constructor result/recursive-target +index spine against the analyzer-owned family index telescope. -/ +inductive ConstructorPreFamilyIndexSpineTrace : + (context : Context) → (expected : Expr) → List Expr → Type where + | nil + (context : Context) (expected : Expr) + (expectedCheck : ConstructorCheckedExpr context expected) + (terminal : expected.isForall = false) : + ConstructorPreFamilyIndexSpineTrace context expected [] + | cons + (context : Context) (name : Name) (domain body : Expr) + (binderInfo : BinderInfo) (argument : Expr) (arguments : List Expr) + (expectedCheck : ConstructorCheckedExpr context + (.forallE name domain body binderInfo)) + (step : ConstructorPreFamilyIndexStep context argument domain) + (tail : ConstructorPreFamilyIndexSpineTrace context + (body.instantiate1 argument) arguments) : + ConstructorPreFamilyIndexSpineTrace context + (.forallE name domain body binderInfo) (argument :: arguments) + +namespace ConstructorPreFamilyIndexSpineTrace + +def build : (context : Context) → (expected : Expr) → + (arguments : List Expr) → + Except Exception + (ConstructorPreFamilyIndexSpineTrace context expected arguments) + | context, expected, [] => + if terminal : expected.isForall = false then do + let expectedCheck ← checkConstructorAlignedExpr context expected + pure <| .nil context expected expectedCheck terminal + else + throw <| .other + "constructor target supplies too few family indices" + | context, .forallE name domain body binderInfo, argument :: arguments => do + let telescopeCheck ← checkConstructorAlignedExpr context + (.forallE name domain body binderInfo) + let argumentCheck ← checkConstructorAlignedExpr context argument + let domainCheck ← checkConstructorAlignedExpr context domain + let comparison ← observeCandidateIsDefEq context + argumentCheck.observation.inferred domain + let tail ← build context (body.instantiate1 argument) arguments + pure <| .cons context name domain body binderInfo argument arguments + telescopeCheck ⟨argumentCheck, domainCheck, comparison⟩ tail + | _, _, _ :: _ => + throw <| .other + "constructor target supplies too many family indices" + +end ConstructorPreFamilyIndexSpineTrace + +theorem ConstructorPreFamilyIndexSpineTrace.build_eq + (trace : ConstructorPreFamilyIndexSpineTrace context expected arguments) : + ConstructorPreFamilyIndexSpineTrace.build context expected arguments = + .ok trace := by + induction trace with + | nil expected expectedCheck terminal => + simp only [ConstructorPreFamilyIndexSpineTrace.build] + rw [dif_pos terminal, expectedCheck.check_eq] + rfl + | cons name domain body binderInfo argument arguments + expectedCheck step tail ih => + simp only [ConstructorPreFamilyIndexSpineTrace.build] + rw [expectedCheck.check_eq, step.argumentCheck.check_eq, + step.expectedCheck.check_eq] + simp only [Bind.bind, Except.bind] + rw [step.comparison.observe_eq, ih] + rfl + +/-- The exact full check retained at the root of an index-spine replay. -/ +def ConstructorPreFamilyIndexSpineTrace.expectedCheck : + (trace : ConstructorPreFamilyIndexSpineTrace context expected arguments) → + ConstructorCheckedExpr context expected + | .nil _ _ expectedCheck _ => expectedCheck + | .cons _ _ _ _ _ _ _ expectedCheck _ _ => expectedCheck + +/-! +### Verified pre-family index spines + +The operational trace checks the complete expected family-index telescope at +every recursive position. Its semantic interpretation follows the strict +translation selected at the root, instantiates the translated Pi body with the +translated argument, and therefore constructs an actual Theory `SpineWF` +rather than a pointwise list whose dependencies have been forgotten. +-/ + +/-- Verified meaning of one pre-family index-spine replay. `expected'` is a +strict translation of the exact parameter-instantiated family telescope in the +current context; `arguments'` and `result'` are forced by the retained checker +executions and dependent Pi instantiation. -/ +structure ConstructorPreFamilyIndexSpineSemanticRun + (env : VEnv) (Us : List Name) + (context : Context) (contextRun : ConstructorContextRun env Us context) + {expected : Expr} {arguments : List Expr} + (trace : ConstructorPreFamilyIndexSpineTrace context expected arguments) + (expected' : VExpr) where + expectedInferred' : VExpr + expectedRun : TypeChecker.CheckTypeRun env Us + contextRun.candidate.context.vlctx expected + trace.expectedCheck.observation.inferred expected' expectedInferred' + arguments' : List VExpr + result' : VExpr + arguments_tr : List.Forall₂ + (TrExprS env Us contextRun.candidate.context.vlctx) + arguments arguments' + spine : env.SpineWF Us.length contextRun.candidate.context.vlctx.toCtx + expected' arguments' result' + +namespace ConstructorPreFamilyIndexSpineSemanticRun + +/-- Interpret a spine at a caller-fixed strict translation of its expected +telescope. Recursive calls receive the translated Pi body instantiated with +the exact checker-selected argument translation. -/ +theorem nonempty_at + (contextRun : ConstructorContextRun env Us context) + (trace : ConstructorPreFamilyIndexSpineTrace context expected arguments) + (expected' : VExpr) + (expected_tr : TrExprS env Us + contextRun.candidate.context.vlctx expected expected') : + Nonempty (ConstructorPreFamilyIndexSpineSemanticRun env Us context + contextRun trace expected') := by + induction trace generalizing expected' with + | nil expected expectedCheck terminal => + have expected_tr' : contextRun.candidate.context.TrExprS expected + expected' := by + simpa only [VContext.TrExprS, contextRun.venv_eq, + contextRun.lparams_eq] using expected_tr + obtain ⟨expectedInferred', ⟨expectedRun⟩⟩ := + TypeChecker.CheckTypeRun.exists_ofCandidateStep + ⟨context, expected, expectedCheck.observation.inferred⟩ + expectedCheck.observation.valid contextRun.candidate expected' + expected_tr' + exact ⟨{ + expectedInferred' := expectedInferred' + expectedRun := by + simpa only [ConstructorPreFamilyIndexSpineTrace.expectedCheck, + contextRun.venv_eq, contextRun.lparams_eq] using expectedRun + arguments' := [] + result' := expected' + arguments_tr := .nil + spine := rfl }⟩ + | cons name domain body binderInfo argument arguments telescopeCheck + step tail ih => + obtain ⟨domain', body', rfl, domainType, bodyType, domain_tr, + body_tr⟩ := TypeChecker.TrExprS.forallE_components expected_tr + have telescope_tr' : contextRun.candidate.context.TrExprS + (.forallE name domain body binderInfo) (.forallE domain' body') := by + simpa only [VContext.TrExprS, contextRun.venv_eq, + contextRun.lparams_eq] using expected_tr + obtain ⟨expectedInferred', ⟨expectedRun⟩⟩ := + TypeChecker.CheckTypeRun.exists_ofCandidateStep + ⟨context, .forallE name domain body binderInfo, + telescopeCheck.observation.inferred⟩ + telescopeCheck.observation.valid contextRun.candidate + (.forallE domain' body') telescope_tr' + have domain_tr' : contextRun.candidate.context.TrExprS domain domain' := by + simpa only [VContext.TrExprS, contextRun.venv_eq, + contextRun.lparams_eq] using domain_tr + obtain ⟨domainInferred', ⟨domainCheck⟩⟩ := + TypeChecker.CheckTypeRun.exists_ofCandidateStep + ⟨context, domain, step.expectedCheck.observation.inferred⟩ + step.expectedCheck.observation.valid contextRun.candidate domain' + domain_tr' + let domainRun : ConstructorCheckedExpr.Run step.expectedCheck + contextRun.candidate := ⟨domain', domainInferred', domainCheck⟩ + obtain ⟨argumentRun⟩ := ConstructorCheckedExpr.Run.exists + step.argumentCheck contextRun.candidate + let comparisonRun := TypeChecker.IsDefEqRun.ofCandidateStep + ⟨context, step.argumentCheck.observation.inferred, domain⟩ + step.comparison.valid contextRun.candidate.context + contextRun.candidate.context_eq rfl rfl rfl + contextRun.candidate.state_wf argumentRun.check.inferred_tr + domainRun.check.expr_tr context.fuel.recDepth rfl + have argumentType' : contextRun.candidate.context.HasType + argumentRun.source' domain' := + argumentRun.check.hasType.defeqU_r + contextRun.candidate.context.Ewf + contextRun.candidate.context.Δwf.toCtx comparisonRun.isDefEqU + have argumentType : env.HasType Us.length + contextRun.candidate.context.vlctx.toCtx argumentRun.source' + domain' := by + simpa only [VContext.HasType, contextRun.venv_eq, + contextRun.lparams_eq] using argumentType' + have argument_tr : TrExprS env Us + contextRun.candidate.context.vlctx argument argumentRun.source' := by + simpa only [contextRun.venv_eq, contextRun.lparams_eq] using + argumentRun.check.expr_tr + have henv : VEnv.WF env := by + simpa only [contextRun.venv_eq] using + contextRun.candidate.context.Ewf + have instantiatedBody_tr : TrExprS env Us + contextRun.candidate.context.vlctx + (body.instantiate1 argument) (body'.inst argumentRun.source') := by + simpa only [Expr.instantiate1_eq] using + body_tr.inst henv.ordered argumentType argument_tr + obtain ⟨tailRun⟩ := ih (body'.inst argumentRun.source') + instantiatedBody_tr + exact ⟨{ + expectedInferred' := expectedInferred' + expectedRun := by + simpa only [ConstructorPreFamilyIndexSpineTrace.expectedCheck, + contextRun.venv_eq, contextRun.lparams_eq] using expectedRun + arguments' := argumentRun.source' :: tailRun.arguments' + result' := tailRun.result' + arguments_tr := .cons argument_tr tailRun.arguments_tr + spine := ⟨domain', body', rfl, 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`. -/ +theorem nonempty + (contextRun : ConstructorContextRun env Us context) + (trace : ConstructorPreFamilyIndexSpineTrace context expected arguments) : + ∃ expected', Nonempty + (ConstructorPreFamilyIndexSpineSemanticRun env Us context contextRun + trace expected') := by + obtain ⟨expectedRun⟩ := ConstructorCheckedExpr.Run.exists + trace.expectedCheck contextRun.candidate + have expected_tr : TrExprS env Us + contextRun.candidate.context.vlctx expected expectedRun.source' := by + simpa only [contextRun.venv_eq, contextRun.lparams_eq] using + expectedRun.check.expr_tr + exact ⟨expectedRun.source', nonempty_at contextRun trace _ expected_tr⟩ + +/-- Strict family translation fixes the expected endpoint chosen by an exact +pre-family index replay, even when the replay context contains a later prefix +of fresh locals. -/ +theorem expected_eq_of_family + {env : VEnv} {Us : List Name} {context : Context} + {contextRun : ConstructorContextRun env Us context} + {expected : Expr} {arguments : List Expr} + {trace : ConstructorPreFamilyIndexSpineTrace context expected arguments} + {expected' : VExpr} + (run : ConstructorPreFamilyIndexSpineSemanticRun env Us context + contextRun trace expected') + {parameterΔ viewΔ : VLCtx} {expectedBase : VExpr} {n : Nat} + (familyTr : TrExprS env Us parameterΔ expected expectedBase) + (unique : TrExprS.IsUnique expected) + (viewLift : VLCtx.FVLift' parameterΔ viewΔ 0 + (.skipN .refl n) 0) + (viewDefEq : VLCtx.IsDefEq env Us.length + contextRun.candidate.context.vlctx viewΔ) + (viewUnique : TrExprS.IsUniqueCtx + contextRun.candidate.context.vlctx viewΔ) : + expected' = expectedBase.liftN n 0 := by + have henv : VEnv.Ordered env := by + simpa only [contextRun.venv_eq] using + contextRun.candidate.context.Ewf.ordered + have viewWF : VLCtx.WF env Us.length viewΔ := + (viewDefEq.symm henv).wf + have familyAtView : TrExprS env Us viewΔ expected + (expectedBase.liftN n 0) := by + simpa only [VExpr.lift'_consN_skipN] using + familyTr.weakFV' henv viewLift viewWF + have retained : TrExprS env Us contextRun.candidate.context.vlctx + expected expected' := run.expectedRun.expr_tr + exact retained.unique' viewUnique unique familyAtView + +/-- Transport the exact pre-family index judgment below an arbitrary later +prefix. This is the proved context weakening used when D4 places the same +spine beneath the remaining constructor fields. -/ +theorem spine_weakPrefix + {expected : Expr} {arguments : List Expr} + {replay : ConstructorPreFamilyIndexSpineTrace context expected arguments} + {expected' : VExpr} + (run : ConstructorPreFamilyIndexSpineSemanticRun env Us context contextRun + replay expected') (Bs : List VExpr) : + env.SpineWF Us.length + (Bs ++ contextRun.candidate.context.vlctx.toCtx) + (expected'.liftN Bs.length 0) + (run.arguments'.map fun argument => + argument.liftN Bs.length 0) + (run.result'.liftN Bs.length 0) := by + have henv : VEnv.WF env := by + simpa only [contextRun.venv_eq] using contextRun.candidate.context.Ewf + exact run.spine.weakN henv.ordered + (Ctx.LiftN.zero (n := Bs.length) + (Γ := contextRun.candidate.context.vlctx.toCtx) Bs) + +end ConstructorPreFamilyIndexSpineSemanticRun + +/-- Pre-family replay of the family-free pieces of one recursive field. Π +domains are checked and introduced normally; the terminal family application +is replaced by an index-spine replay, so the absent family constant is never +looked up. -/ +inductive ConstructorPreFamilyRecursiveTrace + (stats : InductiveStats) (familyIdx : Nat) (familyIndices : Expr) : + (context : Context) → (source : Expr) → (fuel : Nat) → Type where + | forallE + (context : Context) (name : Name) (domain body : Expr) + (binderInfo : BinderInfo) + (domainCheck : ConstructorCheckedExpr context domain) + (ensureType : ConstructorEnsureTypeObservation context domain) + (consumedCheck : ConstructorCheckedExpr context + (consumeTypeAnnotations domain)) + (annotations : CandidateIsDefEqObservation context domain + (consumeTypeAnnotations domain)) + (fresh : context.lctx.find? context.freshFVarId = none) + (tail : ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) fuel) : + ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices context + (.forallE name domain body binderInfo) (fuel + 1) + | target + (context : Context) (source : Expr) + (valid : isValidIndAppIdx stats source familyIdx = true) + (spine : ConstructorPreFamilyIndexSpineTrace context familyIndices + (source.getAppArgs.toList.drop stats.params.size)) : + ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices context + source (fuel + 1) + +namespace ConstructorPreFamilyRecursiveTrace + +def build (stats : InductiveStats) (familyIdx : Nat) + (familyIndices : Expr) : + (context : Context) → (source : Expr) → (fuel : Nat) → + Except Exception + (ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices + context source fuel) + | _, _, 0 => throw .deepRecursion + | context, .forallE name domain body binderInfo, fuel + 1 => do + let domainCheck ← checkConstructorAlignedExpr context domain + let ensureType ← observeConstructorEnsureType context domain + let consumedCheck ← checkConstructorAlignedExpr context + (consumeTypeAnnotations domain) + let annotations ← observeCandidateIsDefEq context domain + (consumeTypeAnnotations domain) + if fresh : context.lctx.find? context.freshFVarId = none then + let tail ← build stats familyIdx familyIndices + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) fuel + pure <| .forallE context name domain body binderInfo domainCheck + ensureType consumedCheck annotations fresh tail + else + throw <| .other + "pre-family recursive replay reused a local identifier" + | context, source, _ + 1 => do + if valid : isValidIndAppIdx stats source familyIdx = true then + let spine ← ConstructorPreFamilyIndexSpineTrace.build context + familyIndices + (source.getAppArgs.toList.drop stats.params.size) + pure <| .target context source valid spine + else + throw <| .other + "pre-family recursive replay reached a non-family target" + +end ConstructorPreFamilyRecursiveTrace + +theorem ConstructorPreFamilyRecursiveTrace.forallE_build_eq + (domainCheck : ConstructorCheckedExpr context domain) + (ensureType : ConstructorEnsureTypeObservation context domain) + (consumedCheck : ConstructorCheckedExpr context + (consumeTypeAnnotations domain)) + (annotations : CandidateIsDefEqObservation context domain + (consumeTypeAnnotations domain)) + (fresh : context.lctx.find? context.freshFVarId = none) + (tail : ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) fuel) + (tailRun : ConstructorPreFamilyRecursiveTrace.build stats familyIdx + familyIndices + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) fuel = .ok tail) : + ConstructorPreFamilyRecursiveTrace.build stats familyIdx familyIndices + context (.forallE name domain body binderInfo) (fuel + 1) = + .ok (.forallE context name domain body binderInfo domainCheck ensureType + consumedCheck annotations fresh tail) := by + simp only [ConstructorPreFamilyRecursiveTrace.build] + rw [domainCheck.check_eq, ensureType.observe_eq, consumedCheck.check_eq] + simp only [Bind.bind, Except.bind] + rw [annotations.observe_eq] + simp only [Bind.bind, Except.bind] + rw [dif_pos fresh, tailRun] + rfl + +theorem ConstructorPreFamilyRecursiveTrace.target_build_eq + (terminal : source.isForall = false) + (valid : isValidIndAppIdx stats source familyIdx = true) + (spine : ConstructorPreFamilyIndexSpineTrace context familyIndices + (source.getAppArgs.toList.drop stats.params.size)) : + ConstructorPreFamilyRecursiveTrace.build stats familyIdx familyIndices + context source (fuel + 1) = + .ok (.target context source valid spine) := by + cases source <;> simp only [ConstructorPreFamilyRecursiveTrace.build] + case forallE => simp [Expr.isForall] at terminal + all_goals + rw [dif_pos valid, spine.build_eq] + rfl + +/-! +### Verified pre-family recursive fields + +Recursive outer-field locals are intentionally absent here. Nested Pi binders +inside the field are family-free, so they are checked, interpreted, and pushed +normally. The terminal family application contributes only its already-verified +index spine. +-/ + +/-- Componentwise verified interpretation of a recursive field replay. -/ +inductive ConstructorPreFamilyRecursiveSemanticRun + (env : VEnv) (Us : List Name) + (stats : InductiveStats) (familyIdx : Nat) (familyIndices : Expr) : + {context : Context} → {source : Expr} → {fuel : Nat} → + (contextRun : ConstructorContextRun env Us context) → + ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices context + source fuel → Type where + | forallE + {context : Context} {name : Name} {domain body : Expr} + {binderInfo : BinderInfo} {fuel : Nat} + {domainCheck : ConstructorCheckedExpr context domain} + {ensureType : ConstructorEnsureTypeObservation context domain} + {consumedCheck : ConstructorCheckedExpr context + (consumeTypeAnnotations domain)} + {annotations : CandidateIsDefEqObservation context domain + (consumeTypeAnnotations domain)} + {fresh : context.lctx.find? context.freshFVarId = none} + {tailTrace : ConstructorPreFamilyRecursiveTrace stats familyIdx + familyIndices + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) fuel} + {contextRun : ConstructorContextRun env Us context} + (domainRun : ConstructorCheckedExpr.Run domainCheck + contextRun.candidate) + (consumedRun : ConstructorCheckedExpr.Run consumedCheck + contextRun.candidate) + (ensureTypeRun : TypeChecker.EnsureTypeRun + contextRun.candidate.context.venv + contextRun.candidate.context.lparams + contextRun.candidate.context.vlctx domain ensureType.result + domainRun.source') + (annotationsRun : TypeChecker.IsDefEqRun + contextRun.candidate.context.venv + contextRun.candidate.context.lparams + contextRun.candidate.context.vlctx domain + (consumeTypeAnnotations domain) domainRun.source' + consumedRun.source') + (consumedType : contextRun.candidate.context.IsType + consumedRun.source') + (tail : ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices + (contextRun.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain) fresh consumedRun.source' + consumedRun.check.expr_tr consumedType) + tailTrace) : + ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices contextRun + (.forallE context name domain body binderInfo domainCheck ensureType + consumedCheck annotations fresh tailTrace) + | target + {context : Context} {source : Expr} {fuel : Nat} + {valid : isValidIndAppIdx stats source familyIdx = true} + {spineTrace : ConstructorPreFamilyIndexSpineTrace context familyIndices + (source.getAppArgs.toList.drop stats.params.size)} + {contextRun : ConstructorContextRun env Us context} + (expected' : VExpr) + (spine : ConstructorPreFamilyIndexSpineSemanticRun env Us context + contextRun spineTrace expected') : + ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices contextRun (.target context source valid spineTrace) + +namespace ConstructorPreFamilyRecursiveSemanticRun + +/-- Interpret every retained nested-binder and terminal-index operation in the +exact verified pre-family context. -/ +theorem nonempty + (contextRun : ConstructorContextRun env Us context) + (trace : ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices + context source fuel) : + Nonempty (ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices contextRun trace) := by + induction trace with + | forallE context name domain body binderInfo domainCheck ensureType + consumedCheck annotations fresh tailTrace ih => + obtain ⟨domainRun⟩ := ConstructorCheckedExpr.Run.exists domainCheck + contextRun.candidate + obtain ⟨consumedRun⟩ := ConstructorCheckedExpr.Run.exists consumedCheck + contextRun.candidate + obtain ⟨ensureTypeRun⟩ := + TypeChecker.EnsureTypeRun.exists_ofConstructorStep + ⟨context, domain, ensureType.result⟩ ensureType.valid + contextRun.candidate domainRun.source' domainRun.check.expr_tr + let annotationsRun := domainRun.isDefEq consumedRun annotations + have consumedType : contextRun.candidate.context.IsType + consumedRun.source' := by + have annotationDef := annotationsRun.isDefEqU.of_l + contextRun.candidate.context.Ewf + contextRun.candidate.context.Δwf.toCtx ensureTypeRun.source_type + exact ⟨ensureTypeRun.resultLevel', annotationDef.hasType.2⟩ + let tailContext := contextRun.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain) fresh consumedRun.source' + consumedRun.check.expr_tr consumedType + obtain ⟨tail⟩ := ih tailContext + exact ⟨.forallE domainRun consumedRun ensureTypeRun annotationsRun + consumedType tail⟩ + | @target traceFuel context source valid spineTrace => + obtain ⟨expected', ⟨spine⟩⟩ := + ConstructorPreFamilyIndexSpineSemanticRun.nonempty contextRun spineTrace + exact ⟨@ConstructorPreFamilyRecursiveSemanticRun.target + env Us stats familyIdx familyIndices traceFuel + context source (traceFuel + 1) valid spineTrace contextRun expected' spine⟩ + +/-- The verified nested Π-binder telescope retained by the recursive field. -/ +def binders + {context : Context} {source : Expr} {fuel : Nat} + {contextRun : ConstructorContextRun env Us context} + {trace : ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices + context source fuel} + (run : ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices contextRun trace) : List VExpr := + match run with + | .forallE _ consumedRun _ _ _ tail => consumedRun.source' :: tail.binders + | .target _ _ => [] + +/-- Translation selected for the analyzer-owned family-index telescope. -/ +def expected' + {context : Context} {source : Expr} {fuel : Nat} + {contextRun : ConstructorContextRun env Us context} + {trace : ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices + context source fuel} + (run : ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices contextRun trace) : VExpr := + match run with + | .forallE _ _ _ _ _ tail => tail.expected' + | .target expected' _ => expected' + +/-- Translated terminal recursive indices, in source order. -/ +def indices' + {context : Context} {source : Expr} {fuel : Nat} + {contextRun : ConstructorContextRun env Us context} + {trace : ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices + context source fuel} + (run : ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices contextRun trace) : List VExpr := + match run with + | .forallE _ _ _ _ _ tail => tail.indices' + | .target _ spine => spine.arguments' + +/-- Translated result type of the terminal recursive index application. -/ +def result' + {context : Context} {source : Expr} {fuel : Nat} + {contextRun : ConstructorContextRun env Us context} + {trace : ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices + context source fuel} + (run : ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices contextRun trace) : VExpr := + match run with + | .forallE _ _ _ _ _ tail => tail.result' + | .target _ spine => spine.result' + +/-- The retained recursive Π domains form a verified Theory telescope in the +exact pre-family context. -/ +theorem onTel + {context : Context} {source : Expr} {fuel : Nat} + {contextRun : ConstructorContextRun env Us context} + {trace : ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices + context source fuel} + (run : ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices contextRun trace) : + env.OnTel Us.length contextRun.candidate.context.vlctx.toCtx run.binders := by + induction run with + | @forallE context name domain body binderInfo fuel domainCheck ensureType + consumedCheck annotations fresh tailTrace branchContextRun domainRun + consumedRun ensureTypeRun annotationsRun consumedType tail ih => + constructor + · simpa only [VContext.IsType, branchContextRun.venv_eq, + branchContextRun.lparams_eq] using consumedType + · simpa only [binders, ConstructorContextRun.pushLocalDecl, + CandidateContextRun.pushLocalDecl_vlctx, VLCtx.toCtx] using ih + | target => trivial + +/-- The terminal recursive indices have the expected analyzer-owned family +index telescope, below all retained nested Π binders. -/ +theorem spine + {context : Context} {source : Expr} {fuel : Nat} + {contextRun : ConstructorContextRun env Us context} + {trace : ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices + context source fuel} + (run : ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices contextRun trace) : + env.SpineWF Us.length + (run.binders.reverse ++ contextRun.candidate.context.vlctx.toCtx) + run.expected' run.indices' run.result' := by + induction run with + | forallE domainRun consumedRun ensureTypeRun annotationsRun consumedType tail ih => + simpa only [binders, expected', indices', result', List.reverse_cons, + List.singleton_append, List.append_assoc, + ConstructorContextRun.pushLocalDecl, + CandidateContextRun.pushLocalDecl_vlctx, VLCtx.toCtx] using ih + | target expectedType spine => + simpa only [binders, expected', indices', result', List.reverse_nil, + List.nil_append] using spine.spine + +/-- Weaken the retained recursive Π telescope over a later prefix of omitted +outer recursive fields. -/ +theorem onTel_weakPrefix + {context : Context} {source : Expr} {fuel : Nat} + {contextRun : ConstructorContextRun env Us context} + {trace : ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices + context source fuel} + (run : ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices contextRun trace) (Bs : List VExpr) : + env.OnTel Us.length + (Bs ++ contextRun.candidate.context.vlctx.toCtx) + (VExpr.liftTelN Bs.length run.binders 0) := by + have henv : VEnv.WF env := by + simpa only [contextRun.venv_eq] using contextRun.candidate.context.Ewf + exact run.onTel.weakN henv.ordered + (Ctx.LiftN.zero (n := Bs.length) + (Γ := contextRun.candidate.context.vlctx.toCtx) Bs) + +/-- Weaken the terminal recursive index judgment below the same omitted outer +field prefix, preserving the nested Π-binder depths. -/ +theorem spine_weakPrefix + {context : Context} {source : Expr} {fuel : Nat} + {contextRun : ConstructorContextRun env Us context} + {trace : ConstructorPreFamilyRecursiveTrace stats familyIdx familyIndices + context source fuel} + (run : ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices contextRun trace) (Bs : List VExpr) : + env.SpineWF Us.length + ((VExpr.liftTelN Bs.length run.binders 0).reverse ++ + Bs ++ contextRun.candidate.context.vlctx.toCtx) + (run.expected'.liftN Bs.length run.binders.length) + (run.indices'.map fun index => + index.liftN Bs.length run.binders.length) + (run.result'.liftN Bs.length run.binders.length) := by + have henv : VEnv.WF env := by + simpa only [contextRun.venv_eq] using contextRun.candidate.context.Ewf + simpa only [List.append_assoc, Nat.add_zero] using + run.spine.weakN henv.ordered + (Ctx.LiftN.consTel run.binders + (Ctx.LiftN.zero (n := Bs.length) + (Γ := contextRun.candidate.context.vlctx.toCtx) Bs)) + +end ConstructorPreFamilyRecursiveSemanticRun + +/-- Exact executable pre-family replay for one analyzer-owned constructor view. + +`removed` contains precisely the validation FVars allocated for recursive +outer fields that were not inserted into the pre-family checker context. +`recursiveStarted` records whether such a field has been crossed; later +ordinary fields are admitted exactly when they are independent of `removed`. -/ +inductive ConstructorPreFamilyViewTrace + (stats : InductiveStats) (familyIdx : Nat) (familyIndices : Expr) : + (context : Context) → (view : Expr) → (argIdx : Nat) → + (removed : List FVarId) → (recursiveStarted : Bool) → Type where + | parameter + (context : Context) (argIdx : Nat) (removed : List FVarId) + (recursiveStarted : Bool) + (name : Name) (domain body : Expr) (binderInfo : BinderInfo) + (parameter : Expr) + (parameterAt : stats.params[argIdx]? = some parameter) + (tail : ConstructorPreFamilyViewTrace stats familyIdx familyIndices + context (body.instantiate1 parameter) (argIdx + 1) removed + recursiveStarted) : + ConstructorPreFamilyViewTrace stats familyIdx familyIndices context + (.forallE name domain body binderInfo) argIdx removed recursiveStarted + | ordinary + (context : Context) (argIdx : Nat) (removed : List FVarId) + (recursiveStarted : Bool) + (name : Name) (domain body : Expr) (binderInfo : BinderInfo) + (noParameter : stats.params[argIdx]? = none) + (nonrecursive : hasIndOcc stats.indConsts domain = false) + (independent : constructorIndependentOf domain removed = true) + (domainCheck : ConstructorCheckedExpr context domain) + (ensureType : ConstructorEnsureTypeObservation context domain) + (consumedCheck : ConstructorCheckedExpr context + (consumeTypeAnnotations domain)) + (annotations : CandidateIsDefEqObservation context domain + (consumeTypeAnnotations domain)) + (fresh : context.lctx.find? context.freshFVarId = none) + (tail : ConstructorPreFamilyViewTrace stats familyIdx familyIndices + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) removed + recursiveStarted) : + ConstructorPreFamilyViewTrace stats familyIdx familyIndices context + (.forallE name domain body binderInfo) argIdx removed recursiveStarted + | recursive + (context : Context) (argIdx : Nat) (removed : List FVarId) + (recursiveStarted : Bool) + (name : Name) (domain body : Expr) (binderInfo : BinderInfo) + (noParameter : stats.params[argIdx]? = none) + (isRecursive : hasIndOcc stats.indConsts domain = true) + (independent : constructorIndependentOf domain removed = true) + (field : ConstructorPreFamilyRecursiveTrace stats familyIdx + familyIndices context domain context.fuel.inductiveFuel) + (fresh : context.lctx.find? context.freshFVarId = none) + (tail : ConstructorPreFamilyViewTrace stats familyIdx familyIndices + context.advanceFresh (body.instantiate1 context.freshExpr) + (argIdx + 1) (context.freshFVarId :: removed) true) : + ConstructorPreFamilyViewTrace stats familyIdx familyIndices context + (.forallE name domain body binderInfo) argIdx removed recursiveStarted + | terminal + (context : Context) (source : Expr) (argIdx : Nat) + (removed : List FVarId) (recursiveStarted : Bool) + (valid : isValidIndAppIdx stats source familyIdx = true) + (independent : constructorIndependentOf source removed = true) + (spine : ConstructorPreFamilyIndexSpineTrace context familyIndices + (source.getAppArgs.toList.drop stats.params.size)) : + ConstructorPreFamilyViewTrace stats familyIdx familyIndices context + source argIdx removed recursiveStarted + +namespace ConstructorPreFamilyViewTrace + +def build (stats : InductiveStats) (familyIdx : Nat) + (familyIndices : Expr) : + (context : Context) → (view : Expr) → (argIdx : Nat) → + (removed : List FVarId) → (recursiveStarted : Bool) → (fuel : Nat) → + Except Exception + (ConstructorPreFamilyViewTrace stats familyIdx familyIndices context view + argIdx removed recursiveStarted) + | _, _, _, _, _, 0 => throw .deepRecursion + | context, .forallE name domain body binderInfo, argIdx, removed, + recursiveStarted, fuel + 1 => + match parameterAt : stats.params[argIdx]? with + | some param => do + let tail ← build stats familyIdx familyIndices context + (body.instantiate1 param) (argIdx + 1) removed + recursiveStarted fuel + pure <| .parameter context argIdx removed recursiveStarted name domain + body binderInfo param parameterAt tail + | none => do + match recursive : hasIndOcc stats.indConsts domain with + | false => + if independent : constructorIndependentOf domain removed = true then + let domainCheck ← checkConstructorAlignedExpr context domain + let ensureType ← observeConstructorEnsureType context domain + let consumedCheck ← checkConstructorAlignedExpr context + (consumeTypeAnnotations domain) + let annotations ← observeCandidateIsDefEq context domain + (consumeTypeAnnotations domain) + if fresh : context.lctx.find? context.freshFVarId = none then + let tail ← build stats familyIdx familyIndices + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) + removed recursiveStarted fuel + pure <| .ordinary context argIdx removed recursiveStarted + name domain body binderInfo parameterAt recursive independent domainCheck + ensureType consumedCheck annotations fresh tail + else + throw <| .other + "pre-family ordinary replay reused a local identifier" + else + throw <| .other + "constructor depends on an omitted recursive local" + | true => + if independent : constructorIndependentOf domain removed = true then + let field ← ConstructorPreFamilyRecursiveTrace.build stats + familyIdx familyIndices context domain + context.fuel.inductiveFuel + if fresh : context.lctx.find? context.freshFVarId = none then + let tail ← build stats familyIdx familyIndices + context.advanceFresh + (body.instantiate1 context.freshExpr) (argIdx + 1) + (context.freshFVarId :: removed) true fuel + pure <| .recursive context argIdx removed recursiveStarted + name domain body binderInfo parameterAt recursive independent + field fresh tail + else + throw <| .other + "pre-family recursive replay reused a local identifier" + else + throw <| .other + "constructor depends on an omitted recursive local" + | context, source, argIdx, removed, recursiveStarted, _ + 1 => do + if valid : isValidIndAppIdx stats source familyIdx = true then + if independent : constructorIndependentOf source removed = true then + let spine ← ConstructorPreFamilyIndexSpineTrace.build context + familyIndices + (source.getAppArgs.toList.drop stats.params.size) + pure <| .terminal context source argIdx removed recursiveStarted valid + independent spine + else + throw <| .other + "constructor result depends on an omitted recursive local" + else + throw <| .other + "pre-family replay reached a non-family constructor result" + +end ConstructorPreFamilyViewTrace + +theorem ConstructorPreFamilyViewTrace.terminal_build_eq + (terminal : source.isForall = false) + (valid : isValidIndAppIdx stats source familyIdx = true) + (independent : constructorIndependentOf source removed = true) + (spine : ConstructorPreFamilyIndexSpineTrace context familyIndices + (source.getAppArgs.toList.drop stats.params.size)) : + ConstructorPreFamilyViewTrace.build stats familyIdx familyIndices + context source argIdx removed recursiveStarted (fuel + 1) = + .ok (.terminal context source argIdx removed recursiveStarted valid + independent spine) := by + cases source <;> simp only [ConstructorPreFamilyViewTrace.build] + case forallE => simp [Expr.isForall] at terminal + all_goals + rw [dif_pos valid, dif_pos independent, spine.build_eq] + rfl + +/-! +### Verified pre-family constructor views + +This interpretation follows the exact executable D3 trace. Ordinary fields +are checked and pushed in the pre-family context, recursive outer fields are +omitted while their family-free nested binders and indices are retained, and +the terminal result contributes its verified index spine. +-/ + +/-- Verified meaning of every family-free operation retained by one exact +pre-family constructor-view replay. -/ +inductive ConstructorPreFamilyViewSemanticRun + (env : VEnv) (Us : List Name) + (stats : InductiveStats) (familyIdx : Nat) (familyIndices : Expr) : + {context : Context} → {view : Expr} → {argIdx : Nat} → + {removed : List FVarId} → {recursiveStarted : Bool} → + (contextRun : ConstructorContextRun env Us context) → + ConstructorPreFamilyViewTrace stats familyIdx familyIndices context view + argIdx removed recursiveStarted → Type where + | parameter + {context : Context} {argIdx : Nat} {removed : List FVarId} + {recursiveStarted : Bool} + {name : Name} {domain body : Expr} {binderInfo : BinderInfo} + {parameter : Expr} + {parameterAt : stats.params[argIdx]? = some parameter} + {tailTrace : ConstructorPreFamilyViewTrace stats familyIdx familyIndices + context (body.instantiate1 parameter) (argIdx + 1) removed + recursiveStarted} + {contextRun : ConstructorContextRun env Us context} + (tail : ConstructorPreFamilyViewSemanticRun env Us stats familyIdx + familyIndices contextRun tailTrace) : + ConstructorPreFamilyViewSemanticRun env Us stats familyIdx familyIndices + contextRun + (.parameter context argIdx removed recursiveStarted name domain body + binderInfo parameter parameterAt tailTrace) + | ordinary + {context : Context} {argIdx : Nat} {removed : List FVarId} + {recursiveStarted : Bool} + {name : Name} {domain body : Expr} {binderInfo : BinderInfo} + {noParameter : stats.params[argIdx]? = none} + {nonrecursive : hasIndOcc stats.indConsts domain = false} + {independent : constructorIndependentOf domain removed = true} + {domainCheck : ConstructorCheckedExpr context domain} + {ensureType : ConstructorEnsureTypeObservation context domain} + {consumedCheck : ConstructorCheckedExpr context + (consumeTypeAnnotations domain)} + {annotations : CandidateIsDefEqObservation context domain + (consumeTypeAnnotations domain)} + {fresh : context.lctx.find? context.freshFVarId = none} + {tailTrace : ConstructorPreFamilyViewTrace stats familyIdx familyIndices + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) removed + recursiveStarted} + {contextRun : ConstructorContextRun env Us context} + (domainRun : ConstructorCheckedExpr.Run domainCheck + contextRun.candidate) + (consumedRun : ConstructorCheckedExpr.Run consumedCheck + contextRun.candidate) + (ensureTypeRun : TypeChecker.EnsureTypeRun + contextRun.candidate.context.venv + contextRun.candidate.context.lparams + contextRun.candidate.context.vlctx domain ensureType.result + domainRun.source') + (annotationsRun : TypeChecker.IsDefEqRun + contextRun.candidate.context.venv + contextRun.candidate.context.lparams + contextRun.candidate.context.vlctx domain + (consumeTypeAnnotations domain) domainRun.source' + consumedRun.source') + (consumedType : contextRun.candidate.context.IsType + consumedRun.source') + (tail : ConstructorPreFamilyViewSemanticRun env Us stats familyIdx + familyIndices + (contextRun.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain) fresh consumedRun.source' + consumedRun.check.expr_tr consumedType) + tailTrace) : + ConstructorPreFamilyViewSemanticRun env Us stats familyIdx familyIndices + contextRun + (.ordinary context argIdx removed recursiveStarted name domain body + binderInfo noParameter nonrecursive independent domainCheck ensureType + consumedCheck annotations fresh tailTrace) + | recursive + {context : Context} {argIdx : Nat} {removed : List FVarId} + {recursiveStarted : Bool} + {name : Name} {domain body : Expr} {binderInfo : BinderInfo} + {noParameter : stats.params[argIdx]? = none} + {isRecursive : hasIndOcc stats.indConsts domain = true} + {independent : constructorIndependentOf domain removed = true} + {fieldTrace : ConstructorPreFamilyRecursiveTrace stats familyIdx + familyIndices context domain context.fuel.inductiveFuel} + {fresh : context.lctx.find? context.freshFVarId = none} + {tailTrace : ConstructorPreFamilyViewTrace stats familyIdx familyIndices + context.advanceFresh (body.instantiate1 context.freshExpr) + (argIdx + 1) (context.freshFVarId :: removed) true} + {contextRun : ConstructorContextRun env Us context} + (field : ConstructorPreFamilyRecursiveSemanticRun env Us stats familyIdx + familyIndices contextRun fieldTrace) + (tail : ConstructorPreFamilyViewSemanticRun env Us stats familyIdx + familyIndices contextRun.advanceFresh tailTrace) : + ConstructorPreFamilyViewSemanticRun env Us stats familyIdx familyIndices + contextRun + (.recursive context argIdx removed recursiveStarted name domain body + binderInfo noParameter isRecursive independent fieldTrace fresh + tailTrace) + | terminal + {context : Context} {source : Expr} {argIdx : Nat} + {removed : List FVarId} {recursiveStarted : Bool} + {valid : isValidIndAppIdx stats source familyIdx = true} + {independent : constructorIndependentOf source removed = true} + {spineTrace : ConstructorPreFamilyIndexSpineTrace context familyIndices + (source.getAppArgs.toList.drop stats.params.size)} + {contextRun : ConstructorContextRun env Us context} + (expected' : VExpr) + (spine : ConstructorPreFamilyIndexSpineSemanticRun env Us context + contextRun spineTrace expected') : + ConstructorPreFamilyViewSemanticRun env Us stats familyIdx familyIndices + contextRun + (.terminal context source argIdx removed recursiveStarted valid + independent spineTrace) + +namespace ConstructorPreFamilyViewSemanticRun + +/-- Interpret every exact family-free checker observation in a successful +constructor-view replay. -/ +theorem nonempty + (contextRun : ConstructorContextRun env Us context) + (trace : ConstructorPreFamilyViewTrace stats familyIdx familyIndices + context view argIdx removed recursiveStarted) : + Nonempty (ConstructorPreFamilyViewSemanticRun env Us stats familyIdx + familyIndices contextRun trace) := by + induction trace with + | parameter context argIdx removed recursiveStarted name domain body + binderInfo parameter parameterAt tailTrace ih => + obtain ⟨tail⟩ := ih contextRun + exact ⟨.parameter tail⟩ + | ordinary context argIdx removed recursiveStarted name domain body + binderInfo noParameter nonrecursive independent domainCheck ensureType + consumedCheck annotations fresh tailTrace ih => + obtain ⟨domainRun⟩ := ConstructorCheckedExpr.Run.exists domainCheck + contextRun.candidate + obtain ⟨consumedRun⟩ := ConstructorCheckedExpr.Run.exists consumedCheck + contextRun.candidate + obtain ⟨ensureTypeRun⟩ := + TypeChecker.EnsureTypeRun.exists_ofConstructorStep + ⟨context, domain, ensureType.result⟩ ensureType.valid + contextRun.candidate domainRun.source' domainRun.check.expr_tr + let annotationsRun := domainRun.isDefEq consumedRun annotations + have consumedType : contextRun.candidate.context.IsType + consumedRun.source' := by + have annotationDef := annotationsRun.isDefEqU.of_l + contextRun.candidate.context.Ewf + contextRun.candidate.context.Δwf.toCtx ensureTypeRun.source_type + exact ⟨ensureTypeRun.resultLevel', annotationDef.hasType.2⟩ + let tailContext := contextRun.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain) fresh consumedRun.source' + consumedRun.check.expr_tr consumedType + obtain ⟨tail⟩ := ih tailContext + exact ⟨.ordinary domainRun consumedRun ensureTypeRun annotationsRun + consumedType tail⟩ + | recursive context argIdx removed recursiveStarted name domain body + binderInfo noParameter isRecursive independent fieldTrace fresh + tailTrace tailIH => + obtain ⟨field⟩ := + ConstructorPreFamilyRecursiveSemanticRun.nonempty contextRun fieldTrace + obtain ⟨tail⟩ := tailIH contextRun.advanceFresh + exact ⟨.recursive field tail⟩ + | terminal context source argIdx removed recursiveStarted valid independent + spineTrace => + obtain ⟨expected', ⟨spine⟩⟩ := + ConstructorPreFamilyIndexSpineSemanticRun.nonempty contextRun spineTrace + exact ⟨.terminal expected' spine⟩ + +end ConstructorPreFamilyViewSemanticRun + +private theorem drop_eq_cons_of_getElem?_eq_some + {values : List α} {index : Nat} {value : α} + (atIndex : values[index]? = some value) : + values.drop index = value :: values.drop (index + 1) := by + induction values generalizing index with + | nil => simp at atIndex + | cons head tail ih => + cases index with + | zero => + simp at atIndex + simpa [atIndex] + | succ index => + simp at atIndex ⊢ + simpa [Nat.add_assoc, Nat.add_comm 1] using ih atIndex + +private theorem eq_length_of_getElem?_eq_none + {values : List α} {index : Nat} + (atIndex : values[index]? = none) + (indexLe : index ≤ values.length) : + index = values.length := by + induction values generalizing index with + | nil => simp_all + | cons head tail ih => + cases index with + | zero => simp at atIndex + | succ index => + simp at atIndex + simp only [List.length_cons, Nat.succ_le_succ_iff] at indexLe + have indexEq : index = tail.length := + Nat.le_antisymm indexLe atIndex + simp [indexEq] + +/-- The exact D3 suffix after consuming every validator-owned parameter. +The context is unchanged because parameter branches instantiate existing +locals rather than pushing constructor fields. -/ +structure ConstructorPreFamilyParameterSuffix + {env : VEnv} {Us : List Name} + {stats : InductiveStats} {familyIndices : Expr} + {context : Context} + {removed : List FVarId} {recursiveStarted : Bool} + {contextRun : ConstructorContextRun env Us context} + (rest : Expr) where + trace : ConstructorPreFamilyViewTrace stats 0 familyIndices + context rest stats.params.size removed recursiveStarted + semantic : ConstructorPreFamilyViewSemanticRun env Us stats 0 + familyIndices contextRun trace + +namespace ConstructorPreFamilyViewSemanticRun + +/-- Strip the exact validator-owned parameter prefix from a verified D3 +view trace. The successful executable instantiation equation excludes an +early terminal, while the indexed parameter lookups exclude an early field. -/ +theorem afterParameters + {env : VEnv} {Us : List Name} + {stats : InductiveStats} {familyIndices : Expr} + {familyName : Name} {levels : List Level} + {context : Context} {view rest : Expr} {argIdx : Nat} + {removed : List FVarId} {recursiveStarted : Bool} + {contextRun : ConstructorContextRun env Us context} + {trace : ConstructorPreFamilyViewTrace stats 0 familyIndices + context view argIdx removed recursiveStarted} + (semantic : ConstructorPreFamilyViewSemanticRun env Us stats 0 + familyIndices contextRun trace) + (indConsts : stats.indConsts = #[.const familyName levels]) + (argIdxLe : argIdx ≤ stats.params.size) + (instantiation : instantiateFamilyParameters view + (stats.params.toList.drop argIdx) = .ok rest) : + Nonempty (ConstructorPreFamilyParameterSuffix + (env := env) (Us := Us) (stats := stats) + (familyIndices := familyIndices) (context := context) + (removed := removed) (recursiveStarted := recursiveStarted) + (contextRun := contextRun) rest) := by + induction semantic generalizing rest with + | @parameter context argIdx removed recursiveStarted name domain body + binderInfo parameter parameterAt tailTrace contextRun tail ih => + have atList : stats.params.toList[argIdx]? = some parameter := by + simpa only [← Array.getElem?_toList] using parameterAt + have dropped := drop_eq_cons_of_getElem?_eq_some atList + rw [dropped] at instantiation + simp only [instantiateFamilyParameters] at instantiation + have argIdxLt : argIdx < stats.params.size := by + by_contra notLt + have argIdxEq : argIdx = stats.params.size := by omega + subst argIdx + simp at parameterAt + exact ih (by omega) instantiation + | @ordinary context argIdx removed recursiveStarted name domain body + binderInfo noParameter nonrecursive independent domainCheck ensureType + consumedCheck annotations fresh tailTrace contextRun domainRun consumedRun + ensureTypeRun annotationsRun consumedType tail => + have noParameterList : stats.params.toList[argIdx]? = none := by + simpa only [← Array.getElem?_toList] using noParameter + have argIdxEq : argIdx = stats.params.toList.length := + eq_length_of_getElem?_eq_none noParameterList (by simpa using argIdxLe) + have sizeEq : stats.params.toList.length = stats.params.size := by simp + rw [sizeEq] at argIdxEq + subst argIdx + have dropEq : stats.params.toList.drop stats.params.size = [] := by + simpa using List.drop_length stats.params.toList + rw [dropEq] at instantiation + have viewEq : (.forallE name domain body binderInfo) = rest := + Except.ok.inj (by + change Except.ok (.forallE name domain body binderInfo) = + Except.ok rest at instantiation + exact instantiation) + subst rest + let suffixTrace := ConstructorPreFamilyViewTrace.ordinary context + stats.params.size removed recursiveStarted name domain body binderInfo + noParameter nonrecursive independent domainCheck ensureType consumedCheck + annotations fresh tailTrace + exact ⟨⟨suffixTrace, + ConstructorPreFamilyViewSemanticRun.ordinary domainRun consumedRun + ensureTypeRun annotationsRun consumedType tail⟩⟩ + | @recursive context argIdx removed recursiveStarted name domain body + binderInfo noParameter isRecursive independent fieldTrace fresh tailTrace + contextRun field tail => + have noParameterList : stats.params.toList[argIdx]? = none := by + simpa only [← Array.getElem?_toList] using noParameter + have argIdxEq : argIdx = stats.params.toList.length := + eq_length_of_getElem?_eq_none noParameterList (by simpa using argIdxLe) + have sizeEq : stats.params.toList.length = stats.params.size := by simp + rw [sizeEq] at argIdxEq + subst argIdx + have dropEq : stats.params.toList.drop stats.params.size = [] := by + simpa using List.drop_length stats.params.toList + rw [dropEq] at instantiation + have viewEq : (.forallE name domain body binderInfo) = rest := + Except.ok.inj (by + change Except.ok (.forallE name domain body binderInfo) = + Except.ok rest at instantiation + exact instantiation) + subst rest + let suffixTrace := ConstructorPreFamilyViewTrace.recursive context + stats.params.size removed recursiveStarted name domain body binderInfo + noParameter isRecursive independent fieldTrace fresh tailTrace + exact ⟨⟨suffixTrace, + ConstructorPreFamilyViewSemanticRun.recursive field tail⟩⟩ + | @terminal context source argIdx removed recursiveStarted valid independent + spineTrace contextRun expected spine => + by_cases argIdxEq : argIdx = stats.params.size + · subst argIdx + have dropEq : stats.params.toList.drop stats.params.size = [] := by + simpa using List.drop_length stats.params.toList + rw [dropEq] at instantiation + have viewEq : source = rest := + Except.ok.inj (by + change Except.ok source = Except.ok rest at instantiation + exact instantiation) + subst rest + let suffixTrace := ConstructorPreFamilyViewTrace.terminal context source + stats.params.size removed recursiveStarted valid independent + spineTrace + exact ⟨⟨suffixTrace, + ConstructorPreFamilyViewSemanticRun.terminal expected spine⟩⟩ + · have argIdxLt : argIdx < stats.params.size := by omega + obtain ⟨parameter, parameterAt⟩ : + ∃ parameter, stats.params.toList[argIdx]? = some parameter := by + have listLt : argIdx < stats.params.toList.length := by + simpa using argIdxLt + exact ⟨stats.params.toList[argIdx], by + simp only [List.getElem?_eq_getElem listLt]⟩ + have dropped := drop_eq_cons_of_getElem?_eq_some parameterAt + rw [dropped] at instantiation + cases source <;> + simp only [instantiateFamilyParameters] at instantiation + case forallE binderName binderType body binderInfo => + unfold isValidIndAppIdx at valid + rw [indConsts] at valid + simp only [Expr.withApp_eq, Expr.getAppFn] at valid + cases headEq : + ((.forallE binderName binderType body binderInfo : Expr) == + .const familyName levels) with + | false => simp [headEq] at valid + | true => + change Expr.eqv + (.forallE binderName binderType body binderInfo) + (.const familyName levels) = true at headEq + rw [Expr.eqv_eq] at headEq + simp [Expr.eqv'] at headEq + all_goals exact nomatch instantiation + +end ConstructorPreFamilyViewSemanticRun + +/-- The exact D2 suffix after consuming every validator-owned parameter. +Both the executable alignment and its verified semantic interpretation are +retained at the first ordinary field or terminal result. -/ +structure ConstructorViewParameterSuffix + {env : VEnv} {Us : List Name} {whnfFuel : Nat} + {stats : InductiveStats} {isUnsafe : Bool} {familyIdx : Nat} + {ctor : Name} {context : Context} + {contextRun : ConstructorContextRun env Us context} + (rest : Expr) where + source : Expr + fuel : Nat + trace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source stats.params.size fuel + alignment : ConstructorViewAlignmentTrace trace rest + semantic : ConstructorViewSemanticRun env Us whnfFuel contextRun trace rest + +namespace ConstructorViewSemanticRun + +/-- Strip the exact parameter prefix shared by D2's validation trace and +analyzer view alignment. Parameter lookups exclude an early ordinary field; +the alignment's retained non-Pi fact excludes an early terminal. -/ +theorem afterParameters + {env : VEnv} {Us : List Name} {whnfFuel : Nat} + {stats : InductiveStats} {isUnsafe : Bool} {familyIdx : Nat} + {ctor : Name} {context : Context} {source view rest : Expr} + {argIdx fuel : Nat} + {contextRun : ConstructorContextRun env Us context} + {trace : ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context source argIdx fuel} + (alignment : ConstructorViewAlignmentTrace trace view) + (semantic : ConstructorViewSemanticRun env Us whnfFuel contextRun trace + view) + (argIdxLe : argIdx ≤ stats.params.size) + (instantiation : instantiateFamilyParameters view + (stats.params.toList.drop argIdx) = .ok rest) : + ∃ suffix : ConstructorViewParameterSuffix + (env := env) (Us := Us) (whnfFuel := whnfFuel) + (stats := stats) (isUnsafe := isUnsafe) (familyIdx := familyIdx) + (ctor := ctor) (context := context) (contextRun := contextRun) rest, + suffix.trace.universeSemantics = trace.universeSemantics := by + induction trace generalizing view rest with + | parameter context fuel argIdx name domain body binderInfo param + parameterType parameterAt parameterTypeRun validationDefEq tailTrace ih => + cases alignment with + | parameter domainCheck viewDomainCheck parameterTypeCheck + parameterShape parameterPresent _ tailAlignment => + cases semantic with + | parameter domainRun viewDomainRun parameterTypeSemantic validationRun + tail => + have atList : stats.params.toList[argIdx]? = some param := by + simpa only [← Array.getElem?_toList] using parameterAt + have dropped := drop_eq_cons_of_getElem?_eq_some atList + rw [dropped] at instantiation + simp only [instantiateFamilyParameters] at instantiation + obtain ⟨suffix, suffixUniverse⟩ := ih tailAlignment tail (by + have argIdxLt : argIdx < stats.params.size := by + by_contra notLt + have argIdxEq : argIdx = stats.params.size := by omega + subst argIdx + simp at parameterAt + omega) instantiation + exact ⟨suffix, by + simpa only [ConstructorTypeValidationTrace.universeSemantics] + using suffixUniverse⟩ + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureTypeStep universeTrace positivityTrace tailTrace ih => + cases alignment with + | @ordinary _ _ viewDomain _ _ _ _ _ _ _ _ _ _ _ _ _ viewName + viewBody viewBinderInfo domainCheck viewDomainCheck viewEquality + consumedCheck _ positivityAlignment fresh annotations _ + tailAlignment => + cases semantic with + | ordinary domainRun viewDomainRun viewEqualityRun consumedRun + ensureTypeRun positivity annotationsRun consumedType tail => + have noParameterList : stats.params.toList[argIdx]? = none := by + simpa only [← Array.getElem?_toList] using noParameter + have argIdxEq : argIdx = stats.params.toList.length := + eq_length_of_getElem?_eq_none noParameterList + (by simpa using argIdxLe) + have sizeEq : stats.params.toList.length = stats.params.size := by + simp + rw [sizeEq] at argIdxEq + subst argIdx + have dropEq : stats.params.toList.drop stats.params.size = [] := by + simpa using List.drop_length stats.params.toList + rw [dropEq] at instantiation + injection instantiation with restEq + subst rest + let suffixTrace := ConstructorTypeValidationTrace.ordinary context + fuel stats.params.size name domain body binderInfo sortResult + noParameter ensureTypeStep universeTrace positivityTrace tailTrace + have suffixAlignment : ConstructorViewAlignmentTrace suffixTrace + (.forallE viewName viewDomain viewBody viewBinderInfo) := + ConstructorViewAlignmentTrace.ordinary domainCheck + viewDomainCheck viewEquality consumedCheck positivityTrace + positivityAlignment fresh annotations tailTrace tailAlignment + have suffixSemantic : ConstructorViewSemanticRun env Us whnfFuel + contextRun suffixTrace + (.forallE viewName viewDomain viewBody viewBinderInfo) := + ConstructorViewSemanticRun.ordinary + (viewEquality := viewEquality) domainRun viewDomainRun + viewEqualityRun consumedRun ensureTypeRun positivity + annotationsRun consumedType tail + exact ⟨⟨_, fuel + 1, suffixTrace, suffixAlignment, + suffixSemantic⟩, rfl⟩ + | terminal context source fuel argIdx sourceTerminal sourceValid => + cases alignment with + | terminal sourceCheck viewCheck viewTerminal viewValid => + cases semantic with + | terminal sourceRun viewRun => + by_cases argIdxEq : argIdx = stats.params.size + · subst argIdx + have dropEq : stats.params.toList.drop stats.params.size = [] := by + simpa using List.drop_length stats.params.toList + rw [dropEq] at instantiation + have viewEq : view = rest := Except.ok.inj instantiation + subst rest + let suffixTrace : ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source stats.params.size (fuel + 1) := + ConstructorTypeValidationTrace.terminal context source fuel + stats.params.size sourceTerminal sourceValid + have suffixAlignment : ConstructorViewAlignmentTrace suffixTrace + view := + ConstructorViewAlignmentTrace.terminal sourceCheck viewCheck + viewTerminal viewValid + have suffixSemantic : ConstructorViewSemanticRun env Us whnfFuel + contextRun suffixTrace view := + ConstructorViewSemanticRun.terminal (isUnsafe := isUnsafe) + (ctor := ctor) sourceRun viewRun + exact ⟨⟨source, fuel + 1, suffixTrace, suffixAlignment, + suffixSemantic⟩, rfl⟩ + · have argIdxLt : argIdx < stats.params.size := by omega + obtain ⟨parameter, parameterAt⟩ : + ∃ parameter, stats.params.toList[argIdx]? = some parameter := by + have listLt : argIdx < stats.params.toList.length := by + simpa using argIdxLt + exact ⟨stats.params.toList[argIdx], by + simp only [List.getElem?_eq_getElem listLt]⟩ + have dropped := drop_eq_cons_of_getElem?_eq_some parameterAt + rw [dropped] at instantiation + cases view <;> + simp_all [instantiateFamilyParameters, Expr.isForall] + +end ConstructorViewSemanticRun + +private def candidateForallDepth : Expr → Nat + | .forallE _ _ body _ => candidateForallDepth body + 1 + | _ => 0 + +private theorem candidateForallDepth_le_instantiate1' + (expression argument : Expr) (depth : Nat) : + candidateForallDepth expression ≤ + candidateForallDepth (expression.instantiate1' argument depth) := by + induction expression generalizing depth <;> + simp [candidateForallDepth, Expr.instantiate1', *] + +private theorem candidateForallDepth_abstract1 + (expression : Expr) (id : FVarId) (depth : Nat) : + candidateForallDepth (Expr.abstract1 id expression depth) = + candidateForallDepth expression := by + induction expression generalizing depth <;> + simp [candidateForallDepth, Expr.abstract1, *] + split <;> rfl + +private theorem candidateForallDepth_abstractList + (expression : Expr) (ids : List FVarId) (depth : Nat) : + candidateForallDepth (Expr.abstractList expression ids depth) = + candidateForallDepth expression := by + induction ids generalizing expression with + | nil => rfl + | cons id ids ih => + simp only [Expr.abstractList, ih, candidateForallDepth_abstract1] + +private theorem candidateForallDepth_abstract + (expression : Expr) (ids : List FVarId) : + candidateForallDepth (expression.abstract ⟨ids.map Expr.fvar⟩) = + candidateForallDepth expression := by + rw [Expr.abstract_eq] + exact candidateForallDepth_abstractList expression ids 0 + +private theorem candidateView_forallDepth + (trace : CandidateExprTrace context source) : + trace.spineLength ≤ candidateForallDepth trace.view := by + induction trace with + | terminal => exact Nat.zero_le _ + | forallE context source inferred name domain body binderInfo fresh + annotations annotationsEq checked normalized domainCandidate + bodyCandidate domainIH bodyIH => + simp only [CandidateExprTrace.view, candidateForallDepth, + CandidateExprTrace.spineLength] + rw [show #[context.freshExpr] = + ⟨[context.freshFVarId].map Expr.fvar⟩ by rfl, + candidateForallDepth_abstract] + omega + +private theorem instantiateFamilyParameters_exists_of_forallDepth + (length : parameters.length ≤ candidateForallDepth source) : + ∃ rest, instantiateFamilyParameters source parameters = .ok rest := by + induction parameters generalizing source with + | nil => exact ⟨source, rfl⟩ + | cons parameter parameters ih => + cases source <;> simp [candidateForallDepth] at length + case forallE name domain body binderInfo => + have bodyLength : parameters.length ≤ candidateForallDepth + (body.instantiate1 parameter) := by + rw [Expr.instantiate1_eq] + exact Nat.le_trans + (by omega : parameters.length ≤ candidateForallDepth body) + (candidateForallDepth_le_instantiate1' body parameter 0) + obtain ⟨rest, restEq⟩ := ih bodyLength + exact ⟨rest, restEq⟩ + +/-- A reconstructed candidate view can instantiate any parameter list no +longer than its retained main Pi spine. This is only a syntactic success +fact; the exact Theory endpoint is supplied separately by strict translation. -/ +theorem CandidateExprTrace.instantiateViewParameters + (trace : CandidateExprTrace context source) + (parameters : List Expr) + (length : parameters.length ≤ trace.spineLength) : + ∃ rest, instantiateFamilyParameters trace.view parameters = .ok rest := by + apply instantiateFamilyParameters_exists_of_forallDepth + exact Nat.le_trans length (candidateView_forallDepth trace) + +namespace ConstructorPreFamilyViewSemanticRun + +/-- Weaken an exact ordinary-field type over any later field prefix. -/ +theorem ordinaryType_weakPrefix + (contextRun : ConstructorContextRun env Us context) + {fieldType : VExpr} + (fieldTypeWF : contextRun.candidate.context.IsType fieldType) + (Bs : List VExpr) : + env.IsType Us.length + (Bs ++ contextRun.candidate.context.vlctx.toCtx) + (fieldType.liftN Bs.length 0) := by + have henv : VEnv.WF env := by + simpa only [contextRun.venv_eq] using contextRun.candidate.context.Ewf + have fieldTypeWF' : env.IsType Us.length + contextRun.candidate.context.vlctx.toCtx fieldType := by + simpa only [VContext.IsType, contextRun.venv_eq, + contextRun.lparams_eq] using fieldTypeWF + exact fieldTypeWF'.weakN henv.ordered + (Ctx.LiftN.zero (n := Bs.length) + (Γ := contextRun.candidate.context.vlctx.toCtx) Bs) + +end ConstructorPreFamilyViewSemanticRun + +/-- Source-ordered D3 traces for the exact dependent constructor candidate +list selected by the producer. -/ +inductive ConstructorPreFamilyListTrace + (stats : InductiveStats) (familyIdx : Nat) (familyIndices : Expr) + (context : Context) : + {constructors : List Constructor} → + AddInductive.CandidateList AddInductive.CandidateConstructor constructors → + Type where + | nil : ConstructorPreFamilyListTrace stats familyIdx familyIndices context + .nil + | cons + (head : ConstructorPreFamilyViewTrace stats familyIdx familyIndices + context candidate.type.view 0 [] false) + (tail : ConstructorPreFamilyListTrace stats familyIdx familyIndices + context candidates) : + ConstructorPreFamilyListTrace stats familyIdx familyIndices context + (.cons candidate candidates) + +namespace ConstructorPreFamilyListTrace + +def build (stats : InductiveStats) (familyIdx : Nat) + (familyIndices : Expr) (context : Context) : + (candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors) → + Except Exception + (ConstructorPreFamilyListTrace stats familyIdx familyIndices context + candidates) + | .nil => pure .nil + | .cons head tail => do + let headTrace ← ConstructorPreFamilyViewTrace.build stats familyIdx + familyIndices context head.type.view 0 [] false + context.fuel.inductiveFuel + let tailTrace ← build stats familyIdx familyIndices context tail + pure <| .cons headTrace tailTrace + +end ConstructorPreFamilyListTrace + +theorem ConstructorPreFamilyListTrace.cons_build_eq + (head : ConstructorPreFamilyViewTrace stats familyIdx familyIndices context + candidate.type.view 0 [] false) + (headRun : ConstructorPreFamilyViewTrace.build stats familyIdx + familyIndices context candidate.type.view 0 [] false + context.fuel.inductiveFuel = .ok head) + (tail : ConstructorPreFamilyListTrace stats familyIdx familyIndices context + candidates) + (tailRun : ConstructorPreFamilyListTrace.build stats familyIdx + familyIndices context candidates = .ok tail) : + ConstructorPreFamilyListTrace.build stats familyIdx familyIndices context + (.cons candidate candidates) = .ok (.cons head tail) := by + simp only [ConstructorPreFamilyListTrace.build] + rw [headRun] + simp only [Bind.bind, Except.bind] + rw [tailRun] + rfl + +/-- Source-ordered verified pre-family meaning for every analyzer-owned +constructor candidate selected by the executable D3 gate. -/ +inductive ConstructorPreFamilyListSemanticRun + (env : VEnv) (Us : List Name) + (stats : InductiveStats) (familyIdx : Nat) (familyIndices : Expr) + (context : Context) (contextRun : ConstructorContextRun env Us context) : + {constructors : List Constructor} → + {candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors} → + ConstructorPreFamilyListTrace stats familyIdx familyIndices context + candidates → Type where + | nil : ConstructorPreFamilyListSemanticRun env Us stats familyIdx + familyIndices context contextRun (.nil) + | cons + {candidate : AddInductive.CandidateConstructor constructor} + {candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors} + {headTrace : ConstructorPreFamilyViewTrace stats familyIdx familyIndices + context candidate.type.view 0 [] false} + {tailTrace : ConstructorPreFamilyListTrace stats familyIdx familyIndices + context candidates} + (head : ConstructorPreFamilyViewSemanticRun env Us stats familyIdx + familyIndices contextRun headTrace) + (tail : ConstructorPreFamilyListSemanticRun env Us stats familyIdx + familyIndices context contextRun tailTrace) : + ConstructorPreFamilyListSemanticRun env Us stats familyIdx + familyIndices context contextRun (.cons headTrace tailTrace) + +namespace ConstructorPreFamilyListSemanticRun + +/-- Interpret every constructor position retained by a successful executable +D3 list trace in the same verified pre-family context. -/ +theorem nonempty + (contextRun : ConstructorContextRun env Us context) + (trace : ConstructorPreFamilyListTrace stats familyIdx familyIndices + context candidates) : + Nonempty (ConstructorPreFamilyListSemanticRun env Us stats familyIdx + familyIndices context contextRun trace) := by + induction trace with + | nil => exact ⟨.nil⟩ + | cons headTrace tailTrace ih => + obtain ⟨head⟩ := ConstructorPreFamilyViewSemanticRun.nonempty contextRun + headTrace + obtain ⟨tail⟩ := ih + exact ⟨.cons head tail⟩ + +end ConstructorPreFamilyListSemanticRun + +/-- Exact output of the executable D3 gate. -/ +structure ConstructorPreFamilySafetyTrace + (stats : InductiveStats) (familyView : Expr) + (candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors) + (context : Context) where + translationUnique : + (theoryTranslationUnique familyView && + candidates.viewTranslationUnique) = true + familyIndices : Expr + parameters : instantiateFamilyParameters familyView stats.params.toList = + .ok familyIndices + constructors : ConstructorPreFamilyListTrace stats 0 familyIndices context + candidates + +theorem ConstructorPreFamilySafetyTrace.familyTranslationUnique + (trace : ConstructorPreFamilySafetyTrace stats familyView candidates + context) : + TrExprS.IsUnique familyView := + by + have unique := trace.translationUnique + simp only [Bool.and_eq_true] at unique + exact theoryTranslationUnique_sound unique.1 + +theorem ConstructorPreFamilySafetyTrace.constructorTranslationUnique + (trace : ConstructorPreFamilySafetyTrace stats familyView candidates + context) : + candidates.ViewTranslationUnique := + by + have unique := trace.translationUnique + simp only [Bool.and_eq_true] at unique + exact candidates.viewTranslationUnique_sound unique.2 + +/-- Build the complete D3 trace or return the first structural/checker +failure. -/ +def buildConstructorPreFamilySafety + (stats : InductiveStats) (familyView : Expr) + (candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors) + (context : Context) : + Except Exception + (ConstructorPreFamilySafetyTrace stats familyView candidates context) := + match translationUnique : + theoryTranslationUnique familyView && + candidates.viewTranslationUnique with + | false => throw <| .other + "candidate view contains a projection with no exact Theory endpoint" + | true => + match parameters : + instantiateFamilyParameters familyView stats.params.toList with + | .error error => .error error + | .ok familyIndices => do + let constructors ← ConstructorPreFamilyListTrace.build stats 0 + familyIndices context candidates + pure ⟨translationUnique, familyIndices, parameters, constructors⟩ + +/-! ### Executable pre-family rejection fixtures -/ + +private def preFamilyNegativeStats : InductiveStats where + levels := [] + resultLevel := .zero + nindices := #[0] + indConsts := #[.const `PreFamilyNegative []] + params := #[] + isNotZero := true + +private def preFamilyNegativeContext : Context where + env := Kernel.Environment.ofConstants `_preFamilyNegative + ({} : ConstMap) + lparams := [] + safety := .safe + allowPrimitive := false + +/- The traversal begins from the public gate's initial state. Its first +recursive field is omitted from the pre-family context, while the following +ordinary field is independent of that local and is therefore admissible. -/ +private def preFamilyOrdinaryAfterRecursiveView : Expr := + .forallE `recursive (.const `PreFamilyNegative []) + (.forallE `ordinary (.sort .zero) + (.const `PreFamilyNegative []) .default) + .default + +private def preFamilyOrdinaryAfterRecursiveAccepted : Bool := + match ConstructorPreFamilyViewTrace.build preFamilyNegativeStats 0 + (.sort (.succ .zero)) preFamilyNegativeContext + preFamilyOrdinaryAfterRecursiveView 0 [] false + preFamilyNegativeContext.fuel.inductiveFuel with + | .ok _ => true + | .error _ => false + +#guard preFamilyOrdinaryAfterRecursiveAccepted + +/- The first recursive local is deliberately omitted. Instantiating the next +recursive field exposes that FVar in its domain, so the dependency gate must +reject it before attempting the recursive-field replay. -/ +private def preFamilyRecursiveLocalDependencyView : Expr := + .forallE `recursive (.const `PreFamilyNegative []) + (.forallE `dependent + (.app (.const `PreFamilyNegative []) (.bvar 0)) + (.const `PreFamilyNegative []) .default) + .default + +private def preFamilyRecursiveLocalDependencyRejected : Bool := + match ConstructorPreFamilyViewTrace.build preFamilyNegativeStats 0 + (.sort (.succ .zero)) preFamilyNegativeContext + preFamilyRecursiveLocalDependencyView 0 [] false + preFamilyNegativeContext.fuel.inductiveFuel with + | .error (.other message) => + message == "constructor depends on an omitted recursive local" + | _ => false + +#guard preFamilyRecursiveLocalDependencyRejected + +/-- One executable D3 gate for the complete singleton constructor list. It +both enforces the recursive-suffix/dependency subset and re-runs every +family-free checker operation in the supplied pre-family context. -/ +def checkConstructorPreFamilySafety + (stats : InductiveStats) (familyView : Expr) + (candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors) : M Unit := fun context => + if theoryTranslationUnique familyView && + candidates.viewTranslationUnique then do + let familyIndices ← instantiateFamilyParameters familyView + stats.params.toList + let _ ← ConstructorPreFamilyListTrace.build stats 0 familyIndices context + candidates + pure () + else + throw <| .other + "candidate view contains a projection with no exact Theory endpoint" + +/-- A successful executable D3 gate returns its exact parameter-instantiated +family telescope and source-ordered replay trace. -/ +theorem ConstructorPreFamilyListTrace.nonempty_of_check + (success : checkConstructorPreFamilySafety stats familyView candidates + context = .ok ()) : + Nonempty (ConstructorPreFamilySafetyTrace stats familyView candidates + context) := by + unfold checkConstructorPreFamilySafety at success + cases translationUnique : + theoryTranslationUnique familyView && + candidates.viewTranslationUnique with + | false => simp [translationUnique] at success + | true => + cases parameters : instantiateFamilyParameters familyView + stats.params.toList with + | error error => + simp [translationUnique, parameters, Bind.bind, Except.bind] at success + | ok familyIndices => + cases constructorsRun : ConstructorPreFamilyListTrace.build stats 0 + familyIndices context candidates with + | error error => + simp [translationUnique, parameters, constructorsRun, + Bind.bind, Except.bind] at success + | ok constructors => + exact ⟨⟨translationUnique, familyIndices, parameters, + constructors⟩⟩ + +end AddInductive + +namespace TypeChecker +open AddInductive + +private theorem abstract1_instantiate_self + (expression : Expr) (id : FVarId) (depth : Nat) : + Closed expression depth → + (expression.abstract1 id depth).instantiate1' (.fvar id) depth = + expression := by + induction expression generalizing depth <;> + simp_all [Closed, Expr.abstract1, Expr.instantiate1', beq_iff_eq] <;> + split <;> + simp_all [Expr.instantiate1', Expr.liftLooseBVars'] <;> + omega + +private theorem abstract_instantiate_self + (expression : Expr) (id : FVarId) (closed : Closed expression) : + (expression.abstract #[.fvar id]).instantiate1 (.fvar id) = + expression := by + rw [show #[Expr.fvar id] = ⟨[id].map Expr.fvar⟩ by rfl] + simp only [Expr.abstract_eq, Expr.abstractList, Expr.instantiate1_eq] + exact abstract1_instantiate_self expression id 0 closed + +/-- A source-ordered list of kernel parameter FVars builds an exact verified +local telescope. The final context is obtained by pushing each parameter in +order; dependency metadata is retained but never guessed by consumers. -/ +inductive CandidateParameterContext : + VLCtx → List Expr → List VExpr → VLCtx → Prop where + | nil : CandidateParameterContext base [] [] base + | cons + (tail : CandidateParameterContext + ((some (fv, deps), .vlam A) :: base) parameters types final) : + CandidateParameterContext base (.fvar fv :: parameters) + (A :: types) final + +/-- A completed analyzer-owned parameter telescope also certifies every +earlier context in that telescope. -/ +theorem CandidateParameterContext.initialWF + (params : CandidateParameterContext base parameters types final) + (finalWF : VLCtx.WF env U final) : + VLCtx.WF env U base := by + induction params with + | nil => exact finalWF + | cons tail ih => exact (ih finalWF).1 + +/-- The source parameter list and analyzer telescope carried by an exact +parameter context have the same number of entries. -/ +theorem CandidateParameterContext.length_eq + (params : CandidateParameterContext base parameters types final) : + parameters.length = types.length := by + induction params with + | nil => rfl + | cons tail ih => simp only [List.length_cons, ih] + +/-- Replay a successful kernel parameter instantiation against the exact +analyzer-owned Theory parameter telescope. Each source Pi body is opened by +the corresponding retained FVar; no whole-Pi injectivity or caller-selected +endpoint is used. -/ +theorem CandidateParameterContext.instantiateForall + (params : CandidateParameterContext base parameters types final) + (henv : VEnv.Ordered env) + (finalWF : VLCtx.WF env Us.length final) + (instantiation : instantiateFamilyParameters source parameters = .ok rest) + (tr : TrExprS env Us base source (VExpr.forallN types result)) : + TrExprS env Us final rest result := by + induction params generalizing source rest with + | nil => + have source_eq : source = rest := Except.ok.inj instantiation + subst rest + simpa only [VExpr.forallN] using tr + | @cons fv deps A base parameters types final tail ih => + cases source <;> simp only [instantiateFamilyParameters] at instantiation + case forallE name domain body binderInfo => + obtain ⟨domain', body', targetEq, domainType, bodyType, domainTr, + bodyTr⟩ := TrExprS.forallE_components tr + simp only [VExpr.forallN, VExpr.forallE.injEq] at targetEq + obtain ⟨rfl, rfl⟩ := targetEq + have nextWF : VLCtx.WF env Us.length + ((some (fv, deps), .vlam A) :: base) := + tail.initialWF finalWF + exact ih finalWF instantiation (by + simpa only [Expr.instantiate1_eq] using + bodyTr.inst_fvar henv nextWF) + all_goals exact nomatch instantiation + +/-- Consume an exact prefix of a strictly translated candidate view and keep +the terminal candidate context tied to the corresponding view telescope. + +The resulting `parameterContext` is the analyzer-owned prefix context. The +final `FVLift'` is over precisely the unconsumed suffix, so a strict +translation in the parameter context can be weakened to the same terminal +context used by pre-family constructor replay. -/ +theorem CandidateExprRun.parameterViewTerminal + {env : VEnv} {Us : List Name} + {candidateContext : AddInductive.Context} {source : Expr} + {trace : AddInductive.CandidateExprTrace candidateContext source} + {Δ : VLCtx} {source' view' inferred' : VExpr} + (run : CandidateExprRun env Us trace Δ source' view' inferred') + (contextRun : CandidateContextRun candidateContext) + (venv_eq : contextRun.context.venv = env) + (lparams_eq : contextRun.context.lparams = Us) + (vlctx_eq : contextRun.context.vlctx = Δ) + (unique : CandidateExprTraceViewIsUnique trace) + (count : Nat) (hcount : count ≤ trace.spineLength) + {viewΔ : VLCtx} + (viewDefEq : VLCtx.IsDefEq env Us.length Δ viewΔ) + (viewContext : TrExprS.IsUniqueCtx Δ viewΔ) + (noBV : Δ.NoBV) : + ∃ (parameterΔ : VLCtx) (rest : Expr) + (terminalRun : CandidateContextRun trace.terminalContext) + (viewTerminal : VLCtx), + instantiateFamilyParameters trace.view (trace.parameterList count) = + .ok rest ∧ + TrExprS env Us parameterΔ rest (VExpr.dropN count view') ∧ + parameterΔ.toCtx = + (VExpr.telN count view').reverse ++ viewΔ.toCtx ∧ + CandidateParameterContext viewΔ (trace.parameterList count) + (VExpr.telN count view') parameterΔ ∧ + parameterΔ.fvars.map Expr.fvar = + (trace.parameterList count).reverse ++ + viewΔ.fvars.map Expr.fvar ∧ + parameterΔ.NoBV ∧ + VLCtx.WF env Us.length parameterΔ ∧ + terminalRun.context.venv = env ∧ + terminalRun.context.lparams = Us ∧ + VLCtx.IsDefEq env Us.length terminalRun.context.vlctx viewTerminal ∧ + TrExprS.IsUniqueCtx terminalRun.context.vlctx viewTerminal ∧ + VLCtx.FVLift' parameterΔ viewTerminal 0 + (.skipN .refl (trace.spineLength - count)) 0 ∧ + viewTerminal.toCtx = + (VExpr.telN (trace.spineLength - count) + (VExpr.dropN count view')).reverse ++ parameterΔ.toCtx := by + induction run generalizing count viewΔ with + | @terminal Δ context source inferred result source' result' inferred' + checked normalized node => + simp only [AddInductive.CandidateExprTrace.spineLength] at hcount + have count_eq : count = 0 := Nat.eq_zero_of_le_zero hcount + subst count + have strict := + CandidateExprRun.view_tr_strict + (CandidateExprRun.terminal node) unique + have henv : VEnv.WF env := by + simpa only [node.check.venv_eq] using node.check.context.Ewf + obtain ⟨moved, movedTr⟩ := strict.defeqDFC henv viewDefEq + have moved_eq : result' = moved := + strict.unique' viewContext unique movedTr + subst moved + obtain ⟨terminalRun, viewTerminal, terminalVenv, terminalLparams, + terminalViewDefEq, terminalViewContext, terminalViewLift, + terminalViewEq⟩ := + (CandidateExprRun.terminal node).terminalContextRunView contextRun + venv_eq lparams_eq vlctx_eq viewDefEq viewContext + exact ⟨viewΔ, result, terminalRun, viewTerminal, rfl, movedTr, rfl, .nil, + by simp [AddInductive.CandidateExprTrace.parameterList], + by simpa only [VLCtx.NoBV, ← viewDefEq.bvars] using noBV, + (viewDefEq.symm henv.ordered).wf, + terminalVenv, terminalLparams, terminalViewDefEq, terminalViewContext, + by simpa only [Nat.sub_zero] using terminalViewLift, + by simpa only [Nat.sub_zero, VExpr.dropN] using terminalViewEq⟩ + | @forallE domain context name binderInfo Δ source inferred body + source' domain' body' inferred' domainView' domainInferred' + storedDomain' bodyΔ storedBody' bodyView' bodyInferred' u v fresh + checked normalized annotations annotationsEq domainCandidate + bodyCandidate node domainRun annotationsRun bodyRun domainType bodyType + bodySource bodyContext domainIH bodyIH => + have currentRun := CandidateExprRun.forallE + (fresh := fresh) (checked := checked) (normalized := normalized) + annotations annotationsEq domainCandidate bodyCandidate node domainRun + annotationsRun bodyRun domainType bodyType bodySource bodyContext + have henv : VEnv.WF env := by + simpa only [node.check.venv_eq] using node.check.context.Ewf + have hΔ : VLCtx.WF env Us.length Δ := by + simpa only [node.check.venv_eq, node.check.lparams_eq, + node.check.vlctx_eq] using node.check.context.Δwf + have allUnique := unique + rcases unique with ⟨domainUnique, bodyUnique, abstractUnique⟩ + cases count with + | zero => + have strict := currentRun.view_tr_strict allUnique + obtain ⟨moved, movedTr⟩ := strict.defeqDFC henv viewDefEq + have moved_eq : VExpr.forallE domainView' bodyView' = moved := + strict.unique' viewContext allUnique.view movedTr + subst moved + obtain ⟨terminalRun, viewTerminal, terminalVenv, terminalLparams, + terminalViewDefEq, terminalViewContext, terminalViewLift, + terminalViewEq⟩ := + currentRun.terminalContextRunView contextRun venv_eq lparams_eq + vlctx_eq viewDefEq viewContext + exact ⟨viewΔ, _, terminalRun, viewTerminal, rfl, movedTr, rfl, .nil, + by simp [AddInductive.CandidateExprTrace.parameterList], + by simpa only [VLCtx.NoBV, ← viewDefEq.bvars] using noBV, + (viewDefEq.symm henv.ordered).wf, + terminalVenv, terminalLparams, terminalViewDefEq, + terminalViewContext, + by simpa only [Nat.sub_zero] using terminalViewLift, + by simpa only [Nat.sub_zero, VExpr.dropN] using terminalViewEq⟩ + | succ count => + simp only [AddInductive.CandidateExprTrace.spineLength, + Nat.succ_le_succ_iff] at hcount + have domainDef : env.IsDefEq Us.length Δ.toCtx + domain' domainView' (.sort u) := + domainRun.evidence.isDefEq.toU.of_l henv hΔ.toCtx domainType + have annotationDef : env.IsDefEq Us.length Δ.toCtx + domain' storedDomain' (.sort u) := + annotationsRun.isDefEqU.of_l henv hΔ.toCtx domainType + have storedToView : env.IsDefEq Us.length Δ.toCtx + storedDomain' domainView' (.sort u) := + annotationDef.symm.trans domainDef + have storedDomain_tr : contextRun.context.TrExprS + annotations.consumed storedDomain' := by + simpa only [VContext.TrExprS, venv_eq, lparams_eq, vlctx_eq] using + annotationsRun.rhs_tr + have storedDomain_type : env.IsType Us.length Δ.toCtx storedDomain' := + ⟨u, annotationDef.hasType.2⟩ + let nextContextRun := contextRun.pushLocalDecl name binderInfo + annotations.consumed fresh storedDomain' storedDomain_tr (by + change contextRun.context.venv.IsType + contextRun.context.lparams.length + contextRun.context.vlctx.toCtx storedDomain' + rw [venv_eq, lparams_eq, vlctx_eq] + exact storedDomain_type) + have nextVenv : nextContextRun.context.venv = env := by + simp only [nextContextRun, CandidateContextRun.pushLocalDecl_venv, + venv_eq] + have nextLparams : nextContextRun.context.lparams = Us := by + simp only [nextContextRun, CandidateContextRun.pushLocalDecl_lparams, + lparams_eq] + have nextVlctx : nextContextRun.context.vlctx = bodyΔ := by + simp only [nextContextRun, CandidateContextRun.pushLocalDecl_vlctx] + rw [vlctx_eq, bodyContext] + let viewBodyΔ : VLCtx := + (some (context.freshFVarId, annotations.consumed.fvarsList), + .vlam domainView') :: viewΔ + have bodyWF := bodyRun.context_wf + rw [bodyContext] at bodyWF + have bodyViewDefEq : VLCtx.IsDefEq env Us.length bodyΔ viewBodyΔ := by + rw [bodyContext] + exact .cons viewDefEq bodyWF.2.1 (.vlam storedToView) + have bodyViewContext : TrExprS.IsUniqueCtx bodyΔ viewBodyΔ := by + rw [bodyContext] + exact viewContext.cons .vlam + have bodyNoBV : bodyΔ.NoBV := by + rw [bodyContext] + simpa only [VLCtx.NoBV, VLCtx.bvars] using noBV + obtain ⟨parameterΔ, rest, terminalRun, viewTerminal, restEq, + restTr, parameterCtx, parameterContext, parameterFVars, + parameterNoBV, parameterWF, terminalVenv, + terminalLparams, terminalViewDefEq, terminalViewContext, + terminalViewLift, terminalViewEq⟩ := + bodyIH nextContextRun nextVenv nextLparams nextVlctx bodyUnique + count hcount bodyViewDefEq bodyViewContext bodyNoBV + have bodyClosed : Closed bodyCandidate.view := by + have closed := (bodyRun.view_tr_strict bodyUnique).closed + simpa only [bodyNoBV] using closed + refine ⟨parameterΔ, rest, terminalRun, viewTerminal, ?_, ?_, ?_, + ?_, ?_, parameterNoBV, parameterWF, terminalVenv, terminalLparams, + ?_, ?_, ?_, ?_⟩ + · simp only [AddInductive.CandidateExprTrace.view, + AddInductive.CandidateExprTrace.parameterList, + instantiateFamilyParameters] + change instantiateFamilyParameters + ((bodyCandidate.view.abstract + #[.fvar context.freshFVarId]).instantiate1 + (.fvar context.freshFVarId)) _ = _ + rw [abstract_instantiate_self _ _ bodyClosed] + exact restEq + · simpa only [VExpr.dropN] using restTr + · simpa only [AddInductive.CandidateExprTrace.spineLength, + VExpr.telN, List.reverse_cons, List.singleton_append, + List.append_assoc, viewBodyΔ, VLCtx.toCtx] using parameterCtx + · simpa only [AddInductive.CandidateExprTrace.parameterList, + VExpr.telN, viewBodyΔ, AddInductive.Context.freshExpr] using + CandidateParameterContext.cons parameterContext + · simpa [AddInductive.CandidateExprTrace.parameterList, + List.reverse_cons, List.singleton_append, List.append_assoc, + viewBodyΔ, VLCtx.fvars, AddInductive.Context.freshExpr] using + parameterFVars + · simpa only [AddInductive.CandidateExprTrace.terminalContext] using + terminalViewDefEq + · simpa only [AddInductive.CandidateExprTrace.terminalContext] using + terminalViewContext + · simpa only [AddInductive.CandidateExprTrace.spineLength, + Nat.succ_sub_succ_eq_sub] using terminalViewLift + · simpa only [AddInductive.CandidateExprTrace.spineLength, + Nat.succ_sub_succ_eq_sub, VExpr.dropN] using terminalViewEq + +end TypeChecker + +namespace VInductDecl + +/-! +## Staged ownership + +The ordinary outer producer deliberately remains unchanged: its successful +equation records kernel validation, while this additive wrapper retains the +verified universe-semantic audit introduced by L4L-01D1 and extended by +L4L-02C. The normalized branch intersects the ordinary core decision with +the proved project comparison, without making bare +`buildNormalizationCandidate` success carry Theory meaning. +-/ + +/-- A staged singleton semantic input together with the exact executable +constructor-universe audit for the same source list, family-validation stats, +and post-family checker context. + +Keeping the ordinary staged input as data preserves the established candidate +and semantic hierarchy. The dependent `universeRun` field prevents an audit +for another family, constructor ordering, parameter split, or environment from +being reused here. -/ +structure StagedNormalizationCandidateUniverseInput + (familyContext constructorContext : AddInductive.Context) + (env : VEnv) (Us : List Name) + {source : InductiveType} + (candidate : AddInductive.NormalizationCandidate [source]) + (rawDecl : VInductDecl) where + staged : StagedNormalizationCandidateSemanticInput familyContext + constructorContext env Us candidate rawDecl + universeRun : + AddInductive.checkConstructorUniverseListSemantics + staged.family.validation.stats source.ctors + { candidate.families.singleton.familyType.type.trace.terminalContext with + env := constructorContext.env } = .ok () + +/-- Pair the retained ordinary validation trace with its source-indexed +universe audit. This is the strengthened D1 validation object; forgetting it +recovers exactly the pre-existing staged owner. -/ +def StagedNormalizationCandidateUniverseInput.semanticValidation + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.NormalizationCandidate [source]} + {rawDecl : VInductDecl} + (input : StagedNormalizationCandidateUniverseInput familyContext + constructorContext env Us candidate rawDecl) : + AddInductive.ConstructorSemanticValidationRun source + input.staged.family.validation.stats false + { candidate.families.singleton.familyType.type.trace.terminalContext with + env := constructorContext.env } where + validation := input.staged.constructorValidation + universeRun := input.universeRun + +/-- Every universe-bearing node in the staged source-ordered validation trace +passes the verified semantic universe gate. -/ +theorem StagedNormalizationCandidateUniverseInput.universeSemantics + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.NormalizationCandidate [source]} + {rawDecl : VInductDecl} + (input : StagedNormalizationCandidateUniverseInput familyContext + constructorContext env Us candidate rawDecl) : + input.staged.constructorValidation.universeSemantics = true := + input.semanticValidation.universeSemantics + +/-- Preserve the existing automatic semantic-hierarchy construction while +retaining the strengthened universe gate in its staged owner. -/ +theorem StagedNormalizationCandidateUniverseInput.exists + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.NormalizationCandidate [source]} + {rawDecl : VInductDecl} + (input : StagedNormalizationCandidateUniverseInput familyContext + constructorContext env Us candidate rawDecl) : + Nonempty (ProducedNormalizationCandidateSemanticRun familyContext + constructorContext env Us candidate rawDecl) := + input.staged.exists + +/-! +## Post-family constructor ownership + +This additive D2 owner keeps D1's universe gate and adds the exact executable +alignment between the retained validation telescope and every analyzer-owned +constructor candidate. It does not replay `checkConstructors` on the view or +claim any pre-family field judgment. +-/ + +/-- The staged semantic/universe owner together with the source-ordered +post-family constructor alignment audit. -/ +structure StagedNormalizationCandidatePostFamilyInput + (familyContext constructorContext : AddInductive.Context) + (env : VEnv) (Us : List Name) + {source : InductiveType} + (candidate : AddInductive.NormalizationCandidate [source]) + (rawDecl : VInductDecl) where + universeInput : StagedNormalizationCandidateUniverseInput familyContext + constructorContext env Us candidate rawDecl + alignment : AddInductive.ConstructorCandidateAlignmentTrace + universeInput.staged.family.validation.stats false 0 + { candidate.families.singleton.familyType.type.trace.terminalContext with + env := constructorContext.env } + universeInput.staged.constructorValidation.trace + candidate.families.singleton.constructors + +/-- 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 + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.NormalizationCandidate [source]} + {rawDecl : VInductDecl} + (universeInput : StagedNormalizationCandidateUniverseInput familyContext + constructorContext env Us candidate rawDecl) + (alignmentRun : + universeInput.staged.constructorValidation.trace.checkCandidateAlignment + candidate.families.singleton.constructors + { candidate.families.singleton.familyType.type.trace.terminalContext with + env := constructorContext.env } = .ok ()) : + StagedNormalizationCandidatePostFamilyInput familyContext + constructorContext env Us candidate rawDecl where + universeInput := universeInput + alignment := Classical.choice <| + AddInductive.ConstructorCandidateAlignmentTrace.nonempty_of_check + alignmentRun + +/-- The exact output of D2: the established produced semantic hierarchy plus +the actual post-family validation context, retained source/candidate +alignment, and a positional semantic interpretation of every exact candidate +view binder and terminal result. -/ +structure ProducedNormalizationCandidatePostFamilySemanticRun + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.NormalizationCandidate [source]} + {rawDecl : VInductDecl} + (input : StagedNormalizationCandidatePostFamilyInput familyContext + constructorContext env Us candidate rawDecl) where + produced : ProducedNormalizationCandidateSemanticRun familyContext + constructorContext env Us candidate rawDecl + contextRun : AddInductive.ConstructorContextRun + produced.semantic.family.typeEnv Us + { candidate.families.singleton.familyType.type.trace.terminalContext with + env := constructorContext.env } + alignment : AddInductive.ConstructorCandidateAlignmentTrace + input.universeInput.staged.family.validation.stats false 0 + { candidate.families.singleton.familyType.type.trace.terminalContext with + env := constructorContext.env } + input.universeInput.staged.constructorValidation.trace + candidate.families.singleton.constructors + constructors : AddInductive.ConstructorPostFamilySemanticListRun + produced.semantic.family.typeEnv Us + input.universeInput.staged.family.validation.stats false 0 + { candidate.families.singleton.familyType.type.trace.terminalContext with + env := constructorContext.env } + contextRun input.universeInput.staged.constructorValidation.trace + candidate.families.singleton.constructors alignment + produced.semantic.family.constructors + +/-- Interpret D2's executable alignment in the exact post-family Theory +environment obtained by the retained raw-family insertion. The only +existential selections are checker-produced Theory translations already +encapsulated by `Nonempty`; no caller supplies a view. -/ +theorem StagedNormalizationCandidatePostFamilyInput.exists + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.NormalizationCandidate [source]} + {rawDecl : VInductDecl} + (input : StagedNormalizationCandidatePostFamilyInput familyContext + constructorContext env Us candidate rawDecl) : + Nonempty (ProducedNormalizationCandidatePostFamilySemanticRun input) := by + obtain ⟨familySemantic⟩ := + input.universeInput.staged.semanticInput.family.exists + let semantic : NormalizationCandidateSemanticRun env Us candidate rawDecl := + { raw := input.universeInput.staged.raw + raw_types_eq := input.universeInput.staged.raw_types_eq + uvars_eq := input.universeInput.staged.declaration_uvars_eq + family := familySemantic } + let produced : ProducedNormalizationCandidateSemanticRun familyContext + constructorContext env Us candidate rawDecl := + { semantic := semantic + familyTypesProduced := + input.universeInput.staged.familyTypesProduced + familiesProduced := input.universeInput.staged.familiesProduced } + have typeEnv_eq : familySemantic.typeEnv = + input.universeInput.staged.family.typeEnv := by + exact Option.some.inj <| + familySemantic.addType.symm.trans + input.universeInput.staged.family.addInduct.env_add + obtain ⟨candidateContext, venv_eq, lparams_eq⟩ := + input.universeInput.staged.family.validationContextRun + familySemantic.type + let contextRun : AddInductive.ConstructorContextRun + produced.semantic.family.typeEnv Us + { candidate.families.singleton.familyType.type.trace.terminalContext with + env := constructorContext.env } := + ⟨candidateContext, venv_eq.trans typeEnv_eq.symm, lparams_eq⟩ + let alignment := input.alignment + obtain ⟨constructors⟩ := + AddInductive.ConstructorPostFamilySemanticListRun.nonempty_of_alignment + contextRun alignment produced.semantic.family.constructors + exact ⟨⟨produced, contextRun, alignment, constructors⟩⟩ + +/-! +## Pre-family constructor ownership + +The D3 owner extends the staged D2 package with the output of one executable +pre-family safety gate. Its semantic result is reconstructed from that exact +trace in the verified context reached by family normalization before the raw +family constant is inserted. +-/ + +/-- The staged D2 owner together with the exact executable pre-family safety +trace for the same singleton family view and dependent constructor list. -/ +structure StagedNormalizationCandidatePreFamilyInput + (familyContext constructorContext : AddInductive.Context) + (env : VEnv) (Us : List Name) + {source : InductiveType} + (candidate : AddInductive.NormalizationCandidate [source]) + (rawDecl : VInductDecl) where + postFamilyInput : StagedNormalizationCandidatePostFamilyInput familyContext + constructorContext env Us candidate rawDecl + safety : AddInductive.ConstructorPreFamilySafetyTrace + postFamilyInput.universeInput.staged.family.validation.stats + candidate.families.singleton.familyType.type.view + candidate.families.singleton.constructors + candidate.families.singleton.familyType.type.trace.terminalContext + +/-- 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 + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.NormalizationCandidate [source]} + {rawDecl : VInductDecl} + (postFamilyInput : StagedNormalizationCandidatePostFamilyInput + familyContext constructorContext env Us candidate rawDecl) + (safetyRun : AddInductive.checkConstructorPreFamilySafety + postFamilyInput.universeInput.staged.family.validation.stats + candidate.families.singleton.familyType.type.view + candidate.families.singleton.constructors + candidate.families.singleton.familyType.type.trace.terminalContext = + .ok ()) : + StagedNormalizationCandidatePreFamilyInput familyContext + constructorContext env Us candidate rawDecl where + postFamilyInput := postFamilyInput + safety := Classical.choice <| + AddInductive.ConstructorPreFamilyListTrace.nonempty_of_check safetyRun + +/-- 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 +the executable safety trace. -/ +structure ProducedNormalizationCandidatePreFamilySemanticRun + {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) where + postFamily : ProducedNormalizationCandidatePostFamilySemanticRun + input.postFamilyInput + contextRun : AddInductive.ConstructorContextRun env Us + candidate.families.singleton.familyType.type.trace.terminalContext + constructors : AddInductive.ConstructorPreFamilyListSemanticRun env Us + input.postFamilyInput.universeInput.staged.family.validation.stats 0 + input.safety.familyIndices + candidate.families.singleton.familyType.type.trace.terminalContext + contextRun input.safety.constructors + +/-- Interpret the executable D3 safety trace in the exact verified pre-family +context recovered from the retained family semantic normalization run. -/ +theorem StagedNormalizationCandidatePreFamilyInput.exists + {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) : + Nonempty (ProducedNormalizationCandidatePreFamilySemanticRun input) := by + obtain ⟨postFamily⟩ := input.postFamilyInput.exists + have raw_eq : postFamily.produced.semantic.raw = + input.postFamilyInput.universeInput.staged.raw := by + have singleton_eq := + postFamily.produced.semantic.raw_types_eq.symm.trans + input.postFamilyInput.universeInput.staged.raw_types_eq + injection singleton_eq + have familyType : TypeChecker.CandidateExprSemanticRootRun env Us + candidate.families.singleton.familyType.type + input.postFamilyInput.universeInput.staged.raw.type := by + rw [← raw_eq] + exact postFamily.produced.semantic.family.type + obtain ⟨candidateContext, venv_eq, lparams_eq⟩ := + input.postFamilyInput.universeInput.staged.family.preValidationContextRun + familyType + let contextRun : AddInductive.ConstructorContextRun env Us + candidate.families.singleton.familyType.type.trace.terminalContext := + ⟨candidateContext, venv_eq, lparams_eq⟩ + obtain ⟨constructors⟩ := + AddInductive.ConstructorPreFamilyListSemanticRun.nonempty contextRun + input.safety.constructors + exact ⟨⟨postFamily, contextRun, constructors⟩⟩ + +/-- Invert a verified iterated Pi type into its exact source-ordered +telescope and terminal type. -/ +private theorem isType_forallN_inv + (henv : VEnv.Ordered env) : + ∀ {As : List VExpr} {U : Nat} {Γ : List VExpr} {B : VExpr}, + env.IsType U Γ (VExpr.forallN As B) → + env.OnTel U Γ As ∧ + env.IsType U (As.reverse ++ Γ) B + | [], U, Γ, B, h => by + change env.IsType _ _ B at h + exact ⟨trivial, h⟩ + | A :: As, U, Γ, B, h => by + obtain ⟨hA, hrest⟩ := h.forallE_inv henv + obtain ⟨hAs, hB⟩ := isType_forallN_inv henv hrest + exact ⟨⟨hA, hAs⟩, by + simpa [List.reverse_cons, List.append_assoc] using hB⟩ + +/-- The family normalization trace and the analyzer's exact generation +equation derive the checked parameter/index telescope. No checked- or +view-well-formedness premise is accepted. -/ +theorem StagedNormalizationCandidatePreFamilyInput.familyOnTel + {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) + (normalization : NormalizationCandidateSemanticRun env Us candidate rawDecl) + (generation : GenerationChecked rawDecl) + (analysis : normalization.root.normalization.generation? = + some generation) : + env.OnTel rawDecl.uvars [] + (generation.block.checked.params ++ generation.block.checked.indices) := by + obtain ⟨_, recursive⟩ := normalization.family.type.recursive + have familyType : env.IsType Us.length [] normalization.family.type.view := + recursive.view_isType_of_terminalSort + input.postFamilyInput.universeInput.staged.family.validation.terminal_eq + have view_eq : normalization.family.type.view = + generation.block.checked.type.type := by + exact (congrArg (fun ty : VInductiveType => ty.type) + (normalization.root.familyViewType_eq analysis)).symm + rw [view_eq, generation.block.checked.type_eq, + ← VExpr.forallN_append] at familyType + have henv : VEnv.Ordered env := by + simpa only [normalization.family.type.venv_eq] using + normalization.family.type.contextRun.context.Ewf.ordered + have htel := (isType_forallN_inv henv familyType).1 + simpa only [normalization.uvars_eq] using htel + +open AddInductive TypeChecker + +private theorem familyTelNForallNLength : + ∀ (As : List VExpr) (B : VExpr), + VExpr.telN As.length (VExpr.forallN As B) = As + | [], _ => rfl + | _ :: As, B => by + simp only [List.length_cons, VExpr.forallN, VExpr.telN, + familyTelNForallNLength As B] + +private theorem familyDropNForallNLength : + ∀ (As : List VExpr) (B : VExpr), + VExpr.dropN As.length (VExpr.forallN As B) = B + | [], _ => rfl + | _ :: As, B => by + simp only [List.length_cons, VExpr.forallN, VExpr.dropN, + familyDropNForallNLength As B] + +/-- Consume the validator-owned parameter prefix of the retained family +candidate and identify both resulting contexts with the analyzer telescope. + +The executable D3 gate selects the residual kernel family expression. Strict +translation uniqueness, the exact generation shape, and dependent analysis +then identify its Theory endpoint and the terminal local context; neither a +view nor a view-context premise is supplied by the caller. -/ +theorem StagedNormalizationCandidatePreFamilyInput.familyParameterTerminal + {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) + (normalization : NormalizationCandidateSemanticRun env Us candidate rawDecl) + (generation : GenerationChecked rawDecl) + (analysis : normalization.root.normalization.generation? = + some generation) + (shape : normalization.generationShape = true) : + let trace := candidate.families.singleton.familyType.type.trace + ∃ (parameterΔ : VLCtx) (rest : Expr) + (terminalRun : CandidateContextRun trace.terminalContext) + (viewTerminal : VLCtx), + instantiateFamilyParameters trace.view + (trace.parameterList rawDecl.nparams) = .ok rest ∧ + TrExprS env Us parameterΔ rest + (VExpr.dropN rawDecl.nparams normalization.family.type.view) ∧ + parameterΔ.toCtx = + (VExpr.telN rawDecl.nparams normalization.family.type.view).reverse ∧ + CandidateParameterContext [] (trace.parameterList rawDecl.nparams) + (VExpr.telN rawDecl.nparams normalization.family.type.view) + parameterΔ ∧ + parameterΔ.fvars.map Expr.fvar = + (trace.parameterList rawDecl.nparams).reverse ∧ + parameterΔ.NoBV ∧ + VLCtx.WF env Us.length parameterΔ ∧ + terminalRun.context.venv = env ∧ + terminalRun.context.lparams = Us ∧ + VLCtx.IsDefEq env Us.length terminalRun.context.vlctx viewTerminal ∧ + TrExprS.IsUniqueCtx terminalRun.context.vlctx viewTerminal ∧ + VLCtx.FVLift' parameterΔ viewTerminal 0 + (.skipN .refl generation.block.checked.indices.length) 0 ∧ + viewTerminal.toCtx = + generation.block.checked.indices.reverse ++ parameterΔ.toCtx := by + dsimp only + have familyShape := shape + simp only [NormalizationCandidateSemanticRun.generationShape, + normalizationCandidateGenerationShape, Bool.and_eq_true, + beq_iff_eq] at familyShape + have spineLength_eq : + candidate.families.singleton.familyType.type.trace.spineLength = + (generation.block.checked.params ++ + generation.block.checked.indices).length := by + calc + _ = (VExpr.telN rawDecl.nparams normalization.raw.type ++ + ctorFields (VExpr.dropN rawDecl.nparams normalization.raw.type)).length := + familyShape.1.2 + _ = (generation.block.rawParams ++ + generation.block.rawIndices).length := by + simp only [NormalizedChecked.rawParams, NormalizedChecked.rawIndices, + NormalizationCandidateSemanticRun.root, + normalization.root.sourceType_eq generation] + _ = (generation.block.checked.params ++ + generation.block.checked.indices).length := by + simp only [List.length_append] + rw [generation.shape.2.1, generation.shape.2.2.1] + have parameterLength : generation.block.checked.params.length = + rawDecl.nparams := + generation.block.checked.direct_anatomy.2.1.trans + generation.block.nparams_eq.symm + have hcount : rawDecl.nparams ≤ + candidate.families.singleton.familyType.type.trace.spineLength := by + rw [spineLength_eq] + simpa only [List.length_append, parameterLength] using + Nat.le_add_right rawDecl.nparams + generation.block.checked.indices.length + have unique : CandidateExprTraceViewIsUnique + candidate.families.singleton.familyType.type.trace := by + apply CandidateExprTrace.viewTranslationUnique_sound + rw [CandidateExprTrace.viewTranslationUnique_eq] + have uniqueGate := input.safety.translationUnique + simp only [Bool.and_eq_true] at uniqueGate + exact uniqueGate.1 + obtain ⟨inferred, recursive⟩ := normalization.family.type.recursive + have rootWF : VLCtx.WF env Us.length ([] : VLCtx) := by + simpa only [normalization.family.type.venv_eq, + normalization.family.type.lparams_eq, + normalization.family.type.vlctx_eq] using + normalization.family.type.contextRun.context.Δwf + have henv : VEnv.Ordered env := by + simpa only [normalization.family.type.venv_eq] using + normalization.family.type.contextRun.context.Ewf.ordered + obtain ⟨parameterΔ, rest, terminalRun, viewTerminal, restEq, restTr, + parameterCtx, parameterContext, parameterFVars, parameterNoBV, + parameterWF, terminalVenv, terminalLparams, + terminalViewDefEq, terminalViewContext, terminalViewLift, + terminalViewEq⟩ := + recursive.parameterViewTerminal normalization.family.type.contextRun + normalization.family.type.venv_eq normalization.family.type.lparams_eq + normalization.family.type.vlctx_eq unique rawDecl.nparams hcount + (.refl henv rootWF) .base (by rfl) + have remaining_eq : + candidate.families.singleton.familyType.type.trace.spineLength - + rawDecl.nparams = generation.block.checked.indices.length := by + rw [spineLength_eq, List.length_append, + parameterLength, Nat.add_sub_cancel_left] + have view_eq : normalization.family.type.view = + generation.block.checked.type.type := + (congrArg (fun ty : VInductiveType => ty.type) + (normalization.root.familyViewType_eq analysis)).symm + have viewDrop_eq : + VExpr.dropN rawDecl.nparams normalization.family.type.view = + VExpr.forallN generation.block.checked.indices + (.sort generation.block.checked.resultLevel) := by + rw [view_eq, generation.block.checked.type_eq, ← parameterLength] + exact familyDropNForallNLength _ _ + refine ⟨parameterΔ, rest, terminalRun, viewTerminal, restEq, restTr, ?_, + parameterContext, ?_, parameterNoBV, parameterWF, terminalVenv, + terminalLparams, + terminalViewDefEq, + terminalViewContext, ?_, ?_⟩ + · simpa only [VLCtx.toCtx, List.append_nil] using parameterCtx + · simpa [VLCtx.fvars] using parameterFVars + · simpa only [remaining_eq] using terminalViewLift + · rw [remaining_eq, viewDrop_eq, + familyTelNForallNLength] at terminalViewEq + exact terminalViewEq + +/-- The analyzer-owned family prefix and D3's pre-family terminal context, +with the residual kernel expression fixed to the exact executable safety +trace and every Theory telescope component fixed to dependent analysis. -/ +theorem StagedNormalizationCandidatePreFamilyInput.familyContext + {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) + (normalization : NormalizationCandidateSemanticRun env Us candidate rawDecl) + (generation : GenerationChecked rawDecl) + (analysis : normalization.root.normalization.generation? = + some generation) + (shape : normalization.generationShape = true) : + let trace := candidate.families.singleton.familyType.type.trace + ∃ (parameterΔ : VLCtx) + (terminalRun : CandidateContextRun trace.terminalContext) + (viewTerminal : VLCtx), + instantiateFamilyParameters trace.view + (trace.parameterList rawDecl.nparams) = + .ok input.safety.familyIndices ∧ + TrExprS env Us parameterΔ input.safety.familyIndices + (VExpr.forallN generation.block.checked.indices + (.sort generation.block.checked.resultLevel)) ∧ + parameterΔ.toCtx = generation.block.checked.params.reverse ∧ + CandidateParameterContext [] (trace.parameterList rawDecl.nparams) + generation.block.checked.params parameterΔ ∧ + parameterΔ.fvars.map Expr.fvar = + (trace.parameterList rawDecl.nparams).reverse ∧ + parameterΔ.NoBV ∧ + VLCtx.WF env Us.length parameterΔ ∧ + terminalRun.context.venv = env ∧ + terminalRun.context.lparams = Us ∧ + VLCtx.IsDefEq env Us.length terminalRun.context.vlctx viewTerminal ∧ + TrExprS.IsUniqueCtx terminalRun.context.vlctx viewTerminal ∧ + VLCtx.FVLift' parameterΔ viewTerminal 0 + (.skipN .refl generation.block.checked.indices.length) 0 ∧ + viewTerminal.toCtx = + generation.block.checked.indices.reverse ++ + generation.block.checked.params.reverse := by + dsimp only + obtain ⟨parameterΔ, rest, terminalRun, viewTerminal, restEq, restTr, + parameterCtx, parameterContext, parameterFVars, parameterNoBV, + parameterWF, terminalVenv, terminalLparams, + terminalViewDefEq, terminalViewContext, terminalViewLift, + terminalViewEq⟩ := input.familyParameterTerminal normalization + generation analysis shape + let validation := + input.postFamilyInput.universeInput.staged.family.validation + have statsParams : validation.stats.params.toList = + candidate.families.singleton.familyType.type.trace.parameterList + rawDecl.nparams := by + rw [validation.stats_eq] + simp only [CandidateExprTrace.singletonCandidateInductiveStats, + validation, input.postFamilyInput.universeInput.staged.validation_nparams_eq] + have safetyParameters := input.safety.parameters + rw [statsParams] at safetyParameters + have rest_eq : rest = input.safety.familyIndices := by + exact Except.ok.inj (restEq.symm.trans safetyParameters) + subst rest + have parameterLength : generation.block.checked.params.length = + rawDecl.nparams := + generation.block.checked.direct_anatomy.2.1.trans + generation.block.nparams_eq.symm + have view_eq : normalization.family.type.view = + generation.block.checked.type.type := + (congrArg (fun ty : VInductiveType => ty.type) + (normalization.root.familyViewType_eq analysis)).symm + have viewDrop_eq : + VExpr.dropN rawDecl.nparams normalization.family.type.view = + VExpr.forallN generation.block.checked.indices + (.sort generation.block.checked.resultLevel) := by + rw [view_eq, generation.block.checked.type_eq, ← parameterLength] + exact familyDropNForallNLength _ _ + have parameterTel_eq : + VExpr.telN rawDecl.nparams normalization.family.type.view = + generation.block.checked.params := by + rw [view_eq, generation.block.checked.type_eq, ← parameterLength] + exact familyTelNForallNLength _ _ + refine ⟨parameterΔ, terminalRun, viewTerminal, restEq, ?_, ?_, + ?_, parameterFVars, parameterNoBV, parameterWF, terminalVenv, + terminalLparams, + terminalViewDefEq, + terminalViewContext, terminalViewLift, ?_⟩ + · simpa only [viewDrop_eq] using restTr + · simpa only [parameterTel_eq] using parameterCtx + · simpa only [parameterTel_eq] using parameterContext + · simpa only [parameterCtx, parameterTel_eq] using terminalViewEq + +/-- Peeling at most `n` binders cannot expose more than `n` telescope +entries. -/ +private theorem constructorTelN_length_le (n : Nat) (expression : VExpr) : + (VExpr.telN n expression).length ≤ n := by + induction n generalizing expression with + | zero => simp [VExpr.telN] + | succ n ih => cases expression <;> simp [VExpr.telN, ih] + +/-- Strip the validator-owned parameter prefix from one analyzer-selected +constructor and retain the exact D3 suffix together with its strict Theory +translation. + +The source parameter list is fixed by the family validation statistics, the +Theory parameter telescope is fixed by dependent analysis, and the complete +constructor endpoint is fixed by the analyzer-owned raw/view pairing. Thus +the residual endpoint is precisely the stored view fields followed by the +analyzed result target; no whole-Pi injectivity or caller-selected view is +used. -/ +theorem CandidateSemanticNormalizedCtorRun.preFamilySuffix + {env typeEnv : VEnv} {Us : List Name} + {source : VInductDecl} {generation : GenerationChecked source} + {kernelCtor : Constructor} + {candidateCtor : AddInductive.CandidateConstructor kernelCtor} + {rawCtor : VConstVal} + {root : CandidateConstructorSemanticRun typeEnv Us candidateCtor rawCtor} + {ctor : NormalizedCtor} + {stats : InductiveStats} {familyIndices : Expr} + {context : AddInductive.Context} + {contextRun : AddInductive.ConstructorContextRun env Us context} + {d3Trace : AddInductive.ConstructorPreFamilyViewTrace stats 0 + familyIndices context candidateCtor.type.view 0 [] false} + {parameterΔ : VLCtx} {parameters : List Expr} + (genRun : CandidateSemanticNormalizedCtorRun generation.block typeEnv Us + root ctor) + (addType : env ≤ typeEnv) + (parameterContext : CandidateParameterContext [] parameters + generation.block.checked.params parameterΔ) + (parameterWF : VLCtx.WF env Us.length parameterΔ) + (unique : CandidateExprTraceViewIsUnique candidateCtor.type.trace) + (d3 : AddInductive.ConstructorPreFamilyViewSemanticRun env Us stats 0 + familyIndices contextRun d3Trace) + (hctor : ctor ∈ generation.block.ctorPairs) + (parametersEq : stats.params.toList = parameters) + {familyName : Name} {levels : List Level} + (indConsts : stats.indConsts = #[.const familyName levels]) : + ∃ rest, + instantiateFamilyParameters candidateCtor.type.view stats.params.toList = + .ok rest ∧ + Nonempty (AddInductive.ConstructorPreFamilyParameterSuffix + (env := env) (Us := Us) (stats := stats) + (familyIndices := familyIndices) (context := context) + (removed := []) (recursiveStarted := false) + (contextRun := contextRun) rest) ∧ + TrExprS typeEnv Us parameterΔ rest + (VExpr.forallN ctor.view.fields + (ctor.resultTarget generation.block)) := by + have viewTel := genRun.run.viewTel_eq hctor + simp only [CandidateConstructorSemanticRun.root, + NormalizedCtor.viewBinders] at viewTel + have parameterLengthLe : generation.block.checked.params.length ≤ + candidateCtor.type.trace.spineLength := by + apply Nat.le_trans (Nat.le_add_right _ ctor.view.fields.length) + rw [← List.length_append, ← viewTel] + exact constructorTelN_length_le _ _ + have sourceParameterLength : stats.params.toList.length ≤ + candidateCtor.type.trace.spineLength := by + rw [parametersEq, parameterContext.length_eq] + exact parameterLengthLe + obtain ⟨rest, instantiation⟩ := + candidateCtor.type.trace.instantiateViewParameters stats.params.toList + sourceParameterLength + obtain ⟨inferred, recursive⟩ := root.type.recursive + have wholeTr : TrExprS typeEnv Us [] candidateCtor.type.view + (VExpr.forallN generation.block.checked.params + (VExpr.forallN ctor.view.fields + (ctor.resultTarget generation.block))) := by + have strict := recursive.view_tr_strict unique + have viewTypeEq : root.type.view = ctor.view.value.type := by + simpa only [CandidateConstructorSemanticRun.root, + CandidateConstructorRun.view] using + (congrArg (fun value : VConstVal => value.type) genRun.view_eq).symm + rw [viewTypeEq, generation.viewCtorType_eq hctor, + NormalizedCtor.viewBinders] at strict + simpa only [CandidateExpr.view, VExpr.forallN_append] using strict + have parameterWF' : VLCtx.WF typeEnv Us.length parameterΔ := + parameterWF.mono addType + have typeEnvOrdered : typeEnv.Ordered := by + simpa only [root.type.venv_eq] using + root.type.contextRun.context.Ewf.ordered + have suffixTr : TrExprS typeEnv Us parameterΔ rest + (VExpr.forallN ctor.view.fields + (ctor.resultTarget generation.block)) := by + apply parameterContext.instantiateForall typeEnvOrdered parameterWF' + · simpa only [← parametersEq] using instantiation + · exact wholeTr + obtain ⟨suffix⟩ := + d3.afterParameters indConsts (by simp) (by + simpa only [CandidateExpr.view, List.drop_zero] using instantiation) + exact ⟨rest, instantiation, ⟨suffix⟩, suffixTr⟩ + +end VInductDecl + +namespace ConstructorValidation +open AddInductive TypeChecker VEnv + +theorem TrExprS.IsUnique.liftLooseBVars + (unique : TrExprS.IsUnique expression) : + TrExprS.IsUnique (expression.liftLooseBVars' start amount) := by + induction expression generalizing start with + | bvar index => trivial + | fvar | mvar | sort | const | lit => trivial + | app function argument functionIH argumentIH => + exact ⟨functionIH unique.1, argumentIH unique.2⟩ + | lam name domain body binderInfo domainIH bodyIH + | forallE name domain body binderInfo domainIH bodyIH => + exact ⟨domainIH unique.1, bodyIH unique.2⟩ + | letE name type value body nondep typeIH valueIH bodyIH => + exact ⟨valueIH unique.1, bodyIH unique.2⟩ + | mdata data expression ih => exact ih unique + | proj => cases unique + +theorem TrExprS.IsUnique.instantiate1' + (expressionUnique : TrExprS.IsUnique expression) + (argumentUnique : TrExprS.IsUnique argument) : + TrExprS.IsUnique (expression.instantiate1' argument depth) := by + induction expression generalizing depth with + | bvar index => + simp only [Expr.instantiate1'] + split + · trivial + · split + · exact liftLooseBVars argumentUnique + · trivial + | fvar | mvar | sort | const | lit => trivial + | app function argument functionIH argumentIH => + exact ⟨functionIH expressionUnique.1, + argumentIH expressionUnique.2⟩ + | lam name domain body binderInfo domainIH bodyIH + | forallE name domain body binderInfo domainIH bodyIH => + exact ⟨domainIH expressionUnique.1, + bodyIH expressionUnique.2⟩ + | letE name type value body nondep typeIH valueIH bodyIH => + exact ⟨valueIH expressionUnique.1, + bodyIH expressionUnique.2⟩ + | mdata data expression ih => exact ih expressionUnique + | proj => cases expressionUnique + +theorem TrExprS.IsUnique.instantiate1 + (expressionUnique : TrExprS.IsUnique expression) + (argumentUnique : TrExprS.IsUnique argument) : + TrExprS.IsUnique (expression.instantiate1 argument) := by + rw [Expr.instantiate1_eq] + exact instantiate1' expressionUnique argumentUnique + +theorem FVarsIn.consumeTypeAnnotations + (scope : FVarsIn predicate source) : + FVarsIn predicate (AddInductive.consumeTypeAnnotations source) := by + fun_induction AddInductive.consumeTypeAnnotations source <;> + simp_all [AddInductive.consumeTypeAnnotations, FVarsIn] + +theorem instantiateFamilyParameters_unique + (sourceUnique : TrExprS.IsUnique source) + (parametersUnique : ∀ parameter ∈ parameters, + TrExprS.IsUnique parameter) + (run : AddInductive.instantiateFamilyParameters source parameters = + .ok rest) : + TrExprS.IsUnique rest := by + induction parameters generalizing source with + | nil => + have source_eq : source = rest := Except.ok.inj run + simpa only [source_eq] using sourceUnique + | cons parameter parameters ih => + cases source <;> + simp only [AddInductive.instantiateFamilyParameters] at run + case forallE name domain body binderInfo => + exact ih (ConstructorValidation.TrExprS.IsUnique.instantiate1 sourceUnique.2 + (parametersUnique parameter (.head parameters))) + (fun candidate member => + parametersUnique candidate (.tail parameter member)) run + all_goals exact nomatch run + +theorem CandidateParameterContext.parametersUnique + (parameters : CandidateParameterContext base sources types final) : + ∀ source ∈ sources, TrExprS.IsUnique source := by + induction parameters with + | nil => simp + | cons tail ih => + intro source member + simp only [List.mem_cons] at member + rcases member with rfl | member + · trivial + · exact ih source member + +/-- The semantic context invariants shared while D3 and D2 consume the +ordinary prefix of one analyzer-owned constructor view. -/ +structure ConstructorOrdinaryContextState + (env typeEnv : VEnv) (Us : List Name) + (base actual view postActual : VLCtx) (lift : Lift) where + baseWF : VLCtx.WF env Us.length base + actualWF : VLCtx.WF env Us.length actual + postWF : VLCtx.WF typeEnv Us.length postActual + postRelation : VLCtx.IsDefEqFVars typeEnv Us.length actual postActual + viewDefEq : VLCtx.IsDefEq env Us.length actual view + viewUnique : TrExprS.IsUniqueCtx actual view + viewLift : VLCtx.FVLift' base view 0 lift 0 + +/-- Extend the synchronized ordinary-prefix invariant by the exact analyzer +field selected by strict translation. D3 and D2 may retain different +dependency metadata, but use the same operational fresh identifier. -/ +theorem ConstructorOrdinaryContextState.push + {env typeEnv : VEnv} {Us : List Name} + {base actual view postActual : VLCtx} {lift : Lift} + (state : ConstructorOrdinaryContextState env typeEnv Us + base actual view postActual lift) + (henv : VEnv.WF env) (typeEnvWF : VEnv.WF typeEnv) + (addType : env ≤ typeEnv) + {source : Expr} {analyzer actualSource actualConsumed postConsumed : VExpr} + {fieldLevel consumedLevel : VLevel} {fv : FVarId} + {deps actualDeps postDeps : List FVarId} + (sourceUnique : TrExprS.IsUnique source) + (sourceTr : TrExprS typeEnv Us base source analyzer) + (actualTr : TrExprS env Us actual source actualSource) + (actualAnnotations : env.IsDefEqU Us.length actual.toCtx + actualSource actualConsumed) + (actualConsumedType : env.HasType Us.length actual.toCtx actualConsumed + (.sort consumedLevel)) + (analyzerType : env.HasType Us.length base.toCtx analyzer + (.sort fieldLevel)) + (depsSubset : deps ⊆ base.fvars) + (actualTailWF : VLCtx.WF env Us.length + ((some (fv, actualDeps), .vlam actualConsumed) :: actual)) + (actualDeps_eq : actualDeps = deps) + (postTailWF : VLCtx.WF typeEnv Us.length + ((some (fv, postDeps), .vlam postConsumed) :: postActual)) + (consumedEq : typeEnv.IsDefEq Us.length actual.toCtx + actualConsumed postConsumed (.sort consumedLevel)) : + ConstructorOrdinaryContextState env typeEnv Us + ((some (fv, deps), .vlam analyzer) :: base) + ((some (fv, actualDeps), .vlam actualConsumed) :: actual) + ((some (fv, deps), .vlam (analyzer.lift' lift)) :: view) + ((some (fv, postDeps), .vlam postConsumed) :: postActual) + (.consN lift 1) := by + subst actualDeps + have viewWF : VLCtx.WF env Us.length view := + (state.viewDefEq.symm henv.ordered).wf + have analyzerAtView : TrExprS typeEnv Us view source + (analyzer.lift' lift) := + sourceTr.weakFV' typeEnvWF.ordered state.viewLift + (viewWF.mono addType) + have actualSource_eq : actualSource = + analyzer.lift' lift := + (actualTr.mono addType).unique' state.viewUnique sourceUnique + analyzerAtView + have consumedToAnalyzer : env.IsDefEq Us.length actual.toCtx + actualConsumed (analyzer.lift' lift) + (.sort consumedLevel) := by + rw [← actualSource_eq] + exact (actualAnnotations.of_r henv state.actualWF.toCtx + actualConsumedType).symm + have freshBase : fv ∉ base.fvars := by + intro present + have presentView : fv ∈ view.fvars := + state.viewLift.fvars_sublist.subset present + have presentActual : fv ∈ actual.fvars := by + simpa only [state.viewDefEq.fvars] using presentView + exact (actualTailWF.2.1 fv deps rfl).1 presentActual + have baseTailWF : VLCtx.WF env Us.length + ((some (fv, deps), .vlam analyzer) :: base) := + ⟨state.baseWF, + fun _ _ equality => by + cases equality + exact ⟨freshBase, depsSubset⟩, + ⟨fieldLevel, analyzerType⟩⟩ + have nextViewDefEq : VLCtx.IsDefEq env Us.length + ((some (fv, deps), .vlam actualConsumed) :: actual) + ((some (fv, deps), .vlam (analyzer.lift' lift)) :: view) := + .cons state.viewDefEq actualTailWF.2.1 (.vlam consumedToAnalyzer) + exact { + baseWF := baseTailWF + actualWF := actualTailWF + postWF := postTailWF + postRelation := .cons_fvar state.postRelation (.vlam consumedEq) + viewDefEq := nextViewDefEq + viewUnique := state.viewUnique.cons .vlam + viewLift := state.viewLift.cons_fvar (fv, deps) (.vlam analyzer) + depsSubset } + +private theorem vexpr_appArgs_acc (expression : VExpr) (suffix : List VExpr) : + VExpr.appArgs expression suffix = + VExpr.appArgs expression [] ++ suffix := by + induction expression generalizing suffix with + | app function argument ihFunction ihArgument => + simp only [VExpr.appArgs] + rw [ihFunction, ihFunction (suffix := [argument])] + simp + | bvar | sort | const | lam | forallE => simp [VExpr.appArgs] + +private theorem expr_getAppArgsList_acc (expression : Expr) + (suffix : List Expr) : + expression.getAppArgsList suffix = + expression.getAppArgsList [] ++ suffix := by + induction expression generalizing suffix with + | app function argument ihFunction ihArgument => + simp only [Expr.getAppArgsList] + rw [ihFunction, ihFunction (suffix := [argument])] + simp + | bvar | fvar | mvar | sort | const | lit | mdata | proj | lam | forallE | + letE => simp [Expr.getAppArgsList] + +theorem TrExprS.IsUnique.getAppArgsList + (unique : TrExprS.IsUnique expression) : + ∀ argument ∈ expression.getAppArgsList, + TrExprS.IsUnique 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 unique.1 candidate member + · exact unique.2 + | bvar | fvar | mvar | sort | const | lit | mdata | proj | lam | forallE | + letE => simp [Expr.getAppArgsList] + +theorem Closed.getAppArgsList + (closed : Closed expression depth) : + ∀ argument ∈ expression.getAppArgsList, + Closed argument depth := 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 closed.1 candidate member + · exact closed.2 + | 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 + | nil => rfl + | cons argument arguments ih => + simp only [VExpr.appN] + rw [ih] + rfl + +private def vexprLiftTel (lift : Lift) : List VExpr → List VExpr + | [] => [] + | domain :: domains => + domain.lift' lift :: vexprLiftTel lift.cons domains + +private theorem vexpr_lift'_forallN (lift : Lift) : + ∀ (domains : List VExpr) (body : VExpr), + (VExpr.forallN domains body).lift' lift = + VExpr.forallN (vexprLiftTel lift domains) + (body.lift' (lift.consN domains.length)) + | [], _ => rfl + | domain :: domains, body => by + simp only [VExpr.forallN, VExpr.lift', vexprLiftTel, + List.length_cons] + rw [vexpr_lift'_forallN lift.cons domains body] + congr 2 + rw [show domains.length + 1 = 1 + domains.length by omega, + ← Lift.consN_consN] + rfl + +private theorem vexprLiftTel_length (lift : Lift) : + ∀ domains : List VExpr, + (vexprLiftTel lift domains).length = domains.length + | [] => rfl + | _ :: domains => by + simp only [vexprLiftTel, List.length_cons, + vexprLiftTel_length lift.cons domains] + +private theorem forall₂_append + (left : List.Forall₂ relation leftSources leftTargets) + (right : List.Forall₂ relation rightSources rightTargets) : + List.Forall₂ relation (leftSources ++ rightSources) + (leftTargets ++ rightTargets) := by + induction left with + | nil => exact right + | cons head tail ih => exact .cons head ih + +private theorem forall₂_length + (run : List.Forall₂ relation sources targets) : + sources.length = targets.length := by + induction run with + | nil => rfl + | cons _ _ ih => exact congrArg Nat.succ ih + +theorem forall₂_translation_unique + (left : List.Forall₂ (TrExprS env Us context) sources leftTargets) + (right : List.Forall₂ (TrExprS env Us context) sources rightTargets) + (unique : ∀ source ∈ sources, TrExprS.IsUnique source) : + leftTargets = rightTargets := by + induction left generalizing rightTargets with + | nil => cases right; rfl + | @cons source leftTarget sources leftTargets leftHead leftTail ih => + cases right with + | cons rightHead rightTail => + rw [leftHead.unique (unique source (.head sources)) rightHead, + ih rightTail (fun candidate member => + unique candidate (.tail source member))] + +theorem forall₂_drop + (run : List.Forall₂ relation sources targets) (n : Nat) : + List.Forall₂ relation (sources.drop n) (targets.drop n) := by + induction n generalizing sources targets with + | zero => simpa using run + | succ n ih => + cases run with + | nil => exact .nil + | cons head tail => simpa using ih tail + +theorem forall₂_tr_weakFV' + {env : VEnv} {Us : List Name} {base full : VLCtx} + {lift : Lift} (henv : VEnv.Ordered env) + (extension : VLCtx.FVLift' base full 0 lift 0) + (fullWF : VLCtx.WF env Us.length full) + (run : List.Forall₂ (TrExprS env Us base) sources targets) : + List.Forall₂ (TrExprS env Us full) sources + (targets.map fun target => target.lift' lift) := by + induction run with + | nil => exact .nil + | cons head tail ih => + exact .cons (by simpa using head.weakFV' henv extension fullWF) ih + +theorem forall₂_tr_mono + (add : env ≤ env') + (run : List.Forall₂ (TrExprS env Us context) sources targets) : + List.Forall₂ (TrExprS env' Us context) sources targets := by + induction run with + | 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} + (valid : AddInductive.isValidIndAppIdx stats source familyIdx = true) : + (source.getAppFn == stats.indConsts[familyIdx]!) = true ∧ + source.getAppArgs.size = + stats.params.size + stats.nindices[familyIdx]! := by + unfold AddInductive.isValidIndAppIdx at valid + rw [Expr.withApp_eq] at valid + simp only [Id.run] at valid + split at valid + · rename_i shape + simpa only [Bool.and_eq_true, beq_iff_eq] using shape + · simp_all + +theorem isValidIndAppIdx_indexArgs_length + {stats : AddInductive.InductiveStats} {source : Expr} + {familyIdx : Nat} + (valid : AddInductive.isValidIndAppIdx stats source familyIdx = true) : + (source.getAppArgs.toList.drop stats.params.size).length = + stats.nindices[familyIdx]! := by + have shape := isValidIndAppIdx_shape valid + rw [List.length_drop, Array.length_toList, shape.2] + omega + +theorem constructorIndependentOf_fvars + {source : Expr} {full base removed : List FVarId} + (scope : FVarsIn (· ∈ full) source) + (independent : AddInductive.constructorIndependentOf source removed = true) + (remaining : ∀ fv, fv ∈ full → fv ∉ removed → fv ∈ base) : + FVarsIn (· ∈ base) source := by + rw [fvarsIn_iff] at scope ⊢ + refine ⟨?_, scope.2⟩ + intro fv member + apply remaining fv (scope.1 fv member) + unfold AddInductive.constructorIndependentOf at independent + simp only [List.all_eq_true] at independent + have omitted := independent fv member + simpa using omitted + +/-- Strict translation preserves a constant-headed application spine and +translates its arguments position-for-position. -/ +theorem TrExprS.constApp_components + {env : VEnv} {Us : List Name} {context : VLCtx} + {source : Expr} {target : VExpr} {name : Name} {levels : List Level} + (run : TrExprS env Us context source target) + (head : source.getAppFn = .const name levels) : + ∃ levels', + VExpr.appHead target = .const name levels' ∧ + List.Forall₂ (TrExprS env Us context) + source.getAppArgsList (VExpr.appArgs target []) := by + induction source generalizing target with + | const sourceName sourceLevels => + cases run with + | const lookup levelsTr arity => + simp only [Expr.getAppFn] at head + obtain ⟨rfl, rfl⟩ := head + exact ⟨_, rfl, .nil⟩ + | app function argument functionIH argumentIH => + cases run with + | app => + rename_i function' domain' body' argument' functionType argumentType + functionTr argumentTr + have functionHead : function.getAppFn = .const name levels := by + simpa only [Expr.getAppFn] using head + obtain ⟨levels', targetHead, argumentsTr⟩ := + functionIH functionTr functionHead + refine ⟨levels', ?_, ?_⟩ + · simpa only [VExpr.appHead] using targetHead + · rw [show VExpr.appArgs (.app function' argument') [] = + VExpr.appArgs function' [] ++ [argument'] by + rw [VExpr.appArgs, vexpr_appArgs_acc]] + simp only [Expr.getAppArgsList] at * + rw [expr_getAppArgsList_acc] + exact forall₂_append argumentsTr (.cons argumentTr .nil) + | bvar => cases run; simp [Expr.getAppFn] at head + | fvar => cases run; simp [Expr.getAppFn] at head + | mvar => cases run + | sort => cases run; simp [Expr.getAppFn] at head + | lam => cases run; simp [Expr.getAppFn] at head + | forallE => cases run; simp [Expr.getAppFn] at head + | letE => cases run; simp [Expr.getAppFn] at head + | lit => cases run; simp [Expr.getAppFn] at head + | mdata => cases run; simp [Expr.getAppFn] at head + | proj => cases run; simp [Expr.getAppFn] at head + +/-- Remove one verified free-variable context extension from a list of strict +translations, retaining the exact lifted endpoints. -/ +theorem TrExprS.forall₂_weakFV_inv + {env : VEnv} {Us : List Name} {base full : VLCtx} + {sources : List Expr} {targets : List VExpr} {n : Lift} + (henv : VEnv.WF env) (fullWF : VLCtx.WF env Us.length full) + (extension : VLCtx.FVLift' base full 0 n 0) + (runs : List.Forall₂ (TrExprS env Us full) sources targets) + (closed : ∀ source ∈ sources, Closed source) + (fvars : ∀ source ∈ sources, FVarsIn (· ∈ base.fvars) source) + (unique : ∀ source ∈ sources, TrExprS.IsUnique source) : + ∃ baseTargets, + List.Forall₂ (TrExprS env Us base) sources baseTargets ∧ + targets = baseTargets.map (fun target => target.lift' (n.consN 0)) := by + induction runs with + | nil => exact ⟨[], .nil, rfl⟩ + | @cons source target sources targets headRun tailRuns ih => + have headClosed := closed source (.head sources) + have headFVars := fvars source (.head sources) + have headUnique := unique source (.head sources) + have tailClosed : ∀ expression ∈ sources, Closed expression := + fun expression member => closed expression (.tail source member) + have tailFVars : ∀ expression ∈ sources, + FVarsIn (· ∈ base.fvars) expression := + fun expression member => fvars expression (.tail source member) + have tailUnique : ∀ expression ∈ sources, + TrExprS.IsUnique expression := + fun expression member => unique expression (.tail source member) + obtain ⟨headBase, headBaseRun⟩ := + headRun.weakFV'_inv henv extension (.refl henv fullWF) + headClosed headFVars + obtain ⟨tailBase, tailBaseRuns, tailEq⟩ := + ih tailClosed tailFVars tailUnique + have headEq : target = headBase.lift' (n.consN 0) := + headRun.unique headUnique + (headBaseRun.weakFV' henv.ordered extension fullWF) + subst target + exact ⟨headBase :: tailBase, .cons headBaseRun tailBaseRuns, by + simp only [List.map_cons, tailEq]⟩ + +/-- Remove a free-variable extension modulo the verified context equality +used by the retained checker run. -/ +theorem TrExprS.forall₂_weakFV_inv_defeq + {env : VEnv} {Us : List Name} {base actual view : VLCtx} + {sources : List Expr} {targets : List VExpr} {n : Lift} + (henv : VEnv.WF env) + (viewDefEq : VLCtx.IsDefEq env Us.length actual view) + (viewUnique : TrExprS.IsUniqueCtx actual view) + (extension : VLCtx.FVLift' base view 0 n 0) + (runs : List.Forall₂ (TrExprS env Us actual) sources targets) + (closed : ∀ source ∈ sources, Closed source) + (fvars : ∀ source ∈ sources, FVarsIn (· ∈ base.fvars) source) + (unique : ∀ source ∈ sources, TrExprS.IsUnique source) : + ∃ baseTargets, + List.Forall₂ (TrExprS env Us base) sources baseTargets ∧ + targets = baseTargets.map (fun target => target.lift' (n.consN 0)) := by + have viewWF : VLCtx.WF env Us.length view := + (viewDefEq.symm henv.ordered).wf + induction runs with + | nil => exact ⟨[], .nil, rfl⟩ + | @cons source target sources targets headRun tailRuns ih => + have headClosed := closed source (.head sources) + have headFVars := fvars source (.head sources) + have headUnique := unique source (.head sources) + have tailClosed : ∀ expression ∈ sources, Closed expression := + fun expression member => closed expression (.tail source member) + have tailFVars : ∀ expression ∈ sources, + FVarsIn (· ∈ base.fvars) expression := + fun expression member => fvars expression (.tail source member) + have tailUnique : ∀ expression ∈ sources, + TrExprS.IsUnique expression := + fun expression member => unique expression (.tail source member) + obtain ⟨headBase, headBaseRun⟩ := + headRun.weakFV'_inv henv extension viewDefEq + headClosed headFVars + obtain ⟨tailBase, tailBaseRuns, tailEq⟩ := + ih tailClosed tailFVars tailUnique + have headEq : target = headBase.lift' (n.consN 0) := + headRun.unique' viewUnique headUnique + (headBaseRun.weakFV' henv.ordered extension viewWF) + subst target + 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} + {expected : Expr} {arguments : List Expr} + {trace : AddInductive.ConstructorPreFamilyIndexSpineTrace context expected + arguments} + {expected' : VExpr} + (run : AddInductive.ConstructorPreFamilyIndexSpineSemanticRun env Us + context contextRun trace expected') + {base view : VLCtx} {expectedBase : VExpr} {lift : Lift} + (familyTr : TrExprS env Us base expected expectedBase) + (unique : TrExprS.IsUnique expected) + (extension : VLCtx.FVLift' base view 0 lift 0) + (viewDefEq : VLCtx.IsDefEq env Us.length + contextRun.candidate.context.vlctx view) + (viewUnique : TrExprS.IsUniqueCtx + contextRun.candidate.context.vlctx view) : + expected' = expectedBase.lift' (lift.consN 0) := by + have henv : VEnv.Ordered env := by + simpa only [contextRun.venv_eq] using + contextRun.candidate.context.Ewf.ordered + have viewWF : VLCtx.WF env Us.length view := + (viewDefEq.symm henv).wf + have familyAtView : TrExprS env Us view expected + (expectedBase.lift' (lift.consN 0)) := + familyTr.weakFV' henv extension viewWF + have retained : TrExprS env Us contextRun.candidate.context.vlctx + expected expected' := run.expectedRun.expr_tr + exact retained.unique' viewUnique unique familyAtView + +theorem VLCtx.FVLift'.toCtxLiftN + {base view : VLCtx} {n : Nat} + (extension : VLCtx.FVLift' base view 0 (.skipN .refl n) 0) : + Ctx.LiftN n 0 base.toCtx view.toCtx := by + exact Ctx.liftN_iff_lift'.2 extension.toCtx + +/-- Transport a spine to the canonical view context and then remove the +free-variable extension from all of its endpoints. -/ +theorem VEnv.SpineWF.fvLift_inv + {env : VEnv} {U n : Nat} {base actual view : VLCtx} + {arguments : List VExpr} {source target : VExpr} + (henv : VEnv.WF env) + (viewDefEq : VLCtx.IsDefEq env U actual view) + (extension : VLCtx.FVLift' base view 0 (.skipN .refl n) 0) + (run : env.SpineWF U actual.toCtx (source.liftN n 0) + (arguments.map fun argument => argument.liftN n 0) + (target.liftN n 0)) : + env.SpineWF U base.toCtx source arguments target := by + have viewWF : VLCtx.WF env U view := + (viewDefEq.symm henv.ordered).wf + have viewRun : env.SpineWF U view.toCtx (source.liftN n 0) + (arguments.map fun argument => argument.liftN n 0) + (target.liftN n 0) := + run.defeqDFC henv.ordered viewDefEq.defeqCtx + exact VEnv.SpineWF.weakN_inv henv viewWF.toCtx + (Ctx.liftN_iff_lift'.2 extension.toCtx) viewRun + +theorem VEnv.SpineWF.fvLift'_inv + {env : VEnv} {U : Nat} {lift : Lift} {base actual view : VLCtx} + {arguments : List VExpr} {source target : VExpr} + (henv : VEnv.WF env) + (viewDefEq : VLCtx.IsDefEq env U actual view) + (extension : VLCtx.FVLift' base view 0 lift 0) + (run : env.SpineWF U actual.toCtx (source.lift' (lift.consN 0)) + (arguments.map fun argument => argument.lift' (lift.consN 0)) + (target.lift' (lift.consN 0))) : + env.SpineWF U base.toCtx source arguments target := by + have viewWF : VLCtx.WF env U view := + (viewDefEq.symm henv.ordered).wf + have viewRun : env.SpineWF U view.toCtx + (source.lift' (lift.consN 0)) + (arguments.map fun argument => argument.lift' (lift.consN 0)) + (target.lift' (lift.consN 0)) := + run.defeqDFC henv.ordered viewDefEq.defeqCtx + exact VEnv.SpineWF.weak'_inv henv viewWF.toCtx extension.toCtx viewRun + +/-- Identify a pre-family index replay with the analyzer family telescope, +remove the family-index locals, and retarget its terminal to the family sort. -/ +theorem ConstructorPreFamilyIndexSpineSemanticRun.baseSpine + {env : VEnv} {Us : List Name} {context : AddInductive.Context} + {contextRun : AddInductive.ConstructorContextRun env Us context} + {expected : Expr} {arguments : List Expr} + {trace : AddInductive.ConstructorPreFamilyIndexSpineTrace context expected + arguments} + {expected' : VExpr} {base view : VLCtx} {indices : List VExpr} + {level : VLevel} {n : Nat} + (run : AddInductive.ConstructorPreFamilyIndexSpineSemanticRun env Us + context contextRun trace expected') + (familyTr : TrExprS env Us base expected + (VExpr.forallN indices (.sort level))) + (expectedUnique : TrExprS.IsUnique expected) + (viewDefEq : VLCtx.IsDefEq env Us.length + contextRun.candidate.context.vlctx view) + (viewUnique : TrExprS.IsUniqueCtx + contextRun.candidate.context.vlctx view) + (extension : VLCtx.FVLift' base view 0 (.skipN .refl n) 0) + (argumentClosed : ∀ argument ∈ arguments, Closed argument) + (argumentFVars : ∀ argument ∈ arguments, + FVarsIn (· ∈ base.fvars) argument) + (argumentUnique : ∀ argument ∈ arguments, + TrExprS.IsUnique argument) + (argumentLength : arguments.length = indices.length) : + ∃ indices', + List.Forall₂ (TrExprS env Us base) arguments indices' ∧ + env.SpineWF Us.length base.toCtx + (VExpr.forallN indices (.sort level)) indices' (.sort level) := by + have henv : VEnv.WF env := by + simpa only [contextRun.venv_eq] using + contextRun.candidate.context.Ewf + have expectedEq : expected' = + (VExpr.forallN indices (.sort level)).liftN n 0 := + run.expected_eq_of_family familyTr expectedUnique extension viewDefEq + viewUnique + subst expected' + obtain ⟨indices', indicesTr, indicesEq⟩ := + TrExprS.forall₂_weakFV_inv_defeq henv viewDefEq viewUnique + extension run.arguments_tr argumentClosed argumentFVars argumentUnique + have translatedLength : run.arguments'.length = + (VExpr.liftTelN n indices 0).length := by + rw [← forall₂_length run.arguments_tr, argumentLength, + VExpr.liftTelN_length] + have liftedSpine : env.SpineWF Us.length + contextRun.candidate.context.vlctx.toCtx + ((VExpr.forallN indices (.sort level)).liftN n 0) + run.arguments' (.sort level) := by + have sourceEq : + (VExpr.forallN indices (.sort level)).liftN n 0 = + VExpr.forallN (VExpr.liftTelN n indices 0) (.sort level) := by + rw [VExpr.liftN_forallN] + rfl + have spine : env.SpineWF Us.length + contextRun.candidate.context.vlctx.toCtx + (VExpr.forallN (VExpr.liftTelN n indices 0) (.sort level)) + run.arguments' run.result' := + sourceEq ▸ run.spine + have retargeted := spine.retarget translatedLength (.sort level) + have sortClosed : (VExpr.sort level).ClosedN 0 := by trivial + have targetEq : (VExpr.sort level).instRev run.arguments' = + .sort level := VExpr.instRev_closedN run.arguments' sortClosed + rw [targetEq] at retargeted + exact Eq.mpr (congrArg (fun source => env.SpineWF Us.length + contextRun.candidate.context.vlctx.toCtx source run.arguments' + (.sort level)) sourceEq) retargeted + simp only [VExpr.lift'_consN_skipN] at indicesEq + rw [indicesEq] at liftedSpine + exact ⟨indices', indicesTr, by + apply VEnv.SpineWF.fvLift_inv henv viewDefEq extension + simpa only [VExpr.liftN] using liftedSpine⟩ + +theorem ConstructorPreFamilyIndexSpineSemanticRun.baseSpine_lift + {env : VEnv} {Us : List Name} {context : AddInductive.Context} + {contextRun : AddInductive.ConstructorContextRun env Us context} + {expected : Expr} {arguments : List Expr} + {trace : AddInductive.ConstructorPreFamilyIndexSpineTrace context expected + arguments} + {expected' : VExpr} {base view : VLCtx} {indices : List VExpr} + {level : VLevel} {lift : Lift} + (run : AddInductive.ConstructorPreFamilyIndexSpineSemanticRun env Us + context contextRun trace expected') + (familyTr : TrExprS env Us base expected + (VExpr.forallN indices (.sort level))) + (expectedUnique : TrExprS.IsUnique expected) + (viewDefEq : VLCtx.IsDefEq env Us.length + contextRun.candidate.context.vlctx view) + (viewUnique : TrExprS.IsUniqueCtx + contextRun.candidate.context.vlctx view) + (extension : VLCtx.FVLift' base view 0 lift 0) + (argumentClosed : ∀ argument ∈ arguments, Closed argument) + (argumentFVars : ∀ argument ∈ arguments, + FVarsIn (· ∈ base.fvars) argument) + (argumentUnique : ∀ argument ∈ arguments, + TrExprS.IsUnique argument) + (argumentLength : arguments.length = indices.length) : + ∃ indices', + List.Forall₂ (TrExprS env Us base) arguments indices' ∧ + env.SpineWF Us.length base.toCtx + (VExpr.forallN indices (.sort level)) indices' (.sort level) := by + have henv : VEnv.WF env := by + simpa only [contextRun.venv_eq] using + contextRun.candidate.context.Ewf + have expectedEq : expected' = + (VExpr.forallN indices (.sort level)).lift' (lift.consN 0) := + expected_eq_of_family_lift run familyTr expectedUnique extension + viewDefEq viewUnique + subst expected' + obtain ⟨indices', indicesTr, indicesEq⟩ := + TrExprS.forall₂_weakFV_inv_defeq henv viewDefEq viewUnique + extension run.arguments_tr argumentClosed argumentFVars argumentUnique + have translatedLength : run.arguments'.length = + (vexprLiftTel (lift.consN 0) indices).length := by + rw [← forall₂_length run.arguments_tr, argumentLength, + vexprLiftTel_length] + have liftedSpine : env.SpineWF Us.length + contextRun.candidate.context.vlctx.toCtx + ((VExpr.forallN indices (.sort level)).lift' (lift.consN 0)) + run.arguments' (.sort level) := by + have sourceEq : + (VExpr.forallN indices (.sort level)).lift' (lift.consN 0) = + VExpr.forallN (vexprLiftTel (lift.consN 0) indices) + (.sort level) := by + rw [vexpr_lift'_forallN] + rfl + have spine : env.SpineWF Us.length + contextRun.candidate.context.vlctx.toCtx + (VExpr.forallN (vexprLiftTel (lift.consN 0) indices) (.sort level)) + run.arguments' run.result' := + sourceEq ▸ run.spine + have retargeted := spine.retarget translatedLength (.sort level) + have sortClosed : (VExpr.sort level).ClosedN 0 := by trivial + have targetEq : (VExpr.sort level).instRev run.arguments' = + .sort level := VExpr.instRev_closedN run.arguments' sortClosed + rw [targetEq] at retargeted + exact Eq.mpr (congrArg (fun source => env.SpineWF Us.length + contextRun.candidate.context.vlctx.toCtx source run.arguments' + (.sort level)) sourceEq) retargeted + rw [indicesEq] at liftedSpine + exact ⟨indices', indicesTr, by + apply VEnv.SpineWF.fvLift'_inv henv viewDefEq extension + simpa only [VExpr.lift'] using liftedSpine⟩ + +/-- Recover the exact analyzer-selected source type and its checker-selected +sort after removing a verified free-variable context extension. -/ +theorem ensureTypeRun_baseType + {env typeEnv : VEnv} {Us : List Name} + {base actual view : VLCtx} {source result : Expr} + {source' actual' : VExpr} {fieldLevel : VLevel} {n : Lift} + (henv : VEnv.WF env) (typeEnvOrdered : VEnv.Ordered typeEnv) + (addType : env ≤ typeEnv) + (baseWF : VLCtx.WF env Us.length base) + (viewDefEq : VLCtx.IsDefEq env Us.length actual view) + (viewUnique : TrExprS.IsUniqueCtx actual view) + (viewLift : VLCtx.FVLift' base view 0 n 0) + (sourceUnique : TrExprS.IsUnique source) + (sourceClosed : Closed source) + (sourceFVars : FVarsIn (· ∈ base.fvars) source) + (sourceTr : TrExprS typeEnv Us base source source') + (actualTr : TrExprS env Us actual source actual') + (actualType : env.HasType Us.length actual.toCtx actual' (.sort fieldLevel)) : + env.HasType Us.length base.toCtx source' (.sort fieldLevel) := by + obtain ⟨base', baseTr⟩ := + actualTr.weakFV'_inv henv viewLift viewDefEq sourceClosed sourceFVars + have baseEq : base' = source' := + (baseTr.mono addType).unique sourceUnique sourceTr + subst base' + have viewWF : VLCtx.WF env Us.length view := + (viewDefEq.symm henv.ordered).wf + have sourceAtView := sourceTr + have sourceAtView' : TrExprS typeEnv Us view source + (source'.lift' (n.consN 0)) := + sourceAtView.weakFV' typeEnvOrdered viewLift (viewWF.mono addType) + have actualEq : actual' = source'.lift' (n.consN 0) := by + exact (actualTr.mono addType).unique' viewUnique sourceUnique sourceAtView' + have sourceTypeAtView : env.HasType Us.length view.toCtx + actual' (.sort fieldLevel) := + actualType.defeqDFC henv.ordered viewDefEq.defeqCtx + rw [actualEq] at sourceTypeAtView + exact (HasType.weak'_iff henv viewWF.toCtx viewLift.toCtx).1 (by + simpa using sourceTypeAtView) + +theorem ensureTypeRun_baseType_mono + {env typeEnv : VEnv} {Us : List Name} + {base actual view : VLCtx} {source : Expr} + {source' actual' : VExpr} {fieldLevel : VLevel} {n : Lift} + (typeEnvWF : VEnv.WF typeEnv) + (addType : env ≤ typeEnv) + (baseWF : VLCtx.WF env Us.length base) + (viewDefEq : VLCtx.IsDefEq env Us.length actual view) + (viewUnique : TrExprS.IsUniqueCtx actual view) + (viewLift : VLCtx.FVLift' base view 0 n 0) + (sourceUnique : TrExprS.IsUnique source) + (sourceClosed : Closed source) + (sourceFVars : FVarsIn (· ∈ base.fvars) source) + (sourceTr : TrExprS typeEnv Us base source source') + (actualTr : TrExprS env Us actual source actual') + (actualType : typeEnv.HasType Us.length actual.toCtx actual' + (.sort fieldLevel)) : + typeEnv.HasType Us.length base.toCtx source' (.sort fieldLevel) := by + exact ensureTypeRun_baseType (result := source) typeEnvWF + typeEnvWF.ordered VEnv.LE.rfl + (baseWF.mono addType) (viewDefEq.mono addType) viewUnique viewLift + sourceUnique sourceClosed sourceFVars sourceTr (actualTr.mono addType) + actualType + +/-- Recover a family-free base endpoint when the analyzer translation lives +under a different prefix than D3's index-extended replay context. -/ +theorem ensureTypeRun_commonType + {env typeEnv : VEnv} {Us : List Name} + {base full actual view : VLCtx} {source : Expr} + {fullTarget actualTarget : VExpr} {fieldLevel : VLevel} + {fullLift viewLift : Lift} + (henv : VEnv.WF env) (typeEnvWF : VEnv.WF typeEnv) + (addType : env ≤ typeEnv) + (baseWF : VLCtx.WF env Us.length base) + (fullWF : VLCtx.WF typeEnv Us.length full) + (fullExtension : VLCtx.FVLift' base full 0 fullLift 0) + (viewDefEq : VLCtx.IsDefEq env Us.length actual view) + (viewUnique : TrExprS.IsUniqueCtx actual view) + (viewExtension : VLCtx.FVLift' base view 0 viewLift 0) + (sourceUnique : TrExprS.IsUnique source) + (sourceClosed : Closed source) + (sourceFVars : FVarsIn (· ∈ base.fvars) source) + (fullTr : TrExprS typeEnv Us full source fullTarget) + (actualTr : TrExprS env Us actual source actualTarget) + (actualType : env.HasType Us.length actual.toCtx actualTarget + (.sort fieldLevel)) : + ∃ baseTarget, + TrExprS typeEnv Us base source baseTarget ∧ + fullTarget = baseTarget.lift' fullLift ∧ + env.HasType Us.length base.toCtx baseTarget (.sort fieldLevel) := by + obtain ⟨baseTarget, baseTr⟩ := fullTr.weakFV'_inv typeEnvWF + fullExtension (.refl typeEnvWF.ordered fullWF) sourceClosed sourceFVars + have fullEq : fullTarget = baseTarget.lift' fullLift := + fullTr.unique sourceUnique + (baseTr.weakFV' typeEnvWF.ordered fullExtension fullWF) + have baseType := ensureTypeRun_baseType (result := source) + henv typeEnvWF.ordered + addType baseWF viewDefEq viewUnique viewExtension sourceUnique + sourceClosed sourceFVars baseTr actualTr actualType + exact ⟨baseTarget, baseTr, fullEq, baseType⟩ + +/-- D2 types the exact analyzer-owned field in the synthetic full field +context and relates it to the declaration actually pushed by validation. -/ +theorem analyzerField_postType + {typeEnv : VEnv} {Us : List Name} + {full postActual : VLCtx} {source : Expr} + {analyzer postRaw postView postConsumed : VExpr} + {rawLevel : VLevel} + (typeEnvWF : VEnv.WF typeEnv) + (fullWF : VLCtx.WF typeEnv Us.length full) + (postWF : VLCtx.WF typeEnv Us.length postActual) + (relation : VLCtx.IsDefEqFVars typeEnv Us.length full postActual) + (analyzerTr : TrExprS typeEnv Us full source analyzer) + (postViewTr : TrExprS typeEnv Us postActual source postView) + (postRawType : typeEnv.HasType Us.length postActual.toCtx postRaw + (.sort rawLevel)) + (postRawView : typeEnv.IsDefEqU Us.length postActual.toCtx + postRaw postView) + (postAnnotations : typeEnv.IsDefEqU Us.length postActual.toCtx + postRaw postConsumed) : + typeEnv.HasType Us.length full.toCtx analyzer (.sort rawLevel) ∧ + typeEnv.IsDefEq Us.length full.toCtx analyzer postConsumed + (.sort rawLevel) := by + have postViewType : typeEnv.HasType Us.length postActual.toCtx postView + (.sort rawLevel) := + postRawType.defeqU_l typeEnvWF postWF.toCtx postRawView + have postViewAtFull : typeEnv.HasType Us.length full.toCtx postView + (.sort rawLevel) := + postViewType.defeqDFC typeEnvWF.ordered + (relation.defeqCtx.symm typeEnvWF.ordered) + have analyzerViewU : typeEnv.IsDefEqU Us.length full.toCtx + analyzer postView := + analyzerTr.uniqFVars typeEnvWF relation fullWF postViewTr + have analyzerView := analyzerViewU.of_r typeEnvWF fullWF.toCtx + postViewAtFull + have rawViewAtFull := postRawView.defeqDFC typeEnvWF.ordered + (relation.defeqCtx.symm typeEnvWF.ordered) + have rawConsumedAtFull := postAnnotations.defeqDFC typeEnvWF.ordered + (relation.defeqCtx.symm typeEnvWF.ordered) + have rawTypeAtFull := postRawType.defeqDFC typeEnvWF.ordered + (relation.defeqCtx.symm typeEnvWF.ordered) + have rawConsumed := rawConsumedAtFull.of_l typeEnvWF fullWF.toCtx + rawTypeAtFull + have analyzerConsumed := analyzerView.trans + ((rawViewAtFull.of_l typeEnvWF fullWF.toCtx rawTypeAtFull).symm.trans + rawConsumed) + exact ⟨analyzerView.hasType.1, analyzerConsumed⟩ + +structure AnalyzerPostContextState + (typeEnv : VEnv) (Us : List Name) + (full postActual postView : VLCtx) (viewLift : Lift) where + fullWF : VLCtx.WF typeEnv Us.length full + postWF : VLCtx.WF typeEnv Us.length postActual + viewWF : VLCtx.WF typeEnv Us.length postView + viewDefEq : VLCtx.IsDefEqFVars typeEnv Us.length postActual postView + viewExtension : VLCtx.FVLift' full postView 0 viewLift 0 + +def vlctxCons + (entry : Option (FVarId × List FVarId) × VLocalDecl) + (tail : VLCtx) : VLCtx := + entry :: tail + +theorem VLCtx.IsDefEqFVars.fvars + (relation : VLCtx.IsDefEqFVars env U left right) : + left.fvars = right.fvars := by + induction relation with + | nil => rfl + | cons_bvar relation declaration ih => + change _ = _ + exact ih + | cons_fvar relation declaration ih => + change _ :: _ = _ :: _ + exact congrArg (fun tail => _ :: tail) ih + +theorem VLCtx.IsDefEqFVars.mono + (add : env ≤ env') : + VLCtx.IsDefEqFVars env U left right → + VLCtx.IsDefEqFVars env' U left right := by + intro relation + induction relation with + | nil => exact .nil + | cons_bvar relation declaration ih => + exact .cons_bvar ih (declaration.mono add) + | cons_fvar relation declaration ih => + exact .cons_fvar ih (declaration.mono add) + +theorem VLCtx.IsDefEqFVars.symm + (henv : VEnv.Ordered env) : + VLCtx.IsDefEqFVars env U left right → + VLCtx.IsDefEqFVars env U right left := by + intro relation + induction relation with + | nil => exact .nil + | cons_bvar relation declaration ih => + exact .cons_bvar ih + (declaration.symm.defeqDFC henv relation.defeqCtx) + | cons_fvar relation declaration ih => + exact .cons_fvar ih + (declaration.symm.defeqDFC henv relation.defeqCtx) + +def FullFreshInvariant (context : AddInductive.Context) + (common full : VLCtx) : Prop := + ∀ fv ∈ full.fvars, + fv ∈ common.fvars ∨ context.ngen.Reserves fv + +theorem FullFreshInvariant.fresh + (invariant : FullFreshInvariant context common full) + (freshCommon : context.freshFVarId ∉ common.fvars) : + context.freshFVarId ∉ full.fvars := by + intro present + rcases invariant context.freshFVarId present with common | reserved + · exact freshCommon common + · exact NameGenerator.not_reserves_self reserved + +theorem FullFreshInvariant.push + (invariant : FullFreshInvariant context common full) + {commonDomain fullDomain : VLocalDecl} + {commonDeps fullDeps : List FVarId} : + FullFreshInvariant + (context.pushLocalDecl name binderInfo sourceDomain) + (vlctxCons + (some (context.freshFVarId, commonDeps), commonDomain) common) + (vlctxCons + (some (context.freshFVarId, fullDeps), fullDomain) full) := by + intro fv present + simp only [vlctxCons, VLCtx.fvars_cons_some, List.mem_cons] at present + rcases present with rfl | present + · exact .inl (by simp [vlctxCons]) + · rcases invariant fv present with commonMem | reserved + · exact .inl (by + simp only [vlctxCons, VLCtx.fvars_cons_some, List.mem_cons] + exact .inr commonMem) + · exact .inr (reserved.mono NameGenerator.LE.next) + +theorem FullFreshInvariant.skip + (invariant : FullFreshInvariant context common full) + {fullDomain : VLocalDecl} {fullDeps : List FVarId} : + FullFreshInvariant context.advanceFresh common + (vlctxCons + (some (context.freshFVarId, fullDeps), fullDomain) full) := by + intro fv present + simp only [vlctxCons, VLCtx.fvars_cons_some, List.mem_cons] at present + rcases present with rfl | present + · exact .inr NameGenerator.next_reserves_self + · rcases invariant fv present with common | reserved + · exact .inl common + · exact .inr (reserved.mono NameGenerator.LE.next) + +structure D3FullContextState + (env typeEnv : VEnv) (Us : List Name) + (context : AddInductive.Context) + (common full actual view : VLCtx) (fullLift viewLift : Lift) where + commonWF : VLCtx.WF env Us.length common + commonNoBV : common.NoBV + fullWF : VLCtx.WF typeEnv Us.length full + fullExtension : VLCtx.FVLift' common full 0 fullLift 0 + actualWF : VLCtx.WF env Us.length actual + viewDefEq : VLCtx.IsDefEq env Us.length actual view + viewUnique : TrExprS.IsUniqueCtx actual view + viewExtension : VLCtx.FVLift' common view 0 viewLift 0 + freshInvariant : FullFreshInvariant context common full + +/-- Push one family-free D3 binder through both the analyzer's full context +and D3's index-extended context. -/ +theorem D3FullContextState.push + {env typeEnv : VEnv} {Us : List Name} + {context : AddInductive.Context} + {common full actual view : VLCtx} {fullLift viewLift : Lift} + (state : D3FullContextState env typeEnv Us context + common full actual view fullLift viewLift) + (henv : VEnv.WF env) (typeEnvWF : VEnv.WF typeEnv) + (addType : env ≤ typeEnv) + {source : Expr} + {fullTarget actualSource actualConsumed : VExpr} + {fieldLevel consumedLevel : VLevel} + (sourceUnique : TrExprS.IsUnique source) + (sourceClosed : Closed source) + (sourceFVars : FVarsIn (· ∈ common.fvars) source) + (fullTr : TrExprS typeEnv Us full source fullTarget) + (actualTr : TrExprS env Us actual source actualSource) + (actualType : env.HasType Us.length actual.toCtx actualSource + (.sort fieldLevel)) + (actualAnnotations : env.IsDefEqU Us.length actual.toCtx + actualSource actualConsumed) + (actualConsumedType : env.HasType Us.length actual.toCtx actualConsumed + (.sort consumedLevel)) + (actualTailWF : VLCtx.WF env Us.length + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList), + .vlam actualConsumed) actual)) : + ∃ commonTarget, + TrExprS typeEnv Us common source commonTarget ∧ + fullTarget = commonTarget.lift' fullLift ∧ + env.HasType Us.length common.toCtx commonTarget (.sort fieldLevel) ∧ + D3FullContextState env typeEnv Us + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations source)) + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList), + .vlam commonTarget) common) + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList), + .vlam fullTarget) full) + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList), + .vlam actualConsumed) actual) + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList), + .vlam (commonTarget.lift' viewLift)) view) + (.consN fullLift 1) (.consN viewLift 1) := by + obtain ⟨commonTarget, commonTr, fullEq, commonType⟩ := + ensureTypeRun_commonType henv typeEnvWF addType state.commonWF + state.fullWF state.fullExtension state.viewDefEq state.viewUnique + state.viewExtension sourceUnique sourceClosed sourceFVars fullTr + actualTr actualType + have viewWF : VLCtx.WF env Us.length view := + (state.viewDefEq.symm henv.ordered).wf + have commonAtView : TrExprS typeEnv Us view source + (commonTarget.lift' viewLift) := + commonTr.weakFV' typeEnvWF.ordered state.viewExtension + (viewWF.mono addType) + have actualSource_eq : actualSource = commonTarget.lift' viewLift := + (actualTr.mono addType).unique' state.viewUnique sourceUnique commonAtView + have consumedToCommon : env.IsDefEq Us.length actual.toCtx + actualConsumed (commonTarget.lift' viewLift) + (.sort consumedLevel) := by + rw [← actualSource_eq] + exact (actualAnnotations.of_r henv state.actualWF.toCtx + actualConsumedType).symm + have depsSubset : (consumeTypeAnnotations source).fvarsList ⊆ + common.fvars := + (FVarsIn.consumeTypeAnnotations sourceFVars |> fvarsIn_iff.mp).1 + have freshCommon : context.freshFVarId ∉ common.fvars := by + intro present + have presentView := state.viewExtension.fvars_sublist.subset present + have presentActual : context.freshFVarId ∈ actual.fvars := by + simpa only [state.viewDefEq.fvars] using presentView + exact (actualTailWF.2.1 _ _ rfl).1 presentActual + have freshFull := state.freshInvariant.fresh freshCommon + have commonTailWF : VLCtx.WF env Us.length + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList), + .vlam commonTarget) common) := by + refine ⟨state.commonWF, ?_, ⟨fieldLevel, commonType⟩⟩ + intro fv deps equality + cases equality + exact ⟨freshCommon, depsSubset⟩ + have fullType : typeEnv.HasType Us.length full.toCtx fullTarget + (.sort fieldLevel) := by + rw [fullEq] + exact (commonType.weak' henv.ordered state.fullExtension.toCtx).mono addType + have fullTailWF : VLCtx.WF typeEnv Us.length + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList), + .vlam fullTarget) full) := by + refine ⟨state.fullWF, ?_, ⟨fieldLevel, fullType⟩⟩ + intro fv deps equality + cases equality + exact ⟨freshFull, fun fv member => + state.fullExtension.fvars_sublist.subset (depsSubset member)⟩ + have nextViewDefEq : VLCtx.IsDefEq env Us.length + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList), + .vlam actualConsumed) actual) + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList), + .vlam (commonTarget.lift' viewLift)) view) := by + exact .cons state.viewDefEq actualTailWF.2.1 + (.vlam consumedToCommon) + refine ⟨commonTarget, commonTr, fullEq, commonType, { + commonWF := commonTailWF + commonNoBV := by + simpa only [vlctxCons, VLCtx.NoBV, VLCtx.bvars] using + state.commonNoBV + fullWF := fullTailWF + fullExtension := ?_ + actualWF := actualTailWF + viewDefEq := nextViewDefEq + viewUnique := state.viewUnique.cons .vlam + viewExtension := state.viewExtension.cons_fvar + (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList) + (.vlam commonTarget) depsSubset + freshInvariant := state.freshInvariant.push }⟩ + simpa only [fullEq, vlctxCons, VLocalDecl.lift', + VLocalDecl.depth] using state.fullExtension.cons_fvar + (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList) + (.vlam commonTarget) depsSubset + +/-- Skip one family-dependent outer field in D3's family-free replay while +retaining that exact analyzer field in the full context. -/ +theorem D3FullContextState.skip + {env typeEnv : VEnv} {Us : List Name} + {context : AddInductive.Context} + {common full actual view : VLCtx} {fullLift viewLift : Lift} + (state : D3FullContextState env typeEnv Us context + common full actual view fullLift viewLift) + {source : Expr} {field : VExpr} + (nextFullWF : VLCtx.WF typeEnv Us.length + ((some (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList), + .vlam field) :: full)) : + D3FullContextState env typeEnv Us context.advanceFresh common + ((some (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList), + .vlam field) :: full) + actual view (.skipN fullLift 1) viewLift where + commonWF := state.commonWF + commonNoBV := state.commonNoBV + fullWF := nextFullWF + fullExtension := by + simpa only [VLocalDecl.depth] using state.fullExtension.skip_fvar + (context.freshFVarId, + (consumeTypeAnnotations source).fvarsList) (.vlam field) + actualWF := state.actualWF + viewDefEq := state.viewDefEq + viewUnique := state.viewUnique + viewExtension := state.viewExtension + freshInvariant := state.freshInvariant.skip + +/-- Exact analyzer syntax and pre-family semantic evidence for one recursive +field. The family telescope is tracked at the analyzer's current full +context; nested binders lift it in the ordinary de Bruijn way. -/ +def RecursiveFieldRunResult + (env : VEnv) (Us : List Name) (full : VLCtx) + (familyTarget fieldTarget : VExpr) (level : VLevel) + (familyName : Name) (parameterCount : Nat) : Prop := + ∃ binders indices terminal, + fieldTarget = VExpr.forallN binders terminal ∧ + env.OnTel Us.length full.toCtx binders ∧ + env.SpineWF Us.length + (binders.reverse ++ full.toCtx) + (familyTarget.liftN binders.length 0) indices (.sort level) ∧ + (∃ levels, VExpr.appHead terminal = .const familyName levels) ∧ + (VExpr.appArgs terminal []).drop parameterCount = indices + +/-- Synchronize the recursive D3 replay with the analyzer's exact strict +translation. D3 supplies all family-free typing and the terminal index +spine; strict translation uniqueness fixes the analyzer-owned domains and +terminal arguments componentwise. -/ +theorem recursiveField_exactAnalyzer + {env typeEnv : VEnv} {Us : List Name} + {stats : AddInductive.InductiveStats} {familyIdx : Nat} + {familyIndices : Expr} {context : AddInductive.Context} + {contextRun : AddInductive.ConstructorContextRun env Us context} + {source : Expr} {fuel : Nat} + {trace : AddInductive.ConstructorPreFamilyRecursiveTrace stats familyIdx + familyIndices context source fuel} + (run : AddInductive.ConstructorPreFamilyRecursiveSemanticRun env Us stats + familyIdx familyIndices contextRun trace) + (henv : VEnv.WF env) (typeEnvWF : VEnv.WF typeEnv) + (addType : env ≤ typeEnv) + {common full view : VLCtx} {fullLift viewLift : Lift} + (state : D3FullContextState env typeEnv Us context common full + contextRun.candidate.context.vlctx view fullLift viewLift) + {commonIndices : List VExpr} {familyTarget fieldTarget : VExpr} + {level : VLevel} {familyName : Name} {familyLevels : List Level} + (familyCommonTr : TrExprS env Us common familyIndices + (VExpr.forallN commonIndices (.sort level))) + (familyFullTr : TrExprS typeEnv Us full familyIndices familyTarget) + (familyUnique : TrExprS.IsUnique familyIndices) + (indexLength : commonIndices.length = stats.nindices[familyIdx]!) + (familyHead : stats.indConsts[familyIdx]! = + .const familyName familyLevels) + (sourceUnique : TrExprS.IsUnique source) + (sourceClosed : Closed source) + (sourceFVars : FVarsIn (· ∈ common.fvars) source) + (fullTr : TrExprS typeEnv Us full source fieldTarget) : + RecursiveFieldRunResult env Us full familyTarget fieldTarget level + familyName stats.params.size := by + induction run generalizing common full view fullLift viewLift commonIndices + familyTarget fieldTarget with + | @target _ context source fuel valid spineTrace branchContextRun expected' + spine => + have argumentClosed : ∀ argument ∈ + source.getAppArgs.toList.drop stats.params.size, + Closed argument := by + intro argument member + apply Closed.getAppArgsList sourceClosed + rw [← Expr.getAppArgs_toList] + exact List.mem_of_mem_drop member + have argumentFVars : ∀ argument ∈ + source.getAppArgs.toList.drop stats.params.size, + FVarsIn (· ∈ common.fvars) argument := by + intro argument member + apply FVarsIn.getAppArgsList sourceFVars + rw [← Expr.getAppArgs_toList] + exact List.mem_of_mem_drop member + have argumentUnique : ∀ argument ∈ + source.getAppArgs.toList.drop stats.params.size, + TrExprS.IsUnique argument := by + intro argument member + apply TrExprS.IsUnique.getAppArgsList sourceUnique + rw [← Expr.getAppArgs_toList] + exact List.mem_of_mem_drop member + have argumentLength : + (source.getAppArgs.toList.drop stats.params.size).length = + commonIndices.length := + (isValidIndAppIdx_indexArgs_length valid).trans + indexLength.symm + obtain ⟨baseIndices, baseIndicesTr, baseSpine⟩ := + ConstructorPreFamilyIndexSpineSemanticRun.baseSpine_lift spine + familyCommonTr familyUnique + state.viewDefEq state.viewUnique state.viewExtension + argumentClosed argumentFVars argumentUnique argumentLength + have commonFamilyAtFull : TrExprS typeEnv Us full familyIndices + ((VExpr.forallN commonIndices (.sort level)).lift' fullLift) := by + simpa using (familyCommonTr.mono addType).weakFV' + typeEnvWF.ordered state.fullExtension state.fullWF + have familyEq : familyTarget = + (VExpr.forallN commonIndices (.sort level)).lift' fullLift := + familyFullTr.unique familyUnique commonFamilyAtFull + have shape := isValidIndAppIdx_shape valid + have sourceHead : source.getAppFn = + .const familyName familyLevels := by + rw [familyHead] at shape + change source.getAppFn.eqv (.const familyName familyLevels) = true ∧ + _ at shape + rw [Expr.eqv_eq] at shape + generalize headEq : source.getAppFn = head at shape + cases head <;> simp_all [Expr.eqv'] + obtain ⟨targetLevels, targetHead, allArgumentsTr⟩ := + TrExprS.constApp_components fullTr sourceHead + have droppedArgumentsTr := + forall₂_drop allArgumentsTr stats.params.size + have baseIndicesAtFull : List.Forall₂ + (TrExprS typeEnv Us full) + (source.getAppArgsList.drop stats.params.size) + (baseIndices.map fun index => index.lift' fullLift) := by + have baseMono := forall₂_tr_mono addType baseIndicesTr + have baseWeak := forall₂_tr_weakFV' typeEnvWF.ordered + state.fullExtension state.fullWF baseMono + simpa only [Expr.getAppArgs_toList] using baseWeak + have translatedIndicesEq : + (VExpr.appArgs fieldTarget []).drop stats.params.size = + baseIndices.map fun index => index.lift' fullLift := + forall₂_translation_unique droppedArgumentsTr + baseIndicesAtFull (fun argument member => + TrExprS.IsUnique.getAppArgsList sourceUnique argument + (List.mem_of_mem_drop member)) + have fullSpine : env.SpineWF Us.length full.toCtx + ((VExpr.forallN commonIndices (.sort level)).lift' fullLift) + (baseIndices.map fun index => index.lift' fullLift) + (.sort level) := by + simpa using VEnv.SpineWF.weak' henv.ordered + state.fullExtension.toCtx baseSpine + rw [← familyEq, ← translatedIndicesEq] at fullSpine + exact ⟨[], (VExpr.appArgs fieldTarget []).drop stats.params.size, + fieldTarget, rfl, trivial, by simpa using fullSpine, + ⟨targetLevels, targetHead⟩, rfl⟩ + | @forallE context name domain body binderInfo fuel domainCheck ensureType + consumedCheck annotations fresh tailTrace branchContextRun domainRun + consumedRun ensureTypeRun annotationsRun consumedType tail ih => + obtain ⟨fullDomain, fullBody, rfl, fullDomainType, fullBodyType, + domainTr, bodyTr⟩ := TrExprS.forallE_components fullTr + have actualDomainTr : TrExprS env Us + branchContextRun.candidate.context.vlctx domain + domainRun.source' := by + simpa only [branchContextRun.venv_eq, + branchContextRun.lparams_eq] using domainRun.check.expr_tr + have actualDomainType : env.HasType Us.length + branchContextRun.candidate.context.vlctx.toCtx domainRun.source' + (.sort ensureTypeRun.resultLevel') := by + simpa only [branchContextRun.venv_eq, + branchContextRun.lparams_eq] using ensureTypeRun.source_type + have actualAnnotations : env.IsDefEqU Us.length + branchContextRun.candidate.context.vlctx.toCtx domainRun.source' + consumedRun.source' := by + simpa only [branchContextRun.venv_eq, + branchContextRun.lparams_eq] using annotationsRun.isDefEqU + have consumedTypeCopy := consumedType + obtain ⟨consumedLevel, consumedHasType⟩ := consumedType + have actualConsumedType : env.HasType Us.length + branchContextRun.candidate.context.vlctx.toCtx consumedRun.source' + (.sort consumedLevel) := by + simpa only [branchContextRun.venv_eq, + branchContextRun.lparams_eq] using consumedHasType + let nextContextRun := branchContextRun.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain) fresh consumedRun.source' + consumedRun.check.expr_tr consumedTypeCopy + have actualTailWF : VLCtx.WF env Us.length + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam consumedRun.source') + branchContextRun.candidate.context.vlctx) := by + have nextWF := nextContextRun.candidate.context.Δwf + rw [nextContextRun.venv_eq, nextContextRun.lparams_eq] at nextWF + simpa only [vlctxCons, nextContextRun, + AddInductive.ConstructorContextRun.pushLocalDecl, + CandidateContextRun.pushLocalDecl_vlctx] using nextWF + obtain ⟨commonDomain, commonDomainTr, fullDomainEq, + commonDomainType, nextState⟩ := + state.push henv typeEnvWF addType sourceUnique.1 sourceClosed.1 + sourceFVars.1 domainTr actualDomainTr actualDomainType + actualAnnotations actualConsumedType actualTailWF + have bodyOpened : TrExprS typeEnv Us + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam fullDomain) full) + (body.instantiate1 context.freshExpr) fullBody := by + simpa only [vlctxCons, AddInductive.Context.freshExpr, + Expr.instantiate1_eq] using + bodyTr.inst_fvar typeEnvWF.ordered nextState.fullWF + have familyCommonNext : TrExprS env Us + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam commonDomain) common) + familyIndices + (VExpr.forallN (VExpr.liftTelN 1 commonIndices 0) + (.sort level)) := by + have weakened := familyCommonTr.weakFV henv.ordered + (VLCtx.FVLift.skip_fvar + (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList) + (.vlam commonDomain) .refl) + nextState.commonWF + simpa [vlctxCons, VLocalDecl.depth, + VExpr.liftN_forallN, VExpr.liftN] using weakened + have familyFullNext : TrExprS typeEnv Us + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam fullDomain) full) + familyIndices (familyTarget.liftN 1 0) := by + have weakened := familyFullTr.weakFV typeEnvWF.ordered + (VLCtx.FVLift.skip_fvar + (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList) + (.vlam fullDomain) .refl) + nextState.fullWF + simpa [vlctxCons, VLocalDecl.depth] using weakened + have nextIndexLength : + (VExpr.liftTelN 1 commonIndices 0).length = + stats.nindices[familyIdx]! := by + simpa only [VExpr.liftTelN_length] using indexLength + have tailUnique : TrExprS.IsUnique + (body.instantiate1 context.freshExpr) := by + apply TrExprS.IsUnique.instantiate1 sourceUnique.2 + simp only [AddInductive.Context.freshExpr] + trivial + have nextFullNoBV : + (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam fullDomain) full).bvars = 0 := + nextState.fullExtension.bvars_eq.trans nextState.commonNoBV + have tailClosed : Closed (body.instantiate1 context.freshExpr) := by + have closed := bodyOpened.closed + rw [nextFullNoBV] at closed + exact closed + have tailFVars : FVarsIn + (· ∈ (vlctxCons + (some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam commonDomain) common).fvars) + (body.instantiate1 context.freshExpr) := by + rw [Expr.instantiate1_eq] + apply FVarsIn.instantiate1 + · exact sourceFVars.2.mono (fun fv member => by + simp only [vlctxCons, VLCtx.fvars_cons_some, + List.mem_cons] + exact .inr member) + · simp [AddInductive.Context.freshExpr, vlctxCons, FVarsIn] + obtain ⟨tailBinders, indices, terminal, tailTargetEq, tailOnTel, + tailSpine, terminalHead, terminalIndices⟩ := + ih nextState familyCommonNext familyFullNext nextIndexLength + tailUnique tailClosed tailFVars bodyOpened + refine ⟨fullDomain :: tailBinders, indices, terminal, ?_, ?_, ?_, + terminalHead, terminalIndices⟩ + · simp only [VExpr.forallN, VExpr.forallE.injEq, true_and] + exact tailTargetEq + · exact ⟨by + rw [fullDomainEq] + exact ⟨ensureTypeRun.resultLevel', by + simpa using commonDomainType.weak' henv.ordered + state.fullExtension.toCtx⟩, + by + simpa only [vlctxCons, VLCtx.toCtx] using tailOnTel⟩ + · simpa only [List.reverse_cons, List.singleton_append, + List.append_assoc, vlctxCons, VLCtx.toCtx, + List.length_cons, VExpr.liftN_liftN, Nat.add_comm] using tailSpine + +private theorem forallN_inj_of_terminal_ne_forall + (leftNot : ∀ domain body, leftTerminal ≠ .forallE domain body) + (rightNot : ∀ domain body, rightTerminal ≠ .forallE domain body) + (equality : VExpr.forallN leftBinders leftTerminal = + VExpr.forallN rightBinders rightTerminal) : + leftBinders = rightBinders ∧ leftTerminal = rightTerminal := by + induction leftBinders generalizing rightBinders with + | nil => + cases rightBinders with + | nil => exact ⟨rfl, equality⟩ + | cons domain binders => + exact (leftNot domain (VExpr.forallN binders rightTerminal) + equality).elim + | cons domain binders ih => + cases rightBinders with + | nil => + exact (rightNot domain (VExpr.forallN binders leftTerminal) + equality.symm).elim + | cons rightDomain rightBinders => + simp only [VExpr.forallN, VExpr.forallE.injEq] at equality + obtain ⟨domainEq, tailEq⟩ := equality + obtain ⟨bindersEq, terminalEq⟩ := + ih tailEq + cases domainEq + cases bindersEq + exact ⟨rfl, terminalEq⟩ + +private theorem terminal_ne_forall_of_appHead_const + (head : VExpr.appHead terminal = .const familyName levels) : + ∀ domain body, terminal ≠ .forallE domain body := by + intro domain body equality + subst terminal + simp only [VExpr.appHead] at head + exact VExpr.noConfusion head + +private theorem hasConst_of_appHead_const + (head : VExpr.appHead terminal = .const familyName levels) : + terminal.hasConst familyName = true := by + induction terminal with + | app function argument functionIH argumentIH => + simp only [VExpr.appHead] at head + simp only [VExpr.hasConst, Bool.or_eq_true] + exact .inl (functionIH head) + | const name levels => + simp only [VExpr.appHead, VExpr.const.injEq] at head + exact (beq_iff_eq).2 head.1 + | bvar | sort | lam | forallE => simp [VExpr.appHead] at head + +private theorem forallN_hasConst_of_terminal + (terminalHasConst : terminal.hasConst familyName = true) : + (VExpr.forallN binders terminal).hasConst familyName = true := by + induction binders with + | nil => exact terminalHasConst + | cons binder binders ih => + 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 + cases recursiveEq : VInductDecl.recArg? U familyName np ni fieldIndex field with + | none => rfl + | some recursive => + have anatomy := VInductDecl.recArg?_eq recursiveEq + have terminalHead : + VExpr.appHead + (VExpr.appN (.const familyName (VLevel.params U)) + (VExpr.bvarRevRange + (fieldIndex + recursive.binders.length) np ++ + recursive.indices)) = + .const familyName (VLevel.params U) := + VExpr.appHead_appN _ _ + have terminalHasConst := + hasConst_of_appHead_const terminalHead + have recursiveHasConst := + forallN_hasConst_of_terminal + (binders := recursive.binders) terminalHasConst + rw [← anatomy.2.2.1, free] at recursiveHasConst + contradiction + +private theorem drop_bvarRevRange_append + (offset count : Nat) (suffix : List VExpr) : + (VExpr.bvarRevRange offset count ++ suffix).drop count = suffix := by + induction count with + | zero => rfl + | succ count ih => + simp only [VExpr.bvarRevRange, List.cons_append, List.drop_succ_cons] + exact ih + +/-- A recursive-field synchronization certificate is exactly the semantic +payload required by the analyzer's `RecArg` descriptor. -/ +theorem recursiveFieldResult_recArgWF + {env : VEnv} {Us : List Name} {full : VLCtx} + {familyTarget fieldTarget : VExpr} {level : VLevel} + {familyName : Name} {np ni fieldIndex : Nat} + {familyIndices : List VExpr} + (result : RecursiveFieldRunResult env Us full familyTarget + fieldTarget level familyName np) + (familyTargetEq : familyTarget = + VExpr.forallN (VExpr.liftTelN fieldIndex familyIndices 0) + (.sort level)) + (stage : VInductDecl.stage3Field Us.length familyName np ni fieldIndex + fieldTarget = true) : + ∃ recursive, + VInductDecl.recArg? Us.length familyName np ni fieldIndex fieldTarget = + some recursive ∧ + recursive.WF Us.length env level familyIndices full.toCtx := by + obtain ⟨binders, indices, terminal, targetEq, onTel, spine, + ⟨terminalLevels, terminalHead⟩, terminalIndices⟩ := result + have terminalHasConst : terminal.hasConst familyName = true := + hasConst_of_appHead_const terminalHead + have fieldHasConst : fieldTarget.hasConst familyName = true := by + rw [targetEq] + exact forallN_hasConst_of_terminal terminalHasConst + have recursiveSome : + (VInductDecl.recArg? Us.length familyName np ni fieldIndex + fieldTarget).isSome = true := by + simpa only [VInductDecl.stage3Field, fieldHasConst, Bool.not_true, + Bool.or_false] using stage + cases recursiveEq : VInductDecl.recArg? Us.length familyName np ni + fieldIndex fieldTarget with + | none => simp [recursiveEq] at recursiveSome + | some recursive => + have anatomy := VInductDecl.recArg?_eq recursiveEq + let recursiveTerminal := VExpr.appN + (.const familyName (VLevel.params Us.length)) + (VExpr.bvarRevRange (fieldIndex + recursive.binders.length) np ++ + recursive.indices) + have telescopesEq : VExpr.forallN binders terminal = + VExpr.forallN recursive.binders recursiveTerminal := by + exact targetEq.symm.trans anatomy.2.2.1 + have recursiveTerminalHead : + VExpr.appHead recursiveTerminal = + .const familyName (VLevel.params Us.length) := by + exact VExpr.appHead_appN _ _ + obtain ⟨bindersEq, terminalEq⟩ := + forallN_inj_of_terminal_ne_forall + (terminal_ne_forall_of_appHead_const terminalHead) + (terminal_ne_forall_of_appHead_const recursiveTerminalHead) + telescopesEq + have indicesEq : indices = recursive.indices := by + rw [terminalEq, VExpr.appArgs_appN] at terminalIndices + simp only [VExpr.appArgs, List.append_nil] at terminalIndices + rw [drop_bvarRevRange_append] at terminalIndices + exact terminalIndices.symm + refine ⟨recursive, rfl, ?_⟩ + unfold VInductDecl.RecArg.WF + refine ⟨?_, ?_⟩ + · rw [← bindersEq] + exact onTel + · rw [anatomy.1, ← bindersEq, ← indicesEq] + rw [familyTargetEq, VExpr.liftN_forallN, + VExpr.liftTelN_liftTelN] at spine + simpa [VExpr.liftN] using spine + +theorem AnalyzerPostContextState.push + {typeEnv : VEnv} {Us : List Name} + {full postActual postViewContext : VLCtx} {viewLift : Lift} + (state : AnalyzerPostContextState typeEnv Us full postActual + postViewContext viewLift) + (typeEnvWF : VEnv.WF typeEnv) + {source : Expr} {analyzer postRaw postView postConsumed : VExpr} + {rawLevel : VLevel} {fv : FVarId} {postDeps : List FVarId} + (sourceUnique : TrExprS.IsUnique source) + (sourceClosed : Closed source) + (analyzerTr : TrExprS typeEnv Us full source analyzer) + (postViewTr : TrExprS typeEnv Us postActual source postView) + (postRawType : typeEnv.HasType Us.length postActual.toCtx postRaw + (.sort rawLevel)) + (postRawView : typeEnv.IsDefEqU Us.length postActual.toCtx + postRaw postView) + (postAnnotations : typeEnv.IsDefEqU Us.length postActual.toCtx + postRaw postConsumed) + (postTailWF : VLCtx.WF typeEnv Us.length + ((some (fv, postDeps), .vlam postConsumed) :: postActual)) : + let deps := (AddInductive.consumeTypeAnnotations source).fvarsList + typeEnv.HasType Us.length full.toCtx analyzer (.sort rawLevel) ∧ + AnalyzerPostContextState typeEnv Us + ((some (fv, deps), .vlam analyzer) :: full) + ((some (fv, postDeps), .vlam postConsumed) :: postActual) + ((some (fv, deps), .vlam (analyzer.lift' viewLift)) :: + postViewContext) + (.consN viewLift 1) := by + dsimp only + have postViewType : typeEnv.HasType Us.length postActual.toCtx postView + (.sort rawLevel) := + postRawType.defeqU_l typeEnvWF state.postWF.toCtx postRawView + have postViewContextWF : VLCtx.WF typeEnv Us.length postViewContext := + state.viewWF + have analyzerAtView : TrExprS typeEnv Us postViewContext source + (analyzer.lift' viewLift) := + analyzerTr.weakFV' typeEnvWF.ordered state.viewExtension + postViewContextWF + have postViewAnalyzer : typeEnv.IsDefEqU Us.length postActual.toCtx + postView (analyzer.lift' viewLift) := + postViewTr.uniqFVars typeEnvWF state.viewDefEq state.postWF + analyzerAtView + have analyzerAtPostType : typeEnv.HasType Us.length postActual.toCtx + (analyzer.lift' viewLift) (.sort rawLevel) := + (postViewAnalyzer.of_l typeEnvWF state.postWF.toCtx postViewType).hasType.2 + have analyzerAtViewType : typeEnv.HasType Us.length postViewContext.toCtx + (analyzer.lift' viewLift) (.sort rawLevel) := + analyzerAtPostType.defeqDFC typeEnvWF.ordered + state.viewDefEq.defeqCtx + have analyzerType : typeEnv.HasType Us.length full.toCtx analyzer + (.sort rawLevel) := + (HasType.weak'_iff typeEnvWF postViewContextWF.toCtx + state.viewExtension.toCtx).1 (by simpa using analyzerAtViewType) + have rawView := postRawView.of_l typeEnvWF state.postWF.toCtx postRawType + have rawConsumed := + postAnnotations.of_l typeEnvWF state.postWF.toCtx postRawType + have analyzerConsumed : typeEnv.IsDefEq Us.length postActual.toCtx + postConsumed (analyzer.lift' viewLift) (.sort rawLevel) := + (rawConsumed.symm.trans rawView).trans + (postViewAnalyzer.of_l typeEnvWF state.postWF.toCtx postViewType) + have depsSubset : (AddInductive.consumeTypeAnnotations source).fvarsList ⊆ + full.fvars := + (FVarsIn.consumeTypeAnnotations analyzerTr.fvarsIn + |> fvarsIn_iff.mp).1 + have freshFull : fv ∉ full.fvars := by + intro present + have presentView := state.viewExtension.fvars_sublist.subset present + have presentPost : fv ∈ postActual.fvars := by + simpa only [ConstructorValidation.VLCtx.IsDefEqFVars.fvars state.viewDefEq] + using presentView + exact (postTailWF.2.1 fv postDeps rfl).1 presentPost + have freshView : fv ∉ postViewContext.fvars := by + intro present + have presentPost : fv ∈ postActual.fvars := by + simpa only [ConstructorValidation.VLCtx.IsDefEqFVars.fvars state.viewDefEq] + using present + exact (postTailWF.2.1 fv postDeps rfl).1 presentPost + have depsSubsetView : + (AddInductive.consumeTypeAnnotations source).fvarsList ⊆ + postViewContext.fvars := fun _ member => + state.viewExtension.fvars_sublist.subset (depsSubset member) + have fullTailWF : VLCtx.WF typeEnv Us.length + ((some (fv, (AddInductive.consumeTypeAnnotations source).fvarsList), + .vlam analyzer) :: full) := + ⟨state.fullWF, + fun _ _ equality => by + cases equality + exact ⟨freshFull, depsSubset⟩, + ⟨rawLevel, analyzerType⟩⟩ + have viewTailWF : VLCtx.WF typeEnv Us.length + ((some (fv, (AddInductive.consumeTypeAnnotations source).fvarsList), + .vlam (analyzer.lift' viewLift)) :: postViewContext) := + ⟨state.viewWF, + fun _ _ equality => by + cases equality + exact ⟨freshView, depsSubsetView⟩, + ⟨rawLevel, analyzerAtViewType⟩⟩ + exact ⟨analyzerType, { + fullWF := fullTailWF + postWF := postTailWF + viewWF := viewTailWF + viewDefEq := .cons_fvar state.viewDefEq (.vlam analyzerConsumed) + viewExtension := state.viewExtension.cons_fvar + (fv, (AddInductive.consumeTypeAnnotations source).fvarsList) + (.vlam analyzer) depsSubset }⟩ + +theorem ordinaryField_baseTypes + {env typeEnv : VEnv} {Us : List Name} + {base actual view postActual : VLCtx} {source : Expr} + {source' actual' postRaw' postView' : VExpr} + {fieldLevel rawLevel resultLevel : VLevel} {n : Lift} + (henv : VEnv.WF env) (typeEnvWF : VEnv.WF typeEnv) + (addType : env ≤ typeEnv) + (baseWF : VLCtx.WF env Us.length base) + (actualWF : VLCtx.WF env Us.length actual) + (postWF : VLCtx.WF typeEnv Us.length postActual) + (postRelation : VLCtx.IsDefEqFVars typeEnv Us.length actual postActual) + (viewDefEq : VLCtx.IsDefEq env Us.length actual view) + (viewUnique : TrExprS.IsUniqueCtx actual view) + (viewLift : VLCtx.FVLift' base view 0 n 0) + (sourceUnique : TrExprS.IsUnique source) + (sourceClosed : Closed source) + (sourceFVars : FVarsIn (· ∈ base.fvars) source) + (sourceTr : TrExprS typeEnv Us base source source') + (actualTr : TrExprS env Us actual source actual') + (actualType : env.HasType Us.length actual.toCtx actual' + (.sort fieldLevel)) + (postViewTr : TrExprS typeEnv Us postActual source postView') + (postRawType : typeEnv.HasType Us.length postActual.toCtx postRaw' + (.sort rawLevel)) + (postRawView : typeEnv.IsDefEqU Us.length postActual.toCtx + postRaw' postView') + (rawBound : resultLevel = .zero ∨ rawLevel ≤ resultLevel) : + env.HasType Us.length base.toCtx source' (.sort fieldLevel) ∧ + fieldLevel ≈ rawLevel ∧ + (resultLevel = .zero ∨ fieldLevel ≤ resultLevel) := by + have baseField := ensureTypeRun_baseType (result := source) henv + typeEnvWF.ordered addType baseWF viewDefEq viewUnique viewLift + sourceUnique sourceClosed sourceFVars sourceTr actualTr actualType + have postViewType : typeEnv.HasType Us.length postActual.toCtx postView' + (.sort rawLevel) := + postRawType.defeqU_l typeEnvWF postWF.toCtx postRawView + have postViewTypeAtActual : typeEnv.HasType Us.length actual.toCtx + postView' (.sort rawLevel) := + postViewType.defeqDFC typeEnvWF.ordered + (postRelation.defeqCtx.symm typeEnvWF.ordered) + have translatedDefEq : typeEnv.IsDefEqU Us.length actual.toCtx + actual' postView' := + (actualTr.mono addType).uniqFVars typeEnvWF postRelation + (actualWF.mono addType) postViewTr + have actualRawType : typeEnv.HasType Us.length actual.toCtx actual' + (.sort rawLevel) := + (translatedDefEq.of_r typeEnvWF (actualWF.mono addType).toCtx + postViewTypeAtActual).hasType.1 + have baseRaw := ensureTypeRun_baseType_mono typeEnvWF addType baseWF + viewDefEq viewUnique viewLift sourceUnique sourceClosed sourceFVars + sourceTr actualTr actualRawType + have levelEq : fieldLevel ≈ rawLevel := + (baseField.mono addType).uniqU typeEnvWF (baseWF.mono addType).toCtx + baseRaw |>.sort_inv typeEnvWF (baseWF.mono addType).toCtx + refine ⟨baseField, levelEq, ?_⟩ + rcases rawBound with prop | bound + · exact .inl prop + · exact .inr (VLevel.le_trans + (VLevel.le_antisymm_iff.mp levelEq).1 bound) + +theorem ordinaryConsumed_defeq + {env typeEnv : VEnv} {Us : List Name} + {actual postActual : VLCtx} {source rawSource rawConsumed sourceConsumed : Expr} + {actualSource' actualConsumed' postRaw' postView' postConsumed' : VExpr} + (typeEnvWF : VEnv.WF typeEnv) (addType : env ≤ typeEnv) + (actualWF : VLCtx.WF env Us.length actual) + (relation : VLCtx.IsDefEqFVars typeEnv Us.length actual postActual) + (actualSourceTr : TrExprS env Us actual source actualSource') + (actualAnnotations : env.IsDefEqU Us.length actual.toCtx + actualSource' actualConsumed') + (actualConsumedType : env.IsType Us.length actual.toCtx actualConsumed') + (postViewTr : TrExprS typeEnv Us postActual source postView') + (postRawView : typeEnv.IsDefEqU Us.length postActual.toCtx + postRaw' postView') + (postAnnotations : typeEnv.IsDefEqU Us.length postActual.toCtx + postRaw' postConsumed') : + ∃ level, typeEnv.IsDefEq Us.length actual.toCtx + actualConsumed' postConsumed' (.sort level) := by + have actualWF' := actualWF.mono addType + have sourceEq : typeEnv.IsDefEqU Us.length actual.toCtx + actualSource' postView' := + (actualSourceTr.mono addType).uniqFVars typeEnvWF relation actualWF' + postViewTr + have postToActual := relation.defeqCtx.symm typeEnvWF.ordered + have rawView := postRawView.defeqDFC typeEnvWF.ordered postToActual + have rawConsumed := postAnnotations.defeqDFC typeEnvWF.ordered postToActual + have consumedEq := (actualAnnotations.mono addType).symm.trans typeEnvWF + actualWF'.toCtx (sourceEq.trans typeEnvWF actualWF'.toCtx + (rawView.symm.trans typeEnvWF actualWF'.toCtx rawConsumed)) + obtain ⟨level, consumedType⟩ := actualConsumedType + exact ⟨level, consumedEq.of_l typeEnvWF actualWF'.toCtx + (consumedType.mono addType)⟩ + +/-- The terminal kernel sort retained by a candidate recursion translates to +the exact terminal Theory sort exposed by its analyzer-owned view telescope. -/ +theorem CandidateExprRun.terminalLevel_tr + {env : VEnv} {Us : List Name} + {candidateContext : AddInductive.Context} {source : Expr} + {trace : AddInductive.CandidateExprTrace candidateContext source} + {context : VLCtx} {source' view' inferred' : VExpr} + (run : CandidateExprRun env Us trace context source' view' inferred') + {resultLevel : Level} {resultLevel' : VLevel} {binders : List VExpr} + (terminal : trace.terminalResult = .sort resultLevel) + (viewEq : view' = VExpr.forallN binders (.sort resultLevel')) + (lengthEq : trace.spineLength = binders.length) : + VLevel.ofLevel Us resultLevel = some resultLevel' := by + induction run generalizing binders with + | terminal node => + simp only [AddInductive.CandidateExprTrace.spineLength] at lengthEq + have bindersEq : binders = [] := List.eq_nil_of_length_eq_zero + lengthEq.symm + subst binders + simp only [VExpr.forallN] at viewEq + simp only [AddInductive.CandidateExprTrace.terminalResult] at terminal + rw [terminal, viewEq] at node + cases node.whnf.rhs_tr with + | sort levelTr => exact levelTr + | @forallE domain candidateContext name binderInfo context source inferred + body source' domain' body' inferred' domainView' domainInferred' + storedDomain' bodyContext storedBody' bodyView' bodyInferred' u v fresh + checked normalized annotations annotationsEq domainCandidate bodyCandidate + node domainRun annotationsRun bodyRun domainType bodyType bodySource + bodyContextEq domainIH bodyIH => + simp only [AddInductive.CandidateExprTrace.spineLength] at lengthEq + cases binders with + | nil => simp at lengthEq + | cons binder binders => + simp only [VExpr.forallN, VExpr.forallE.injEq] at viewEq + obtain ⟨_, bodyViewEq⟩ := viewEq + apply bodyIH terminal bodyViewEq + simpa only [List.length_cons] using Nat.succ.inj lengthEq + +end ConstructorValidation + + +namespace ConstructorValidation +open AddInductive TypeChecker VEnv + +/-- Every full-context free variable not deliberately omitted by D3 is still +present in the family-free common context. -/ +def FullRemovedInvariant (common full : VLCtx) + (removed : List FVarId) : Prop := + ∀ fv, fv ∈ full.fvars → fv ∉ removed → fv ∈ common.fvars + +theorem FullRemovedInvariant.push + (invariant : FullRemovedInvariant common full removed) : + FullRemovedInvariant + ((some (fv, commonDeps), commonDomain) :: common) + ((some (fv, fullDeps), fullDomain) :: full) removed := by + intro candidate present notRemoved + simp only [VLCtx.fvars_cons_some, List.mem_cons] at present ⊢ + rcases present with rfl | present + · exact .inl rfl + · exact .inr (invariant candidate present notRemoved) + +theorem FullRemovedInvariant.skip + (invariant : FullRemovedInvariant common full removed) + (fresh : fv ∉ full.fvars) : + FullRemovedInvariant common + ((some (fv, fullDeps), fullDomain) :: full) (fv :: removed) := by + intro candidate present notRemoved + simp only [VLCtx.fvars_cons_some, List.mem_cons] at present + rcases present with rfl | present + · exact (notRemoved (by simp)).elim + · exact invariant candidate present (fun old => notRemoved (by simp [old])) + +theorem Context.freshFVarId_eq_of_ngen_eq + {left right : AddInductive.Context} + (equal : left.ngen = right.ngen) : + left.freshFVarId = right.freshFVarId := by + simp only [AddInductive.Context.freshFVarId, equal] + +theorem Context.push_advance_ngen_eq + {left right : AddInductive.Context} + (equal : left.ngen = right.ngen) : + (left.pushLocalDecl name binderInfo domain).ngen = + right.advanceFresh.ngen := by + simp only [AddInductive.Context.pushLocalDecl, + AddInductive.Context.advanceFresh, equal] + +theorem ordinaryConsumed_defeqAt + {env typeEnv : VEnv} {Us : List Name} + {actual postActual : VLCtx} {source : Expr} + {actualSource' actualConsumed' postRaw' postView' postConsumed' : VExpr} + {consumedLevel : VLevel} + (typeEnvWF : VEnv.WF typeEnv) (addType : env ≤ typeEnv) + (actualWF : VLCtx.WF env Us.length actual) + (relation : VLCtx.IsDefEqFVars typeEnv Us.length actual postActual) + (actualSourceTr : TrExprS env Us actual source actualSource') + (actualAnnotations : env.IsDefEqU Us.length actual.toCtx + actualSource' actualConsumed') + (actualConsumedType : env.HasType Us.length actual.toCtx actualConsumed' + (.sort consumedLevel)) + (postViewTr : TrExprS typeEnv Us postActual source postView') + (postRawView : typeEnv.IsDefEqU Us.length postActual.toCtx + postRaw' postView') + (postAnnotations : typeEnv.IsDefEqU Us.length postActual.toCtx + postRaw' postConsumed') : + typeEnv.IsDefEq Us.length actual.toCtx + actualConsumed' postConsumed' (.sort consumedLevel) := by + have actualWF' := actualWF.mono addType + have sourceEq : typeEnv.IsDefEqU Us.length actual.toCtx + actualSource' postView' := + (actualSourceTr.mono addType).uniqFVars typeEnvWF relation actualWF' + postViewTr + have postToActual := relation.defeqCtx.symm typeEnvWF.ordered + have rawView := postRawView.defeqDFC typeEnvWF.ordered postToActual + have rawConsumed := postAnnotations.defeqDFC typeEnvWF.ordered postToActual + have consumedEq := (actualAnnotations.mono addType).symm.trans typeEnvWF + actualWF'.toCtx (sourceEq.trans typeEnvWF actualWF'.toCtx + (rawView.symm.trans typeEnvWF actualWF'.toCtx rawConsumed)) + exact consumedEq.of_l typeEnvWF actualWF'.toCtx + (actualConsumedType.mono addType) + +theorem ConstructorUniverseTrace.bound + {stats : AddInductive.InductiveStats} + {sortResult : Expr} + (trace : AddInductive.ConstructorUniverseTrace stats.resultLevel + sortResult.sortLevel!) + (valid : trace.semantic = true) + (resultLevelTr : VLevel.ofLevel Us stats.resultLevel = some resultLevel) + (ensureTypeRun : TypeChecker.EnsureTypeRun typeEnv Us postContext + source sortResult source') : + resultLevel = .zero ∨ ensureTypeRun.resultLevel' ≤ resultLevel := by + apply AddInductive.constructorUniverseSemanticGe_ofLevel valid resultLevelTr + have sortLevelEq : sortResult.sortLevel! = ensureTypeRun.resultLevel := by + simpa only [Expr.sortLevel!] using + congrArg Expr.sortLevel! ensureTypeRun.result_eq + rw [sortLevelEq] + exact ensureTypeRun.resultLevel_tr + +/-- D3's terminal index replay transported to the analyzer's exact full +context and exact translated result target. -/ +theorem terminal_exactAnalyzer + {env typeEnv : VEnv} {Us : List Name} + {stats : AddInductive.InductiveStats} {familyIdx : Nat} + {familyIndices : Expr} {context : AddInductive.Context} + {contextRun : AddInductive.ConstructorContextRun env Us context} + {source : Expr} {argIdx : Nat} {removed : List FVarId} + {recursiveStarted : Bool} + {valid : AddInductive.isValidIndAppIdx stats source familyIdx = true} + {independent : AddInductive.constructorIndependentOf source removed = true} + {spineTrace : AddInductive.ConstructorPreFamilyIndexSpineTrace context + familyIndices (source.getAppArgs.toList.drop stats.params.size)} + {expected' : VExpr} + (spine : AddInductive.ConstructorPreFamilyIndexSpineSemanticRun env Us + context contextRun spineTrace expected') + (henv : VEnv.WF env) (typeEnvWF : VEnv.WF typeEnv) + (addType : env ≤ typeEnv) + {common full view : VLCtx} {fullLift viewLift : Lift} + (state : D3FullContextState env typeEnv Us context common full + contextRun.candidate.context.vlctx view fullLift viewLift) + {commonIndices : List VExpr} {familyTarget resultTarget : VExpr} + {level : VLevel} {familyName : Name} {familyLevels : List Level} + (familyCommonTr : TrExprS env Us common familyIndices + (VExpr.forallN commonIndices (.sort level))) + (familyFullTr : TrExprS typeEnv Us full familyIndices familyTarget) + (familyUnique : TrExprS.IsUnique familyIndices) + (indexLength : commonIndices.length = stats.nindices[familyIdx]!) + (familyHead : stats.indConsts[familyIdx]! = + .const familyName familyLevels) + (sourceUnique : TrExprS.IsUnique source) + (sourceClosed : Closed source) + (sourceFVars : FVarsIn (· ∈ common.fvars) source) + (fullTr : TrExprS typeEnv Us full source resultTarget) : + env.SpineWF Us.length full.toCtx familyTarget + (VInductDecl.recFieldIdxs stats.params.size resultTarget) + (.sort level) := by + have argumentClosed : ∀ argument ∈ + source.getAppArgs.toList.drop stats.params.size, + Closed argument := by + intro argument member + apply Closed.getAppArgsList sourceClosed + rw [← Expr.getAppArgs_toList] + exact List.mem_of_mem_drop member + have argumentFVars : ∀ argument ∈ + source.getAppArgs.toList.drop stats.params.size, + FVarsIn (· ∈ common.fvars) argument := by + intro argument member + apply FVarsIn.getAppArgsList sourceFVars + rw [← Expr.getAppArgs_toList] + exact List.mem_of_mem_drop member + have argumentUnique : ∀ argument ∈ + source.getAppArgs.toList.drop stats.params.size, + TrExprS.IsUnique argument := by + intro argument member + apply TrExprS.IsUnique.getAppArgsList sourceUnique + rw [← Expr.getAppArgs_toList] + exact List.mem_of_mem_drop member + have argumentLength : + (source.getAppArgs.toList.drop stats.params.size).length = + commonIndices.length := + (isValidIndAppIdx_indexArgs_length valid).trans indexLength.symm + obtain ⟨baseIndices, baseIndicesTr, baseSpine⟩ := + ConstructorPreFamilyIndexSpineSemanticRun.baseSpine_lift + spine familyCommonTr familyUnique state.viewDefEq state.viewUnique + state.viewExtension argumentClosed argumentFVars argumentUnique + argumentLength + have commonFamilyAtFull : TrExprS typeEnv Us full familyIndices + ((VExpr.forallN commonIndices (.sort level)).lift' fullLift) := by + simpa using (familyCommonTr.mono addType).weakFV' + typeEnvWF.ordered state.fullExtension state.fullWF + have familyEq : familyTarget = + (VExpr.forallN commonIndices (.sort level)).lift' fullLift := + familyFullTr.unique familyUnique commonFamilyAtFull + have shape := isValidIndAppIdx_shape valid + have sourceHead : source.getAppFn = .const familyName familyLevels := by + rw [familyHead] at shape + change source.getAppFn.eqv (.const familyName familyLevels) = true ∧ _ + at shape + rw [Expr.eqv_eq] at shape + generalize headEq : source.getAppFn = head at shape + cases head <;> simp_all [Expr.eqv'] + obtain ⟨targetLevels, targetHead, allArgumentsTr⟩ := + TrExprS.constApp_components fullTr sourceHead + have droppedArgumentsTr := + forall₂_drop allArgumentsTr stats.params.size + have baseIndicesAtFull : List.Forall₂ (TrExprS typeEnv Us full) + (source.getAppArgsList.drop stats.params.size) + (baseIndices.map fun index => index.lift' fullLift) := by + have baseMono := forall₂_tr_mono addType baseIndicesTr + have baseWeak := forall₂_tr_weakFV' typeEnvWF.ordered + state.fullExtension state.fullWF baseMono + simpa only [Expr.getAppArgs_toList] using baseWeak + have translatedIndicesEq : + (VExpr.appArgs resultTarget []).drop stats.params.size = + baseIndices.map fun index => index.lift' fullLift := + forall₂_translation_unique droppedArgumentsTr baseIndicesAtFull + (fun argument member => + TrExprS.IsUnique.getAppArgsList sourceUnique argument + (List.mem_of_mem_drop member)) + have fullSpine : env.SpineWF Us.length full.toCtx + ((VExpr.forallN commonIndices (.sort level)).lift' fullLift) + (baseIndices.map fun index => index.lift' fullLift) (.sort level) := by + simpa using VEnv.SpineWF.weak' henv.ordered + state.fullExtension.toCtx baseSpine + rw [← familyEq, ← translatedIndicesEq] at fullSpine + simpa only [VInductDecl.recFieldIdxs] using fullSpine + +def ConstructorFieldsRunResult + (env : VEnv) (Us : List Name) (full : VLCtx) + (familyTarget : VExpr) (level : VLevel) (familyName : Name) + (parameters : Nat) (familyIndices fields : List VExpr) + (fieldIndex : Nat) (resultTarget : VExpr) : Prop := + VInductDecl.fieldsWF Us.length familyName parameters env level familyIndices + full.toCtx fieldIndex fields ∧ + env.SpineWF Us.length (fields.reverse ++ full.toCtx) + (familyTarget.liftN fields.length 0) + (VInductDecl.recFieldIdxs parameters resultTarget) (.sort level) + +/-- Synchronize the exact D3 family-free replay with D2's analyzer-owned +constructor view, deriving every field judgment and the terminal index spine. -/ +theorem constructorFields_exactAnalyzer + {env typeEnv : VEnv} {Us : List Name} + {stats : AddInductive.InductiveStats} {familyIdx : Nat} + {familyIndices : Expr} + {d3Context d2Context : AddInductive.Context} + {d3ContextRun : AddInductive.ConstructorContextRun env Us d3Context} + {d2ContextRun : AddInductive.ConstructorContextRun typeEnv Us d2Context} + {view : Expr} {argIdx : Nat} {removed : List FVarId} + {recursiveStarted : Bool} + {d3Trace : AddInductive.ConstructorPreFamilyViewTrace stats familyIdx + familyIndices d3Context view argIdx removed recursiveStarted} + (d3 : AddInductive.ConstructorPreFamilyViewSemanticRun env Us stats + familyIdx familyIndices d3ContextRun d3Trace) + {isUnsafe : Bool} {ctorName : Name} {rawSource : Expr} + {d2Fuel whnfFuel : Nat} + {d2Trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctorName d2Context rawSource argIdx d2Fuel} + (d2Alignment : AddInductive.ConstructorViewAlignmentTrace d2Trace view) + (d2 : AddInductive.ConstructorViewSemanticRun typeEnv Us whnfFuel + d2ContextRun d2Trace view) + (henv : VEnv.WF env) (typeEnvWF : VEnv.WF typeEnv) + (addType : env ≤ typeEnv) + {common full d3ViewContext analyzerViewContext : VLCtx} + {fullLift viewLift analyzerViewLift : Lift} + (d3State : D3FullContextState env typeEnv Us d3Context common full + d3ContextRun.candidate.context.vlctx d3ViewContext fullLift viewLift) + (analyzerState : AnalyzerPostContextState typeEnv Us full + d2ContextRun.candidate.context.vlctx analyzerViewContext + analyzerViewLift) + (removedInvariant : FullRemovedInvariant common full removed) + (ngenEq : d3Context.ngen = d2Context.ngen) + {commonIndices checkedIndices fields : List VExpr} + {familyTarget resultTarget : VExpr} {level : VLevel} + {familyName : Name} {familyLevels : List Level} + (familyCommonTr : TrExprS env Us common familyIndices + (VExpr.forallN commonIndices (.sort level))) + (familyFullTr : TrExprS typeEnv Us full familyIndices familyTarget) + (familyUnique : TrExprS.IsUnique familyIndices) + (indexLength : commonIndices.length = stats.nindices[familyIdx]!) + (familyHead : stats.indConsts[familyIdx]! = + .const familyName familyLevels) + (familyTargetEq : familyTarget = + VExpr.forallN (VExpr.liftTelN fieldIndex checkedIndices 0) + (.sort level)) + (resultNotForall : ∀ domain body, resultTarget ≠ .forallE domain body) + (resultLevelTr : VLevel.ofLevel Us stats.resultLevel = some level) + (absent : env.constants familyName = none) + (sourceUnique : TrExprS.IsUnique view) + (sourceClosed : Closed view) + (wholeTr : TrExprS typeEnv Us full view + (VExpr.forallN fields resultTarget)) + (parametersDone : stats.params.size ≤ argIdx) + (universeSemantics : d2Trace.universeSemantics = true) + (stageFields : ∀ q field, fields[q]? = some field → + VInductDecl.stage3Field Us.length familyName stats.params.size + checkedIndices.length (fieldIndex + q) field = true) : + ConstructorFieldsRunResult env Us full familyTarget level familyName + stats.params.size checkedIndices fields fieldIndex resultTarget := by + induction d3 generalizing d2Context d2ContextRun rawSource d2Fuel + common full d3ViewContext fullLift viewLift commonIndices familyTarget + analyzerViewContext analyzerViewLift fields fieldIndex with + | @parameter context parameterArgIdx removed recursiveStarted name domain + body binderInfo parameter parameterAt tailTrace contextRun tail ih => + have parameterLt : parameterArgIdx < stats.params.size := by + exact Array.getElem?_eq_some_iff.mp parameterAt |>.1 + omega + | @ordinary context ordinaryArgIdx removed recursiveStarted name domain body + binderInfo noParameter nonrecursive independent domainCheck ensureType + consumedCheck annotations fresh tailTrace contextRun domainRun + consumedRun ensureTypeRun annotationsRun consumedType tail ih => + cases d2 with + | @parameter _ _ _ _ d2Context d2Fuel ordinaryArgIdx name₂ + rawDomain rawBody + binderInfo₂ parameter parameterType parameterAt parameterTypeGet + validationDefEq d2TailTrace viewName viewDomain viewBody + viewBinderInfo domainCheck₂ viewDomainCheck₂ parameterTypeCheck + d2ContextRun domainRun₂ viewDomainRun₂ parameterTypeSemantic + validationRun tail₂ => + rw [noParameter] at parameterAt + contradiction + | @ordinary _ _ _ _ d2Context d2Fuel ordinaryArgIdx name₂ + rawDomain rawBody + binderInfo₂ sortResult noParameter₂ ensureTypeStep universeTrace + positivityTrace d2TailTrace viewName viewDomain viewBody + viewBinderInfo domainCheck₂ viewDomainCheck₂ viewEquality + consumedCheck₂ fresh₂ d2ContextRun domainRun₂ viewDomainRun₂ + viewEqualityRun₂ + consumedRun₂ ensureTypeRun₂ positivity₂ annotationsRun₂ + consumedType₂ tail₂ => + cases d2Alignment with + | ordinary _ _ _ _ _ positivityAlignment _ _ _ tailAlignment => + obtain ⟨fieldTarget, bodyTarget, targetEq, fieldType, + bodyType, fieldTr, bodyTr⟩ := + TrExprS.forallE_components wholeTr + cases fields with + | nil => + exact (resultNotForall fieldTarget bodyTarget targetEq).elim + | cons field fields => + simp only [VExpr.forallN, VExpr.forallE.injEq] at targetEq + obtain ⟨rfl, rfl⟩ := targetEq + have actualFieldTr : TrExprS env Us + contextRun.candidate.context.vlctx domain + domainRun.source' := by + simpa only [contextRun.venv_eq, contextRun.lparams_eq] + using domainRun.check.expr_tr + have actualFieldType : env.HasType Us.length + contextRun.candidate.context.vlctx.toCtx + domainRun.source' (.sort ensureTypeRun.resultLevel') := by + simpa only [contextRun.venv_eq, contextRun.lparams_eq] + using ensureTypeRun.source_type + have actualAnnotations : env.IsDefEqU Us.length + contextRun.candidate.context.vlctx.toCtx + domainRun.source' consumedRun.source' := by + simpa only [contextRun.venv_eq, contextRun.lparams_eq] + using annotationsRun.isDefEqU + obtain ⟨consumedLevel, actualConsumedType⟩ := consumedType + have actualConsumedType' : env.HasType Us.length + contextRun.candidate.context.vlctx.toCtx + consumedRun.source' (.sort consumedLevel) := by + simpa only [contextRun.venv_eq, contextRun.lparams_eq] + using actualConsumedType + let nextD3ContextRun := contextRun.pushLocalDecl name + binderInfo (consumeTypeAnnotations domain) fresh + consumedRun.source' consumedRun.check.expr_tr + ⟨consumedLevel, actualConsumedType⟩ + have actualTailWF : VLCtx.WF env Us.length + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam consumedRun.source') :: + contextRun.candidate.context.vlctx) := by + 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 + have postViewTr : TrExprS typeEnv Us + d2ContextRun.candidate.context.vlctx domain + viewDomainRun₂.source' := by + simpa only [d2ContextRun.venv_eq, + d2ContextRun.lparams_eq] using + viewDomainRun₂.check.expr_tr + have postRawType : typeEnv.HasType Us.length + d2ContextRun.candidate.context.vlctx.toCtx + domainRun₂.source' (.sort ensureTypeRun₂.resultLevel') := by + simpa only [d2ContextRun.venv_eq, + d2ContextRun.lparams_eq] using ensureTypeRun₂.source_type + have postRawView : typeEnv.IsDefEqU Us.length + d2ContextRun.candidate.context.vlctx.toCtx + domainRun₂.source' viewDomainRun₂.source' := by + simpa only [d2ContextRun.venv_eq, + d2ContextRun.lparams_eq] using + viewEqualityRun₂.isDefEqU + have postAnnotations : typeEnv.IsDefEqU Us.length + d2ContextRun.candidate.context.vlctx.toCtx + domainRun₂.source' consumedRun₂.source' := by + simpa only [d2ContextRun.venv_eq, + d2ContextRun.lparams_eq] using + annotationsRun₂.isDefEqU + let nextD2ContextRun := d2ContextRun.pushLocalDecl name₂ + binderInfo₂ (consumeTypeAnnotations rawDomain) fresh₂ + consumedRun₂.source' consumedRun₂.check.expr_tr + consumedType₂ + have postTailWF : VLCtx.WF typeEnv Us.length + ((some (d2Context.freshFVarId, + (consumeTypeAnnotations rawDomain).fvarsList), + .vlam consumedRun₂.source') :: + d2ContextRun.candidate.context.vlctx) := by + have nextWF := nextD2ContextRun.candidate.context.Δwf + rw [nextD2ContextRun.venv_eq, + nextD2ContextRun.lparams_eq] at nextWF + simpa only [nextD2ContextRun, + AddInductive.ConstructorContextRun.pushLocalDecl, + CandidateContextRun.pushLocalDecl_vlctx] using nextWF + simp only [AddInductive.ConstructorTypeValidationTrace.universeSemantics, + Bool.and_eq_true] at universeSemantics + have sortLevelEq : sortResult.sortLevel! = + ensureTypeRun₂.resultLevel := by + simpa only [Expr.sortLevel!] using + congrArg Expr.sortLevel! ensureTypeRun₂.result_eq + have fieldLevelTr : VLevel.ofLevel Us + sortResult.sortLevel! = + some ensureTypeRun₂.resultLevel' := by + rw [sortLevelEq] + simpa only [d2ContextRun.lparams_eq] using + ensureTypeRun₂.resultLevel_tr + have rawBound := + AddInductive.constructorUniverseSemanticGe_ofLevel + universeSemantics.1 resultLevelTr fieldLevelTr + have freshEq : context.freshFVarId = + d2Context.freshFVarId := + Context.freshFVarId_eq_of_ngen_eq ngenEq + have domainFVars : FVarsIn (· ∈ common.fvars) domain := + constructorIndependentOf_fvars fieldTr.fvarsIn + independent removedInvariant + obtain ⟨commonDomain, commonDomainTr, fieldEq, + commonDomainType, nextD3State⟩ := + d3State.push (name := name) (binderInfo := binderInfo) + henv typeEnvWF addType sourceUnique.1 + sourceClosed.1 domainFVars fieldTr actualFieldTr + actualFieldType actualAnnotations actualConsumedType' + actualTailWF + obtain ⟨postAnalyzerType, nextAnalyzerState⟩ := + analyzerState.push typeEnvWF sourceUnique.1 sourceClosed.1 + fieldTr postViewTr postRawType postRawView + postAnnotations postTailWF + have fieldBaseType : env.HasType Us.length full.toCtx field + (.sort ensureTypeRun.resultLevel') := by + rw [fieldEq] + exact commonDomainType.weak' henv.ordered + d3State.fullExtension.toCtx + have levelEq : ensureTypeRun.resultLevel' ≈ + ensureTypeRun₂.resultLevel' := + (fieldBaseType.mono addType).uniqU typeEnvWF + d3State.fullWF.toCtx postAnalyzerType |>.sort_inv + typeEnvWF d3State.fullWF.toCtx + have fieldBound : level = .zero ∨ + ensureTypeRun.resultLevel' ≤ level := by + rcases rawBound with prop | bound + · exact .inl prop + · exact .inr <| VLevel.le_trans + (VLevel.le_antisymm_iff.mp levelEq).1 bound + have commonFree : commonDomain.hasConst familyName = false := + VEnv.HasType.hasConst_false_of_absent henv.ordered + d3State.commonWF.toCtx absent commonDomainType + have fieldFree : field.hasConst familyName = false := by + rw [fieldEq, VExpr.hasConst_lift'] + exact commonFree + have recNone := recArg?_eq_none_of_hasConst_false + (U := Us.length) (np := stats.params.size) + (ni := checkedIndices.length) (fieldIndex := fieldIndex) + fieldFree + have nextD3State' : D3FullContextState env typeEnv Us + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam commonDomain) :: common) + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam field) :: full) + nextD3ContextRun.candidate.context.vlctx + ((some (context.freshFVarId, + (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 + have nextAnalyzerState' : AnalyzerPostContextState + typeEnv Us + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam field) :: full) + nextD2ContextRun.candidate.context.vlctx + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam (field.lift' analyzerViewLift)) :: + analyzerViewContext) + (.consN analyzerViewLift 1) := by + rw [freshEq] + simpa only [nextD2ContextRun, + AddInductive.ConstructorContextRun.pushLocalDecl, + CandidateContextRun.pushLocalDecl_vlctx] using + nextAnalyzerState + have familyCommonNext : TrExprS env Us + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam commonDomain) :: common) + familyIndices + (VExpr.forallN (VExpr.liftTelN 1 commonIndices 0) + (.sort level)) := by + have weakened := familyCommonTr.weakFV henv.ordered + (VLCtx.FVLift.skip_fvar + (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList) + (.vlam commonDomain) .refl) + nextD3State'.commonWF + simpa [VLocalDecl.depth, VExpr.liftN_forallN, + VExpr.liftN] using weakened + have familyFullNext : TrExprS typeEnv Us + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam field) :: full) + familyIndices (familyTarget.liftN 1 0) := by + have weakened := familyFullTr.weakFV typeEnvWF.ordered + (VLCtx.FVLift.skip_fvar + (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList) + (.vlam field) .refl) + nextD3State'.fullWF + simpa [VLocalDecl.depth] using weakened + have bodyOpened : TrExprS typeEnv Us + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam field) :: full) + (body.instantiate1 context.freshExpr) + (VExpr.forallN fields resultTarget) := by + simpa only [AddInductive.Context.freshExpr, + Expr.instantiate1_eq] using + bodyTr.inst_fvar typeEnvWF.ordered nextD3State'.fullWF + have tailUnique : TrExprS.IsUnique + (body.instantiate1 context.freshExpr) := by + apply TrExprS.IsUnique.instantiate1 sourceUnique.2 + simp only [AddInductive.Context.freshExpr] + trivial + have nextFullNoBV : + VLCtx.bvars (((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam field) :: full) : VLCtx) = 0 := + nextD3State'.fullExtension.bvars_eq.trans + nextD3State'.commonNoBV + have tailClosed : Closed + (body.instantiate1 context.freshExpr) := by + have closed := bodyOpened.closed + rw [nextFullNoBV] at closed + exact closed + have freshExprEq : d2Context.freshExpr = + context.freshExpr := by + simp only [AddInductive.Context.freshExpr, freshEq] + have tailAlignment' : AddInductive.ConstructorViewAlignmentTrace + d2TailTrace (body.instantiate1 context.freshExpr) := by + rw [← freshExprEq] + exact tailAlignment + have tail₂' : AddInductive.ConstructorViewSemanticRun + typeEnv Us whnfFuel nextD2ContextRun d2TailTrace + (body.instantiate1 context.freshExpr) := by + rw [← freshExprEq] + exact tail₂ + have nextNgenEq : + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)).ngen = + (d2Context.pushLocalDecl name₂ binderInfo₂ + (consumeTypeAnnotations rawDomain)).ngen := by + simpa only [AddInductive.Context.pushLocalDecl, ngenEq] + have nextIndexLength : + (VExpr.liftTelN 1 commonIndices 0).length = + stats.nindices[familyIdx]! := by + simpa only [VExpr.liftTelN_length] using indexLength + have familyTargetNextEq : familyTarget.liftN 1 0 = + VExpr.forallN + (VExpr.liftTelN (fieldIndex + 1) checkedIndices 0) + (.sort level) := by + rw [familyTargetEq, VExpr.liftN_forallN, + VExpr.liftTelN_liftTelN] + simp only [VExpr.liftN] + have stageTail : ∀ q candidate, + fields[q]? = some candidate → + VInductDecl.stage3Field Us.length familyName + stats.params.size checkedIndices.length + (fieldIndex + 1 + q) candidate = true := by + intro q candidate member + have staged := stageFields (q + 1) candidate (by + simpa using member) + simpa only [Nat.add_assoc, Nat.add_comm 1 q] using staged + obtain ⟨tailFields, tailSpine⟩ := ih + (fieldIndex := fieldIndex + 1) tailAlignment' tail₂' + nextD3State' nextAnalyzerState' + (removedInvariant.push) nextNgenEq familyCommonNext + familyFullNext nextIndexLength familyTargetNextEq + tailUnique tailClosed bodyOpened (by omega) + universeSemantics.2 stageTail + unfold ConstructorFieldsRunResult + refine ⟨⟨?_, ?_, ?_⟩, ?_⟩ + · exact .inr (.inr ⟨recNone, ensureTypeRun.resultLevel', + fieldBaseType, fieldBound⟩) + · intro recursive + rw [VInductDecl.recArg?_of_isRecField recursive] at recNone + contradiction + · simpa only [VLCtx.toCtx] using tailFields + · simpa only [List.reverse_cons, List.singleton_append, + List.append_assoc, VLCtx.toCtx, List.length_cons, + VExpr.liftN_liftN, Nat.add_comm] using tailSpine + | terminal sourceRun₂ viewRun₂ => + cases d2Alignment <;> simp_all [Expr.isForall] + | @recursive context recursiveArgIdx removed recursiveStarted name domain + body binderInfo noParameter isRecursive independent fieldTrace fresh + tailTrace contextRun recursiveRun tail ih => + cases d2 with + | @parameter _ _ _ _ d2Context d2Fuel recursiveArgIdx name₂ + rawDomain rawBody binderInfo₂ parameter parameterType parameterAt + parameterTypeGet validationDefEq d2TailTrace viewName viewDomain + viewBody viewBinderInfo domainCheck₂ viewDomainCheck₂ + parameterTypeCheck d2ContextRun domainRun₂ viewDomainRun₂ + parameterTypeSemantic validationRun tail₂ => + rw [noParameter] at parameterAt + contradiction + | @ordinary _ _ _ _ d2Context d2Fuel recursiveArgIdx name₂ + rawDomain rawBody binderInfo₂ sortResult noParameter₂ + ensureTypeStep universeTrace positivityTrace d2TailTrace viewName + viewDomain viewBody viewBinderInfo domainCheck₂ viewDomainCheck₂ + viewEquality consumedCheck₂ fresh₂ d2ContextRun domainRun₂ + viewDomainRun₂ viewEqualityRun₂ consumedRun₂ ensureTypeRun₂ + positivity₂ annotationsRun₂ consumedType₂ tail₂ => + cases d2Alignment with + | ordinary _ _ _ _ _ positivityAlignment _ _ _ tailAlignment => + obtain ⟨fieldTarget, bodyTarget, targetEq, fieldType, + bodyType, fieldTr, bodyTr⟩ := + TrExprS.forallE_components wholeTr + cases fields with + | nil => + exact (resultNotForall fieldTarget bodyTarget targetEq).elim + | cons field fields => + simp only [VExpr.forallN, VExpr.forallE.injEq] at targetEq + obtain ⟨rfl, rfl⟩ := targetEq + have postViewTr : TrExprS typeEnv Us + d2ContextRun.candidate.context.vlctx domain + viewDomainRun₂.source' := by + simpa only [d2ContextRun.venv_eq, + d2ContextRun.lparams_eq] using + viewDomainRun₂.check.expr_tr + have postRawType : typeEnv.HasType Us.length + d2ContextRun.candidate.context.vlctx.toCtx + domainRun₂.source' (.sort ensureTypeRun₂.resultLevel') := by + simpa only [d2ContextRun.venv_eq, + d2ContextRun.lparams_eq] using ensureTypeRun₂.source_type + have postRawView : typeEnv.IsDefEqU Us.length + d2ContextRun.candidate.context.vlctx.toCtx + domainRun₂.source' viewDomainRun₂.source' := by + simpa only [d2ContextRun.venv_eq, + d2ContextRun.lparams_eq] using + viewEqualityRun₂.isDefEqU + have postAnnotations : typeEnv.IsDefEqU Us.length + d2ContextRun.candidate.context.vlctx.toCtx + domainRun₂.source' consumedRun₂.source' := by + simpa only [d2ContextRun.venv_eq, + d2ContextRun.lparams_eq] using annotationsRun₂.isDefEqU + let nextD2ContextRun := d2ContextRun.pushLocalDecl name₂ + binderInfo₂ (consumeTypeAnnotations rawDomain) fresh₂ + consumedRun₂.source' consumedRun₂.check.expr_tr + consumedType₂ + have postTailWF : VLCtx.WF typeEnv Us.length + ((some (d2Context.freshFVarId, + (consumeTypeAnnotations rawDomain).fvarsList), + .vlam consumedRun₂.source') :: + d2ContextRun.candidate.context.vlctx) := by + have nextWF := nextD2ContextRun.candidate.context.Δwf + rw [nextD2ContextRun.venv_eq, + nextD2ContextRun.lparams_eq] at nextWF + simpa only [nextD2ContextRun, + AddInductive.ConstructorContextRun.pushLocalDecl, + CandidateContextRun.pushLocalDecl_vlctx] using nextWF + simp only [ + AddInductive.ConstructorTypeValidationTrace.universeSemantics, + Bool.and_eq_true] at universeSemantics + have freshEq : context.freshFVarId = + d2Context.freshFVarId := + Context.freshFVarId_eq_of_ngen_eq ngenEq + obtain ⟨postAnalyzerType, nextAnalyzerState⟩ := + analyzerState.push typeEnvWF sourceUnique.1 sourceClosed.1 + fieldTr postViewTr postRawType postRawView + postAnnotations postTailWF + have nextAnalyzerState' : AnalyzerPostContextState + typeEnv Us + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam field) :: full) + nextD2ContextRun.candidate.context.vlctx + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam (field.lift' analyzerViewLift)) :: + analyzerViewContext) + (.consN analyzerViewLift 1) := by + rw [freshEq] + simpa only [nextD2ContextRun, + AddInductive.ConstructorContextRun.pushLocalDecl, + CandidateContextRun.pushLocalDecl_vlctx] using + nextAnalyzerState + have domainFVars : FVarsIn (· ∈ common.fvars) domain := + constructorIndependentOf_fvars fieldTr.fvarsIn + independent removedInvariant + have recursiveResult := recursiveField_exactAnalyzer + recursiveRun henv typeEnvWF addType d3State + familyCommonTr familyFullTr familyUnique indexLength + familyHead sourceUnique.1 sourceClosed.1 domainFVars fieldTr + have stageHead : VInductDecl.stage3Field Us.length + familyName stats.params.size checkedIndices.length + fieldIndex field = true := by + simpa using stageFields 0 field (by simp) + obtain ⟨recursive, recursiveEq, recursiveWF⟩ := + recursiveFieldResult_recArgWF recursiveResult + familyTargetEq stageHead + have nextD3State : D3FullContextState env typeEnv Us + context.advanceFresh common + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam field) :: full) + contextRun.advanceFresh.candidate.context.vlctx + d3ViewContext (.skipN fullLift 1) viewLift := by + simpa only [AddInductive.ConstructorContextRun.advanceFresh, + AddInductive.advanceCandidateContextRun] using + d3State.skip (source := domain) + nextAnalyzerState'.fullWF + have familyFullNext : TrExprS typeEnv Us + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam field) :: full) + familyIndices (familyTarget.liftN 1 0) := by + have weakened := familyFullTr.weakFV typeEnvWF.ordered + (VLCtx.FVLift.skip_fvar + (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList) + (.vlam field) .refl) + nextD3State.fullWF + simpa [VLocalDecl.depth] using weakened + have bodyOpened : TrExprS typeEnv Us + ((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam field) :: full) + (body.instantiate1 context.freshExpr) + (VExpr.forallN fields resultTarget) := by + simpa only [AddInductive.Context.freshExpr, + Expr.instantiate1_eq] using + bodyTr.inst_fvar typeEnvWF.ordered nextD3State.fullWF + have tailUnique : TrExprS.IsUnique + (body.instantiate1 context.freshExpr) := by + apply TrExprS.IsUnique.instantiate1 sourceUnique.2 + simp only [AddInductive.Context.freshExpr] + trivial + have nextFullNoBV : + VLCtx.bvars (((some (context.freshFVarId, + (consumeTypeAnnotations domain).fvarsList), + .vlam field) :: full) : VLCtx) = 0 := + nextD3State.fullExtension.bvars_eq.trans + nextD3State.commonNoBV + have tailClosed : Closed + (body.instantiate1 context.freshExpr) := by + have closed := bodyOpened.closed + rw [nextFullNoBV] at closed + exact closed + have freshExprEq : d2Context.freshExpr = + context.freshExpr := by + simp only [AddInductive.Context.freshExpr, freshEq] + have tailAlignment' : AddInductive.ConstructorViewAlignmentTrace + d2TailTrace (body.instantiate1 context.freshExpr) := by + rw [← freshExprEq] + exact tailAlignment + have tail₂' : AddInductive.ConstructorViewSemanticRun + typeEnv Us whnfFuel nextD2ContextRun d2TailTrace + (body.instantiate1 context.freshExpr) := by + rw [← freshExprEq] + exact tail₂ + have nextNgenEq : context.advanceFresh.ngen = + (d2Context.pushLocalDecl name₂ binderInfo₂ + (consumeTypeAnnotations rawDomain)).ngen := by + simp only [AddInductive.Context.advanceFresh, + AddInductive.Context.pushLocalDecl, ngenEq] + have freshFull : context.freshFVarId ∉ full.fvars := + (nextAnalyzerState'.fullWF.2.1 _ _ rfl).1 + have familyTargetNextEq : familyTarget.liftN 1 0 = + VExpr.forallN + (VExpr.liftTelN (fieldIndex + 1) checkedIndices 0) + (.sort level) := by + rw [familyTargetEq, VExpr.liftN_forallN, + VExpr.liftTelN_liftTelN] + simp only [VExpr.liftN] + have stageTail : ∀ q candidate, + fields[q]? = some candidate → + VInductDecl.stage3Field Us.length familyName + stats.params.size checkedIndices.length + (fieldIndex + 1 + q) candidate = true := by + intro q candidate member + have staged := stageFields (q + 1) candidate (by + simpa using member) + simpa only [Nat.add_assoc, Nat.add_comm 1 q] using staged + obtain ⟨tailFields, tailSpine⟩ := ih + (fieldIndex := fieldIndex + 1) tailAlignment' tail₂' + nextD3State nextAnalyzerState' + (removedInvariant.skip freshFull) nextNgenEq + familyCommonTr familyFullNext indexLength + familyTargetNextEq tailUnique tailClosed bodyOpened + (by omega) universeSemantics.2 stageTail + have headClassification : + VInductDecl.isRecField Us.length familyName + stats.params.size checkedIndices.length fieldIndex + field = true ∨ + (∃ descriptor, + VInductDecl.recArg? Us.length familyName + stats.params.size checkedIndices.length + fieldIndex field = some descriptor ∧ + descriptor.binders ≠ [] ∧ + descriptor.WF Us.length env level checkedIndices + full.toCtx) ∨ + VInductDecl.recArg? Us.length familyName + stats.params.size checkedIndices.length fieldIndex + field = none ∧ + ∃ fieldLevel, + env.HasType Us.length full.toCtx field + (.sort fieldLevel) ∧ + (level = .zero ∨ fieldLevel ≤ level) := by + by_cases nonempty : recursive.binders ≠ [] + · exact .inr (.inl ⟨recursive, recursiveEq, nonempty, + recursiveWF⟩) + · have empty : recursive.binders = [] := by + simpa using nonempty + exact .inl + (VInductDecl.recArg?_nil recursiveEq empty).1 + have headDirectSpine : + VInductDecl.isRecField Us.length familyName + stats.params.size checkedIndices.length fieldIndex + field = true → + env.SpineWF Us.length full.toCtx + (VExpr.forallN + (VExpr.liftTelN fieldIndex checkedIndices 0) + (.sort level)) + (VInductDecl.recFieldIdxs stats.params.size field) + (.sort level) := by + intro direct + have canonical := + VInductDecl.recArg?_of_isRecField direct + have descriptorEq : recursive = + { fieldIndex := fieldIndex, binders := [], + targetType := 0, + indices := VInductDecl.recFieldIdxs + stats.params.size field } := + Option.some.inj (recursiveEq.symm.trans canonical) + rw [descriptorEq] at recursiveWF + simpa [VInductDecl.RecArg.WF] using recursiveWF.2 + unfold ConstructorFieldsRunResult + refine ⟨⟨headClassification, headDirectSpine, ?_⟩, ?_⟩ + · simpa only [VLCtx.toCtx] using tailFields + · simpa only [List.reverse_cons, List.singleton_append, + List.append_assoc, VLCtx.toCtx, List.length_cons, + VExpr.liftN_liftN, Nat.add_comm] using tailSpine + | terminal sourceRun₂ viewRun₂ => + cases d2Alignment <;> simp_all [Expr.isForall] + | @terminal context source terminalArgIdx removed recursiveStarted valid + independent spineTrace contextRun expected spine => + have shape := isValidIndAppIdx_shape valid + have sourceHead : source.getAppFn = .const familyName familyLevels := by + rw [familyHead] at shape + change source.getAppFn.eqv (.const familyName familyLevels) = true ∧ _ + at shape + rw [Expr.eqv_eq] at shape + generalize headEq : source.getAppFn = head at shape + cases head <;> simp_all [Expr.eqv'] + cases fields with + | nil => + unfold ConstructorFieldsRunResult + refine ⟨trivial, ?_⟩ + simpa using terminal_exactAnalyzer + (argIdx := terminalArgIdx) (removed := removed) + (recursiveStarted := recursiveStarted) (valid := valid) + (independent := independent) (resultTarget := resultTarget) + spine henv typeEnvWF addType d3State + familyCommonTr familyFullTr familyUnique indexLength familyHead + sourceUnique sourceClosed + (constructorIndependentOf_fvars wholeTr.fvarsIn independent + removedInvariant) + wholeTr + | cons field fields => + cases wholeTr + all_goals simp_all [Expr.getAppFn] + +end ConstructorValidation + +namespace VInductDecl +open AddInductive TypeChecker VEnv + +theorem stagedIndexCount_eq + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {kernelSource : InductiveType} + {source : VInductDecl} + {candidate : AddInductive.NormalizationCandidate [kernelSource]} + (input : StagedNormalizationCandidatePreFamilyInput familyContext + constructorContext env Us candidate source) + (normalization : NormalizationCandidateSemanticRun env Us candidate source) + (generation : GenerationChecked source) + (analysis : normalization.root.normalization.generation? = + some generation) + (shape : normalization.generationShape = true) : + (input.postFamilyInput.universeInput.staged.family.validation.stats + ).nindices[0]! = generation.block.checked.indices.length := by + let validation := input.postFamilyInput.universeInput.staged.family.validation + have familyShape := shape + simp only [NormalizationCandidateSemanticRun.generationShape, + normalizationCandidateGenerationShape, Bool.and_eq_true, + beq_iff_eq] at familyShape + have spineLengthEq : + candidate.families.singleton.familyType.type.trace.spineLength = + (generation.block.checked.params ++ + generation.block.checked.indices).length := by + calc + _ = (VExpr.telN source.nparams normalization.raw.type ++ + ctorFields (VExpr.dropN source.nparams normalization.raw.type)).length := + familyShape.1.2 + _ = (generation.block.rawParams ++ + generation.block.rawIndices).length := by + simp only [NormalizedChecked.rawParams, NormalizedChecked.rawIndices, + NormalizationCandidateSemanticRun.root, + normalization.root.sourceType_eq generation] + _ = (generation.block.checked.params ++ + generation.block.checked.indices).length := by + simp only [List.length_append] + rw [generation.shape.2.1, generation.shape.2.2.1] + have parameterLength : generation.block.checked.params.length = + source.nparams := + generation.block.checked.direct_anatomy.2.1.trans + generation.block.nparams_eq.symm + change validation.stats.nindices[0]! = _ + rw [validation.stats_eq] + simp only [CandidateExprTrace.singletonCandidateInductiveStats] + rw [spineLengthEq, List.length_append, parameterLength, + input.postFamilyInput.universeInput.staged.validation_nparams_eq, + Nat.add_sub_cancel_left] + rfl + +theorem stagedResultLevel_tr + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {kernelSource : InductiveType} + {source : VInductDecl} + {candidate : AddInductive.NormalizationCandidate [kernelSource]} + (input : StagedNormalizationCandidatePreFamilyInput familyContext + constructorContext env Us candidate source) + (normalization : NormalizationCandidateSemanticRun env Us candidate source) + (generation : GenerationChecked source) + (analysis : normalization.root.normalization.generation? = + some generation) + (shape : normalization.generationShape = true) : + VLevel.ofLevel Us + input.postFamilyInput.universeInput.staged.family.validation.stats.resultLevel = + some generation.block.checked.resultLevel := by + let validation := input.postFamilyInput.universeInput.staged.family.validation + have familyShape := shape + simp only [NormalizationCandidateSemanticRun.generationShape, + normalizationCandidateGenerationShape, Bool.and_eq_true, + beq_iff_eq] at familyShape + have spineLengthEq : + candidate.families.singleton.familyType.type.trace.spineLength = + (generation.block.checked.params ++ + generation.block.checked.indices).length := by + calc + _ = (VExpr.telN source.nparams normalization.raw.type ++ + ctorFields (VExpr.dropN source.nparams normalization.raw.type)).length := + familyShape.1.2 + _ = (generation.block.rawParams ++ + generation.block.rawIndices).length := by + simp only [NormalizedChecked.rawParams, NormalizedChecked.rawIndices, + NormalizationCandidateSemanticRun.root, + normalization.root.sourceType_eq generation] + _ = (generation.block.checked.params ++ + generation.block.checked.indices).length := by + simp only [List.length_append] + rw [generation.shape.2.1, generation.shape.2.2.1] + have viewEq : normalization.family.type.view = + VExpr.forallN + (generation.block.checked.params ++ generation.block.checked.indices) + (.sort generation.block.checked.resultLevel) := by + have analyzerEq : normalization.family.type.view = + generation.block.checked.type.type := + (congrArg (fun ty : VInductiveType => ty.type) + (normalization.root.familyViewType_eq analysis)).symm + rw [analyzerEq, generation.block.checked.type_eq, + VExpr.forallN_append] + obtain ⟨_, recursive⟩ := normalization.family.type.recursive + have levelTr := ConstructorValidation.CandidateExprRun.terminalLevel_tr recursive + validation.terminal_eq viewEq spineLengthEq + change VLevel.ofLevel Us validation.stats.resultLevel = _ + rw [validation.stats_eq] + simpa only [CandidateExprTrace.singletonCandidateInductiveStats] using levelTr + +end VInductDecl + +namespace VInductDecl +open AddInductive TypeChecker VEnv +open ConstructorValidation + +/-- Derive the checked field and result-spine obligations for one exact +analyzer-owned constructor position after consuming its parameter prefix. -/ +theorem CandidateSemanticNormalizedCtorRun.checkedConstructorWF + {env typeEnv : VEnv} {Us : List Name} + {source : VInductDecl} {generation : GenerationChecked source} + {kernelCtor : Constructor} + {candidateCtor : AddInductive.CandidateConstructor kernelCtor} + {rawCtor : VConstVal} + {root : CandidateConstructorSemanticRun typeEnv Us candidateCtor rawCtor} + {ctor : NormalizedCtor} + {stats : InductiveStats} {familyIndices : Expr} + {d3Context d2Context : AddInductive.Context} + {d3ContextRun : AddInductive.ConstructorContextRun env Us d3Context} + {d2ContextRun : AddInductive.ConstructorContextRun typeEnv Us d2Context} + {d3Trace : AddInductive.ConstructorPreFamilyViewTrace stats 0 + familyIndices d3Context candidateCtor.type.view 0 [] false} + (d3 : AddInductive.ConstructorPreFamilyViewSemanticRun env Us stats 0 + familyIndices d3ContextRun d3Trace) + {d2Trace : AddInductive.ConstructorTypeValidationTrace stats false 0 + kernelCtor.name d2Context kernelCtor.type 0 d2Context.fuel.inductiveFuel} + (d2Alignment : AddInductive.ConstructorViewAlignmentTrace d2Trace + candidateCtor.type.view) + (d2 : AddInductive.ConstructorViewSemanticRun typeEnv Us + root.type.whnfFuel d2ContextRun d2Trace candidateCtor.type.view) + (genRun : CandidateSemanticNormalizedCtorRun generation.block typeEnv Us + root ctor) + (hctor : ctor ∈ generation.block.ctorPairs) + (henv : VEnv.WF env) (typeEnvWF : VEnv.WF typeEnv) + (addType : env ≤ typeEnv) + {parameterΔ d3ViewContext analyzerViewContext : VLCtx} + {viewLift analyzerViewLift : Lift} + {parameters : List Expr} + (parameterContext : CandidateParameterContext [] parameters + generation.block.checked.params parameterΔ) + (parameterWF : VLCtx.WF env Us.length parameterΔ) + (parameterCtx : parameterΔ.toCtx = + generation.block.checked.params.reverse) + (d3State : D3FullContextState env typeEnv Us d3Context + parameterΔ parameterΔ d3ContextRun.candidate.context.vlctx + d3ViewContext .refl viewLift) + (analyzerState : AnalyzerPostContextState typeEnv Us parameterΔ + d2ContextRun.candidate.context.vlctx analyzerViewContext + analyzerViewLift) + (ngenEq : d3Context.ngen = d2Context.ngen) + (parametersEq : stats.params.toList = parameters) + {familyName : Name} {familyLevels : List Level} + (indConsts : stats.indConsts = #[.const familyName familyLevels]) + (familyTr : TrExprS env Us parameterΔ familyIndices + (VExpr.forallN generation.block.checked.indices + (.sort generation.block.checked.resultLevel))) + (familyUnique : TrExprS.IsUnique familyIndices) + (indexLength : generation.block.checked.indices.length = + stats.nindices[0]!) + (resultLevelTr : VLevel.ofLevel Us stats.resultLevel = + some generation.block.checked.resultLevel) + (absent : env.constants familyName = none) + (unique : CandidateExprTraceViewIsUnique candidateCtor.type.trace) + (universeSemantics : d2Trace.universeSemantics = true) + (stageFields : ∀ q field, ctor.view.fields[q]? = some field → + VInductDecl.stage3Field Us.length familyName stats.params.size + generation.block.checked.indices.length q field = true) : + VInductDecl.fieldsWF Us.length familyName stats.params.size env + generation.block.checked.resultLevel + generation.block.checked.indices + generation.block.checked.params.reverse 0 ctor.view.fields ∧ + env.SpineWF Us.length + (ctor.view.fields.reverse ++ + generation.block.checked.params.reverse) + (VExpr.forallN + (VExpr.liftTelN ctor.view.fields.length + generation.block.checked.indices 0) + (.sort generation.block.checked.resultLevel)) + (VInductDecl.recFieldIdxs stats.params.size + (ctor.resultTarget generation.block)) + (.sort generation.block.checked.resultLevel) := by + obtain ⟨rest, instantiation, ⟨d3Suffix⟩, wholeTr⟩ := + genRun.preFamilySuffix addType parameterContext parameterWF unique d3 + hctor parametersEq indConsts + obtain ⟨d2Suffix, suffixUniverse⟩ := + d2.afterParameters d2Alignment (by omega) instantiation + have instantiation' : instantiateFamilyParameters candidateCtor.type.view + parameters = .ok rest := by + rw [← parametersEq] + exact instantiation + have sourceUnique : TrExprS.IsUnique rest := + instantiateFamilyParameters_unique unique.view + (ConstructorValidation.CandidateParameterContext.parametersUnique + parameterContext) instantiation' + have sourceClosed : Closed rest := by + have closed := wholeTr.closed + rw [show parameterΔ.bvars = 0 from by + simpa only [VLCtx.NoBV] using d3State.commonNoBV] at closed + exact closed + have resultNotForall : ∀ domain body, + ctor.resultTarget generation.block ≠ .forallE domain body := by + intro domain body equality + have headEq := congrArg VExpr.appHead equality + simp only [NormalizedCtor.resultTarget, VExpr.appHead_appN, + VExpr.appHead] at headEq + exact VExpr.noConfusion headEq + have familyTargetEq : + VExpr.forallN generation.block.checked.indices + (.sort generation.block.checked.resultLevel) = + VExpr.forallN + (VExpr.liftTelN 0 generation.block.checked.indices 0) + (.sort generation.block.checked.resultLevel) := by + have liftTelNZero : ∀ (indices : List VExpr) (cutoff : Nat), + VExpr.liftTelN 0 indices cutoff = indices := by + intro indices cutoff + induction indices generalizing cutoff with + | nil => rfl + | cons index indices ih => + simp only [VExpr.liftTelN, VExpr.liftN_zero] + rw [ih] + rw [liftTelNZero] + have removedInvariant : FullRemovedInvariant parameterΔ parameterΔ + [] := by + intro fv member _ + exact member + have familyHead : stats.indConsts[0]! = + .const familyName familyLevels := by + rw [indConsts] + rfl + have suffixUniverseSemantics : + d2Suffix.trace.universeSemantics = true := + suffixUniverse.trans universeSemantics + have result := constructorFields_exactAnalyzer + (d3 := d3Suffix.semantic) + (d2Alignment := d2Suffix.alignment) (d2 := d2Suffix.semantic) + henv typeEnvWF addType d3State analyzerState + removedInvariant ngenEq + familyTr (familyTr.mono addType) familyUnique indexLength + familyHead + familyTargetEq resultNotForall resultLevelTr absent sourceUnique + sourceClosed wholeTr (by omega) suffixUniverseSemantics (by + intro q field atIndex + simpa only [Nat.zero_add] using stageFields q field atIndex) + unfold ConstructorFieldsRunResult at result + simpa only [parameterCtx, VExpr.liftN_forallN, VExpr.liftN, + Nat.zero_add] using result + +/-- Traverse the exact source-indexed D3, D2, and analyzer lists in lockstep. +The dependent indices rule out truncation, reordering, or reuse of evidence +from a different constructor position. -/ +theorem CandidateSemanticNormalizedCtorListRun.checkedConstructorsWF + {env typeEnv : VEnv} {Us : List Name} + {source : VInductDecl} {generation : GenerationChecked source} + {stats : InductiveStats} {familyIndices : Expr} + {d3Context d2Context : AddInductive.Context} + {d3ContextRun : AddInductive.ConstructorContextRun env Us d3Context} + {d2ContextRun : AddInductive.ConstructorContextRun typeEnv Us d2Context} + {kernelCtors : List Constructor} + {candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor kernelCtors} + {d3Trace : AddInductive.ConstructorPreFamilyListTrace stats 0 + familyIndices d3Context candidates} + (d3 : AddInductive.ConstructorPreFamilyListSemanticRun env Us stats 0 + familyIndices d3Context d3ContextRun d3Trace) + {seen : NameSet} + {d2Trace : AddInductive.ConstructorListValidationTrace stats false 0 + d2Context seen kernelCtors} + {alignment : AddInductive.ConstructorCandidateAlignmentTrace stats false 0 + d2Context d2Trace candidates} + {raws : List VConstVal} + {roots : CandidateConstructorSemanticListRun typeEnv Us candidates raws} + (d2 : AddInductive.ConstructorPostFamilySemanticListRun typeEnv Us stats + false 0 d2Context d2ContextRun d2Trace candidates alignment roots) + {ctors : List NormalizedCtor} + (generationRuns : CandidateSemanticNormalizedCtorListRun generation.block + typeEnv Us roots ctors) + (membership : ∀ ctor ∈ ctors, + ctor ∈ generation.block.ctorPairs) + (henv : VEnv.WF env) (typeEnvWF : VEnv.WF typeEnv) + (addType : env ≤ typeEnv) + {parameterΔ d3ViewContext analyzerViewContext : VLCtx} + {viewLift analyzerViewLift : Lift} + {parameters : List Expr} + (parameterContext : CandidateParameterContext [] parameters + generation.block.checked.params parameterΔ) + (parameterWF : VLCtx.WF env Us.length parameterΔ) + (parameterCtx : parameterΔ.toCtx = + generation.block.checked.params.reverse) + (d3State : D3FullContextState env typeEnv Us d3Context + parameterΔ parameterΔ d3ContextRun.candidate.context.vlctx + d3ViewContext .refl viewLift) + (analyzerState : AnalyzerPostContextState typeEnv Us parameterΔ + d2ContextRun.candidate.context.vlctx analyzerViewContext + analyzerViewLift) + (ngenEq : d3Context.ngen = d2Context.ngen) + (parametersEq : stats.params.toList = parameters) + {familyName : Name} {familyLevels : List Level} + (indConsts : stats.indConsts = #[.const familyName familyLevels]) + (familyTr : TrExprS env Us parameterΔ familyIndices + (VExpr.forallN generation.block.checked.indices + (.sort generation.block.checked.resultLevel))) + (familyUnique : TrExprS.IsUnique familyIndices) + (indexLength : generation.block.checked.indices.length = + stats.nindices[0]!) + (resultLevelTr : VLevel.ofLevel Us stats.resultLevel = + some generation.block.checked.resultLevel) + (absent : env.constants familyName = none) + (unique : candidates.ViewTranslationUnique) + (universeSemantics : d2Trace.universeSemantics = true) + (uvarsEq : source.uvars = Us.length) + (familyNameEq : familyName = generation.block.checked.type.name) + (paramsSizeEq : stats.params.size = source.nparams) : + ∀ ctor ∈ ctors, + VInductDecl.fieldsWF Us.length familyName stats.params.size env + generation.block.checked.resultLevel + generation.block.checked.indices + generation.block.checked.params.reverse 0 ctor.view.fields ∧ + env.SpineWF Us.length + (ctor.view.fields.reverse ++ + generation.block.checked.params.reverse) + (VExpr.forallN + (VExpr.liftTelN ctor.view.fields.length + generation.block.checked.indices 0) + (.sort generation.block.checked.resultLevel)) + (VInductDecl.recFieldIdxs stats.params.size + (ctor.resultTarget generation.block)) + (.sort generation.block.checked.resultLevel) := by + induction d3 generalizing seen raws ctors with + | nil => + cases d2 + cases generationRuns + intro ctor member + simp at member + | cons d3Head d3Tail ih => + cases alignment with + | cons rootScope storedSpine spineLength candidateDepth headAlignment + tailAlignment => + cases d2 with + | cons root d2Head spine d2Tail => + cases generationRuns with + | cons generationHead generationTail => + simp only [AddInductive.ConstructorListValidationTrace.universeSemantics, + Bool.and_eq_true] at universeSemantics + intro ctor member + simp only [List.mem_cons] at member + rcases member with rfl | member + · have hctor : ctor ∈ generation.block.ctorPairs := + membership ctor (.head _) + obtain ⟨directCtor, directMember, viewEq⟩ := + generation.viewCtor_ofDirect hctor + have directStage := + (generation.block.checked.direct_anatomy.2.2.2.2.2 + directCtor directMember).2.2 + rw [← generation.block.uvars_eq, + ← generation.block.nparams_eq, + uvarsEq, ← familyNameEq, ← paramsSizeEq] at directStage + have viewEq' : ctor.view = + CheckedCtor.ofDirect Us.length familyName stats.params.size + generation.block.checked.indices.length directCtor := by + simpa only [uvarsEq, paramsSizeEq, + generation.block.sourceType_name_eq, familyNameEq] using viewEq + have stageFields : ∀ q field, + ctor.view.fields[q]? = some field → + VInductDecl.stage3Field Us.length familyName + stats.params.size + generation.block.checked.indices.length q field = true := by + intro q field atIndex + rw [viewEq'] at atIndex + simpa only [Nat.zero_add] using + (VInductDecl.stage3Ctor_eq directStage).2.2.2 q field + (by simpa only [CheckedCtor.ofDirect] using atIndex) + exact generationHead.checkedConstructorWF d3Head + headAlignment d2Head hctor henv typeEnvWF addType + parameterContext parameterWF parameterCtx d3State analyzerState + ngenEq parametersEq indConsts familyTr + familyUnique indexLength resultLevelTr absent unique.1 + universeSemantics.1 stageFields + · exact ih d2Tail generationTail + (fun ctor member => membership ctor (.tail _ member)) unique.2 + universeSemantics.2 ctor member + +/-- The retained D1/D2/D3 producer traces derive the exact analyzer-owned +checked declaration semantics. -/ +theorem StagedNormalizationCandidatePreFamilyInput.checkedWF + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {kernelSource : InductiveType} + {source : VInductDecl} + {candidate : AddInductive.NormalizationCandidate [kernelSource]} + (input : StagedNormalizationCandidatePreFamilyInput familyContext + constructorContext env Us candidate source) + (normalization : NormalizationCandidateSemanticRun env Us candidate source) + (generation : GenerationChecked source) + (analysis : normalization.root.normalization.generation? = + some generation) + (shape : normalization.generationShape = true) : + generation.block.checked.WF env := by + let staged := input.postFamilyInput.universeInput.staged + let validation := staged.family.validation + obtain ⟨parameterΔ, terminalRun, viewTerminal, familyInstantiation, + familyTr, parameterCtx, parameterContext, parameterFVars, + parameterNoBV, parameterWF, terminalVenv, terminalLparams, + terminalViewDefEq, terminalViewUnique, terminalViewLift, + terminalViewEq⟩ := + input.familyContext normalization generation analysis shape + have henv : VEnv.WF env := by + simpa only [normalization.family.type.venv_eq] using + normalization.family.type.contextRun.context.Ewf + have rawWF : normalization.raw.toVConstant.WF env := by + show env.IsType normalization.raw.uvars [] normalization.raw.type + simpa only [normalization.family.uvars_eq] using + normalization.family.type.source_isType_of_terminalSort + validation.terminal_eq + have typeEnvWF : VEnv.WF normalization.family.typeEnv := by + obtain ⟨declarations, declarationsWF⟩ := henv + exact ⟨.axiom normalization.raw.toVConstVal :: declarations, + .decl (.axiom rawWF normalization.family.addType) declarationsWF⟩ + have rawEq : normalization.raw = staged.raw := by + have singletonEq : [normalization.raw] = [staged.raw] := + normalization.raw_types_eq.symm.trans staged.raw_types_eq + injection singletonEq + have typeEnvEq : normalization.family.typeEnv = staged.family.typeEnv := by + exact Option.some.inj <| normalization.family.addType.symm.trans (by + simpa only [rawEq] using staged.family.addInduct.env_add) + obtain ⟨validationRun, validationVenv, validationLparams, + validationVlctx⟩ := + staged.family.validationContextRunFromPre terminalRun terminalVenv + terminalLparams + let d3ContextRun : AddInductive.ConstructorContextRun env Us + candidate.families.singleton.familyType.type.trace.terminalContext := + ⟨terminalRun, terminalVenv, terminalLparams⟩ + let d2ContextRun : AddInductive.ConstructorContextRun + normalization.family.typeEnv Us + { candidate.families.singleton.familyType.type.trace.terminalContext with + env := constructorContext.env } := + ⟨validationRun, validationVenv.trans typeEnvEq.symm, + validationLparams⟩ + obtain ⟨d3Constructors⟩ := + AddInductive.ConstructorPreFamilyListSemanticRun.nonempty d3ContextRun + input.safety.constructors + obtain ⟨d2Constructors⟩ := + AddInductive.ConstructorPostFamilySemanticListRun.nonempty_of_alignment + d2ContextRun input.postFamilyInput.alignment + normalization.family.constructors + let generationRuns := normalization.constructorGenerationRuns generation + analysis shape + have terminalWF : VLCtx.WF env Us.length + terminalRun.context.vlctx := by + simpa only [terminalVenv, terminalLparams] using terminalRun.context.Δwf + have validationWF : VLCtx.WF normalization.family.typeEnv Us.length + validationRun.context.vlctx := by + simpa only [validationVenv, ← typeEnvEq, validationLparams] using + validationRun.context.Δwf + have viewTerminalWF : VLCtx.WF env Us.length viewTerminal := + (terminalViewDefEq.symm henv.ordered).wf + have d3State : D3FullContextState env normalization.family.typeEnv Us + candidate.families.singleton.familyType.type.trace.terminalContext + parameterΔ parameterΔ terminalRun.context.vlctx viewTerminal .refl + (.skipN .refl generation.block.checked.indices.length) := { + commonWF := parameterWF + commonNoBV := parameterNoBV + fullWF := parameterWF.mono + (VEnv.addConst_le normalization.family.addType) + fullExtension := .refl + actualWF := terminalWF + viewDefEq := terminalViewDefEq + viewUnique := terminalViewUnique + viewExtension := terminalViewLift + freshInvariant := fun _ present => .inl present } + have analyzerState : AnalyzerPostContextState + normalization.family.typeEnv Us parameterΔ validationRun.context.vlctx + viewTerminal (.skipN .refl + generation.block.checked.indices.length) := { + fullWF := parameterWF.mono + (VEnv.addConst_le normalization.family.addType) + postWF := validationWF + viewWF := viewTerminalWF.mono + (VEnv.addConst_le normalization.family.addType) + viewDefEq := by + rw [validationVlctx] + exact (terminalViewDefEq.mono + (VEnv.addConst_le normalization.family.addType)).toFVars + viewExtension := terminalViewLift } + have parametersEq : validation.stats.params.toList = + candidate.families.singleton.familyType.type.trace.parameterList + source.nparams := by + rw [validation.stats_eq] + simp only [CandidateExprTrace.singletonCandidateInductiveStats, + validation, staged, staged.validation_nparams_eq] + have paramsSizeEq : validation.stats.params.size = source.nparams := by + calc + validation.stats.params.size = + validation.stats.params.toList.length := by simp + _ = (candidate.families.singleton.familyType.type.trace.parameterList + source.nparams).length := congrArg List.length parametersEq + _ = generation.block.checked.params.length := + parameterContext.length_eq + _ = source.nparams := + generation.block.checked.direct_anatomy.2.1.trans + generation.block.nparams_eq.symm + have sourceTypeEq : generation.block.sourceType = normalization.raw := by + simpa only [NormalizationCandidateSemanticRun.root] using + normalization.root.sourceType_eq generation + have familyNameEq : generation.block.sourceType.name = + generation.block.checked.type.name := + generation.block.sourceType_name_eq + have familyLparams : + candidate.families.singleton.familyType.type.context.lparams = Us := by + exact normalization.family.type.contextRun.context_lparams.symm.trans + normalization.family.type.lparams_eq + have indConsts : validation.stats.indConsts = + #[.const generation.block.sourceType.name (Us.map .param)] := by + rw [validation.stats_eq] + simp only [CandidateExprTrace.singletonCandidateInductiveStats, + familyLparams] + congr 2 + exact congrArg (fun name => Expr.const name (Us.map .param)) <| + staged.family.name_eq.trans (congrArg + (fun type : VInductiveType => type.name) + (rawEq.symm.trans sourceTypeEq.symm)) + have familyUnique : TrExprS.IsUnique input.safety.familyIndices := + instantiateFamilyParameters_unique + input.safety.familyTranslationUnique + (ConstructorValidation.CandidateParameterContext.parametersUnique + parameterContext) familyInstantiation + have indexLength : generation.block.checked.indices.length = + validation.stats.nindices[0]! := + (stagedIndexCount_eq input normalization generation analysis + shape).symm + have resultLevelTr : VLevel.ofLevel Us validation.stats.resultLevel = + some generation.block.checked.resultLevel := + stagedResultLevel_tr input normalization generation analysis shape + have absent : env.constants generation.block.sourceType.name = none := by + rw [sourceTypeEq] + exact VEnv.addConst_fresh normalization.family.addType + have pairWF := generationRuns.checkedConstructorsWF + d3Constructors d2Constructors (fun _ member => member) henv typeEnvWF + (VEnv.addConst_le normalization.family.addType) parameterContext + parameterWF parameterCtx d3State analyzerState rfl + parametersEq indConsts familyTr familyUnique indexLength resultLevelTr + absent input.safety.constructorTranslationUnique + input.postFamilyInput.universeInput.universeSemantics + normalization.uvars_eq familyNameEq paramsSizeEq + refine ⟨by + simpa only [generation.block.uvars_eq] using + input.familyOnTel normalization generation analysis, ?_⟩ + intro ctor ctorMember + have directMember : + CheckedCtor.ofDirect generation.block.normalization.view.uvars + generation.block.checked.type.name + generation.block.normalization.view.nparams + generation.block.checked.indices.length ctor ∈ + generation.block.checked.constructors := by + rw [generation.block.checked.constructors_eq] + exact List.mem_map.2 ⟨ctor, ctorMember, rfl⟩ + rw [← generation.viewCtors_eq] at directMember + obtain ⟨pair, pairMember, pairViewEq⟩ := List.mem_map.1 directMember + have result := pairWF pair pairMember + rw [pairViewEq] at result + have viewUvarsEq : generation.block.normalization.view.uvars = Us.length := + generation.block.uvars_eq.symm.trans normalization.uvars_eq + have dropBvarRevRange : ∀ (offset count : Nat) (suffix : List VExpr), + (VExpr.bvarRevRange offset count ++ suffix).drop count = suffix := by + intro offset count suffix + induction count with + | zero => rfl + | succ count ih => + simp only [VExpr.bvarRevRange, List.cons_append, + List.drop_succ_cons] + exact ih + rw [← viewUvarsEq, paramsSizeEq, generation.block.nparams_eq, + familyNameEq] at result + simpa only [ + generation.block.nparams_eq, pairViewEq, + CheckedCtor.ofDirect, NormalizedCtor.resultTarget, + VInductDecl.recFieldIdxs, VExpr.appArgs_appN, VExpr.appArgs, + List.append_nil, dropBvarRevRange] using result + +/-- Re-index the derived checked semantics onto the exact normalization view +selected by dependent analysis. -/ +theorem StagedNormalizationCandidatePreFamilyInput.viewDeclWF + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {kernelSource : InductiveType} + {source : VInductDecl} + {candidate : AddInductive.NormalizationCandidate [kernelSource]} + (input : StagedNormalizationCandidatePreFamilyInput familyContext + constructorContext env Us candidate source) + (normalization : NormalizationCandidateSemanticRun env Us candidate source) + (generation : GenerationChecked source) + (analysis : normalization.root.normalization.generation? = + some generation) + (shape : normalization.generationShape = true) : + normalization.root.viewDecl.WF env := by + have checkedWF := input.checkedWF normalization generation analysis shape + have normalizationEq : generation.block.normalization = + normalization.root.normalization := + Normalization.generation?_normalization analysis + have viewEq : generation.block.normalization.view = + normalization.root.viewDecl := by + simpa only [NormalizationCandidateRun.normalization] using + congrArg (fun normalized : Normalization source => normalized.view) + normalizationEq + rw [← viewEq] + exact generation.block.checked.to_declWF generation.block.checked_eq + checkedWF + +/-- Build the semantic generation owner from the retained D1/D2/D3 input, +exact dependent analysis, and the single executable hierarchy shape check. +The analyzer-owned checked semantics are derived from those traces rather +than accepted as a premise. -/ +def GenerationCandidateSemanticRun.ofGenerationShape + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} + {kernelSource : InductiveType} {source : VInductDecl} + {candidate : AddInductive.NormalizationCandidate [kernelSource]} + (input : StagedNormalizationCandidatePreFamilyInput familyContext + constructorContext env Us candidate source) + (normalization : NormalizationCandidateSemanticRun env Us candidate source) + (generation : GenerationChecked source) + (analysis : normalization.root.normalization.generation? = + some generation) + (shape : normalization.generationShape = true) : + GenerationCandidateSemanticRun normalization generation := by + have familyShape := shape + simp only [NormalizationCandidateSemanticRun.generationShape, + normalizationCandidateGenerationShape, Bool.and_eq_true, + beq_iff_eq] at familyShape + have sourceTypeEq : generation.block.sourceType = normalization.raw := by + simpa only [NormalizationCandidateSemanticRun.root] using + normalization.root.sourceType_eq generation + apply GenerationCandidateSemanticShapeRun.run { + analysis := analysis + checked := input.checkedWF normalization generation analysis shape + family := { + storedSpine := familyShape.1.1 + spineLength_eq := by + simpa only [NormalizedChecked.rawParams, + NormalizedChecked.rawIndices, sourceTypeEq] using familyShape.1.2 } + constructors := + CandidateConstructorSemanticGenerationShapeList.ofCheck + normalization.family.constructors familyShape.2 } + +/-- Construct the produced package at the consolidated generation-shape +boundary without accepting a checked- or view-WF premise. -/ +def NormalizationCandidateSemanticRun.producedPackageOfGenerationShape + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} + {kernelSource : InductiveType} {source : VInductDecl} + {candidate : AddInductive.NormalizationCandidate [kernelSource]} + (normalization : NormalizationCandidateSemanticRun env Us candidate source) + (input : StagedNormalizationCandidatePreFamilyInput familyContext + constructorContext env Us candidate source) + (generation : GenerationChecked source) + (analysis : normalization.root.normalization.generation? = + some generation) + (shape : normalization.generationShape = true) + (context : AddInductive.Context) + (nparams numNested : Nat) (isUnsafe : Bool) + (produced : + AddInductive.buildNormalizationCandidate nparams + [kernelSource] numNested isUnsafe context = .ok candidate) : + ProducedGenerationCandidatePackage env Us := + (GenerationCandidateSemanticRun.ofGenerationShape input normalization + generation analysis shape).producedPackage context nparams numNested + isUnsafe produced + +/-- Interpret one successful shape-producing outer result using the matching +retained D1/D2/D3 semantic input. -/ +def ProducedGenerationShapeCandidate.producedPackage + {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) + (normalization : NormalizationCandidateSemanticRun env Us + producedCandidate.candidate source) + (rawEq : raw = normalization.raw) + (generation : GenerationChecked source) + (analysis : normalization.root.normalization.generation? = + some generation) : + ProducedGenerationCandidatePackage env Us := + normalization.producedPackageOfGenerationShape input generation analysis + (by + simpa only [NormalizationCandidateSemanticRun.generationShape, + rawEq] using producedCandidate.shape) + context source.nparams numNested isUnsafe producedCandidate.produced + +/-- Projection-free D3 candidates determine one exact Theory constructor +view at every source position, independently of the existential checker run +that selected it. -/ +theorem CandidateConstructorSemanticListRun.roots_views_eq + {env : VEnv} {Us : List Name} {constructors : List Constructor} + {candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors} + {raws : List VConstVal} + (unique : candidates.ViewTranslationUnique) + (left right : CandidateConstructorSemanticListRun env Us candidates raws) : + left.roots.views = right.roots.views := by + induction left with + | nil => + cases right + rfl + | @cons constructor constructors candidate candidates raw raws head tail ih => + cases right with + | cons otherHead otherTail => + obtain ⟨_, headRecursive⟩ := head.type.recursive + obtain ⟨_, otherHeadRecursive⟩ := otherHead.type.recursive + have headViewEq : head.type.view = otherHead.type.view := + TrExprS.unique unique.1.view + (headRecursive.view_tr_strict unique.1) + (otherHeadRecursive.view_tr_strict unique.1) + have tailViewsEq := ih unique.2 otherTail + simp only [CandidateConstructorSemanticListRun.roots, + CandidateConstructorListRun.views, + CandidateConstructorSemanticRun.root, + CandidateConstructorRun.view] + rw [headViewEq, tailViewsEq] + +/-- Transport the positional uniqueness theorem across the uniquely produced +post-family environment and raw constructor list. -/ +theorem CandidateConstructorSemanticListRun.roots_views_eq_of_eq + {leftEnv rightEnv : VEnv} {Us : List Name} + {constructors : List Constructor} + {candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors} + {leftRaws rightRaws : List VConstVal} + (unique : candidates.ViewTranslationUnique) + (envEq : leftEnv = rightEnv) (rawsEq : leftRaws = rightRaws) + (left : CandidateConstructorSemanticListRun leftEnv Us candidates leftRaws) + (right : CandidateConstructorSemanticListRun rightEnv Us candidates + rightRaws) : + left.roots.views = right.roots.views := by + subst rightEnv + subst rightRaws + exact left.roots_views_eq unique right + +private theorem candidateFamilyView_eq_of_components + {rawLeft rawRight : VInductiveType} + {typeLeft typeRight : VExpr} + {ctorsLeft ctorsRight : List VConstVal} + (rawEq : rawLeft = rawRight) (typeEq : typeLeft = typeRight) + (ctorsEq : ctorsLeft = ctorsRight) : + ({ rawLeft with type := typeLeft, ctors := ctorsLeft } : + VInductiveType) = + { rawRight with type := typeRight, ctors := ctorsRight } := by + cases rawEq + cases typeEq + cases ctorsEq + rfl + +private theorem Normalization.eq_of_view_eq + {source : VInductDecl} {left right : Normalization source} + (viewEq : left.view = right.view) : left = right := by + cases left with + | mk leftView leftShape => + cases right with + | mk rightView rightShape => + cases viewEq + rfl + +/-- The D3 projection-free safety gate makes the complete normalization +selected by the staged semantic owner syntactically unique. In particular, +fixtures may state dependent analysis once for the known normalization and +transport it to whichever semantic hierarchy `input.exists` selects. -/ +theorem StagedNormalizationCandidatePreFamilyInput.normalization_eq + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} + {kernelSource : InductiveType} {source : VInductDecl} + {candidate : AddInductive.NormalizationCandidate [kernelSource]} + (input : StagedNormalizationCandidatePreFamilyInput familyContext + constructorContext env Us candidate source) + (left right : NormalizationCandidateSemanticRun env Us candidate source) : + left.root.normalization = right.root.normalization := by + have rawEq : left.raw = right.raw := by + have singletonEq := left.raw_types_eq.symm.trans right.raw_types_eq + injection singletonEq + have typeEnvEq : left.family.typeEnv = right.family.typeEnv := by + exact Option.some.inj <| left.family.addType.symm.trans <| by + simpa only [rawEq] using right.family.addType + have familyViewEq : left.family.type.view = right.family.type.view := by + obtain ⟨_, leftRecursive⟩ := left.family.type.recursive + obtain ⟨_, rightRecursive⟩ := right.family.type.recursive + exact TrExprS.unique input.safety.familyTranslationUnique + (leftRecursive.view_tr_strict <| + AddInductive.CandidateExprTrace.viewTranslationUnique_sound _ <| by + rw [AddInductive.CandidateExprTrace.viewTranslationUnique_eq] + have gate := input.safety.translationUnique + simp only [Bool.and_eq_true] at gate + exact gate.1) + (rightRecursive.view_tr_strict <| + AddInductive.CandidateExprTrace.viewTranslationUnique_sound _ <| by + rw [AddInductive.CandidateExprTrace.viewTranslationUnique_eq] + have gate := input.safety.translationUnique + simp only [Bool.and_eq_true] at gate + exact gate.1) + have constructorViewsEq : left.family.constructors.roots.views = + right.family.constructors.roots.views := by + exact left.family.constructors.roots_views_eq_of_eq + input.safety.constructorTranslationUnique typeEnvEq + (congrArg VInductiveType.ctors rawEq) right.family.constructors + have familyEq : left.family.root.view = right.family.root.view := by + exact candidateFamilyView_eq_of_components rawEq familyViewEq + constructorViewsEq + have viewDeclEq : left.root.viewDecl = right.root.viewDecl := by + simp only [NormalizationCandidateSemanticRun.root, + NormalizationCandidateRun.viewDecl] + rw [familyEq] + exact Normalization.eq_of_view_eq viewDeclEq + +/-- Exact, source-indexed refinement of the public producer package. + +The public `ProducedGenerationCandidatePackage` deliberately erases its +dependent source, normalization, and generation indices. Keeping those +indices in this closure result lets clients choose the `Nonempty` witness and +still recover a package whose projections reduce to the requested source and +generation. -/ +structure ExactProducedGenerationCandidatePackage + {source : VInductDecl} {raw : VInductiveType} + {kernelSource : InductiveType} {numNested : Nat} {isUnsafe : Bool} + {context : AddInductive.Context} + (env : VEnv) (Us : List Name) + (producedCandidate : ProducedGenerationShapeCandidate source raw + kernelSource numNested isUnsafe context) + (generation : GenerationChecked source) where + normalization : NormalizationCandidateSemanticRun env Us + producedCandidate.candidate source + raw_eq : raw = normalization.raw + semantic : GenerationCandidateSemanticRun normalization generation + +/-- Erase only the exact dependent indices retained by the generic closure. +The ordinary producer equation is copied from the same strengthened producer +value; it contributes provenance, not semantic authority. -/ +def ExactProducedGenerationCandidatePackage.package + {source : VInductDecl} {raw : VInductiveType} + {kernelSource : InductiveType} {numNested : Nat} {isUnsafe : Bool} + {context : AddInductive.Context} {env : VEnv} {Us : List Name} + {producedCandidate : ProducedGenerationShapeCandidate source raw + kernelSource numNested isUnsafe context} + {generation : GenerationChecked source} + (exact : ExactProducedGenerationCandidatePackage env Us + producedCandidate generation) : + ProducedGenerationCandidatePackage env Us := + exact.semantic.producedPackage context source.nparams numNested isUnsafe + producedCandidate.produced + +/-- 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. -/ +theorem ProducedGenerationShapeCandidate.exactProducedPackage_nonempty + {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) : + Nonempty (ExactProducedGenerationCandidatePackage env Us + producedCandidate generation) := by + obtain ⟨preFamily⟩ := input.exists + let normalization := preFamily.postFamily.produced.semantic + have semanticRawEq : normalization.raw = + input.postFamilyInput.universeInput.staged.raw := by + have singletonEq := normalization.raw_types_eq.symm.trans + input.postFamilyInput.universeInput.staged.raw_types_eq + injection singletonEq + have rawEq := rawOwnerEq.trans semanticRawEq.symm + let semantic := GenerationCandidateSemanticRun.ofGenerationShape input + normalization generation (analysis normalization) (by + simpa only [NormalizationCandidateSemanticRun.generationShape, + rawEq] using producedCandidate.shape) + exact ⟨{ normalization, raw_eq := rawEq, semantic }⟩ + +/-- Close one strengthened singleton producer from the staged D1--D4 owner +without choosing a semantic hierarchy at the API boundary. + +`analysis` is exact for every checker-selected semantic normalization owned by +the staged input. The proof eliminates `input.exists` only into `Nonempty`, +then applies D4 to that exact selected normalization. The ordinary producer +equation and the independent generation-shape gate remain the two fields of +`producedCandidate`; neither supplies Theory meaning by itself. -/ +theorem ProducedGenerationShapeCandidate.producedPackage_nonempty + {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) : + Nonempty (ProducedGenerationCandidatePackage env Us) := by + obtain ⟨exact⟩ := producedCandidate.exactProducedPackage_nonempty input + rawOwnerEq generation analysis + exact ⟨exact.package⟩ + +end VInductDecl + +namespace VInductDecl + +/- The D4 closure roots intentionally inherit the exact transitional Verify +axiom set already present in the staged semantic inputs. -/ +/-- +info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidatePreFamilyInput.checkedWF' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms StagedNormalizationCandidatePreFamilyInput.checkedWF + +/-- +info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidatePreFamilyInput.viewDeclWF' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms StagedNormalizationCandidatePreFamilyInput.viewDeclWF + +/-- +info: 'Lean4Lean.VInductDecl.GenerationCandidateSemanticRun.ofGenerationShape' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms GenerationCandidateSemanticRun.ofGenerationShape + +/-- +info: 'Lean4Lean.VInductDecl.NormalizationCandidateSemanticRun.producedPackageOfGenerationShape' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms NormalizationCandidateSemanticRun.producedPackageOfGenerationShape + +/-- +info: 'Lean4Lean.VInductDecl.ProducedGenerationShapeCandidate.producedPackage' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms ProducedGenerationShapeCandidate.producedPackage + +/-- +info: 'Lean4Lean.VInductDecl.ProducedGenerationShapeCandidate.exactProducedPackage_nonempty' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms ProducedGenerationShapeCandidate.exactProducedPackage_nonempty + +/-- +info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidatePreFamilyInput.exists' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms StagedNormalizationCandidatePreFamilyInput.exists + +/-- +info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidatePostFamilyInput.exists' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms StagedNormalizationCandidatePostFamilyInput.exists + +/- The wrapper projections expose their exact existing Verify closure. The +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] +-/ +#guard_msgs in +#print axioms StagedNormalizationCandidateUniverseInput.semanticValidation + +/-- +info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidateUniverseInput.universeSemantics' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms StagedNormalizationCandidateUniverseInput.universeSemantics + +/-- +info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidateUniverseInput.exists' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms StagedNormalizationCandidateUniverseInput.exists + +end VInductDecl +end Lean4Lean diff --git a/Lean4Lean/Verify/Environment/ConstructorValidityMatrix.lean b/Lean4Lean/Verify/Environment/ConstructorValidityMatrix.lean new file mode 100644 index 00000000..6610f37c --- /dev/null +++ b/Lean4Lean/Verify/Environment/ConstructorValidityMatrix.lean @@ -0,0 +1,352 @@ +import Lean4Lean.Theory.ConstructorValidityFixtures +import Lean4Lean.Verify.Environment.InductiveFixtures + +/-! +# L4L-05 constructor-validity differential matrix + +The positive half quotes real Lean metadata, runs the ordinary normalization +candidate producer, then runs both strengthened constructor gates at their +actual pre-family and post-family environments. The negative half pairs each failed +source declaration in `Theory.ConstructorValidityFixtures` with hand-built +metadata at the nearest ordinary-producer phase. +-/ + +namespace Lean4Lean.InductiveReplayFixtures +open Lean Meta Elab Term +open Lean4Lean.InductiveFixtures + +/-! ## Actual positive metadata -/ + +def constructorValidityMatrixInfo : ConstantInfo := + kernelInductInfo% ConstructorValidityMatrix + +def constructorValidityMatrixMkInfo : ConstantInfo := + kernelCtorInfo% ConstructorValidityMatrix.mk + +def constructorValidityMatrixRecInfo : ConstantInfo := + kernelRecInfo% ConstructorValidityMatrix.rec + +def constructorValidityMatrixKernelRuleRhs : VExpr := + kernelRecRuleRhs% ConstructorValidityMatrix.rec 0 + +def constructorValidityMatrixKernelCtor : Constructor where + name := constructorValidityMatrixMkInfo.name + type := constructorValidityMatrixMkInfo.type + +def constructorValidityMatrixKernelType : InductiveType where + name := constructorValidityMatrixInfo.name + type := constructorValidityMatrixInfo.type + ctors := [constructorValidityMatrixKernelCtor] + +def propRecursiveBoundaryInfo : ConstantInfo := + kernelInductInfo% PropRecursiveBoundary + +def propRecursiveBoundaryMkInfo : ConstantInfo := + kernelCtorInfo% PropRecursiveBoundary.mk + +def propRecursiveBoundaryRecInfo : ConstantInfo := + kernelRecInfo% PropRecursiveBoundary.rec + +def propRecursiveBoundaryKernelRuleRhs : VExpr := + kernelRecRuleRhs% PropRecursiveBoundary.rec 0 + +def propRecursiveBoundaryKernelCtor : Constructor where + name := propRecursiveBoundaryMkInfo.name + type := propRecursiveBoundaryMkInfo.type + +def propRecursiveBoundaryKernelType : InductiveType where + name := propRecursiveBoundaryInfo.name + type := propRecursiveBoundaryInfo.type + ctors := [propRecursiveBoundaryKernelCtor] + +theorem constructorValidityMatrix_kernel_shape : + (match constructorValidityMatrixInfo with + | .inductInfo info => (info.numParams, info.numIndices) + | _ => (0, 0)) = (2, 0) ∧ + (match constructorValidityMatrixMkInfo with + | .ctorInfo info => info.numFields + | _ => 0) = 6 ∧ + (match constructorValidityMatrixRecInfo with + | .recInfo info => + (info.numParams, info.numIndices, info.numMotives, + info.numMinors, info.rules.length) + | _ => (0, 0, 0, 0, 0)) = (2, 0, 1, 1, 1) := by + exact ⟨rfl, rfl, rfl⟩ + +theorem constructorValidityMatrix_recursive_positions_exact : + constructorValidityMatrixChecked.constructors[0].recursive.map + (fun position => (position.fieldIndex, position.binders.length)) = + [(2, 0), (3, 1)] := rfl + +theorem constructorValidityMatrix_kernel_rule_exact : + constructorValidityMatrixKernelRuleRhs = + constructorValidityMatrixGenerationChecked.generatedRules[0].rhs := rfl + +theorem propRecursiveBoundary_kernel_shape : + (match propRecursiveBoundaryInfo with + | .inductInfo info => (info.numParams, info.numIndices) + | _ => (0, 0)) = (1, 1) ∧ + (match propRecursiveBoundaryMkInfo with + | .ctorInfo info => info.numFields + | _ => 0) = 2 ∧ + (match propRecursiveBoundaryRecInfo with + | .recInfo info => + (info.numParams, info.numIndices, info.numMotives, + info.numMinors, info.rules.length) + | _ => (0, 0, 0, 0, 0)) = (1, 1, 1, 1, 1) := by + exact ⟨rfl, rfl, rfl⟩ + +theorem propRecursiveBoundary_recursive_positions_exact : + propRecursiveBoundaryChecked.constructors[0].recursive.map + (fun position => (position.fieldIndex, position.binders.length)) = + [(1, 1)] := rfl + +theorem propRecursiveBoundary_kernel_rule_exact : + propRecursiveBoundaryKernelRuleRhs = + propRecursiveBoundaryGenerationChecked.generatedRules[0].rhs := rfl + +/-! ## Positive ordinary and strengthened gates -/ + +def constructorValidityMatrixContext : AddInductive.Context where + env := Kernel.Environment.ofConstants `_constructorValidityMatrix + ({} : ConstMap) + lparams := [`u] + safety := .safe + allowPrimitive := false + +def propRecursiveBoundaryContext : AddInductive.Context where + env := Kernel.Environment.ofConstants `_propRecursiveBoundary + ({} : ConstMap) + lparams := [`u] + safety := .safe + allowPrimitive := false + +def singletonCandidateExact (nparams : Nat) (source : InductiveType) + (context : AddInductive.Context) : Bool := + match AddInductive.buildNormalizationCandidate nparams [source] 0 false + context with + | .error _ => false + | .ok candidate => + candidate.families.singleton.familyType.type.view.equal source.type && + candidate.families.singleton.constructors.toList + (fun _ constructor => constructor.type.view) == + source.ctors.map (fun constructor => constructor.type) + +def singletonPreFamilyAccepted (nparams : Nat) (source : InductiveType) + (context : AddInductive.Context) : Bool := + match AddInductive.buildNormalizationCandidate nparams [source] 0 false + context with + | .error _ => false + | .ok candidate => + match AddInductive.checkInductiveTypes nparams #[source] + (fun stats => + AddInductive.checkConstructorPreFamilySafety stats + candidate.families.singleton.familyType.type.view + candidate.families.singleton.constructors) context with + | .ok _ => true + | .error _ => false + +def singletonUniverseAccepted (nparams : Nat) (source : InductiveType) + (context : AddInductive.Context) : Bool := + match AddInductive.checkInductiveTypes nparams #[source] + (fun stats => do + let familyEnv ← AddInductive.declareInductiveTypes stats nparams + #[source] 0 false + AddInductive.withEnv familyEnv do + AddInductive.checkConstructorUniverseListSemantics stats + source.ctors) context with + | .ok _ => true + | .error _ => false + +#guard singletonCandidateExact 2 constructorValidityMatrixKernelType + constructorValidityMatrixContext + +#guard singletonPreFamilyAccepted 2 constructorValidityMatrixKernelType + constructorValidityMatrixContext + +#guard singletonUniverseAccepted 2 constructorValidityMatrixKernelType + constructorValidityMatrixContext + +#guard singletonCandidateExact 1 propRecursiveBoundaryKernelType + propRecursiveBoundaryContext + +#guard singletonPreFamilyAccepted 1 propRecursiveBoundaryKernelType + propRecursiveBoundaryContext + +#guard singletonUniverseAccepted 1 propRecursiveBoundaryKernelType + propRecursiveBoundaryContext + +/-! ## Matching ordinary-producer rejections -/ + +def l4l05TypeBoxName : Name := + `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05TypeBox + +def l4l05ProofBoxName : Name := + `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05ProofBox + +def l4l05DepProofBoxName : Name := + `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05DepProofBox + +def l4l05TypeBoxInfo : ConstantInfo := .axiomInfo { + name := l4l05TypeBoxName + levelParams := [] + type := .forallE `α (.sort (.succ .zero)) + (.sort (.succ .zero)) .default + isUnsafe := false } + +def l4l05ProofBoxInfo : ConstantInfo := .axiomInfo { + name := l4l05ProofBoxName + levelParams := [] + type := .forallE `α (.sort (.succ .zero)) (.sort .zero) .default + isUnsafe := false } + +def l4l05DepProofBoxInfo : ConstantInfo := .axiomInfo { + name := l4l05DepProofBoxName + levelParams := [] + type := .forallE `α (.sort (.succ .zero)) + (.forallE `value (.bvar 0) (.sort .zero) .default) .implicit + isUnsafe := false } + +def l4l05NegativeMap : ConstMap := + ((({} : ConstMap).insert l4l05TypeBoxName l4l05TypeBoxInfo).insert + l4l05ProofBoxName l4l05ProofBoxInfo).insert + l4l05DepProofBoxName l4l05DepProofBoxInfo + +def l4l05NegativeContext : AddInductive.Context where + env := Kernel.Environment.ofConstants `_l4l05Negative l4l05NegativeMap + lparams := [] + safety := .safe + allowPrimitive := false + +def l4l05UnsafeNegativeContext : AddInductive.Context := + { l4l05NegativeContext with safety := .unsafe } + +def l4l05NegativeType (name ctorName : Name) (ctorType : Expr) : + InductiveType where + name := name + type := .sort (.succ .zero) + ctors := [{ name := ctorName, type := ctorType }] + +def l4l05NestedNegativeName : Name := + `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05NestedNegative + +def l4l05NestedNegativeMkName : Name := + .str l4l05NestedNegativeName "mk" + +def l4l05NestedNegativeConst : Expr := + .const l4l05NestedNegativeName [] + +def l4l05NestedNegativeField : Expr := + .forallE `_ + (.forallE `_ l4l05NestedNegativeConst (.sort .zero) .default) + l4l05NestedNegativeConst .default + +def l4l05NestedNegativeType : InductiveType := + l4l05NegativeType l4l05NestedNegativeName l4l05NestedNegativeMkName + (.forallE `field l4l05NestedNegativeField + l4l05NestedNegativeConst .default) + +def l4l05FamilyNonrecursiveName : Name := + `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05FamilyNonrecursive + +def l4l05FamilyNonrecursiveMkName : Name := + .str l4l05FamilyNonrecursiveName "mk" + +def l4l05FamilyNonrecursiveConst : Expr := + .const l4l05FamilyNonrecursiveName [] + +def l4l05FamilyNonrecursiveType : InductiveType := + l4l05NegativeType l4l05FamilyNonrecursiveName + l4l05FamilyNonrecursiveMkName + (.forallE `field + (.app (.const l4l05TypeBoxName []) l4l05FamilyNonrecursiveConst) + l4l05FamilyNonrecursiveConst .default) + +def l4l05FamilyProofName : Name := + `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05FamilyProof + +def l4l05FamilyProofMkName : Name := + .str l4l05FamilyProofName "mk" + +def l4l05FamilyProofConst : Expr := + .const l4l05FamilyProofName [] + +def l4l05FamilyProofType : InductiveType := + l4l05NegativeType l4l05FamilyProofName l4l05FamilyProofMkName + (.forallE `proof + (.app (.const l4l05ProofBoxName []) l4l05FamilyProofConst) + l4l05FamilyProofConst .default) + +def l4l05RecursiveDependencyName : Name := + `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05RecursiveDependency + +def l4l05RecursiveDependencyMkName : Name := + .str l4l05RecursiveDependencyName "mk" + +def l4l05RecursiveDependencyConst : Expr := + .const l4l05RecursiveDependencyName [] + +def l4l05RecursiveDependencyProof : Expr := + .app (.app (.const l4l05DepProofBoxName []) + l4l05RecursiveDependencyConst) (.bvar 0) + +def l4l05RecursiveDependencyType : InductiveType := + l4l05NegativeType l4l05RecursiveDependencyName + l4l05RecursiveDependencyMkName + (.forallE `recursive l4l05RecursiveDependencyConst + (.forallE `proof l4l05RecursiveDependencyProof + l4l05RecursiveDependencyConst .default) .default) + +def l4l05UniverseRejectName : Name := + `Lean4Lean.InductiveFixtures.KernelDifferential.L4L05UniverseReject + +def l4l05UniverseRejectMkName : Name := + .str l4l05UniverseRejectName "mk" + +def l4l05UniverseRejectConst : Expr := + .const l4l05UniverseRejectName [] + +def l4l05UniverseRejectType : InductiveType := + l4l05NegativeType l4l05UniverseRejectName l4l05UniverseRejectMkName + (.forallE `α (.sort (.succ .zero)) l4l05UniverseRejectConst .default) + +def l4l05CandidateError (source : InductiveType) : Option String := + match AddInductive.buildNormalizationCandidate 0 [source] 0 false + l4l05NegativeContext with + | .error (.other message) => some message + | _ => none + +#guard l4l05CandidateError l4l05NestedNegativeType = some + "arg #1 of 'Lean4Lean.InductiveFixtures.KernelDifferential.L4L05NestedNegative.mk' has a non positive occurrence of the datatypes being declared" + +#guard l4l05CandidateError l4l05FamilyNonrecursiveType = some + "arg #1 of 'Lean4Lean.InductiveFixtures.KernelDifferential.L4L05FamilyNonrecursive.mk' has a non valid occurrence of the datatypes being declared" + +#guard l4l05CandidateError l4l05FamilyProofType = some + "arg #1 of 'Lean4Lean.InductiveFixtures.KernelDifferential.L4L05FamilyProof.mk' has a non valid occurrence of the datatypes being declared" + +#guard l4l05CandidateError l4l05RecursiveDependencyType = some + "arg #2 of 'Lean4Lean.InductiveFixtures.KernelDifferential.L4L05RecursiveDependency.mk' has a non valid occurrence of the datatypes being declared" + +#guard l4l05CandidateError l4l05UniverseRejectType = some + "universe level of type_of(arg #1) of 'Lean4Lean.InductiveFixtures.KernelDifferential.L4L05UniverseReject.mk' is too big for the corresponding inductive datatype" + +def l4l05RecursiveDependencyPreFamilyError : Option String := + match AddInductive.buildNormalizationCandidate 0 + [l4l05RecursiveDependencyType] 0 true l4l05UnsafeNegativeContext with + | .error _ => none + | .ok candidate => + match AddInductive.checkInductiveTypes 0 + #[l4l05RecursiveDependencyType] + (fun stats => + AddInductive.checkConstructorPreFamilySafety stats + candidate.families.singleton.familyType.type.view + candidate.families.singleton.constructors) + l4l05UnsafeNegativeContext with + | .error (.other message) => some message + | _ => none + +#guard l4l05RecursiveDependencyPreFamilyError = + some "constructor depends on an omitted recursive local" + +end Lean4Lean.InductiveReplayFixtures diff --git a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean new file mode 100644 index 00000000..9e096ec3 --- /dev/null +++ b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean @@ -0,0 +1,12196 @@ +import Lean4Lean.Verify.Environment.ConstructorValidityMatrix +import Lean4Lean.Verify.Environment.CandidateIdentityReplay + +/-! +# L4L-05 accepted constructor-validity replay + +The two accepted differential fixtures retain the exact executable +normalization candidate, close it through the staged D1--D4 owner, and route +the resulting generation certificate through both the Theory transaction and +the actual-kernel-metadata environment replay. +-/ + +namespace Lean4Lean.InductiveReplayFixtures +open Lean Meta Elab Term +open Lean4Lean.InductiveFixtures + +local instance instInhabitedVEnvValidityReplay : Inhabited VEnv := ⟨.empty⟩ + +private theorem exceptUnit_eq_ok_of_isOk {error : Type} + (result : Except error Unit) (h : result.isOk = true) : + result = .ok () := by + cases result with + | error error => + change false = true at h + contradiction + | ok result => + cases result + rfl + +private theorem normalization_eq_of_view_eq + {source : VInductDecl} {left right : VInductDecl.Normalization source} + (view_eq : left.view = right.view) : left = right := by + cases left with + | mk leftView leftShape => + cases right with + | mk rightView rightShape => + simp only [VInductDecl.Normalization.mk.injEq] at * + exact view_eq + +private theorem stagedPreFamily_transport_raw + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {kernelSource : InductiveType} + {source : VInductDecl} + {left right : AddInductive.NormalizationCandidate [kernelSource]} + (candidate_eq : left = right) + (input : VInductDecl.StagedNormalizationCandidatePreFamilyInput + familyContext constructorContext env Us left source) : + ((candidate_eq ▸ input : + VInductDecl.StagedNormalizationCandidatePreFamilyInput + familyContext constructorContext env Us right source) + |>.postFamilyInput.universeInput.staged.raw) = + input.postFamilyInput.universeInput.staged.raw := by + cases candidate_eq + rfl + +def l4l05EmptyVEnvs : VEnvs where + venv _ := VEnv.empty + +theorem l4l05EmptyHasPrimitives : VEnv.HasPrimitives VEnv.empty := by + apply TypeChecker.VEnv.HasPrimitives.of_avoids + intro name membership + rfl + +theorem cvmEmptySafePrimitives : + constructorValidityMatrixContext.env.find? name = some info → + Kernel.Environment.primitives.contains name → + info.safety = .safe ∧ info.levelParams = [] := by + intro hfind hprimitive + change ({} : ConstMap).find?' name = some info at hfind + rw [SMap.WF.find?'_eq_find? SMap.WF.empty] at hfind + simp [SMap.find?] at hfind + +theorem cvmEmptyVEnvsWF : + l4l05EmptyVEnvs.WF constructorValidityMatrixContext.env where + tr := by + intro safety + change TrEnv' safety ({} : ConstMap) false VEnv.empty + exact .empty + hasPrimitives := l4l05EmptyHasPrimitives + safePrimitives := cvmEmptySafePrimitives + mono := fun _ => .rfl + +theorem prbEmptySafePrimitives : + propRecursiveBoundaryContext.env.find? name = some info → + Kernel.Environment.primitives.contains name → + info.safety = .safe ∧ info.levelParams = [] := by + intro hfind hprimitive + change ({} : ConstMap).find?' name = some info at hfind + rw [SMap.WF.find?'_eq_find? SMap.WF.empty] at hfind + simp [SMap.find?] at hfind + +theorem prbEmptyVEnvsWF : + l4l05EmptyVEnvs.WF propRecursiveBoundaryContext.env where + tr := by + intro safety + change TrEnv' safety ({} : ConstMap) false VEnv.empty + exact .empty + hasPrimitives := l4l05EmptyHasPrimitives + safePrimitives := prbEmptySafePrimitives + mono := fun _ => .rfl + +def cvmExecutionResult := + AddInductive.buildNormalizationCandidateExecution 2 + [constructorValidityMatrixKernelType] 0 false + constructorValidityMatrixContext + +theorem cvmExecutionResult_isOk : cvmExecutionResult.isOk = true := by + native_decide + +def cvmProducedExecution : + { execution // cvmExecutionResult = .ok execution } := + match h : cvmExecutionResult with + | .ok execution => ⟨execution, rfl⟩ + | .error _ => by + have hOk := cvmExecutionResult_isOk + rw [h] at hOk + contradiction + +def cvmExecution := cvmProducedExecution.val + +def cvmCandidate := cvmExecution.candidate + +open TypeChecker in +def cvmFamilyIdentityShape : + CandidateExprIdentityReplay.Shaped constructorValidityMatrixContext + constructorValidityMatrixKernelType.type 2 + (.sort (.succ (.param `u))) := by + let aName := constructorValidityMatrixKernelType.type.bindingBody! + |>.bindingDomain!.bindingName! + change CandidateExprIdentityReplay.Shaped constructorValidityMatrixContext + (.forallE `α (.sort (.succ (.param `u))) + (.forallE `P + (.forallE aName (.bvar 0) (.sort .zero) .default) + (.sort (.succ (.param `u))) .default) .default) + 2 (.sort (.succ (.param `u))) + let alphaContext := constructorValidityMatrixContext.pushLocalDecl + `α .default (.sort (.succ (.param `u))) + let alphaAnnotations := AddInductive.builtCandidateTypeAnnotations + (Expr.sort (.succ (.param `u))) + refine .forallE (expectedSpineLength := 1) + constructorValidityMatrixContext `α + (.sort (.succ (.param `u))) + (.forallE `P + (.forallE aName (.bvar 0) (.sort .zero) .default) + (.sort (.succ (.param `u))) .default) .default + (by rfl) alphaAnnotations + (AddInductive.buildCandidateTypeAnnotations_built _) (by + simpa [AddInductive.CandidateTypeAnnotationTrace.build] using + (AddInductive.CandidateTypeAnnotationTrace.build_consumed + (.sort (.succ (.param `u)))).symm) + (.terminal _ _ (by rfl) rfl) ?_ + let pDomain := Expr.forallE aName + constructorValidityMatrixContext.freshExpr + (.sort .zero) .default + have alphaFVarWhnf : AddInductive.CandidateWhnfStep.Valid + ⟨alphaContext, constructorValidityMatrixContext.freshExpr, + constructorValidityMatrixContext.freshExpr⟩ := by + simpa [alphaContext] using + TypeChecker.candidateWhnfPushedFVar_refl + constructorValidityMatrixContext `α + (.sort (.succ (.param `u))) .default 9999 (by rfl) + (by + change LocalContext.WF ⟨.empty, .empty, .empty⟩ + exact LocalContext.WF.nil) + (by + change (⟨.empty, .empty, .empty⟩ : LocalContext).find? + constructorValidityMatrixContext.freshFVarId = none + exact TypeChecker.emptyLocalContextFindNone _) + have pDomainShape : CandidateExprIdentityReplay.Shaped alphaContext + pDomain 1 (.sort .zero) := by + let aAnnotations := AddInductive.builtCandidateTypeAnnotations + constructorValidityMatrixContext.freshExpr + refine .forallE (expectedSpineLength := 0) alphaContext aName + constructorValidityMatrixContext.freshExpr (.sort .zero) .default + (by rfl) aAnnotations + (AddInductive.buildCandidateTypeAnnotations_built _) (by + simpa [AddInductive.Context.freshExpr, + AddInductive.CandidateTypeAnnotationTrace.build] using + (AddInductive.CandidateTypeAnnotationTrace.build_consumed + constructorValidityMatrixContext.freshExpr).symm) + (.terminal _ _ alphaFVarWhnf rfl) ?_ + have terminal : CandidateExprIdentityReplay.Shaped + (alphaContext.pushLocalDecl aName .default + constructorValidityMatrixContext.freshExpr) + (.sort .zero) 0 (.sort .zero) := + .terminal _ _ (by rfl) rfl + simpa [aAnnotations, AddInductive.builtCandidateTypeAnnotations, + AddInductive.CandidateTypeAnnotationTrace.build, + AddInductive.Context.freshExpr, + Expr.instantiate1_eq, Expr.instantiate1'] using terminal + have alphaBody : CandidateExprIdentityReplay.Shaped alphaContext + (.forallE `P pDomain (.sort (.succ (.param `u))) .default) + 1 (.sort (.succ (.param `u))) := by + let pAnnotations := AddInductive.builtCandidateTypeAnnotations pDomain + refine .forallE (expectedSpineLength := 0) alphaContext `P pDomain + (.sort (.succ (.param `u))) .default (by rfl) pAnnotations + (AddInductive.buildCandidateTypeAnnotations_built _) (by + simpa [pDomain, AddInductive.Context.freshExpr, + AddInductive.CandidateTypeAnnotationTrace.build] using + (AddInductive.CandidateTypeAnnotationTrace.build_consumed + pDomain).symm) + pDomainShape.replay ?_ + have terminal : CandidateExprIdentityReplay.Shaped + (alphaContext.pushLocalDecl `P .default pDomain) + (.sort (.succ (.param `u))) 0 + (.sort (.succ (.param `u))) := + .terminal _ _ (by rfl) rfl + simpa [pAnnotations, AddInductive.builtCandidateTypeAnnotations, + AddInductive.CandidateTypeAnnotationTrace.build, + Expr.instantiate1_eq, Expr.instantiate1'] using terminal + simpa [alphaContext, alphaAnnotations, pDomain, + AddInductive.builtCandidateTypeAnnotations, + AddInductive.CandidateTypeAnnotationTrace.build, + Expr.instantiate1_eq, Expr.instantiate1'] using alphaBody + +def cvmFamilyIdentityReplay : + TypeChecker.CandidateExprIdentityReplay + constructorValidityMatrixContext + constructorValidityMatrixKernelType.type := + cvmFamilyIdentityShape.replay + +theorem cvmFamilyCandidateBuild : + AddInductive.buildCandidateExpr constructorValidityMatrixKernelType.type + constructorValidityMatrixContext = + .ok cvmCandidate.families.singleton.familyType.type := by + have produced := cvmExecution.familyTypes.produced + rw [AddInductive.CandidateList.singleton_eta + cvmExecution.familyTypes.candidates] at produced + rw [← cvmExecution.families.produced.singleton_familyType] at produced + have exactProduced : AddInductive.CandidateFamilyTypeListProduced + constructorValidityMatrixContext + (.cons cvmCandidate.families.singleton.familyType .nil) := by + simpa [cvmCandidate, + AddInductive.NormalizationCandidateExecution.candidate, + constructorValidityMatrixContext] using produced + exact exactProduced.singleton_build + +def cvmFamilyIdentityEvidence : + TypeChecker.CandidateExprIdentityReplay.Evidence + cvmFamilyIdentityReplay + cvmCandidate.families.singleton.familyType.type.trace := + cvmFamilyIdentityReplay.evidence_of_build cvmFamilyCandidateBuild + +theorem cvmFamilyIdentityReplay_shape : + cvmFamilyIdentityReplay.spineLength = 2 ∧ + cvmFamilyIdentityReplay.terminalSource = + .sort (.succ (.param `u)) := + ⟨cvmFamilyIdentityShape.spineLength_eq, + cvmFamilyIdentityShape.terminalSource_eq⟩ + +theorem cvmFamilyValidationAnnotations : + cvmCandidate.families.singleton.familyType.type.trace + |>.validationAnnotations := by + have h := cvmExecution.familyTypes.produced + |>.singleton_validationAnnotations + rw [← cvmExecution.families.produced.singleton_familyType] at h + simpa [cvmCandidate, + AddInductive.NormalizationCandidateExecution.candidate] using h + +private theorem cvmFamilyData_hasExprMVar_false : + constructorValidityMatrixInfo.type.data.hasExprMVar = false := by + change constructorValidityMatrixInfo.type.hasExprMVar = false + rw [Expr.hasExprMVar_eq] + rfl + +private theorem cvmFamilyData_hasLevelMVar_false : + constructorValidityMatrixInfo.type.data.hasLevelMVar = false := by + change constructorValidityMatrixInfo.type.hasLevelMVar = false + rw [Expr.hasLevelMVar_eq] + simp [constructorValidityMatrixInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, Expr.hasLevelMVar', + Level.hasMVar_eq, Level.hasMVar'] + +private theorem cvmFamilyData_hasFVar_false : + constructorValidityMatrixInfo.type.data.hasFVar = false := by + change constructorValidityMatrixInfo.type.hasFVar = false + rw [Expr.hasFVar_eq] + rfl + +private theorem cvmFamily_hasMVar_false : + constructorValidityMatrixInfo.type.hasMVar = false := by + change (constructorValidityMatrixInfo.type.data.hasExprMVar || + constructorValidityMatrixInfo.type.data.hasLevelMVar) = false + rw [cvmFamilyData_hasExprMVar_false, + cvmFamilyData_hasLevelMVar_false] + rfl + +private theorem cvmFamily_hasFVar_false : + constructorValidityMatrixInfo.type.hasFVar = false := + cvmFamilyData_hasFVar_false + +theorem cvmFamilyClosed : + cvmCandidate.families.singleton.familyType.type.context.env.checkNoMVarNoFVar + constructorValidityMatrixKernelType.name + constructorValidityMatrixKernelType.type = .ok () := by + unfold Kernel.Environment.checkNoMVarNoFVar + Kernel.Environment.checkNoMVar Kernel.Environment.checkNoFVar + rw [show constructorValidityMatrixKernelType.type.hasMVar = false by + simpa [constructorValidityMatrixKernelType] using + cvmFamily_hasMVar_false] + rw [show constructorValidityMatrixKernelType.type.hasFVar = false by + simpa [constructorValidityMatrixKernelType] using + cvmFamily_hasFVar_false] + rfl + +theorem cvmFamilyEnsureSort : + TypeChecker.M.run + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.env + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.safety + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.lctx + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.lparams + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.fuel + (TypeChecker.ensureSort (.sort (.succ (.param `u)))) = + .ok (.sort (.succ (.param `u))) := by + rfl + +theorem cvmFamilySpineCount : + 2 ≤ cvmCandidate.families.singleton.familyType.type.trace.spineLength := by + rw [cvmFamilyIdentityEvidence.spineLength_eq, + cvmFamilyIdentityReplay_shape.1] + decide + +theorem cvmFamilySpineFuel : + cvmCandidate.families.singleton.familyType.type.trace.spineLength < + cvmCandidate.families.singleton.familyType.type.context.fuel.inductiveFuel := by + have contextFuel := congrArg (fun context : AddInductive.Context => + context.fuel.inductiveFuel) + (AddInductive.CandidateExpr.context_eq_of_build cvmFamilyCandidateBuild) + rw [contextFuel] + rw [cvmFamilyIdentityEvidence.spineLength_eq, + cvmFamilyIdentityReplay_shape.1] + decide + +def cvmFamilyValidationRun : + AddInductive.CandidateExprTrace.FamilyValidationRun + constructorValidityMatrixKernelType + cvmCandidate.families.singleton.familyType.type.trace where + nparams := 2 + resultLevel := .succ (.param `u) + stats := + cvmCandidate.families.singleton.familyType.type.trace + |>.singletonCandidateInductiveStats + constructorValidityMatrixKernelType 2 (.succ (.param `u)) + stats_eq := rfl + terminal_eq := cvmFamilyIdentityEvidence.terminalResult_eq.trans + cvmFamilyIdentityReplay_shape.2 + run := fun k => + AddInductive.CandidateExprTrace.checkInductiveTypes_singleton_of_candidate + constructorValidityMatrixKernelType + cvmCandidate.families.singleton.familyType.type.trace + 2 (.succ (.param `u)) k + cvmFamilyClosed cvmFamilySpineCount cvmFamilySpineFuel + cvmFamilyValidationAnnotations + (cvmFamilyIdentityEvidence.terminalResult_eq.trans + cvmFamilyIdentityReplay_shape.2) + cvmFamilyEnsureSort + +theorem cvmFamilyContext_eq : + cvmCandidate.families.singleton.familyType.type.context = + constructorValidityMatrixContext := by + have h := cvmExecution.familyTypes.produced.singleton_context_eq + rw [← cvmExecution.families.produced.singleton_familyType] at h + simpa [cvmCandidate, + AddInductive.NormalizationCandidateExecution.candidate, + constructorValidityMatrixContext] using h + +theorem cvmFamilyNparams_eq : cvmFamilyValidationRun.nparams = 2 := by + rfl + +theorem cvmFamilyValidationRun_exact : ∀ {alpha} + (k : AddInductive.InductiveStats → AddInductive.M alpha), + AddInductive.checkInductiveTypes 2 #[constructorValidityMatrixKernelType] + k constructorValidityMatrixContext = + k cvmFamilyValidationRun.stats + cvmCandidate.families.singleton.familyType.type.trace.terminalContext := by + intro alpha k + simpa only [cvmFamilyNparams_eq, cvmFamilyContext_eq] using + cvmFamilyValidationRun.run k + +theorem cvmAfterValidationRun : + AddInductive.buildNormalizationCandidateExecutionAfterValidation 2 + [constructorValidityMatrixKernelType] 0 false + constructorValidityMatrixContext cvmFamilyValidationRun.stats + cvmCandidate.families.singleton.familyType.type.trace.terminalContext = + .ok cvmExecution := by + have h := cvmProducedExecution.property + change AddInductive.buildNormalizationCandidateExecution 2 + [constructorValidityMatrixKernelType] 0 false + constructorValidityMatrixContext = .ok cvmExecution at h + unfold AddInductive.buildNormalizationCandidateExecution at h + rw [cvmFamilyValidationRun_exact] at h + exact h + +theorem cvmExecutionStats_eq : + cvmExecution.stats = cvmFamilyValidationRun.stats := + (cvmExecution.fields_of_afterValidation cvmFamilyValidationRun.stats + cvmCandidate.families.singleton.familyType.type.trace.terminalContext + cvmAfterValidationRun).1 + +theorem cvmExecutionValidationContext_eq : + cvmExecution.validationContext = + cvmCandidate.families.singleton.familyType.type.trace.terminalContext := + (cvmExecution.fields_of_afterValidation cvmFamilyValidationRun.stats + cvmCandidate.families.singleton.familyType.type.trace.terminalContext + cvmAfterValidationRun).2 + +theorem cvmExecutionValidationRun : ∀ {alpha} + (k : AddInductive.InductiveStats → AddInductive.M alpha), + AddInductive.checkInductiveTypes 2 #[constructorValidityMatrixKernelType] + k constructorValidityMatrixContext = + k cvmExecution.stats cvmExecution.validationContext := by + intro alpha k + rw [cvmFamilyValidationRun_exact, cvmExecutionStats_eq, + cvmExecutionValidationContext_eq] + +theorem cvmCandidate_produced : + AddInductive.buildNormalizationCandidate 2 + [constructorValidityMatrixKernelType] 0 false + constructorValidityMatrixContext = .ok cvmCandidate := + cvmExecution.produces cvmExecutionValidationRun + +def cvmFamilyContext : AddInductive.Context := + { constructorValidityMatrixContext with lctx := {} } + +def cvmConstructorContext : AddInductive.Context := + { constructorValidityMatrixContext with + env := cvmExecution.familyEnv, lctx := {} } + +theorem cvmFamilyCandidateContext_eq : + cvmCandidate.families.singleton.familyType.type.context = + cvmFamilyContext := by + simpa [cvmFamilyContext, constructorValidityMatrixContext] using + cvmFamilyContext_eq + +theorem cvmConstructorCandidateContext_eq : + cvmCandidate.families.singleton.constructors.singleton.type.context = + cvmConstructorContext := by + have h := cvmExecution.families.produced.singleton_constructors + |>.singleton_context_eq + simpa [cvmCandidate, + AddInductive.NormalizationCandidateExecution.candidate, + cvmConstructorContext] using h + +theorem cvmFamilyPrefix_ne : + cvmFamilyContext.ngen.namePrefix ≠ + (({} : TypeChecker.VState).ngen).namePrefix := by + decide + +def cvmFamilyContextRun : + TypeChecker.CandidateContextRun cvmFamilyContext := + TypeChecker.CandidateContextRun.root cvmEmptyVEnvsWF rfl + cvmFamilyPrefix_ne + +def cvmPreFamilyStage : + TypeChecker.CandidateSemanticStage cvmFamilyContext VEnv.empty [`u] where + contextRun := cvmFamilyContextRun + venv_eq := rfl + lparams_eq := rfl + vlctx_eq := rfl + +theorem cvmRawFamily_isType : + VEnv.empty.IsType 1 [] constructorValidityMatrixType.type := by + change VEnv.empty.IsType 1 [] + (.forallE (.sort (.succ (.param 0))) + (.forallE (.forallE (.bvar 0) (.sort .zero)) + (.sort (.succ (.param 0))))) + apply VEnv.IsType.forallE + · exact ⟨_, VEnv.HasType.sort (by decide)⟩ + · apply VEnv.IsType.forallE + · apply VEnv.IsType.forallE + · exact ⟨_, by type_tac⟩ + · exact ⟨_, VEnv.HasType.sort (by decide)⟩ + · exact ⟨_, VEnv.HasType.sort (by decide)⟩ + +theorem cvmFamilySource_tr : + TrExprS VEnv.empty [`u] [] constructorValidityMatrixKernelType.type + constructorValidityMatrixType.type := by + have shape : TrTypeExpr VEnv.empty [`u] [] + constructorValidityMatrixKernelType.type + constructorValidityMatrixType.type := by + tr_type_expr_tac + obtain ⟨level, type⟩ := cvmRawFamily_isType + exact shape.to_trExprS .empty trivial ⟨.sort level, type⟩ + +theorem cvmStatsNindices_eq : + cvmFamilyValidationRun.stats.nindices = #[0] := by + rw [cvmFamilyValidationRun.stats_eq] + change #[cvmCandidate.families.singleton.familyType.type.trace.spineLength - + 2] = #[0] + rw [cvmFamilyIdentityEvidence.spineLength_eq, + cvmFamilyIdentityReplay_shape.1] + +theorem cvmTerminalEnv_eq : + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.env = + constructorValidityMatrixContext.env := by + calc + _ = cvmCandidate.families.singleton.familyType.type.context.env := + cvmCandidate.families.singleton.familyType.type.trace.terminalContext_env + _ = cvmFamilyContext.env := + congrArg AddInductive.Context.env cvmFamilyCandidateContext_eq + _ = constructorValidityMatrixContext.env := rfl + +theorem cvmTerminalLparams_eq : + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.lparams = + constructorValidityMatrixContext.lparams := by + calc + _ = cvmCandidate.families.singleton.familyType.type.context.lparams := + cvmCandidate.families.singleton.familyType.type.trace.terminalContext_lparams + _ = cvmFamilyContext.lparams := + congrArg AddInductive.Context.lparams cvmFamilyCandidateContext_eq + _ = constructorValidityMatrixContext.lparams := rfl + +theorem cvmTerminalAllowPrimitive_eq : + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.allowPrimitive = + constructorValidityMatrixContext.allowPrimitive := by + calc + _ = cvmCandidate.families.singleton.familyType.type.context.allowPrimitive := + cvmCandidate.families.singleton.familyType.type.trace + |>.terminalContext_allowPrimitive + _ = cvmFamilyContext.allowPrimitive := + congrArg AddInductive.Context.allowPrimitive cvmFamilyCandidateContext_eq + _ = constructorValidityMatrixContext.allowPrimitive := rfl + +theorem cvmFamilyNameAbsent : + constructorValidityMatrixContext.env.contains + constructorValidityMatrixKernelType.name = false := by + change ({} : ConstMap).contains + constructorValidityMatrixKernelType.name = false + rw [SMap.find?_isSome, + SMap.WF.find?_eq SMap.WF.empty] + simp [SMap.toList'] + +theorem cvmFamilyNameNotPrimitive : + Kernel.Environment.primitives.contains + constructorValidityMatrixKernelType.name = false := by + simp [constructorValidityMatrixKernelType, + constructorValidityMatrixInfo, Kernel.Environment.primitives, + NameSet.ofList] + simp +decide [NameSet.contains] + +def cvmDeclaredInfo : ConstantInfo := + .inductInfo <| AddInductive.singletonDeclaredInfo + cvmFamilyValidationRun.stats 2 0 constructorValidityMatrixKernelType + 0 false + cvmCandidate.families.singleton.familyType.type.trace.terminalContext + +theorem cvmFamilyNames_eq : + constructorValidityMatrixKernelType.name = + constructorValidityMatrixType.name := by + decide + +theorem cvmFamilyMap_add : + cvmExecution.familyEnv.constants = + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.env.constants.insert + constructorValidityMatrixType.name cvmDeclaredInfo := by + have h := cvmExecution.declareRun + rw [cvmExecutionStats_eq, cvmExecutionValidationContext_eq] at h + rw [← cvmFamilyNames_eq] + simpa [cvmDeclaredInfo] using + AddInductive.declareInductiveTypes_singleton_constants + cvmFamilyValidationRun.stats 2 0 constructorValidityMatrixKernelType + 0 false + cvmCandidate.families.singleton.familyType.type.trace.terminalContext + cvmExecution.familyEnv cvmStatsNindices_eq h + +def cvmTypeEnv : VEnv := + (VEnv.empty.addConst constructorValidityMatrixType.name + constructorValidityMatrixType.toVConstant).get! + +theorem cvmTypeEnv_add : + VEnv.empty.addConst constructorValidityMatrixType.name + constructorValidityMatrixType.toVConstant = some cvmTypeEnv := by + rfl + +theorem cvmDeclaredInfo_tr : + TrConstVal .safe VEnv.empty cvmDeclaredInfo + constructorValidityMatrixType.toVConstVal := by + refine ⟨⟨by decide, ?_, ?_⟩, rfl⟩ + · change + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.lparams.length = + constructorValidityMatrixType.uvars + rw [cvmTerminalLparams_eq] + rfl + · change TrExprS VEnv.empty + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.lparams + [] constructorValidityMatrixKernelType.type + constructorValidityMatrixType.type + rw [cvmTerminalLparams_eq] + exact cvmFamilySource_tr + +def cvmAddType : + AddInductConstant .induct cvmFamilyContext.env.constants VEnv.empty + constructorValidityMatrixType.toVConstVal + cvmConstructorContext.env.constants cvmTypeEnv where + info := cvmDeclaredInfo + kind_eq := by simp [cvmDeclaredInfo, InductConstantKind.Matches] + tr := cvmDeclaredInfo_tr + map_fresh := by + change ({} : ConstMap).find? + constructorValidityMatrixType.name = none + rw [SMap.WF.find?_eq SMap.WF.empty] + simp [SMap.toList'] + env_add := cvmTypeEnv_add + map_add := by + simpa [cvmFamilyContext, cvmConstructorContext, + cvmTerminalEnv_eq] using cvmFamilyMap_add + +theorem cvmFamilyWhnfDepth : + cvmCandidate.families.singleton.familyType.type.context.fuel.recDepth = + 9999 + 1 := by + rw [cvmFamilyCandidateContext_eq] + rfl + +def cvmFamilyStage : + VInductDecl.CandidateFamilyStagedInput + cvmFamilyContext cvmConstructorContext VEnv.empty [`u] + cvmCandidate.families.singleton.familyType + constructorValidityMatrixType cvmPreFamilyStage where + name_eq := cvmFamilyNames_eq + uvars_eq := rfl + type := { + context_eq := cvmFamilyCandidateContext_eq.symm + source_tr := cvmFamilySource_tr + whnfFuel := 9999 + whnfDepth := cvmFamilyWhnfDepth } + validation := cvmFamilyValidationRun + typeEnv := cvmTypeEnv + addInduct := cvmAddType + family_lctx_eq := rfl + constructorContext_eq := rfl + quotInit_eq := by + have h := cvmExecution.declareRun + rw [cvmExecutionStats_eq, cvmExecutionValidationContext_eq] at h + simpa [cvmConstructorContext, cvmFamilyContext, + cvmTerminalEnv_eq] using + AddInductive.declareInductiveTypes_singleton_quotInit + cvmFamilyValidationRun.stats 2 0 constructorValidityMatrixKernelType + 0 false + cvmCandidate.families.singleton.familyType.type.trace.terminalContext + cvmExecution.familyEnv cvmStatsNindices_eq h + name_not_reflected := by decide + name_not_primitive := by + rw [← cvmFamilyNames_eq] + exact cvmFamilyNameNotPrimitive + +def cvmCtorAlphaDomain : Expr := + constructorValidityMatrixKernelCtor.type.bindingDomain! + +def cvmCtorAlphaContext : AddInductive.Context := + cvmConstructorContext.pushLocalDecl `α .implicit cvmCtorAlphaDomain + +def cvmCtorAfterAlpha : Expr := + constructorValidityMatrixKernelCtor.type.bindingBody!.instantiate1 + cvmConstructorContext.freshExpr + +def cvmCtorPDomain : Expr := cvmCtorAfterAlpha.bindingDomain! + +def cvmCtorPContext : AddInductive.Context := + cvmCtorAlphaContext.pushLocalDecl `P .implicit cvmCtorPDomain + +def cvmCtorAfterP : Expr := + cvmCtorAfterAlpha.bindingBody!.instantiate1 + cvmCtorAlphaContext.freshExpr + +def cvmCtorXDomain : Expr := cvmCtorAfterP.bindingDomain! + +def cvmCtorXContext : AddInductive.Context := + cvmCtorPContext.pushLocalDecl `x .default cvmCtorXDomain + +def cvmCtorAfterX : Expr := + cvmCtorAfterP.bindingBody!.instantiate1 cvmCtorPContext.freshExpr + +def cvmCtorProofDomain : Expr := cvmCtorAfterX.bindingDomain! + +def cvmCtorProofContext : AddInductive.Context := + cvmCtorXContext.pushLocalDecl `proof .default cvmCtorProofDomain + +def cvmCtorAfterProof : Expr := + cvmCtorAfterX.bindingBody!.instantiate1 cvmCtorXContext.freshExpr + +def cvmCtorDirectDomain : Expr := cvmCtorAfterProof.bindingDomain! + +def cvmCtorDirectContext : AddInductive.Context := + cvmCtorProofContext.pushLocalDecl `direct .default cvmCtorDirectDomain + +def cvmCtorAfterDirect : Expr := + cvmCtorAfterProof.bindingBody!.instantiate1 cvmCtorProofContext.freshExpr + +def cvmCtorFunctionDomain : Expr := cvmCtorAfterDirect.bindingDomain! + +def cvmCtorFunctionContext : AddInductive.Context := + cvmCtorDirectContext.pushLocalDecl `function .default cvmCtorFunctionDomain + +def cvmCtorAfterFunction : Expr := + cvmCtorAfterDirect.bindingBody!.instantiate1 + cvmCtorDirectContext.freshExpr + +def cvmCtorLaterDomain : Expr := cvmCtorAfterFunction.bindingDomain! + +def cvmCtorLaterContext : AddInductive.Context := + cvmCtorFunctionContext.pushLocalDecl `later .default cvmCtorLaterDomain + +def cvmCtorAfterLater : Expr := + cvmCtorAfterFunction.bindingBody!.instantiate1 + cvmCtorFunctionContext.freshExpr + +def cvmCtorLaterProofDomain : Expr := cvmCtorAfterLater.bindingDomain! + +def cvmCtorLaterProofContext : AddInductive.Context := + cvmCtorLaterContext.pushLocalDecl `laterProof .default + cvmCtorLaterProofDomain + +def cvmCtorTerminal : Expr := + cvmCtorAfterLater.bindingBody!.instantiate1 + cvmCtorLaterContext.freshExpr + +def cvmCtorPArgContext : AddInductive.Context := + cvmCtorAlphaContext.pushLocalDecl cvmCtorPDomain.bindingName! + .default cvmCtorPDomain.bindingDomain! + +def cvmCtorFunctionArgContext : AddInductive.Context := + cvmCtorDirectContext.pushLocalDecl `y .default + cvmCtorFunctionDomain.bindingDomain! + +def cvmCtorRootLocalRun : + TypeChecker.CandidateLocalContextRun cvmConstructorContext := + .empty _ rfl + +def cvmCtorAlphaLocalRun : + TypeChecker.CandidateLocalContextRun cvmCtorAlphaContext := + cvmCtorRootLocalRun.push `α .implicit cvmCtorAlphaDomain + +def cvmCtorPLocalRun : + TypeChecker.CandidateLocalContextRun cvmCtorPContext := + cvmCtorAlphaLocalRun.push `P .implicit cvmCtorPDomain + +def cvmCtorXLocalRun : + TypeChecker.CandidateLocalContextRun cvmCtorXContext := + cvmCtorPLocalRun.push `x .default cvmCtorXDomain + +def cvmCtorProofLocalRun : + TypeChecker.CandidateLocalContextRun cvmCtorProofContext := + cvmCtorXLocalRun.push `proof .default cvmCtorProofDomain + +def cvmCtorDirectLocalRun : + TypeChecker.CandidateLocalContextRun cvmCtorDirectContext := + cvmCtorProofLocalRun.push `direct .default cvmCtorDirectDomain + +def cvmCtorFunctionLocalRun : + TypeChecker.CandidateLocalContextRun cvmCtorFunctionContext := + cvmCtorDirectLocalRun.push `function .default cvmCtorFunctionDomain + +def cvmCtorLaterLocalRun : + TypeChecker.CandidateLocalContextRun cvmCtorLaterContext := + cvmCtorFunctionLocalRun.push `later .default cvmCtorLaterDomain + +def cvmCtorLaterProofLocalRun : + TypeChecker.CandidateLocalContextRun cvmCtorLaterProofContext := + cvmCtorLaterLocalRun.push `laterProof .default cvmCtorLaterProofDomain + +theorem cvmCtorAlphaFindInAlpha : + cvmCtorAlphaContext.lctx.find? cvmConstructorContext.freshFVarId = + some (.cdecl cvmConstructorContext.lctx.decls.size + cvmConstructorContext.freshFVarId `α cvmCtorAlphaDomain + .implicit .default) := + cvmCtorRootLocalRun.push_findNew `α .implicit cvmCtorAlphaDomain + +theorem cvmCtorAlphaFindInP : + cvmCtorPContext.lctx.find? cvmConstructorContext.freshFVarId = + some (.cdecl cvmConstructorContext.lctx.decls.size + cvmConstructorContext.freshFVarId `α cvmCtorAlphaDomain + .implicit .default) := + cvmCtorAlphaLocalRun.push_findOld `P .implicit cvmCtorPDomain + cvmCtorAlphaFindInAlpha + +theorem cvmCtorAlphaFindInX : + cvmCtorXContext.lctx.find? cvmConstructorContext.freshFVarId = + some (.cdecl cvmConstructorContext.lctx.decls.size + cvmConstructorContext.freshFVarId `α cvmCtorAlphaDomain + .implicit .default) := + cvmCtorPLocalRun.push_findOld `x .default cvmCtorXDomain + cvmCtorAlphaFindInP + +theorem cvmCtorAlphaFindInProof : + cvmCtorProofContext.lctx.find? cvmConstructorContext.freshFVarId = + some (.cdecl cvmConstructorContext.lctx.decls.size + cvmConstructorContext.freshFVarId `α cvmCtorAlphaDomain + .implicit .default) := + cvmCtorXLocalRun.push_findOld `proof .default cvmCtorProofDomain + cvmCtorAlphaFindInX + +theorem cvmCtorAlphaFindInDirect : + cvmCtorDirectContext.lctx.find? cvmConstructorContext.freshFVarId = + some (.cdecl cvmConstructorContext.lctx.decls.size + cvmConstructorContext.freshFVarId `α cvmCtorAlphaDomain + .implicit .default) := + cvmCtorProofLocalRun.push_findOld `direct .default cvmCtorDirectDomain + cvmCtorAlphaFindInProof + +theorem cvmCtorAlphaFindInFunction : + cvmCtorFunctionContext.lctx.find? cvmConstructorContext.freshFVarId = + some (.cdecl cvmConstructorContext.lctx.decls.size + cvmConstructorContext.freshFVarId `α cvmCtorAlphaDomain + .implicit .default) := + cvmCtorDirectLocalRun.push_findOld `function .default + cvmCtorFunctionDomain cvmCtorAlphaFindInDirect + +theorem cvmCtorPFindInP : + cvmCtorPContext.lctx.find? cvmCtorAlphaContext.freshFVarId = + some (.cdecl cvmCtorAlphaContext.lctx.decls.size + cvmCtorAlphaContext.freshFVarId `P cvmCtorPDomain + .implicit .default) := + cvmCtorAlphaLocalRun.push_findNew `P .implicit cvmCtorPDomain + +theorem cvmCtorPFindInX : + cvmCtorXContext.lctx.find? cvmCtorAlphaContext.freshFVarId = + some (.cdecl cvmCtorAlphaContext.lctx.decls.size + cvmCtorAlphaContext.freshFVarId `P cvmCtorPDomain + .implicit .default) := + cvmCtorPLocalRun.push_findOld `x .default cvmCtorXDomain + cvmCtorPFindInP + +theorem cvmCtorPFindInProof : + cvmCtorProofContext.lctx.find? cvmCtorAlphaContext.freshFVarId = + some (.cdecl cvmCtorAlphaContext.lctx.decls.size + cvmCtorAlphaContext.freshFVarId `P cvmCtorPDomain + .implicit .default) := + cvmCtorXLocalRun.push_findOld `proof .default cvmCtorProofDomain + cvmCtorPFindInX + +theorem cvmCtorPFindInDirect : + cvmCtorDirectContext.lctx.find? cvmCtorAlphaContext.freshFVarId = + some (.cdecl cvmCtorAlphaContext.lctx.decls.size + cvmCtorAlphaContext.freshFVarId `P cvmCtorPDomain + .implicit .default) := + cvmCtorProofLocalRun.push_findOld `direct .default cvmCtorDirectDomain + cvmCtorPFindInProof + +theorem cvmCtorPFindInFunction : + cvmCtorFunctionContext.lctx.find? cvmCtorAlphaContext.freshFVarId = + some (.cdecl cvmCtorAlphaContext.lctx.decls.size + cvmCtorAlphaContext.freshFVarId `P cvmCtorPDomain + .implicit .default) := + cvmCtorDirectLocalRun.push_findOld `function .default + cvmCtorFunctionDomain cvmCtorPFindInDirect + +theorem cvmCtorPFindInLater : + cvmCtorLaterContext.lctx.find? cvmCtorAlphaContext.freshFVarId = + some (.cdecl cvmCtorAlphaContext.lctx.decls.size + cvmCtorAlphaContext.freshFVarId `P cvmCtorPDomain + .implicit .default) := + cvmCtorFunctionLocalRun.push_findOld `later .default cvmCtorLaterDomain + cvmCtorPFindInFunction + +theorem cvmCtorFamilyLookup : + cvmConstructorContext.env.find? + constructorValidityMatrixKernelType.name = + some cvmDeclaredInfo := by + change cvmExecution.familyEnv.constants.find?' + constructorValidityMatrixKernelType.name = some cvmDeclaredInfo + rw [show cvmExecution.familyEnv.constants = + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.env.constants.insert + constructorValidityMatrixType.name cvmDeclaredInfo from cvmFamilyMap_add] + have hbase : + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.env.constants.WF := by + rw [cvmTerminalEnv_eq] + exact SMap.WF.empty + have hfresh : + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.env.constants.find? + constructorValidityMatrixType.name = none := by + rw [cvmTerminalEnv_eq] + change ({} : ConstMap).find? constructorValidityMatrixType.name = none + rw [SMap.WF.find?_eq SMap.WF.empty] + simp [SMap.toList'] + have hinsert := hbase.insert constructorValidityMatrixType.name + cvmDeclaredInfo hfresh + rw [SMap.WF.find?'_eq_find? hinsert] + rw [hbase.find?_insert] + simp [cvmFamilyNames_eq] + +theorem cvmCtorFamilyWhnf + (context : AddInductive.Context) + (arg1 arg2 : FVarId) + (henv : context.env = cvmConstructorContext.env) + (hdepth : context.fuel.recDepth = 10000) + (hwhnf : context.fuel.whnf = 100000) + (hquot : context.env.quotInit = false) : + AddInductive.CandidateWhnfStep.Valid + ⟨context, + .app + (.app (.const ``ConstructorValidityMatrix [.param `u]) + (.fvar arg1)) + (.fvar arg2), + .app + (.app (.const ``ConstructorValidityMatrix [.param `u]) + (.fvar arg1)) + (.fvar arg2)⟩ := by + apply TypeChecker.candidateWhnfConstFVarFVar_refl context + ``ConstructorValidityMatrix [.param `u] arg1 arg2 + (AddInductive.singletonDeclaredInfo + cvmFamilyValidationRun.stats 2 0 constructorValidityMatrixKernelType + 0 false + cvmCandidate.families.singleton.familyType.type.trace.terminalContext) + · exact hdepth + · exact hwhnf + · exact hquot + · rw [henv] + simpa [cvmDeclaredInfo, constructorValidityMatrixKernelType, + constructorValidityMatrixInfo, ConstantInfo.name, + ConstantInfo.toConstantVal] using cvmCtorFamilyLookup + · rfl + +def cvmCtorFamilyApp : Expr := + .app + (.app (.const ``ConstructorValidityMatrix [.param `u]) + cvmConstructorContext.freshExpr) + cvmCtorAlphaContext.freshExpr + +macro "simp_cvm_ctor_expr" : tactic => + `(tactic| simp [cvmCtorTerminal, cvmCtorLaterProofContext, + cvmCtorPArgContext, cvmCtorFunctionArgContext, + cvmCtorLaterProofDomain, cvmCtorAfterLater, cvmCtorLaterContext, + cvmCtorLaterDomain, cvmCtorAfterFunction, cvmCtorFunctionContext, + cvmCtorFunctionDomain, cvmCtorAfterDirect, cvmCtorDirectContext, + cvmCtorDirectDomain, cvmCtorAfterProof, cvmCtorProofContext, + cvmCtorProofDomain, cvmCtorAfterX, cvmCtorXContext, + cvmCtorXDomain, cvmCtorAfterP, cvmCtorPContext, cvmCtorPDomain, + cvmCtorAfterAlpha, cvmCtorAlphaContext, cvmCtorAlphaDomain, + cvmCtorFamilyApp, cvmConstructorContext, + constructorValidityMatrixKernelCtor, + constructorValidityMatrixKernelType, + constructorValidityMatrixMkInfo, constructorValidityMatrixInfo, + ConstantInfo.type, ConstantInfo.toConstantVal, + AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, + Expr.bindingDomain!, Expr.bindingBody!, Expr.bindingName!, + Expr.bindingInfo!, Expr.isForall, + Expr.instantiate1_eq, Expr.instantiate1', + Expr.liftLooseBVars_zero, + AddInductive.CandidateTypeAnnotationTrace.build]) + +macro "simpa_cvm_ctor_expr" " using " t:term : tactic => + `(tactic| simpa [cvmCtorTerminal, cvmCtorLaterProofContext, + cvmCtorPArgContext, cvmCtorFunctionArgContext, + cvmCtorLaterProofDomain, cvmCtorAfterLater, cvmCtorLaterContext, + cvmCtorLaterDomain, cvmCtorAfterFunction, cvmCtorFunctionContext, + cvmCtorFunctionDomain, cvmCtorAfterDirect, cvmCtorDirectContext, + cvmCtorDirectDomain, cvmCtorAfterProof, cvmCtorProofContext, + cvmCtorProofDomain, cvmCtorAfterX, cvmCtorXContext, + cvmCtorXDomain, cvmCtorAfterP, cvmCtorPContext, cvmCtorPDomain, + cvmCtorAfterAlpha, cvmCtorAlphaContext, cvmCtorAlphaDomain, + cvmCtorFamilyApp, cvmConstructorContext, + constructorValidityMatrixKernelCtor, + constructorValidityMatrixKernelType, + constructorValidityMatrixMkInfo, constructorValidityMatrixInfo, + ConstantInfo.type, ConstantInfo.toConstantVal, + AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, + Expr.bindingDomain!, Expr.bindingBody!, Expr.bindingName!, + Expr.bindingInfo!, Expr.isForall, + Expr.instantiate1_eq, Expr.instantiate1', + Expr.liftLooseBVars_zero, + AddInductive.CandidateTypeAnnotationTrace.build] using $t) + + +theorem cvmCtorQuotInit : + cvmConstructorContext.env.quotInit = false := by + rw [cvmFamilyStage.quotInit_eq] + rfl + +theorem cvmCtorFamilyAppWhnf + (context : AddInductive.Context) + (henv : context.env = cvmConstructorContext.env) + (hdepth : context.fuel.recDepth = 10000) + (hwhnf : context.fuel.whnf = 100000) : + AddInductive.CandidateWhnfStep.Valid + ⟨context, cvmCtorFamilyApp, cvmCtorFamilyApp⟩ := by + have hquot : context.env.quotInit = false := by + rw [henv] + exact cvmCtorQuotInit + simpa [cvmCtorFamilyApp, AddInductive.Context.freshExpr, + constructorValidityMatrixKernelType, + constructorValidityMatrixInfo, ConstantInfo.name] using + cvmCtorFamilyWhnf context cvmConstructorContext.freshFVarId + cvmCtorAlphaContext.freshFVarId henv hdepth hwhnf hquot + +open TypeChecker in +def cvmCtorIdentityShape : + CandidateExprIdentityReplay.Shaped cvmConstructorContext + constructorValidityMatrixKernelCtor.type 8 cvmCtorFamilyApp := by + have alphaInAlpha : AddInductive.CandidateWhnfStep.Valid + ⟨cvmCtorAlphaContext, cvmConstructorContext.freshExpr, + cvmConstructorContext.freshExpr⟩ := by + simpa [cvmCtorAlphaContext, cvmCtorAlphaDomain] using + TypeChecker.candidateWhnfPushedFVar_refl + cvmConstructorContext `α cvmCtorAlphaDomain .implicit 9999 + (by rfl) cvmCtorRootLocalRun.wf cvmCtorRootLocalRun.fresh + have alphaInP : AddInductive.CandidateWhnfStep.Valid + ⟨cvmCtorPContext, cvmConstructorContext.freshExpr, + cvmConstructorContext.freshExpr⟩ := by + apply TypeChecker.candidateWhnfFVar_refl _ _ 9999 + · rfl + · unfold TypeChecker.Inner.isLetFVar + rw [cvmCtorAlphaFindInP] + have alphaInDirect : AddInductive.CandidateWhnfStep.Valid + ⟨cvmCtorDirectContext, cvmConstructorContext.freshExpr, + cvmConstructorContext.freshExpr⟩ := by + apply TypeChecker.candidateWhnfFVar_refl _ _ 9999 + · rfl + · unfold TypeChecker.Inner.isLetFVar + rw [cvmCtorAlphaFindInDirect] + have alphaInFunction : AddInductive.CandidateWhnfStep.Valid + ⟨cvmCtorFunctionContext, cvmConstructorContext.freshExpr, + cvmConstructorContext.freshExpr⟩ := by + apply TypeChecker.candidateWhnfFVar_refl _ _ 9999 + · rfl + · unfold TypeChecker.Inner.isLetFVar + rw [cvmCtorAlphaFindInFunction] + have proofDomainWhnf : AddInductive.CandidateWhnfStep.Valid + ⟨cvmCtorXContext, cvmCtorProofDomain, + cvmCtorProofDomain⟩ := by + have run := TypeChecker.candidateWhnfFVarAppFVar_refl + cvmCtorXContext cvmCtorAlphaContext.freshFVarId + cvmCtorPContext.freshFVarId (by rfl) (by rfl) + (by + change cvmConstructorContext.env.quotInit = false + exact cvmCtorQuotInit) (by + unfold TypeChecker.Inner.isLetFVar + rw [cvmCtorPFindInX]) + rw [show cvmCtorProofDomain = + .app cvmCtorAlphaContext.freshExpr cvmCtorPContext.freshExpr by + simp_cvm_ctor_expr] + exact run + have laterProofDomainWhnf : AddInductive.CandidateWhnfStep.Valid + ⟨cvmCtorLaterContext, cvmCtorLaterProofDomain, + cvmCtorLaterProofDomain⟩ := by + have run := TypeChecker.candidateWhnfFVarAppFVar_refl + cvmCtorLaterContext cvmCtorAlphaContext.freshFVarId + cvmCtorFunctionContext.freshFVarId (by rfl) (by rfl) + (by + change cvmConstructorContext.env.quotInit = false + exact cvmCtorQuotInit) (by + unfold TypeChecker.Inner.isLetFVar + rw [cvmCtorPFindInLater]) + rw [show cvmCtorLaterProofDomain = + .app cvmCtorAlphaContext.freshExpr + cvmCtorFunctionContext.freshExpr by simp_cvm_ctor_expr] + exact run + have terminalShape : CandidateExprIdentityReplay.Shaped + cvmCtorLaterProofContext cvmCtorTerminal 0 + cvmCtorFamilyApp := by + rw [show cvmCtorTerminal = cvmCtorFamilyApp by simp_cvm_ctor_expr] + exact .terminal _ _ + (cvmCtorFamilyAppWhnf _ rfl rfl rfl) rfl + have laterProofShape : CandidateExprIdentityReplay.Shaped + cvmCtorLaterContext cvmCtorAfterLater 1 + cvmCtorFamilyApp := by + apply CandidateExprIdentityReplay.Shaped.forallEBuiltOfSource + cvmCtorLaterContext cvmCtorAfterLater + · simp_cvm_ctor_expr + · apply CandidateExprIdentityReplay.Shaped.candidateWhnfForallSource_refl + _ _ 9999 (by rfl) + simp_cvm_ctor_expr + · rw [← AddInductive.CandidateTypeAnnotationTrace.build_consumed] + simp_cvm_ctor_expr + · simpa_cvm_ctor_expr using + ((CandidateExprIdentityReplay.Shaped.terminal _ _ + laterProofDomainWhnf (by simp_cvm_ctor_expr)).replay) + · simpa_cvm_ctor_expr using terminalShape + have laterShape : CandidateExprIdentityReplay.Shaped + cvmCtorFunctionContext cvmCtorAfterFunction 2 + cvmCtorFamilyApp := by + apply CandidateExprIdentityReplay.Shaped.forallEBuiltOfSource + cvmCtorFunctionContext cvmCtorAfterFunction + · simp_cvm_ctor_expr + · apply CandidateExprIdentityReplay.Shaped.candidateWhnfForallSource_refl + _ _ 9999 (by rfl) + simp_cvm_ctor_expr + · rw [← AddInductive.CandidateTypeAnnotationTrace.build_consumed] + simp_cvm_ctor_expr + · simpa_cvm_ctor_expr using + ((CandidateExprIdentityReplay.Shaped.terminal _ _ + alphaInFunction rfl).replay) + · simpa_cvm_ctor_expr using laterProofShape + have functionArgTerminal : CandidateExprIdentityReplay.Shaped + cvmCtorFunctionArgContext cvmCtorFamilyApp 0 + cvmCtorFamilyApp := + .terminal _ _ (cvmCtorFamilyAppWhnf _ rfl rfl rfl) rfl + have functionDomainShape : CandidateExprIdentityReplay.Shaped + cvmCtorDirectContext cvmCtorFunctionDomain 1 + cvmCtorFamilyApp := by + apply CandidateExprIdentityReplay.Shaped.forallEBuiltOfSource + cvmCtorDirectContext cvmCtorFunctionDomain + · simp_cvm_ctor_expr + · apply CandidateExprIdentityReplay.Shaped.candidateWhnfForallSource_refl + _ _ 9999 (by rfl) + simp_cvm_ctor_expr + · rw [← AddInductive.CandidateTypeAnnotationTrace.build_consumed] + simp_cvm_ctor_expr + · simpa_cvm_ctor_expr using + ((CandidateExprIdentityReplay.Shaped.terminal _ _ + alphaInDirect rfl).replay) + · simpa_cvm_ctor_expr using functionArgTerminal + have functionShape : CandidateExprIdentityReplay.Shaped + cvmCtorDirectContext cvmCtorAfterDirect 3 + cvmCtorFamilyApp := by + apply CandidateExprIdentityReplay.Shaped.forallEBuiltOfSource + cvmCtorDirectContext cvmCtorAfterDirect + · simp_cvm_ctor_expr + · apply CandidateExprIdentityReplay.Shaped.candidateWhnfForallSource_refl + _ _ 9999 (by rfl) + simp_cvm_ctor_expr + · rw [← AddInductive.CandidateTypeAnnotationTrace.build_consumed] + simp_cvm_ctor_expr + · simpa_cvm_ctor_expr using functionDomainShape.replay + · simpa_cvm_ctor_expr using laterShape + have directDomainShape : CandidateExprIdentityReplay.Shaped + cvmCtorProofContext cvmCtorDirectDomain 0 + cvmCtorFamilyApp := by + rw [show cvmCtorDirectDomain = cvmCtorFamilyApp by simp_cvm_ctor_expr] + exact .terminal _ _ (cvmCtorFamilyAppWhnf _ rfl rfl rfl) rfl + have directShape : CandidateExprIdentityReplay.Shaped + cvmCtorProofContext cvmCtorAfterProof 4 + cvmCtorFamilyApp := by + apply CandidateExprIdentityReplay.Shaped.forallEBuiltOfSource + cvmCtorProofContext cvmCtorAfterProof + · simp_cvm_ctor_expr + · apply CandidateExprIdentityReplay.Shaped.candidateWhnfForallSource_refl + _ _ 9999 (by rfl) + simp_cvm_ctor_expr + · have consumeDirect : AddInductive.consumeTypeAnnotations + cvmCtorDirectDomain = cvmCtorDirectDomain := by + rw [show cvmCtorDirectDomain = cvmCtorFamilyApp by simp_cvm_ctor_expr] + simpa [cvmCtorFamilyApp, + AddInductive.CandidateTypeAnnotationTrace.build] using + (AddInductive.CandidateTypeAnnotationTrace.build_consumed + cvmCtorFamilyApp).symm + simpa only [cvmCtorDirectDomain] using consumeDirect + · simpa_cvm_ctor_expr using directDomainShape.replay + · simpa_cvm_ctor_expr using functionShape + have proofShape : CandidateExprIdentityReplay.Shaped + cvmCtorXContext cvmCtorAfterX 5 cvmCtorFamilyApp := by + apply CandidateExprIdentityReplay.Shaped.forallEBuiltOfSource + cvmCtorXContext cvmCtorAfterX + · simp_cvm_ctor_expr + · apply CandidateExprIdentityReplay.Shaped.candidateWhnfForallSource_refl + _ _ 9999 (by rfl) + simp_cvm_ctor_expr + · rw [← AddInductive.CandidateTypeAnnotationTrace.build_consumed] + simp_cvm_ctor_expr + · simpa_cvm_ctor_expr using + ((CandidateExprIdentityReplay.Shaped.terminal _ _ + proofDomainWhnf (by simp_cvm_ctor_expr)).replay) + · simpa_cvm_ctor_expr using directShape + have xShape : CandidateExprIdentityReplay.Shaped + cvmCtorPContext cvmCtorAfterP 6 cvmCtorFamilyApp := by + apply CandidateExprIdentityReplay.Shaped.forallEBuiltOfSource + cvmCtorPContext cvmCtorAfterP + · simp_cvm_ctor_expr + · apply CandidateExprIdentityReplay.Shaped.candidateWhnfForallSource_refl + _ _ 9999 (by rfl) + simp_cvm_ctor_expr + · rw [← AddInductive.CandidateTypeAnnotationTrace.build_consumed] + simp_cvm_ctor_expr + · simpa_cvm_ctor_expr using + ((CandidateExprIdentityReplay.Shaped.terminal _ _ alphaInP rfl).replay) + · simpa_cvm_ctor_expr using proofShape + have pArgTerminal : CandidateExprIdentityReplay.Shaped + cvmCtorPArgContext (.sort .zero) 0 (.sort .zero) := + .terminal _ _ (by rfl) rfl + have pDomainShape : CandidateExprIdentityReplay.Shaped + cvmCtorAlphaContext cvmCtorPDomain 1 (.sort .zero) := by + apply CandidateExprIdentityReplay.Shaped.forallEBuiltOfSource + cvmCtorAlphaContext cvmCtorPDomain + · simp_cvm_ctor_expr + · apply CandidateExprIdentityReplay.Shaped.candidateWhnfForallSource_refl + _ _ 9999 (by rfl) + simp_cvm_ctor_expr + · rw [← AddInductive.CandidateTypeAnnotationTrace.build_consumed] + simp_cvm_ctor_expr + · simpa_cvm_ctor_expr using + ((CandidateExprIdentityReplay.Shaped.terminal _ _ + alphaInAlpha rfl).replay) + · simpa_cvm_ctor_expr using pArgTerminal + have pShape : CandidateExprIdentityReplay.Shaped + cvmCtorAlphaContext cvmCtorAfterAlpha 7 + cvmCtorFamilyApp := by + apply CandidateExprIdentityReplay.Shaped.forallEBuiltOfSource + cvmCtorAlphaContext cvmCtorAfterAlpha + · simp_cvm_ctor_expr + · apply CandidateExprIdentityReplay.Shaped.candidateWhnfForallSource_refl + _ _ 9999 (by rfl) + simp_cvm_ctor_expr + · rw [← AddInductive.CandidateTypeAnnotationTrace.build_consumed] + simp_cvm_ctor_expr + · simpa_cvm_ctor_expr using pDomainShape.replay + · simpa_cvm_ctor_expr using xShape + apply CandidateExprIdentityReplay.Shaped.forallEBuiltOfSource + cvmConstructorContext constructorValidityMatrixKernelCtor.type + · simp_cvm_ctor_expr + · apply CandidateExprIdentityReplay.Shaped.candidateWhnfForallSource_refl + _ _ 9999 (by rfl) + simp_cvm_ctor_expr + · rw [← AddInductive.CandidateTypeAnnotationTrace.build_consumed] + simp_cvm_ctor_expr + · have alphaDomainWhnf : AddInductive.CandidateWhnfStep.Valid + ⟨cvmConstructorContext, cvmCtorAlphaDomain, + cvmCtorAlphaDomain⟩ := by + change AddInductive.CandidateWhnfStep.Valid + ⟨cvmConstructorContext, .sort (.succ (.param `u)), + .sort (.succ (.param `u))⟩ + rfl + exact (CandidateExprIdentityReplay.Shaped.terminal _ _ + alphaDomainWhnf rfl).replay + · simpa_cvm_ctor_expr using pShape + +theorem cvmCtorCandidateBuild : + AddInductive.buildCandidateExpr constructorValidityMatrixKernelCtor.type + cvmConstructorContext = + .ok cvmCandidate.families.singleton.constructors.singleton.type := by + have produced := cvmExecution.families.produced.singleton_constructors + rw [AddInductive.CandidateList.singleton_eta + cvmExecution.families.candidates.singleton.constructors] at produced + have exactProduced : AddInductive.CandidateConstructorListProduced + cvmConstructorContext + (.cons cvmCandidate.families.singleton.constructors.singleton .nil) := by + simpa [cvmCandidate, + AddInductive.NormalizationCandidateExecution.candidate, + cvmConstructorContext, constructorValidityMatrixKernelType] using produced + exact exactProduced.singleton_build + +def cvmCtorIdentityReplay : + TypeChecker.CandidateExprIdentityReplay cvmConstructorContext + constructorValidityMatrixKernelCtor.type := + cvmCtorIdentityShape.replay + +def cvmCtorIdentityEvidence : + TypeChecker.CandidateExprIdentityReplay.Evidence + cvmCtorIdentityReplay + cvmCandidate.families.singleton.constructors.singleton.type.trace := + cvmCtorIdentityReplay.evidence_of_build cvmCtorCandidateBuild + +theorem cvmCtorIdentityReplay_shape : + cvmCtorIdentityReplay.spineLength = 8 ∧ + cvmCtorIdentityReplay.terminalSource = cvmCtorFamilyApp := + ⟨cvmCtorIdentityShape.spineLength_eq, + cvmCtorIdentityShape.terminalSource_eq⟩ + +theorem cvmTypeEnv_ordered : cvmTypeEnv.Ordered := + .const (n := constructorValidityMatrixType.name) + (ci := constructorValidityMatrixType.toVConstant) + .empty cvmRawFamily_isType cvmTypeEnv_add + +theorem cvmRawCtor_isType : + cvmTypeEnv.IsType 1 [] constructorValidityMatrixType.ctors[0].type := by + have hFamily : cvmTypeEnv.constants constructorValidityMatrixType.name = + some constructorValidityMatrixType.toVConstant := + VEnv.addConst_self cvmTypeEnv_add + exact ⟨_, by type_tac⟩ + +theorem cvmCtorSource_tr : + TrExprS cvmTypeEnv [`u] [] constructorValidityMatrixKernelCtor.type + constructorValidityMatrixType.ctors[0].type := by + have shape : TrTypeExpr cvmTypeEnv [`u] [] + constructorValidityMatrixKernelCtor.type + constructorValidityMatrixType.ctors[0].type := by + tr_type_expr_tac + obtain ⟨level, type⟩ := cvmRawCtor_isType + exact shape.to_trExprS cvmTypeEnv_ordered trivial ⟨.sort level, type⟩ + +theorem cvmCtorNames_eq : + constructorValidityMatrixKernelCtor.name = + constructorValidityMatrixType.ctors[0].name := by + decide + +theorem cvmCtorWhnfDepth : + cvmCandidate.families.singleton.constructors.singleton.type.context.fuel.recDepth = + 9999 + 1 := by + rw [cvmConstructorCandidateContext_eq] + rfl + +theorem cvmRawCtors_eq : + constructorValidityMatrixType.ctors = + [constructorValidityMatrixType.ctors[0]] := by + rfl + +def cvmCtorStagedInput : + VInductDecl.CandidateConstructorStagedInput + cvmFamilyStage.postFamily + cvmCandidate.families.singleton.constructors.singleton + constructorValidityMatrixType.ctors[0] where + name_eq := cvmCtorNames_eq + uvars_eq := rfl + type := { + context_eq := cvmConstructorCandidateContext_eq.symm + source_tr := cvmCtorSource_tr + whnfFuel := 9999 + whnfDepth := cvmCtorWhnfDepth } + +def cvmConstructorsStage : + VInductDecl.CandidateConstructorStagedListInput + cvmFamilyStage.postFamily + cvmCandidate.families.singleton.constructors + constructorValidityMatrixType.ctors := by + rw [AddInductive.CandidateList.singleton_eta + cvmCandidate.families.singleton.constructors, cvmRawCtors_eq] + exact .cons cvmCtorStagedInput .nil + +theorem cvmFamilyTypesProduced : + AddInductive.CandidateFamilyTypeListProduced cvmFamilyContext + (.cons cvmCandidate.families.singleton.familyType .nil) := by + have h := cvmExecution.familyTypes.produced + rw [AddInductive.CandidateList.singleton_eta + cvmExecution.familyTypes.candidates] at h + rw [← cvmExecution.families.produced.singleton_familyType] at h + simpa [cvmCandidate, cvmFamilyContext, + AddInductive.NormalizationCandidateExecution.candidate] using h + +theorem cvmFamiliesProduced : + AddInductive.CandidateFamilyListProduced cvmConstructorContext + (.cons cvmCandidate.families.singleton.familyType .nil) + cvmCandidate.families := by + simpa [cvmCandidate, cvmConstructorContext, + AddInductive.NormalizationCandidateExecution.candidate] using + cvmExecution.families.produced.singleton_reindex + +theorem cvmCheckConstructorsRun : + AddInductive.checkConstructors #[constructorValidityMatrixKernelType] + cvmFamilyValidationRun.stats false + { cvmCandidate.families.singleton.familyType.type.trace.terminalContext with + env := cvmConstructorContext.env } = .ok () := by + have h := cvmExecution.constructorRun + rw [cvmExecutionStats_eq, cvmExecutionValidationContext_eq] at h + simpa [cvmConstructorContext] using h + +/- The CVM D2--D4 stages are reconstructed structurally after the shared +PRB replay helpers below. -/ + +def prbExecutionResult := + AddInductive.buildNormalizationCandidateExecution 1 + [propRecursiveBoundaryKernelType] 0 false + propRecursiveBoundaryContext + +theorem prbExecutionResult_isOk : prbExecutionResult.isOk = true := by + native_decide + +def prbProducedExecution : + { execution // prbExecutionResult = .ok execution } := + match h : prbExecutionResult with + | .ok execution => ⟨execution, rfl⟩ + | .error _ => by + have hOk := prbExecutionResult_isOk + rw [h] at hOk + contradiction + +def prbExecution := prbProducedExecution.val + +def prbCandidate := prbExecution.candidate + +open TypeChecker in +def prbFamilyIdentityShape : + CandidateExprIdentityReplay.Shaped propRecursiveBoundaryContext + propRecursiveBoundaryKernelType.type 2 (.sort .zero) := by + let aName := propRecursiveBoundaryKernelType.type.bindingBody!.bindingName! + change CandidateExprIdentityReplay.Shaped propRecursiveBoundaryContext + (.forallE `α (.sort (.succ (.param `u))) + (.forallE aName (.bvar 0) (.sort .zero) .default) .default) + 2 (.sort .zero) + let alphaContext := propRecursiveBoundaryContext.pushLocalDecl + `α .default (.sort (.succ (.param `u))) + let alphaAnnotations := AddInductive.builtCandidateTypeAnnotations + (Expr.sort (.succ (.param `u))) + refine .forallE (expectedSpineLength := 1) + propRecursiveBoundaryContext `α + (.sort (.succ (.param `u))) + (.forallE aName (.bvar 0) (.sort .zero) .default) .default + (by rfl) alphaAnnotations + (AddInductive.buildCandidateTypeAnnotations_built _) (by + simpa [AddInductive.CandidateTypeAnnotationTrace.build] using + (AddInductive.CandidateTypeAnnotationTrace.build_consumed + (.sort (.succ (.param `u)))).symm) + (.terminal _ _ (by rfl) rfl) ?_ + have alphaFVarWhnf : AddInductive.CandidateWhnfStep.Valid + ⟨alphaContext, propRecursiveBoundaryContext.freshExpr, + propRecursiveBoundaryContext.freshExpr⟩ := by + simpa [alphaContext] using + TypeChecker.candidateWhnfPushedFVar_refl + propRecursiveBoundaryContext `α + (.sort (.succ (.param `u))) .default 9999 (by rfl) + (by + change LocalContext.WF ⟨.empty, .empty, .empty⟩ + exact LocalContext.WF.nil) + (by + change (⟨.empty, .empty, .empty⟩ : LocalContext).find? + propRecursiveBoundaryContext.freshFVarId = none + exact TypeChecker.emptyLocalContextFindNone _) + have alphaBody : CandidateExprIdentityReplay.Shaped alphaContext + (.forallE aName propRecursiveBoundaryContext.freshExpr + (.sort .zero) .default) 1 (.sort .zero) := by + let aAnnotations := AddInductive.builtCandidateTypeAnnotations + propRecursiveBoundaryContext.freshExpr + refine .forallE (expectedSpineLength := 0) alphaContext aName + propRecursiveBoundaryContext.freshExpr (.sort .zero) .default + (by rfl) aAnnotations + (AddInductive.buildCandidateTypeAnnotations_built _) (by + simpa [AddInductive.Context.freshExpr, + AddInductive.CandidateTypeAnnotationTrace.build] using + (AddInductive.CandidateTypeAnnotationTrace.build_consumed + propRecursiveBoundaryContext.freshExpr).symm) + (.terminal _ _ alphaFVarWhnf rfl) ?_ + have terminal : CandidateExprIdentityReplay.Shaped + (alphaContext.pushLocalDecl aName .default + propRecursiveBoundaryContext.freshExpr) + (.sort .zero) 0 (.sort .zero) := + .terminal _ _ (by rfl) rfl + simpa [aAnnotations, AddInductive.builtCandidateTypeAnnotations, + AddInductive.CandidateTypeAnnotationTrace.build, + AddInductive.Context.freshExpr, + Expr.instantiate1_eq, Expr.instantiate1'] using terminal + simpa [alphaContext, alphaAnnotations, + AddInductive.builtCandidateTypeAnnotations, + AddInductive.CandidateTypeAnnotationTrace.build, + Expr.instantiate1_eq, Expr.instantiate1'] using alphaBody + +def prbFamilyIdentityReplay : + TypeChecker.CandidateExprIdentityReplay propRecursiveBoundaryContext + propRecursiveBoundaryKernelType.type := + prbFamilyIdentityShape.replay + +theorem prbFamilyCandidateBuild : + AddInductive.buildCandidateExpr propRecursiveBoundaryKernelType.type + propRecursiveBoundaryContext = + .ok prbCandidate.families.singleton.familyType.type := by + have produced := prbExecution.familyTypes.produced + rw [AddInductive.CandidateList.singleton_eta + prbExecution.familyTypes.candidates] at produced + rw [← prbExecution.families.produced.singleton_familyType] at produced + have exactProduced : AddInductive.CandidateFamilyTypeListProduced + propRecursiveBoundaryContext + (.cons prbCandidate.families.singleton.familyType .nil) := by + simpa [prbCandidate, + AddInductive.NormalizationCandidateExecution.candidate, + propRecursiveBoundaryContext] using produced + exact exactProduced.singleton_build + +def prbFamilyIdentityEvidence : + TypeChecker.CandidateExprIdentityReplay.Evidence + prbFamilyIdentityReplay + prbCandidate.families.singleton.familyType.type.trace := + prbFamilyIdentityReplay.evidence_of_build prbFamilyCandidateBuild + +theorem prbFamilyIdentityReplay_shape : + prbFamilyIdentityReplay.spineLength = 2 ∧ + prbFamilyIdentityReplay.terminalSource = .sort .zero := + ⟨prbFamilyIdentityShape.spineLength_eq, + prbFamilyIdentityShape.terminalSource_eq⟩ + +theorem prbFamilyValidationAnnotations : + prbCandidate.families.singleton.familyType.type.trace + |>.validationAnnotations := by + have h := prbExecution.familyTypes.produced + |>.singleton_validationAnnotations + rw [← prbExecution.families.produced.singleton_familyType] at h + simpa [prbCandidate, + AddInductive.NormalizationCandidateExecution.candidate] using h + +private theorem prbFamilyData_hasExprMVar_false : + propRecursiveBoundaryInfo.type.data.hasExprMVar = false := by + change propRecursiveBoundaryInfo.type.hasExprMVar = false + rw [Expr.hasExprMVar_eq] + rfl + +private theorem prbFamilyData_hasLevelMVar_false : + propRecursiveBoundaryInfo.type.data.hasLevelMVar = false := by + change propRecursiveBoundaryInfo.type.hasLevelMVar = false + rw [Expr.hasLevelMVar_eq] + simp [propRecursiveBoundaryInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, Expr.hasLevelMVar', + Level.hasMVar_eq, Level.hasMVar'] + +private theorem prbFamilyData_hasFVar_false : + propRecursiveBoundaryInfo.type.data.hasFVar = false := by + change propRecursiveBoundaryInfo.type.hasFVar = false + rw [Expr.hasFVar_eq] + rfl + +private theorem prbFamily_hasMVar_false : + propRecursiveBoundaryInfo.type.hasMVar = false := by + change (propRecursiveBoundaryInfo.type.data.hasExprMVar || + propRecursiveBoundaryInfo.type.data.hasLevelMVar) = false + rw [prbFamilyData_hasExprMVar_false, + prbFamilyData_hasLevelMVar_false] + rfl + +private theorem prbFamily_hasFVar_false : + propRecursiveBoundaryInfo.type.hasFVar = false := + prbFamilyData_hasFVar_false + +theorem prbFamilyClosed : + prbCandidate.families.singleton.familyType.type.context.env.checkNoMVarNoFVar + propRecursiveBoundaryKernelType.name + propRecursiveBoundaryKernelType.type = .ok () := by + unfold Kernel.Environment.checkNoMVarNoFVar + Kernel.Environment.checkNoMVar Kernel.Environment.checkNoFVar + rw [show propRecursiveBoundaryKernelType.type.hasMVar = false by + simpa [propRecursiveBoundaryKernelType] using + prbFamily_hasMVar_false] + rw [show propRecursiveBoundaryKernelType.type.hasFVar = false by + simpa [propRecursiveBoundaryKernelType] using + prbFamily_hasFVar_false] + rfl + +theorem prbFamilyEnsureSort : + TypeChecker.M.run + prbCandidate.families.singleton.familyType.type.trace.terminalContext.env + prbCandidate.families.singleton.familyType.type.trace.terminalContext.safety + prbCandidate.families.singleton.familyType.type.trace.terminalContext.lctx + prbCandidate.families.singleton.familyType.type.trace.terminalContext.lparams + prbCandidate.families.singleton.familyType.type.trace.terminalContext.fuel + (TypeChecker.ensureSort (.sort .zero)) = + .ok (.sort .zero) := by + rfl + +theorem prbFamilySpineCount : + 1 ≤ prbCandidate.families.singleton.familyType.type.trace.spineLength := by + rw [prbFamilyIdentityEvidence.spineLength_eq, + prbFamilyIdentityReplay_shape.1] + decide + +theorem prbFamilySpineFuel : + prbCandidate.families.singleton.familyType.type.trace.spineLength < + prbCandidate.families.singleton.familyType.type.context.fuel.inductiveFuel := by + have contextFuel := congrArg (fun context : AddInductive.Context => + context.fuel.inductiveFuel) + (AddInductive.CandidateExpr.context_eq_of_build prbFamilyCandidateBuild) + rw [contextFuel] + rw [prbFamilyIdentityEvidence.spineLength_eq, + prbFamilyIdentityReplay_shape.1] + decide + +def prbFamilyValidationRun : + AddInductive.CandidateExprTrace.FamilyValidationRun + propRecursiveBoundaryKernelType + prbCandidate.families.singleton.familyType.type.trace where + nparams := 1 + resultLevel := .zero + stats := + prbCandidate.families.singleton.familyType.type.trace + |>.singletonCandidateInductiveStats + propRecursiveBoundaryKernelType 1 .zero + stats_eq := rfl + terminal_eq := prbFamilyIdentityEvidence.terminalResult_eq.trans + prbFamilyIdentityReplay_shape.2 + run := fun k => + AddInductive.CandidateExprTrace.checkInductiveTypes_singleton_of_candidate + propRecursiveBoundaryKernelType + prbCandidate.families.singleton.familyType.type.trace + 1 .zero k + prbFamilyClosed prbFamilySpineCount prbFamilySpineFuel + prbFamilyValidationAnnotations + (prbFamilyIdentityEvidence.terminalResult_eq.trans + prbFamilyIdentityReplay_shape.2) + prbFamilyEnsureSort + +theorem prbFamilyContext_eq : + prbCandidate.families.singleton.familyType.type.context = + propRecursiveBoundaryContext := by + have h := prbExecution.familyTypes.produced.singleton_context_eq + rw [← prbExecution.families.produced.singleton_familyType] at h + simpa [prbCandidate, + AddInductive.NormalizationCandidateExecution.candidate, + propRecursiveBoundaryContext] using h + +theorem prbFamilyNparams_eq : prbFamilyValidationRun.nparams = 1 := by + rfl + +theorem prbFamilyValidationRun_exact : ∀ {alpha} + (k : AddInductive.InductiveStats → AddInductive.M alpha), + AddInductive.checkInductiveTypes 1 #[propRecursiveBoundaryKernelType] + k propRecursiveBoundaryContext = + k prbFamilyValidationRun.stats + prbCandidate.families.singleton.familyType.type.trace.terminalContext := by + intro alpha k + simpa only [prbFamilyNparams_eq, prbFamilyContext_eq] using + prbFamilyValidationRun.run k + +theorem prbAfterValidationRun : + AddInductive.buildNormalizationCandidateExecutionAfterValidation 1 + [propRecursiveBoundaryKernelType] 0 false + propRecursiveBoundaryContext prbFamilyValidationRun.stats + prbCandidate.families.singleton.familyType.type.trace.terminalContext = + .ok prbExecution := by + have h := prbProducedExecution.property + change AddInductive.buildNormalizationCandidateExecution 1 + [propRecursiveBoundaryKernelType] 0 false + propRecursiveBoundaryContext = .ok prbExecution at h + unfold AddInductive.buildNormalizationCandidateExecution at h + rw [prbFamilyValidationRun_exact] at h + exact h + +theorem prbExecutionStats_eq : + prbExecution.stats = prbFamilyValidationRun.stats := + (prbExecution.fields_of_afterValidation prbFamilyValidationRun.stats + prbCandidate.families.singleton.familyType.type.trace.terminalContext + prbAfterValidationRun).1 + +theorem prbExecutionValidationContext_eq : + prbExecution.validationContext = + prbCandidate.families.singleton.familyType.type.trace.terminalContext := + (prbExecution.fields_of_afterValidation prbFamilyValidationRun.stats + prbCandidate.families.singleton.familyType.type.trace.terminalContext + prbAfterValidationRun).2 + +theorem prbExecutionValidationRun : ∀ {alpha} + (k : AddInductive.InductiveStats → AddInductive.M alpha), + AddInductive.checkInductiveTypes 1 #[propRecursiveBoundaryKernelType] + k propRecursiveBoundaryContext = + k prbExecution.stats prbExecution.validationContext := by + intro alpha k + rw [prbFamilyValidationRun_exact, prbExecutionStats_eq, + prbExecutionValidationContext_eq] + +theorem prbCandidate_produced : + AddInductive.buildNormalizationCandidate 1 + [propRecursiveBoundaryKernelType] 0 false + propRecursiveBoundaryContext = .ok prbCandidate := + prbExecution.produces prbExecutionValidationRun + +def prbFamilyContext : AddInductive.Context := + { propRecursiveBoundaryContext with lctx := {} } + +def prbConstructorContext : AddInductive.Context := + { propRecursiveBoundaryContext with + env := prbExecution.familyEnv, lctx := {} } + +theorem prbFamilyCandidateContext_eq : + prbCandidate.families.singleton.familyType.type.context = + prbFamilyContext := by + simpa [prbFamilyContext, propRecursiveBoundaryContext] using + prbFamilyContext_eq + +theorem prbConstructorCandidateContext_eq : + prbCandidate.families.singleton.constructors.singleton.type.context = + prbConstructorContext := by + have h := prbExecution.families.produced.singleton_constructors + |>.singleton_context_eq + simpa [prbCandidate, + AddInductive.NormalizationCandidateExecution.candidate, + prbConstructorContext] using h + +/-- The retained singleton family spine selects exactly its first generated +local as the sole kernel parameter. This is derived from the structural +identity witness, not by evaluating the opaque outer producer again. -/ +theorem prbStatsParams_eq : + prbFamilyValidationRun.stats.params = + #[prbFamilyContext.freshExpr] := by + rw [prbFamilyValidationRun.stats_eq] + change + (prbCandidate.families.singleton.familyType.type.trace.parameterList 1).toArray = + #[prbFamilyContext.freshExpr] + have identity := prbFamilyIdentityEvidence.identity + have spineLength := prbFamilyIdentityEvidence.spineLength_eq + generalize htrace : + prbCandidate.families.singleton.familyType.type.trace = trace at identity spineLength ⊢ + cases identity with + | terminal result_eq => + simp only [AddInductive.CandidateExprTrace.spineLength] at spineLength + rw [prbFamilyIdentityReplay_shape.1] at spineLength + omega + | forallE domainCandidate bodyCandidate source_eq consumed_eq + domainIdentity bodyIdentity => + simp only [AddInductive.CandidateExprTrace.parameterList] + rw [prbFamilyCandidateContext_eq] + +theorem prbFamilyPrefix_ne : + prbFamilyContext.ngen.namePrefix ≠ + (({} : TypeChecker.VState).ngen).namePrefix := by + decide + +def prbFamilyContextRun : + TypeChecker.CandidateContextRun prbFamilyContext := + TypeChecker.CandidateContextRun.root prbEmptyVEnvsWF rfl + prbFamilyPrefix_ne + +def prbPreFamilyStage : + TypeChecker.CandidateSemanticStage prbFamilyContext VEnv.empty [`u] where + contextRun := prbFamilyContextRun + venv_eq := rfl + lparams_eq := rfl + vlctx_eq := rfl + +theorem prbRawFamily_isType : + VEnv.empty.IsType 1 [] propRecursiveBoundaryType.type := by + change VEnv.empty.IsType 1 [] + (.forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) (.sort .zero))) + apply VEnv.IsType.forallE + · exact ⟨_, VEnv.HasType.sort (by decide)⟩ + · apply VEnv.IsType.forallE + · exact ⟨_, by type_tac⟩ + · exact ⟨_, VEnv.HasType.sort (by decide)⟩ + +theorem prbFamilySource_tr : + TrExprS VEnv.empty [`u] [] propRecursiveBoundaryKernelType.type + propRecursiveBoundaryType.type := by + have shape : TrTypeExpr VEnv.empty [`u] [] + propRecursiveBoundaryKernelType.type + propRecursiveBoundaryType.type := by + tr_type_expr_tac + obtain ⟨level, type⟩ := prbRawFamily_isType + exact shape.to_trExprS .empty trivial ⟨.sort level, type⟩ + +theorem prbStatsNindices_eq : + prbFamilyValidationRun.stats.nindices = #[1] := by + rw [prbFamilyValidationRun.stats_eq] + change #[prbCandidate.families.singleton.familyType.type.trace.spineLength - + 1] = #[1] + rw [prbFamilyIdentityEvidence.spineLength_eq, + prbFamilyIdentityReplay_shape.1] + +theorem prbFamilyNames_eq : + propRecursiveBoundaryKernelType.name = + propRecursiveBoundaryType.name := by + decide + +theorem prbFamilyNameAbsent : + propRecursiveBoundaryContext.env.contains + propRecursiveBoundaryKernelType.name = false := by + change ({} : ConstMap).contains + propRecursiveBoundaryKernelType.name = false + rw [SMap.find?_isSome, + SMap.WF.find?_eq SMap.WF.empty] + simp [SMap.toList'] + +theorem prbFamilyNameNotPrimitive : + Kernel.Environment.primitives.contains + propRecursiveBoundaryKernelType.name = false := by + simp [propRecursiveBoundaryKernelType, + propRecursiveBoundaryInfo, Kernel.Environment.primitives, + NameSet.ofList] + simp +decide [NameSet.contains] + +def prbDeclaredInfo : ConstantInfo := + .inductInfo <| AddInductive.singletonDeclaredInfo + prbFamilyValidationRun.stats 1 1 propRecursiveBoundaryKernelType + 0 false + prbCandidate.families.singleton.familyType.type.trace.terminalContext + +theorem prbFamilyMap_add : + prbExecution.familyEnv.constants = + prbCandidate.families.singleton.familyType.type.trace.terminalContext.env.constants.insert + propRecursiveBoundaryType.name prbDeclaredInfo := by + have h := prbExecution.declareRun + rw [prbExecutionStats_eq, prbExecutionValidationContext_eq] at h + rw [← prbFamilyNames_eq] + simpa [prbDeclaredInfo] using + AddInductive.declareInductiveTypes_singleton_constants + prbFamilyValidationRun.stats 1 1 propRecursiveBoundaryKernelType + 0 false + prbCandidate.families.singleton.familyType.type.trace.terminalContext + prbExecution.familyEnv prbStatsNindices_eq h + +def prbTypeEnv : VEnv := + (VEnv.empty.addConst propRecursiveBoundaryType.name + propRecursiveBoundaryType.toVConstant).get! + +theorem prbTypeEnv_add : + VEnv.empty.addConst propRecursiveBoundaryType.name + propRecursiveBoundaryType.toVConstant = some prbTypeEnv := by + rfl + +theorem prbTerminalLparams_eq : + prbCandidate.families.singleton.familyType.type.trace.terminalContext.lparams = + propRecursiveBoundaryContext.lparams := by + calc + _ = prbCandidate.families.singleton.familyType.type.context.lparams := + prbCandidate.families.singleton.familyType.type.trace.terminalContext_lparams + _ = prbFamilyContext.lparams := + congrArg AddInductive.Context.lparams prbFamilyCandidateContext_eq + _ = propRecursiveBoundaryContext.lparams := rfl + +theorem prbTerminalEnv_eq : + prbCandidate.families.singleton.familyType.type.trace.terminalContext.env = + propRecursiveBoundaryContext.env := by + calc + _ = prbCandidate.families.singleton.familyType.type.context.env := + prbCandidate.families.singleton.familyType.type.trace.terminalContext_env + _ = prbFamilyContext.env := + congrArg AddInductive.Context.env prbFamilyCandidateContext_eq + _ = propRecursiveBoundaryContext.env := rfl + +theorem prbDeclaredInfo_tr : + TrConstVal .safe VEnv.empty prbDeclaredInfo + propRecursiveBoundaryType.toVConstVal := by + refine ⟨⟨by decide, ?_, ?_⟩, rfl⟩ + · change + prbCandidate.families.singleton.familyType.type.trace.terminalContext.lparams.length = + propRecursiveBoundaryType.uvars + rw [prbTerminalLparams_eq] + rfl + · change TrExprS VEnv.empty + prbCandidate.families.singleton.familyType.type.trace.terminalContext.lparams + [] propRecursiveBoundaryKernelType.type propRecursiveBoundaryType.type + rw [prbTerminalLparams_eq] + exact prbFamilySource_tr + +def prbAddType : + AddInductConstant .induct prbFamilyContext.env.constants VEnv.empty + propRecursiveBoundaryType.toVConstVal + prbConstructorContext.env.constants prbTypeEnv where + info := prbDeclaredInfo + kind_eq := by simp [prbDeclaredInfo, InductConstantKind.Matches] + tr := prbDeclaredInfo_tr + map_fresh := by + change ({} : ConstMap).find? + propRecursiveBoundaryType.name = none + rw [SMap.WF.find?_eq SMap.WF.empty] + simp [SMap.toList'] + env_add := prbTypeEnv_add + map_add := by + simpa [prbFamilyContext, prbConstructorContext, + prbTerminalEnv_eq] using prbFamilyMap_add + +theorem prbFamilyWhnfDepth : + prbCandidate.families.singleton.familyType.type.context.fuel.recDepth = + 9999 + 1 := by + rw [prbFamilyCandidateContext_eq] + rfl + +def prbFamilyStage : + VInductDecl.CandidateFamilyStagedInput + prbFamilyContext prbConstructorContext VEnv.empty [`u] + prbCandidate.families.singleton.familyType + propRecursiveBoundaryType prbPreFamilyStage where + name_eq := prbFamilyNames_eq + uvars_eq := rfl + type := { + context_eq := prbFamilyCandidateContext_eq.symm + source_tr := prbFamilySource_tr + whnfFuel := 9999 + whnfDepth := prbFamilyWhnfDepth } + validation := prbFamilyValidationRun + typeEnv := prbTypeEnv + addInduct := prbAddType + family_lctx_eq := rfl + constructorContext_eq := rfl + quotInit_eq := by + have h := prbExecution.declareRun + rw [prbExecutionStats_eq, prbExecutionValidationContext_eq] at h + simpa [prbConstructorContext, prbFamilyContext, + prbTerminalEnv_eq] using + AddInductive.declareInductiveTypes_singleton_quotInit + prbFamilyValidationRun.stats 1 1 propRecursiveBoundaryKernelType + 0 false + prbCandidate.families.singleton.familyType.type.trace.terminalContext + prbExecution.familyEnv prbStatsNindices_eq h + name_not_reflected := by decide + name_not_primitive := by + rw [← prbFamilyNames_eq] + exact prbFamilyNameNotPrimitive + +def prbCtorAlphaContext := prbConstructorContext.pushLocalDecl `α .implicit + (.sort (.succ (.param `u))) + +def prbCtorAContext := prbCtorAlphaContext.pushLocalDecl `a .default + prbConstructorContext.freshExpr + +def prbCtorNextDomain : Expr := + .forallE `b prbConstructorContext.freshExpr + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.bvar 0)) .default + +def prbCtorNextContext := prbCtorAContext.pushLocalDecl `next .default + prbCtorNextDomain + +def prbCtorBContext := prbCtorAContext.pushLocalDecl `b .default + prbConstructorContext.freshExpr + +theorem prbCtorFamilyLookup : + prbConstructorContext.env.find? + propRecursiveBoundaryKernelType.name = + some prbDeclaredInfo := by + change prbExecution.familyEnv.constants.find?' + propRecursiveBoundaryKernelType.name = some prbDeclaredInfo + rw [show prbExecution.familyEnv.constants = + prbCandidate.families.singleton.familyType.type.trace.terminalContext.env.constants.insert + propRecursiveBoundaryType.name prbDeclaredInfo from prbFamilyMap_add] + have hbase : + prbCandidate.families.singleton.familyType.type.trace.terminalContext.env.constants.WF := by + rw [prbTerminalEnv_eq] + exact SMap.WF.empty + have hfresh : + prbCandidate.families.singleton.familyType.type.trace.terminalContext.env.constants.find? + propRecursiveBoundaryType.name = none := by + rw [prbTerminalEnv_eq] + change ({} : ConstMap).find? propRecursiveBoundaryType.name = none + rw [SMap.WF.find?_eq SMap.WF.empty] + simp [SMap.toList'] + have hinsert := hbase.insert propRecursiveBoundaryType.name + prbDeclaredInfo hfresh + rw [SMap.WF.find?'_eq_find? hinsert] + rw [hbase.find?_insert] + simp [prbFamilyNames_eq] + +theorem prbCtorFamilyWhnf + (context : AddInductive.Context) + (arg1 arg2 : FVarId) + (henv : context.env = prbConstructorContext.env) + (hdepth : context.fuel.recDepth = 10000) + (hwhnf : context.fuel.whnf = 100000) + (hquot : context.env.quotInit = false) : + AddInductive.CandidateWhnfStep.Valid + ⟨context, + .app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar arg1)) + (.fvar arg2), + .app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar arg1)) + (.fvar arg2)⟩ := by + apply TypeChecker.candidateWhnfConstFVarFVar_refl context + propRecursiveBoundaryKernelType.name [.param `u] arg1 arg2 + (AddInductive.singletonDeclaredInfo + prbFamilyValidationRun.stats 1 1 propRecursiveBoundaryKernelType + 0 false + prbCandidate.families.singleton.familyType.type.trace.terminalContext) + · exact hdepth + · exact hwhnf + · exact hquot + · rw [henv] + simpa [prbDeclaredInfo] using prbCtorFamilyLookup + · rfl + +theorem prbCtorRootWF : prbConstructorContext.lctx.WF := by + change LocalContext.WF ⟨.empty, .empty, .empty⟩ + exact LocalContext.WF.nil + +theorem prbCtorRootFresh : + prbConstructorContext.lctx.find? + prbConstructorContext.freshFVarId = none := by + change (⟨.empty, .empty, .empty⟩ : LocalContext).find? + prbConstructorContext.freshFVarId = none + exact TypeChecker.emptyLocalContextFindNone _ + +theorem prbCtorAlphaContextWF : prbCtorAlphaContext.lctx.WF := by + simpa [prbCtorAlphaContext, AddInductive.Context.pushLocalDecl] using + (LocalContext.WF.mkLocalDecl prbCtorRootWF prbCtorRootFresh) + +theorem prbCtorAlphaContextFresh : + prbCtorAlphaContext.lctx.find? + prbCtorAlphaContext.freshFVarId = none := by + have h := LocalContext.WF.find?_eq_find?_toList + (fv := prbCtorAlphaContext.freshFVarId) prbCtorAlphaContextWF + rw [h] + simp only [prbCtorAlphaContext, prbConstructorContext, + propRecursiveBoundaryContext, AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshFVarId] + rw [LocalContext.mkLocalDecl_toList] + rw [show ({} : LocalContext).toList = [] by rfl] + simp [LocalDecl.fvarId, NameGenerator.next, NameGenerator.curr] + +theorem prbCtorAlphaFindInA : + prbCtorAContext.lctx.find? prbConstructorContext.freshFVarId = + some (.cdecl 0 prbConstructorContext.freshFVarId `α + (.sort (.succ (.param `u))) .implicit .default) := by + have hnew := TypeChecker.localContextFindNew + prbConstructorContext.lctx prbConstructorContext.freshFVarId + `α (.sort (.succ (.param `u))) .implicit .default + prbCtorRootWF prbCtorRootFresh + have hold := TypeChecker.localContextFindOld + prbCtorAlphaContext.lctx prbConstructorContext.freshFVarId + prbCtorAlphaContext.freshFVarId `a + prbConstructorContext.freshExpr .default .default + (.cdecl prbConstructorContext.lctx.decls.size + prbConstructorContext.freshFVarId `α + (.sort (.succ (.param `u))) .implicit .default) + prbCtorAlphaContextWF prbCtorAlphaContextFresh (by + simpa [prbCtorAlphaContext, AddInductive.Context.pushLocalDecl] + using hnew) + simpa [prbCtorAContext, prbCtorAlphaContext, + prbConstructorContext, propRecursiveBoundaryContext, + AddInductive.Context.pushLocalDecl] using hold + +open TypeChecker in +def prbCtorIdentityShape : + CandidateExprIdentityReplay.Shaped prbConstructorContext + propRecursiveBoundaryKernelCtor.type 3 + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.fvar prbCtorAlphaContext.freshFVarId)) := by + change CandidateExprIdentityReplay.Shaped prbConstructorContext + (.forallE `α (.sort (.succ (.param `u))) + (.forallE `a (.bvar 0) + (.forallE `next + (.forallE `b (.bvar 1) + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.bvar 2)) + (.bvar 0)) .default) + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.bvar 2)) + (.bvar 1)) .default) .default) .implicit) + 3 + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.fvar prbCtorAlphaContext.freshFVarId)) + have alphaInAlpha : AddInductive.CandidateWhnfStep.Valid + ⟨prbCtorAlphaContext, prbConstructorContext.freshExpr, + prbConstructorContext.freshExpr⟩ := by + simpa [prbCtorAlphaContext] using + TypeChecker.candidateWhnfPushedFVar_refl + prbConstructorContext `α (.sort (.succ (.param `u))) + .implicit 9999 (by rfl) prbCtorRootWF prbCtorRootFresh + have alphaInA : AddInductive.CandidateWhnfStep.Valid + ⟨prbCtorAContext, prbConstructorContext.freshExpr, + prbConstructorContext.freshExpr⟩ := by + apply TypeChecker.candidateWhnfFVar_refl _ _ 9999 + · rfl + · unfold TypeChecker.Inner.isLetFVar + rw [prbCtorAlphaFindInA] + have bBody : CandidateExprIdentityReplay.Shaped prbCtorBContext + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.fvar prbCtorAContext.freshFVarId)) + 0 + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.fvar prbCtorAContext.freshFVarId)) := + .terminal _ _ (prbCtorFamilyWhnf _ _ _ rfl rfl rfl (by + rw [show prbCtorBContext.env = prbConstructorContext.env by rfl] + rw [prbFamilyStage.quotInit_eq] + rfl)) rfl + have nextDomainShape : CandidateExprIdentityReplay.Shaped prbCtorAContext + prbCtorNextDomain 1 + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.fvar prbCtorAContext.freshFVarId)) := by + apply CandidateExprIdentityReplay.Shaped.forallEBuilt prbCtorAContext `b + prbConstructorContext.freshExpr + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.bvar 0)) .default (by rfl) + · simpa [AddInductive.Context.freshExpr, + AddInductive.CandidateTypeAnnotationTrace.build] using + (AddInductive.CandidateTypeAnnotationTrace.build_consumed + prbConstructorContext.freshExpr).symm + · exact (CandidateExprIdentityReplay.Shaped.terminal + _ _ alphaInA rfl).replay + · simpa [prbCtorBContext, prbCtorNextDomain, + AddInductive.Context.freshExpr, + Expr.instantiate1_eq, Expr.instantiate1'] using bBody + have resultShape : CandidateExprIdentityReplay.Shaped prbCtorNextContext + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.fvar prbCtorAlphaContext.freshFVarId)) + 0 + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.fvar prbCtorAlphaContext.freshFVarId)) := + .terminal _ _ (prbCtorFamilyWhnf _ _ _ rfl rfl rfl (by + rw [show prbCtorNextContext.env = prbConstructorContext.env by rfl] + rw [prbFamilyStage.quotInit_eq] + rfl)) rfl + have nextShape : CandidateExprIdentityReplay.Shaped prbCtorAContext + (.forallE `next prbCtorNextDomain + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.fvar prbCtorAlphaContext.freshFVarId)) .default) + 1 + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.fvar prbCtorAlphaContext.freshFVarId)) := by + apply CandidateExprIdentityReplay.Shaped.forallEBuilt + prbCtorAContext `next prbCtorNextDomain + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.fvar prbCtorAlphaContext.freshFVarId)) .default (by rfl) + · simpa [prbCtorNextDomain, + AddInductive.Context.freshExpr, + AddInductive.CandidateTypeAnnotationTrace.build] using + (AddInductive.CandidateTypeAnnotationTrace.build_consumed + prbCtorNextDomain).symm + · exact nextDomainShape.replay + · simpa [prbCtorNextContext, Expr.instantiate1_eq, + Expr.instantiate1'] using resultShape + have aShape : CandidateExprIdentityReplay.Shaped prbCtorAlphaContext + (.forallE `a prbConstructorContext.freshExpr + (.forallE `next + (.forallE `b prbConstructorContext.freshExpr + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.bvar 0)) .default) + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.bvar 1)) .default) .default) + 2 + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.fvar prbCtorAlphaContext.freshFVarId)) := by + apply CandidateExprIdentityReplay.Shaped.forallEBuilt + prbCtorAlphaContext `a + prbConstructorContext.freshExpr + (.forallE `next + (.forallE `b prbConstructorContext.freshExpr + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.bvar 0)) .default) + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.bvar 1)) .default) .default (by rfl) + · simpa [AddInductive.Context.freshExpr, + AddInductive.CandidateTypeAnnotationTrace.build] using + (AddInductive.CandidateTypeAnnotationTrace.build_consumed + prbConstructorContext.freshExpr).symm + · exact (CandidateExprIdentityReplay.Shaped.terminal + _ _ alphaInAlpha rfl).replay + · simpa [prbCtorAContext, prbCtorNextDomain, + AddInductive.Context.freshExpr, + Expr.instantiate1_eq, Expr.instantiate1', + Expr.liftLooseBVars_zero] using nextShape + apply CandidateExprIdentityReplay.Shaped.forallEBuilt + prbConstructorContext `α + (.sort (.succ (.param `u))) + (.forallE `a (.bvar 0) + (.forallE `next + (.forallE `b (.bvar 1) + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.bvar 2)) + (.bvar 0)) .default) + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.bvar 2)) + (.bvar 1)) .default) .default) .implicit (by rfl) + · simpa [AddInductive.CandidateTypeAnnotationTrace.build] using + (AddInductive.CandidateTypeAnnotationTrace.build_consumed + (.sort (.succ (.param `u)))).symm + · exact (CandidateExprIdentityReplay.Shaped.terminal + _ _ (by rfl) rfl).replay + · simpa [prbCtorAlphaContext, Expr.instantiate1_eq, + Expr.instantiate1', Expr.liftLooseBVars_zero, + AddInductive.Context.freshExpr] using aShape + +theorem prbCtorCandidateBuild : + AddInductive.buildCandidateExpr propRecursiveBoundaryKernelCtor.type + prbConstructorContext = + .ok prbCandidate.families.singleton.constructors.singleton.type := by + have produced := prbExecution.families.produced.singleton_constructors + rw [AddInductive.CandidateList.singleton_eta + prbExecution.families.candidates.singleton.constructors] at produced + have exactProduced : AddInductive.CandidateConstructorListProduced + prbConstructorContext + (.cons prbCandidate.families.singleton.constructors.singleton .nil) := by + simpa [prbCandidate, + AddInductive.NormalizationCandidateExecution.candidate, + prbConstructorContext, propRecursiveBoundaryKernelType] using produced + exact exactProduced.singleton_build + +def prbCtorIdentityReplay : + TypeChecker.CandidateExprIdentityReplay prbConstructorContext + propRecursiveBoundaryKernelCtor.type := + prbCtorIdentityShape.replay + +def prbCtorIdentityEvidence : + TypeChecker.CandidateExprIdentityReplay.Evidence + prbCtorIdentityReplay + prbCandidate.families.singleton.constructors.singleton.type.trace := + prbCtorIdentityReplay.evidence_of_build prbCtorCandidateBuild + +/-- The structurally identity-normalizing constructor candidate reconstructs +the exact closed kernel constructor type. In particular, later alignment can +inspect the retained view without a separate computation oracle. -/ +theorem prbCtorView_eq : + prbCandidate.families.singleton.constructors.singleton.type.view = + propRecursiveBoundaryKernelCtor.type := by + apply prbCtorIdentityEvidence.identity.view_eq_source + · apply TypeChecker.CandidateLocalContextRun.empty + rw [prbConstructorCandidateContext_eq] + rfl + · rw [prbConstructorCandidateContext_eq] + simp [propRecursiveBoundaryKernelCtor, + propRecursiveBoundaryMkInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, FVarsIn, Level.hasMVar'] + +theorem prbCtorIdentityReplay_shape : + prbCtorIdentityReplay.spineLength = 3 ∧ + prbCtorIdentityReplay.terminalSource = + (.app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar prbConstructorContext.freshFVarId)) + (.fvar prbCtorAlphaContext.freshFVarId)) := + ⟨prbCtorIdentityShape.spineLength_eq, + prbCtorIdentityShape.terminalSource_eq⟩ + +theorem prbTypeEnv_ordered : prbTypeEnv.Ordered := + .const (n := propRecursiveBoundaryType.name) + (ci := propRecursiveBoundaryType.toVConstant) + .empty prbRawFamily_isType prbTypeEnv_add + +theorem prbRawCtor_isType : + prbTypeEnv.IsType 1 [] propRecursiveBoundaryType.ctors[0].type := by + have hFamily : prbTypeEnv.constants propRecursiveBoundaryType.name = + some propRecursiveBoundaryType.toVConstant := + VEnv.addConst_self prbTypeEnv_add + exact ⟨_, by type_tac⟩ + +theorem prbCtorSource_tr : + TrExprS prbTypeEnv [`u] [] propRecursiveBoundaryKernelCtor.type + propRecursiveBoundaryType.ctors[0].type := by + have shape : TrTypeExpr prbTypeEnv [`u] [] + propRecursiveBoundaryKernelCtor.type + propRecursiveBoundaryType.ctors[0].type := by + tr_type_expr_tac + obtain ⟨level, type⟩ := prbRawCtor_isType + exact shape.to_trExprS prbTypeEnv_ordered trivial ⟨.sort level, type⟩ + +theorem prbCtorNames_eq : + propRecursiveBoundaryKernelCtor.name = + propRecursiveBoundaryType.ctors[0].name := by + decide + +theorem prbCtorWhnfDepth : + prbCandidate.families.singleton.constructors.singleton.type.context.fuel.recDepth = + 9999 + 1 := by + rw [prbConstructorCandidateContext_eq] + rfl + +theorem prbRawCtors_eq : + propRecursiveBoundaryType.ctors = + [propRecursiveBoundaryType.ctors[0]] := by + rfl + +def prbCtorStagedInput : + VInductDecl.CandidateConstructorStagedInput + prbFamilyStage.postFamily + prbCandidate.families.singleton.constructors.singleton + propRecursiveBoundaryType.ctors[0] where + name_eq := prbCtorNames_eq + uvars_eq := rfl + type := { + context_eq := prbConstructorCandidateContext_eq.symm + source_tr := prbCtorSource_tr + whnfFuel := 9999 + whnfDepth := prbCtorWhnfDepth } + +def prbConstructorsStage : + VInductDecl.CandidateConstructorStagedListInput + prbFamilyStage.postFamily + prbCandidate.families.singleton.constructors + propRecursiveBoundaryType.ctors := by + rw [AddInductive.CandidateList.singleton_eta + prbCandidate.families.singleton.constructors, prbRawCtors_eq] + exact .cons prbCtorStagedInput .nil + +theorem prbFamilyTypesProduced : + AddInductive.CandidateFamilyTypeListProduced prbFamilyContext + (.cons prbCandidate.families.singleton.familyType .nil) := by + have h := prbExecution.familyTypes.produced + rw [AddInductive.CandidateList.singleton_eta + prbExecution.familyTypes.candidates] at h + rw [← prbExecution.families.produced.singleton_familyType] at h + simpa [prbCandidate, prbFamilyContext, + AddInductive.NormalizationCandidateExecution.candidate] using h + +theorem prbFamiliesProduced : + AddInductive.CandidateFamilyListProduced prbConstructorContext + (.cons prbCandidate.families.singleton.familyType .nil) + prbCandidate.families := by + simpa [prbCandidate, prbConstructorContext, + AddInductive.NormalizationCandidateExecution.candidate] using + prbExecution.families.produced.singleton_reindex + +theorem prbCheckConstructorsRun : + AddInductive.checkConstructors #[propRecursiveBoundaryKernelType] + prbFamilyValidationRun.stats false + { prbCandidate.families.singleton.familyType.type.trace.terminalContext with + env := prbConstructorContext.env } = .ok () := by + have h := prbExecution.constructorRun + rw [prbExecutionStats_eq, prbExecutionValidationContext_eq] at h + simpa [prbConstructorContext] using h + +theorem prbUniverseRun : + AddInductive.checkConstructorUniverseListSemantics + prbFamilyValidationRun.stats propRecursiveBoundaryKernelType.ctors + { prbCandidate.families.singleton.familyType.type.trace.terminalContext with + env := prbConstructorContext.env } = .ok () := by + let validation : AddInductive.ConstructorValidationRun + propRecursiveBoundaryKernelType prbFamilyValidationRun.stats false + { prbCandidate.families.singleton.familyType.type.trace.terminalContext with + env := prbConstructorContext.env } := + AddInductive.ConstructorValidationRun.of_run prbCheckConstructorsRun + apply validation.trace.universeRun_of_semantics + apply validation.trace.universeSemantics_of_resultLevel_isZero + rfl + +def prbValidationAlphaContext : AddInductive.Context := + prbFamilyContext.pushLocalDecl `α .default (.sort (.succ (.param `u))) + +def prbValidationAName : Name := + propRecursiveBoundaryKernelType.type.bindingBody!.bindingName! + +def prbValidationFamilyContext : AddInductive.Context := + prbValidationAlphaContext.pushLocalDecl prbValidationAName .default + prbFamilyContext.freshExpr + +theorem prbFamilyTerminalContext_eq : + prbCandidate.families.singleton.familyType.type.trace.terminalContext = + prbValidationFamilyContext := by + have identity := prbFamilyIdentityEvidence.identity + have spineLength := prbFamilyIdentityEvidence.spineLength_eq + generalize htrace : + prbCandidate.families.singleton.familyType.type.trace = trace at identity spineLength ⊢ + cases identity with + | terminal result_eq => + simp only [AddInductive.CandidateExprTrace.spineLength] at spineLength + rw [prbFamilyIdentityReplay_shape.1] at spineLength + omega + | forallE domainCandidate bodyCandidate source_eq consumed_eq + domainIdentity bodyIdentity => + simp only [AddInductive.CandidateExprTrace.spineLength, + AddInductive.CandidateExprTrace.terminalContext] + cases bodyIdentity with + | terminal result_eq => + simp only [AddInductive.CandidateExprTrace.spineLength] at spineLength + rw [prbFamilyIdentityReplay_shape.1] at spineLength + omega + | forallE domainCandidate' bodyCandidate' source_eq' consumed_eq' + domainIdentity' bodyIdentity' => + cases bodyIdentity' with + | terminal result_eq => + simp only [AddInductive.CandidateExprTrace.terminalContext] + simp [propRecursiveBoundaryKernelType, + propRecursiveBoundaryInfo, ConstantInfo.type, + ConstantInfo.toConstantVal] at source_eq + rcases source_eq with ⟨rfl, rfl, rfl, rfl⟩ + simp [Expr.instantiate1_eq, Expr.instantiate1'] at source_eq' + rcases source_eq' with ⟨rfl, rfl, rfl, rfl⟩ + rw [consumed_eq, consumed_eq', prbFamilyCandidateContext_eq] + rfl + | forallE domainCandidate'' bodyCandidate'' source_eq'' consumed_eq'' + domainIdentity'' bodyIdentity'' => + simp only [AddInductive.CandidateExprTrace.spineLength] at spineLength + rw [prbFamilyIdentityReplay_shape.1] at spineLength + omega + +def prbConstructorValidationContext : AddInductive.Context := + { prbCandidate.families.singleton.familyType.type.trace.terminalContext with + env := prbConstructorContext.env } + +theorem prbConstructorValidationContext_eq : + prbConstructorValidationContext = + { prbValidationFamilyContext with env := prbConstructorContext.env } := by + rw [prbConstructorValidationContext, prbFamilyTerminalContext_eq] + +def prbValidationAlphaLocalRun : + TypeChecker.CandidateLocalContextRun prbValidationAlphaContext := + (TypeChecker.CandidateLocalContextRun.empty prbFamilyContext rfl).push + `α .default (.sort (.succ (.param `u))) + +def prbValidationFamilyLocalRun : + TypeChecker.CandidateLocalContextRun prbValidationFamilyContext := + prbValidationAlphaLocalRun.push prbValidationAName .default + prbFamilyContext.freshExpr + +def prbValidationRootContext : AddInductive.Context := + { prbValidationFamilyContext with env := prbConstructorContext.env } + +def prbValidationRootLocalRun : + TypeChecker.CandidateLocalContextRun prbValidationRootContext where + wf := prbValidationFamilyLocalRun.wf + reserves := prbValidationFamilyLocalRun.reserves + +def prbValidationAlphaId : FVarId := prbFamilyContext.freshFVarId +def prbValidationAlpha : Expr := prbFamilyContext.freshExpr +def prbValidationIndexId : FVarId := prbValidationAlphaContext.freshFVarId + +theorem prbValidationAlphaFind : + prbValidationRootContext.lctx.find? prbValidationAlphaId = + some (.cdecl 0 prbValidationAlphaId `α + (.sort (.succ (.param `u))) .default .default) := by + have first := + (TypeChecker.CandidateLocalContextRun.empty prbFamilyContext rfl).push_findNew + `α .default (.sort (.succ (.param `u))) + have old := prbValidationAlphaLocalRun.push_findOld + prbValidationAName .default prbFamilyContext.freshExpr first + simpa [prbValidationRootContext, prbValidationFamilyContext, + prbValidationAlphaContext, prbValidationAlphaId, prbFamilyContext, + propRecursiveBoundaryContext, AddInductive.Context.pushLocalDecl] using old + +theorem prbValidationIndexFind : + prbValidationRootContext.lctx.find? prbValidationIndexId = + some (.cdecl prbValidationAlphaContext.lctx.decls.size + prbValidationIndexId prbValidationAName + prbValidationAlpha .default .default) := by + have found := prbValidationAlphaLocalRun.push_findNew + prbValidationAName .default prbFamilyContext.freshExpr + simpa [prbValidationRootContext, prbValidationFamilyContext, + prbValidationAlphaContext, prbValidationIndexId, prbValidationAlpha, + prbValidationAlphaId, prbFamilyContext, propRecursiveBoundaryContext, + AddInductive.Context.pushLocalDecl, AddInductive.Context.freshExpr] using found + +theorem prbCandidateCheckTypeFVar + (context : AddInductive.Context) (id : FVarId) (type : Expr) + (hdepth : context.fuel.recDepth = 10000) + (hfind : context.lctx.find? id = + some (.cdecl index id name type bi kind)) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, .fvar id, type⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + change TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel (TypeChecker.checkType (.fvar id)) = + .ok type + unfold TypeChecker.M.run TypeChecker.checkType TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rw [hdepth] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' (.fvar id) false + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker + ({} : TypeChecker.State)) = .ok type + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + TypeChecker.Inner.inferFVar, AddInductive.Context.toTypeChecker, hfind, + LocalDecl.type, Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rfl + +@[simp] theorem prbValidationAlpha_shape : + prbValidationAlpha = .fvar prbValidationAlphaId := by + rfl + +theorem prbValidationGetTypeAlpha : + AddInductive.getType prbValidationAlpha prbValidationRootContext = + .ok (.sort (.succ (.param `u))) := by + unfold AddInductive.getType + simp only [getLCtx, ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] + change Except.ok ((prbValidationRootContext.lctx.get! + prbValidationAlpha.fvarId!).type) = _ + rw [show prbValidationAlpha.fvarId! = prbValidationAlphaId by + rw [prbValidationAlpha_shape] + rfl] + simp [LocalContext.get!, prbValidationAlphaFind, LocalDecl.type] + +@[simp] theorem prbValidationCheckLevelSuccParam : + TypeChecker.Inner.checkLevel prbValidationRootContext.toTypeChecker + (.succ (.param `u)) = .ok () := by + simp [TypeChecker.Inner.checkLevel, prbValidationRootContext, + prbValidationFamilyContext, prbValidationAlphaContext, + prbFamilyContext, propRecursiveBoundaryContext, + AddInductive.Context.toTypeChecker, Level.getUndefParam, + Level.forEach, Level.hasParam_eq, Level.hasParam'] + rfl + +theorem prbValidationSortCheckValid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨prbValidationRootContext, .sort (.succ (.param `u)), + .sort (.succ (.succ (.param `u)))⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + change TypeChecker.M.run prbValidationRootContext.env + prbValidationRootContext.safety prbValidationRootContext.lctx + prbValidationRootContext.lparams prbValidationRootContext.fuel + (TypeChecker.checkType (.sort (.succ (.param `u)))) = _ + unfold TypeChecker.M.run TypeChecker.checkType TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' + (.sort (.succ (.param `u))) false + (TypeChecker.Methods.withFuel 9999) + prbValidationRootContext.toTypeChecker + ({} : TypeChecker.State)) = _ + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + prbValidationCheckLevelSuccParam, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + rfl + +def prbValidationSortChecked : AddInductive.ConstructorCheckedExpr + prbValidationRootContext (.sort (.succ (.param `u))) := + .ofRun (by simp [FVarsIn, Level.hasMVar']) prbValidationSortCheckValid + +def prbValidationFamilyApp (arg : Expr) : Expr := + .app + (.app (.const propRecursiveBoundaryKernelType.name [.param `u]) + prbValidationAlpha) + arg + +def prbValidationNextDomain : Expr := + .forallE `b prbValidationAlpha + (prbValidationFamilyApp (.bvar 0)) .default + +def prbValidationAfterParam : Expr := + .forallE `a prbValidationAlpha + (.forallE `next prbValidationNextDomain + (prbValidationFamilyApp (.bvar 1)) .default) .default + +def prbValidationAId : FVarId := prbValidationRootContext.freshFVarId +def prbValidationAExpr : Expr := prbValidationRootContext.freshExpr +def prbValidationAContext : AddInductive.Context := + prbValidationRootContext.pushLocalDecl `a .default prbValidationAlpha + +def prbValidationAfterA : Expr := + .forallE `next prbValidationNextDomain + (prbValidationFamilyApp prbValidationAExpr) .default + +def prbValidationNextContext : AddInductive.Context := + prbValidationAContext.pushLocalDecl `next .default prbValidationNextDomain + +def prbValidationBId : FVarId := prbValidationAContext.freshFVarId +def prbValidationBExpr : Expr := prbValidationAContext.freshExpr +def prbValidationBContext : AddInductive.Context := + prbValidationAContext.pushLocalDecl `b .default prbValidationAlpha + +@[simp] theorem prbValidationAExpr_shape : + prbValidationAExpr = .fvar prbValidationAId := by + rfl + +@[simp] theorem prbValidationBExpr_shape : + prbValidationBExpr = .fvar prbValidationBId := by + rfl + +def prbValidationTerminal : Expr := + prbValidationFamilyApp prbValidationAExpr + +def prbValidationTarget : Expr := + prbValidationFamilyApp prbValidationBExpr + +theorem prbValidationAfterParam_shape : + (propRecursiveBoundaryKernelCtor.type.bindingBody!.instantiate1 + prbValidationAlpha) = prbValidationAfterParam := by + simp [propRecursiveBoundaryKernelCtor, propRecursiveBoundaryMkInfo, + ConstantInfo.type, ConstantInfo.toConstantVal, + prbValidationAfterParam, prbValidationNextDomain, + prbValidationFamilyApp, prbValidationAlpha, + prbFamilyContext, propRecursiveBoundaryContext, + AddInductive.Context.freshExpr, + propRecursiveBoundaryKernelType, propRecursiveBoundaryInfo, + ConstantInfo.name, + TypeChecker.candidateLiftLooseBVarsFVar, + Expr.bindingBody!, Expr.instantiate1_eq, Expr.instantiate1', + Expr.liftLooseBVars_zero] + +theorem prbValidationAfterA_shape : + prbValidationAfterParam.bindingBody!.instantiate1 + prbValidationAExpr = prbValidationAfterA := by + simp [prbValidationAfterParam, prbValidationAfterA, + prbValidationNextDomain, prbValidationTerminal, + prbValidationFamilyApp, prbValidationAExpr, + prbValidationRootContext, prbValidationFamilyContext, + prbValidationAlphaContext, prbFamilyContext, + propRecursiveBoundaryContext, AddInductive.Context.freshExpr, + TypeChecker.candidateLiftLooseBVarsFVar, + Expr.bindingBody!, + Expr.instantiate1_eq, Expr.instantiate1'] + +theorem prbValidationTerminal_shape : + prbValidationAfterA.bindingBody!.instantiate1 + prbValidationAContext.freshExpr = prbValidationTerminal := by + simp [prbValidationAfterA, prbValidationTerminal, + prbValidationFamilyApp, prbValidationAExpr, + prbValidationRootContext, prbValidationAContext, + prbValidationFamilyContext, prbValidationAlphaContext, + prbFamilyContext, propRecursiveBoundaryContext, + AddInductive.Context.freshExpr, + TypeChecker.candidateInstantiateFVar, + Expr.bindingBody!, Expr.instantiate1_eq, Expr.instantiate1'] + +theorem prbValidationTarget_shape : + prbValidationNextDomain.bindingBody!.instantiate1 + prbValidationBExpr = prbValidationTarget := by + simp [prbValidationNextDomain, prbValidationTarget, + prbValidationFamilyApp, Expr.bindingBody!, + Expr.instantiate1_eq, Expr.instantiate1'] + +def prbValidationALocalRun : + TypeChecker.CandidateLocalContextRun prbValidationAContext := + prbValidationRootLocalRun.push `a .default prbValidationAlpha + +def prbValidationNextLocalRun : + TypeChecker.CandidateLocalContextRun prbValidationNextContext := + prbValidationALocalRun.push `next .default prbValidationNextDomain + +def prbValidationBLocalRun : + TypeChecker.CandidateLocalContextRun prbValidationBContext := + prbValidationALocalRun.push `b .default prbValidationAlpha + +theorem prbValidationAlphaFindInA : + prbValidationAContext.lctx.find? prbValidationAlphaId = + some (.cdecl 0 prbValidationAlphaId `α + (.sort (.succ (.param `u))) .default .default) := + prbValidationRootLocalRun.push_findOld `a .default prbValidationAlpha + prbValidationAlphaFind + +theorem prbValidationAlphaFindInNext : + prbValidationNextContext.lctx.find? prbValidationAlphaId = + some (.cdecl 0 prbValidationAlphaId `α + (.sort (.succ (.param `u))) .default .default) := + prbValidationALocalRun.push_findOld `next .default + prbValidationNextDomain prbValidationAlphaFindInA + +theorem prbValidationAlphaFindInB : + prbValidationBContext.lctx.find? prbValidationAlphaId = + some (.cdecl 0 prbValidationAlphaId `α + (.sort (.succ (.param `u))) .default .default) := + prbValidationALocalRun.push_findOld `b .default prbValidationAlpha + prbValidationAlphaFindInA + +theorem prbValidationAFind : + prbValidationAContext.lctx.find? prbValidationAId = + some (.cdecl prbValidationRootContext.lctx.decls.size + prbValidationAId `a prbValidationAlpha .default .default) := by + simpa [prbValidationAContext, prbValidationAId, prbValidationAExpr] using + prbValidationRootLocalRun.push_findNew `a .default prbValidationAlpha + +theorem prbValidationAFindInNext : + prbValidationNextContext.lctx.find? prbValidationAId = + some (.cdecl prbValidationRootContext.lctx.decls.size + prbValidationAId `a prbValidationAlpha .default .default) := + prbValidationALocalRun.push_findOld `next .default + prbValidationNextDomain prbValidationAFind + +theorem prbValidationAFindInB : + prbValidationBContext.lctx.find? prbValidationAId = + some (.cdecl prbValidationRootContext.lctx.decls.size + prbValidationAId `a prbValidationAlpha .default .default) := + prbValidationALocalRun.push_findOld `b .default prbValidationAlpha + prbValidationAFind + +theorem prbValidationBFind : + prbValidationBContext.lctx.find? prbValidationBId = + some (.cdecl prbValidationAContext.lctx.decls.size + prbValidationBId `b prbValidationAlpha .default .default) := by + simpa [prbValidationBContext, prbValidationBId, prbValidationBExpr] using + prbValidationALocalRun.push_findNew `b .default prbValidationAlpha + +theorem prbValidationRootFresh : + prbValidationRootContext.lctx.find? + prbValidationRootContext.freshFVarId = none := + prbValidationRootLocalRun.fresh + +theorem prbValidationAFresh : + prbValidationAContext.lctx.find? + prbValidationAContext.freshFVarId = none := + prbValidationALocalRun.fresh + +theorem prbValidationNextFresh : + prbValidationNextContext.lctx.find? + prbValidationNextContext.freshFVarId = none := + prbValidationNextLocalRun.fresh + +theorem prbValidationBFresh : + prbValidationBContext.lctx.find? + prbValidationBContext.freshFVarId = none := + prbValidationBLocalRun.fresh + +theorem prbValidationFamilyGet : + prbConstructorContext.env.get propRecursiveBoundaryKernelType.name = + .ok prbDeclaredInfo := by + unfold Kernel.Environment.get + rw [prbCtorFamilyLookup] + rfl + +@[simp] theorem prbValidationCheckLevelParam + (context : AddInductive.Context) + (hlparams : context.lparams = [`u]) : + TypeChecker.Inner.checkLevel context.toTypeChecker (.param `u) = + .ok () := by + simp [TypeChecker.Inner.checkLevel, AddInductive.Context.toTypeChecker, + hlparams, Level.getUndefParam, Level.forEach, + Level.hasParam_eq, Level.hasParam'] + rfl + +@[simp] theorem prbValidationInferConstantFamily + (context : AddInductive.Context) + (henv : context.env = prbConstructorContext.env) + (hlparams : context.lparams = [`u]) + (hsafety : context.safety = .safe) : + TypeChecker.Inner.inferConstant context.toTypeChecker + propRecursiveBoundaryKernelType.name [.param `u] false = + .ok propRecursiveBoundaryKernelType.type := by + unfold TypeChecker.Inner.inferConstant + simp only [AddInductive.Context.toTypeChecker] + rw [henv, prbValidationFamilyGet] + have terminalLparams : + prbCandidate.families.singleton.familyType.type.trace.terminalContext.lparams = + [`u] := by + rw [prbTerminalLparams_eq] + rfl + unfold prbDeclaredInfo AddInductive.singletonDeclaredInfo + rw [terminalLparams] + have hlevel : TypeChecker.Inner.checkLevel + ({ env := prbConstructorContext.env + lctx := context.lctx + safety := .safe + lparams := [`u] + fuel := context.fuel } : TypeChecker.Context) + (.param `u) = .ok () := by + simp [TypeChecker.Inner.checkLevel, + Level.getUndefParam, Level.forEach, + Level.hasParam_eq, Level.hasParam'] + rfl + simp [ + propRecursiveBoundaryKernelType, propRecursiveBoundaryInfo, + ConstantInfo.levelParams, ConstantInfo.isUnsafe, + ConstantInfo.instantiateTypeLevelParams, ConstantInfo.toConstantVal, + ConstantVal.instantiateTypeLevelParams, + Expr.instantiateLevelParams_eq, Expr.instantiateLevelParamsCore', + Syntax.structEq_eq, + Level.substParams', hsafety, hlparams, + hlevel, Bind.bind, Except.bind, Pure.pure, Except.pure] + simp [Expr.instantiateLevelParamsCore', Level.substParams', + propRecursiveBoundaryKernelType, propRecursiveBoundaryInfo, + ConstantInfo.type, ConstantInfo.toConstantVal] + +def prbValidationFamilyTail (alpha : Expr) : Expr := + .forallE prbValidationAName alpha (.sort .zero) .default + +def prbValidationFirstApp (alpha : Expr) : Expr := + .app (.const propRecursiveBoundaryKernelType.name [.param `u]) alpha + +def prbReplayInsert (state : TypeChecker.State) (source type : Expr) : + TypeChecker.State := + { state with inferTypeC := state.inferTypeC.insert source type } + +@[simp] theorem prbEnsureForallExact + (name : Name) (domain body : Expr) (bi : BinderInfo) + (source : Expr) (fuel : Nat) (context : TypeChecker.Context) + (state : TypeChecker.State) : + TypeChecker.Inner.ensureForallCore (.forallE name domain body bi) + source (TypeChecker.Methods.withFuel fuel) context state = + .ok (.forallE name domain body bi, state) := by + rfl + +theorem prbSelfDefEq (source : Expr) fuel context state : + TypeChecker.Inner.isDefEq source source + (TypeChecker.Methods.withFuel fuel) context state = .ok (true, state) := by + unfold TypeChecker.Inner.isDefEq + rw [if_pos (Expr.eqv_refl _)] + rfl + +@[simp] theorem prbConstBeqFVar (name : Name) (levels : List Level) + (id : FVarId) : + ((.const name levels : Expr) == .fvar id) = false := by + change Expr.eqv (.const name levels) (.fvar id) = false + rw [Expr.eqv_eq] + rfl + +@[simp] theorem prbAppBeqFVar (fn arg : Expr) (id : FVarId) : + ((.app fn arg : Expr) == .fvar id) = false := by + change Expr.eqv (.app fn arg) (.fvar id) = false + rw [Expr.eqv_eq] + rfl + +@[simp] theorem prbFVarBeqConst (id : FVarId) (name : Name) + (levels : List Level) : + ((.fvar id : Expr) == .const name levels) = false := by + change Expr.eqv (.fvar id) (.const name levels) = false + rw [Expr.eqv_eq] + rfl + +@[simp] theorem prbFVarBeqApp (id : FVarId) (fn arg : Expr) : + ((.fvar id : Expr) == .app fn arg) = false := by + change Expr.eqv (.fvar id) (.app fn arg) = false + rw [Expr.eqv_eq] + rfl + +@[simp] theorem prbConstBeqApp (name : Name) (levels : List Level) + (fn arg : Expr) : + ((.const name levels : Expr) == .app fn arg) = false := by + change Expr.eqv (.const name levels) (.app fn arg) = false + rw [Expr.eqv_eq] + rfl + +@[simp] theorem prbAppBeqConst (fn arg : Expr) (name : Name) + (levels : List Level) : + ((.app fn arg : Expr) == .const name levels) = false := by + change Expr.eqv (.app fn arg) (.const name levels) = false + rw [Expr.eqv_eq] + rfl + +theorem prbInferAppCoreOf + (fuel : Nat) (context : TypeChecker.Context) + (state stateFn stateArg : TypeChecker.State) + (fn arg domain body : Expr) (name : Name) (bi : BinderInfo) + (hclosed : (.app fn arg : Expr).hasLooseBVars = false) + (hcache : state.inferTypeC[(.app fn arg : Expr)]? = none) + (hfn : TypeChecker.Inner.inferType' fn false + (TypeChecker.Methods.withFuel fuel) context state = + .ok (.forallE name domain body bi, stateFn)) + (harg : TypeChecker.Inner.inferType' arg false + (TypeChecker.Methods.withFuel fuel) context stateFn = + .ok (domain, stateArg)) + (heager : arg.isAppOfArity ``eagerReduce 2 = false) : + TypeChecker.Inner.inferType' (.app fn arg) false + (TypeChecker.Methods.withFuel fuel) context state = + .ok (body.instantiate1 arg, + { stateArg with inferTypeC := + (stateArg.inferTypeC.insert + (.app fn arg) (body.instantiate1 arg)) }) := by + unfold TypeChecker.Inner.inferType' + simp [hclosed, hcache, hfn, harg, heager, + prbEnsureForallExact, prbSelfDefEq, + Expr.instantiate1_eq, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + +theorem prbInferTypeForallCore + (fuel : Nat) (context : TypeChecker.Context) + (state finalState : TypeChecker.State) + (name : Name) (domain body result : Expr) (bi : BinderInfo) + (hclosed : (.forallE name domain body bi : Expr).hasLooseBVars = false) + (hcache : state.inferTypeC[ + (.forallE name domain body bi : Expr)]? = none) + (hforall : TypeChecker.Inner.inferForall + (.forallE name domain body bi) false + (TypeChecker.Methods.withFuel fuel) context state = + .ok (result, finalState)) : + TypeChecker.Inner.inferType' + (.forallE name domain body bi) false + (TypeChecker.Methods.withFuel fuel) context state = + .ok (result, { finalState with inferTypeC := + (finalState.inferTypeC.insert + (.forallE name domain body bi) result) }) := by + unfold TypeChecker.Inner.inferType' + simp [hclosed, hcache, hforall, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + +open private mkLevelIMaxCore mkLevelMaxCore from Lean.Level in +@[simp] theorem prbMkLevelIMaxSuccParamZero : + mkLevelIMax' (.succ (.param `u)) .zero = .zero := by + simp [mkLevelIMax', mkLevelIMaxCore, mkLevelMax', mkLevelMaxCore, + Level.isNeverZero, Level.isZero] + +def prbValidationConstState (state : TypeChecker.State) : TypeChecker.State := + prbReplayInsert state + (.const propRecursiveBoundaryKernelType.name [.param `u]) + propRecursiveBoundaryKernelType.type + +def prbValidationAlphaState (state : TypeChecker.State) + (alphaId : FVarId) : TypeChecker.State := + prbReplayInsert (prbValidationConstState state) + (.fvar alphaId) (.sort (.succ (.param `u))) + +def prbValidationFirstAppState (state : TypeChecker.State) + (alphaId : FVarId) : TypeChecker.State := + prbReplayInsert + (prbValidationAlphaState state alphaId) + (prbValidationFirstApp (.fvar alphaId)) + (prbValidationFamilyTail (.fvar alphaId)) + +def prbValidationArgumentState (state : TypeChecker.State) + (alphaId argId : FVarId) : TypeChecker.State := + prbReplayInsert + (prbValidationFirstAppState state alphaId) + (.fvar argId) (.fvar alphaId) + +def prbValidationFamilyAppState (state : TypeChecker.State) + (alphaId argId : FVarId) : TypeChecker.State := + prbReplayInsert + (prbValidationArgumentState state alphaId argId) + (prbValidationFamilyApp (.fvar argId)) (.sort .zero) + +def prbValidationCachedFirstAppState (state : TypeChecker.State) + (alphaId : FVarId) : TypeChecker.State := + prbReplayInsert (prbValidationConstState state) + (prbValidationFirstApp (.fvar alphaId)) + (prbValidationFamilyTail (.fvar alphaId)) + +def prbValidationCachedArgumentState (state : TypeChecker.State) + (alphaId argId : FVarId) : TypeChecker.State := + prbReplayInsert (prbValidationCachedFirstAppState state alphaId) + (.fvar argId) (.fvar alphaId) + +def prbValidationCachedFamilyAppState (state : TypeChecker.State) + (alphaId argId : FVarId) : TypeChecker.State := + prbReplayInsert (prbValidationCachedArgumentState state alphaId argId) + (prbValidationFamilyApp (.fvar argId)) (.sort .zero) + +theorem prbWithLocalDeclEq + {α} (name : Name) (bi : BinderInfo) (type : Expr) + (k : Expr → TypeChecker.RecM α) + (methods : TypeChecker.Methods) + (context : TypeChecker.Context) + (state : TypeChecker.State) : + (withLocalDecl (m := TypeChecker.RecM) name bi type k) + methods context state = + k (.fvar ⟨state.ngen.curr⟩) methods + { context with lctx := + context.lctx.mkLocalDecl ⟨state.ngen.curr⟩ name type bi } + { state with ngen := state.ngen.next } := by + rfl + +@[simp] theorem prbEnsureSortExact + (level : Level) (source : Expr) (fuel : Nat) + (context : TypeChecker.Context) (state : TypeChecker.State) : + TypeChecker.Inner.ensureSortCore (.sort level) source + (TypeChecker.Methods.withFuel fuel) context state = + .ok (.sort level, state) := by + rfl + +def prbValidationNextAlphaState : TypeChecker.State := + prbReplayInsert ({} : TypeChecker.State) prbValidationAlpha + (.sort (.succ (.param `u))) + +def prbValidationNextInternalBId : FVarId := + ⟨prbValidationNextAlphaState.ngen.curr⟩ + +def prbValidationNextInternalLctx : LocalContext := + prbValidationAContext.lctx.mkLocalDecl prbValidationNextInternalBId `b + prbValidationAlpha .default + +def prbValidationNextInternalContext : AddInductive.Context := + { prbValidationAContext with lctx := prbValidationNextInternalLctx } + +def prbValidationNextBodyState : TypeChecker.State := + { prbValidationNextAlphaState with + ngen := prbValidationNextAlphaState.ngen.next } + +theorem prbValidationNextInternalFresh : + prbValidationAContext.lctx.find? prbValidationNextInternalBId = none := by + rw [prbValidationALocalRun.wf.find?_eq_find?_toList, + List.find?_eq_none] + intro decl membership equal + simp only [prbValidationAContext, prbValidationRootContext, + prbValidationFamilyContext, prbValidationAlphaContext, + AddInductive.Context.pushLocalDecl, + LocalContext.mkLocalDecl_toList, List.mem_cons] at membership + rw [show prbFamilyContext.lctx.toList = [] by rfl] at membership + simp only [List.not_mem_nil, or_false] at membership + rcases membership with rfl | rfl | rfl + all_goals + simp [LocalDecl.fvarId, prbValidationNextInternalBId, + prbValidationNextAlphaState, prbReplayInsert, + prbValidationAlpha, prbValidationAId, prbValidationIndexId, + prbValidationAlphaId, prbValidationRootContext, + prbValidationFamilyContext, prbValidationAlphaContext, + prbFamilyContext, propRecursiveBoundaryContext, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId] at equal + all_goals injection equal + all_goals simp [NameGenerator.next] at * + +theorem prbValidationAlphaFindInternal : + prbValidationNextInternalContext.lctx.find? prbValidationAlphaId = + some (.cdecl 0 prbValidationAlphaId `α + (.sort (.succ (.param `u))) .default .default) := by + exact TypeChecker.localContextFindOld prbValidationAContext.lctx + prbValidationAlphaId prbValidationNextInternalBId `b + prbValidationAlpha .default .default _ prbValidationALocalRun.wf + prbValidationNextInternalFresh prbValidationAlphaFindInA + +theorem prbValidationNextInternalBFind : + prbValidationNextInternalContext.lctx.find? + prbValidationNextInternalBId = + some (.cdecl prbValidationAContext.lctx.decls.size + prbValidationNextInternalBId `b prbValidationAlpha + .default .default) := by + exact TypeChecker.localContextFindNew prbValidationAContext.lctx + prbValidationNextInternalBId `b prbValidationAlpha .default .default + prbValidationALocalRun.wf prbValidationNextInternalFresh + +theorem prbValidationAlphaNeNextInternalB : + prbValidationAlphaId ≠ prbValidationNextInternalBId := by + intro equal + have fresh := prbValidationNextInternalFresh + rw [← equal, prbValidationAlphaFindInA] at fresh + contradiction + +theorem prbValidationAlphaNeA : + prbValidationAlphaId ≠ prbValidationAId := by + intro equal + have fresh : prbValidationRootContext.lctx.find? + prbValidationAId = none := by + simpa [prbValidationAId] using prbValidationRootFresh + rw [← equal, prbValidationAlphaFind] at fresh + contradiction + +theorem prbValidationAlphaNeB : + prbValidationAlphaId ≠ prbValidationBId := by + intro equal + have fresh : prbValidationAContext.lctx.find? + prbValidationBId = none := by + simpa [prbValidationBId] using prbValidationAFresh + rw [← equal, prbValidationAlphaFindInA] at fresh + contradiction + +@[simp] theorem prbValidationConsumeAlpha : + AddInductive.consumeTypeAnnotations prbValidationAlpha = + prbValidationAlpha := by + rw [prbValidationAlpha_shape] + simp [AddInductive.consumeTypeAnnotations] + +@[simp] theorem prbValidationConsumeNextDomain : + AddInductive.consumeTypeAnnotations prbValidationNextDomain = + prbValidationNextDomain := by + simp [prbValidationNextDomain, + AddInductive.consumeTypeAnnotations] + +theorem prbValidationInferTypeFamilyCore + (fuel : Nat) (context : AddInductive.Context) + (state : TypeChecker.State) + (hcache : state.inferTypeC[ + (.const propRecursiveBoundaryKernelType.name [.param `u] : Expr)]? = + none) + (henv : context.env = prbConstructorContext.env) + (hlparams : context.lparams = [`u]) + (hsafety : context.safety = .safe) : + TypeChecker.Inner.inferType' + (.const propRecursiveBoundaryKernelType.name [.param `u]) false + (TypeChecker.Methods.withFuel fuel) context.toTypeChecker state = + .ok (propRecursiveBoundaryKernelType.type, + prbValidationConstState state) := by + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', hcache, + prbValidationConstState, prbReplayInsert, + prbValidationInferConstantFamily context henv hlparams hsafety, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +theorem prbValidationInferTypeFVarCore + (fuel : Nat) (context : AddInductive.Context) + (state : TypeChecker.State) (id : FVarId) (type : Expr) + (hcache : state.inferTypeC[(.fvar id : Expr)]? = none) + (hfind : context.lctx.find? id = + some (.cdecl index id name type bi kind)) : + TypeChecker.Inner.inferType' (.fvar id) false + (TypeChecker.Methods.withFuel fuel) context.toTypeChecker state = + .ok (type, prbReplayInsert state (.fvar id) type) := by + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', hcache, + TypeChecker.Inner.inferFVar, AddInductive.Context.toTypeChecker, + hfind, LocalDecl.type, prbReplayInsert, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +theorem prbValidationInferTypeCachedCore + (fuel : Nat) (context : AddInductive.Context) + (state : TypeChecker.State) (source type : Expr) + (hclosed : source.hasLooseBVars = false) + (hcache : state.inferTypeC[source]? = some type) : + TypeChecker.Inner.inferType' source false + (TypeChecker.Methods.withFuel fuel) context.toTypeChecker state = + .ok (type, state) := by + unfold TypeChecker.Inner.inferType' + simp [hclosed, hcache] + +theorem prbValidationInferFirstAppAlphaCachedCore + (fuel : Nat) (context : AddInductive.Context) + (state : TypeChecker.State) (alphaId : FVarId) + (halpha : state.inferTypeC[(.fvar alphaId : Expr)]? = + some (.sort (.succ (.param `u)))) + (hconst : state.inferTypeC[ + (.const propRecursiveBoundaryKernelType.name [.param `u] : Expr)]? = + none) + (happ : state.inferTypeC[ + prbValidationFirstApp (.fvar alphaId)]? = none) + (henv : context.env = prbConstructorContext.env) + (hlparams : context.lparams = [`u]) + (hsafety : context.safety = .safe) : + TypeChecker.Inner.inferType' + (prbValidationFirstApp (.fvar alphaId)) false + (TypeChecker.Methods.withFuel fuel) context.toTypeChecker state = + .ok (prbValidationFamilyTail (.fvar alphaId), + prbValidationCachedFirstAppState state alphaId) := by + have constRun := prbValidationInferTypeFamilyCore fuel context state hconst + henv hlparams hsafety + have alphaCache : (prbValidationConstState state).inferTypeC[ + (.fvar alphaId : Expr)]? = + some (.sort (.succ (.param `u))) := by + simp only [prbValidationConstState, prbReplayInsert, + Std.HashMap.getElem?_insert] + rw [prbConstBeqFVar] + exact halpha + have alphaRun := prbValidationInferTypeCachedCore fuel context + (prbValidationConstState state) (.fvar alphaId) + (.sort (.succ (.param `u))) + (by simp [Expr.hasLooseBVars, Expr.looseBVarRange']) alphaCache + have appRun := prbInferAppCoreOf fuel context.toTypeChecker state + (prbValidationConstState state) (prbValidationConstState state) + (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar alphaId) (.sort (.succ (.param `u))) + (.forallE prbValidationAName (.bvar 0) (.sort .zero) .default) + `α .default + (by simp [Expr.hasLooseBVars, Expr.looseBVarRange']) happ + (by simpa [prbValidationAName, propRecursiveBoundaryKernelType, + propRecursiveBoundaryInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, Expr.bindingBody!, + Expr.bindingName!] using constRun) + alphaRun (by rfl) + simpa [prbValidationCachedFirstAppState, + prbValidationFirstApp, prbValidationFamilyTail, prbReplayInsert, + Expr.instantiate1_eq, Expr.instantiate1'] using appRun + +theorem prbValidationNextBodyInferExists : + ∃ finalState : TypeChecker.State, + TypeChecker.Inner.inferType' + (prbValidationFamilyApp + (.fvar prbValidationNextInternalBId)) false + (TypeChecker.Methods.withFuel 9998) + prbValidationNextInternalContext.toTypeChecker + prbValidationNextBodyState = + .ok (.sort .zero, finalState) := by + have alphaCache : prbValidationNextBodyState.inferTypeC[ + (.fvar prbValidationAlphaId : Expr)]? = + some (.sort (.succ (.param `u))) := by + simp [prbValidationNextBodyState, prbValidationNextAlphaState, + prbReplayInsert] + have constMiss : prbValidationNextBodyState.inferTypeC[ + (.const propRecursiveBoundaryKernelType.name [.param `u] : Expr)]? = + none := by + simp only [prbValidationNextBodyState, prbValidationNextAlphaState, + prbReplayInsert, Std.HashMap.getElem?_insert] + rw [prbValidationAlpha_shape, prbFVarBeqConst] + exact Std.HashMap.getElem?_empty + have firstMiss : prbValidationNextBodyState.inferTypeC[ + prbValidationFirstApp (.fvar prbValidationAlphaId)]? = none := by + simp only [prbValidationNextBodyState, prbValidationNextAlphaState, + prbReplayInsert, Std.HashMap.getElem?_insert] + rw [prbValidationAlpha_shape, prbValidationFirstApp, + prbFVarBeqApp] + exact Std.HashMap.getElem?_empty + have firstRun : TypeChecker.Inner.inferType' + (prbValidationFirstApp (.fvar prbValidationAlphaId)) false + (TypeChecker.Methods.withFuel 9998) + prbValidationNextInternalContext.toTypeChecker + prbValidationNextBodyState = + .ok (prbValidationFamilyTail (.fvar prbValidationAlphaId), + prbValidationCachedFirstAppState + prbValidationNextBodyState prbValidationAlphaId) := by + apply prbValidationInferFirstAppAlphaCachedCore + · exact alphaCache + · exact constMiss + · exact firstMiss + · rfl + · rfl + · rfl + have idBeq : ((.fvar prbValidationAlphaId : Expr) == + .fvar prbValidationNextInternalBId) = false := by + change Expr.eqv (.fvar prbValidationAlphaId) + (.fvar prbValidationNextInternalBId) = false + rw [Expr.eqv_eq] + simp [Expr.eqv', prbValidationAlphaNeNextInternalB] + have argMiss : (prbValidationCachedFirstAppState + prbValidationNextBodyState prbValidationAlphaId).inferTypeC[ + (.fvar prbValidationNextInternalBId : Expr)]? = none := by + simp only [prbValidationCachedFirstAppState, + prbValidationConstState, prbValidationNextBodyState, + prbValidationNextAlphaState, prbReplayInsert, + Std.HashMap.getElem?_insert] + rw [prbValidationFirstApp, prbAppBeqFVar, prbConstBeqFVar, + prbValidationAlpha_shape, idBeq] + exact Std.HashMap.getElem?_empty + have argRun : TypeChecker.Inner.inferType' + (.fvar prbValidationNextInternalBId) false + (TypeChecker.Methods.withFuel 9998) + prbValidationNextInternalContext.toTypeChecker + (prbValidationCachedFirstAppState + prbValidationNextBodyState prbValidationAlphaId) = + .ok (.fvar prbValidationAlphaId, + prbValidationCachedArgumentState prbValidationNextBodyState + prbValidationAlphaId prbValidationNextInternalBId) := by + simpa [prbValidationCachedArgumentState, + prbValidationAlpha_shape] using + prbValidationInferTypeFVarCore 9998 + prbValidationNextInternalContext + (prbValidationCachedFirstAppState + prbValidationNextBodyState prbValidationAlphaId) + prbValidationNextInternalBId (.fvar prbValidationAlphaId) + argMiss prbValidationNextInternalBFind + have appMiss : prbValidationNextBodyState.inferTypeC[ + prbValidationFamilyApp + (.fvar prbValidationNextInternalBId)]? = none := by + simp only [prbValidationNextBodyState, prbValidationNextAlphaState, + prbReplayInsert, Std.HashMap.getElem?_insert] + rw [prbValidationAlpha_shape, prbValidationFamilyApp, + prbFVarBeqApp] + exact Std.HashMap.getElem?_empty + have appRun := prbInferAppCoreOf 9998 + prbValidationNextInternalContext.toTypeChecker + prbValidationNextBodyState + (prbValidationCachedFirstAppState + prbValidationNextBodyState prbValidationAlphaId) + (prbValidationCachedArgumentState prbValidationNextBodyState + prbValidationAlphaId prbValidationNextInternalBId) + (prbValidationFirstApp (.fvar prbValidationAlphaId)) + (.fvar prbValidationNextInternalBId) + (.fvar prbValidationAlphaId) (.sort .zero) + prbValidationAName .default + (by simp [prbValidationFamilyApp, prbValidationFirstApp, + Expr.hasLooseBVars, Expr.looseBVarRange']) + appMiss firstRun argRun (by rfl) + refine ⟨prbValidationCachedFamilyAppState prbValidationNextBodyState + prbValidationAlphaId prbValidationNextInternalBId, ?_⟩ + simpa [prbValidationFamilyApp, prbValidationFirstApp, + prbValidationFamilyTail, prbValidationCachedFamilyAppState, + prbReplayInsert, Expr.instantiate1_eq, Expr.instantiate1'] using appRun + +theorem prbValidationNextDomainCheckValid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨prbValidationAContext, prbValidationNextDomain, + .sort .zero⟩ := by + obtain ⟨bodyFinalState, bodyRun⟩ := + prbValidationNextBodyInferExists + have domainRun : TypeChecker.Inner.inferType' + prbValidationAlpha false (TypeChecker.Methods.withFuel 9998) + prbValidationAContext.toTypeChecker ({} : TypeChecker.State) = + .ok (.sort (.succ (.param `u)), + prbValidationNextAlphaState) := by + simpa [prbValidationNextAlphaState, prbValidationAlpha_shape] using + prbValidationInferTypeFVarCore 9998 prbValidationAContext + ({} : TypeChecker.State) prbValidationAlphaId + (.sort (.succ (.param `u))) Std.HashMap.getElem?_empty + prbValidationAlphaFindInA + have forallRun : TypeChecker.Inner.inferForall + prbValidationNextDomain false + (TypeChecker.Methods.withFuel 9999) + prbValidationAContext.toTypeChecker ({} : TypeChecker.State) = + .ok (.sort .zero, bodyFinalState) := by + unfold prbValidationNextDomain TypeChecker.Inner.inferForall + simp only [TypeChecker.Inner.inferForall.loop] + rw [show prbValidationAlpha.instantiateRev #[] = + prbValidationAlpha by + simp [Expr.instantiateRev_eq, Expr.instantiate_eq]] + simp only [Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rw [show TypeChecker.Inner.inferType prbValidationAlpha false + (TypeChecker.Methods.withFuel 9999) + prbValidationAContext.toTypeChecker ({} : TypeChecker.State) = + TypeChecker.Inner.inferType' prbValidationAlpha false + (TypeChecker.Methods.withFuel 9998) + prbValidationAContext.toTypeChecker + ({} : TypeChecker.State) by rfl] + rw [domainRun] + simp only [prbEnsureSortExact] + rw [prbWithLocalDeclEq] + change TypeChecker.Inner.inferForall.loop + false + #[Expr.fvar prbValidationNextInternalBId] + #[Level.succ (.param `u)] + (prbValidationFamilyApp (.bvar 0)) + (TypeChecker.Methods.withFuel 9999) + prbValidationNextInternalContext.toTypeChecker + prbValidationNextBodyState = + .ok (Expr.sort .zero, bodyFinalState) + simp only [prbValidationFamilyApp, + TypeChecker.Inner.inferForall.loop] + rw [show (((.const propRecursiveBoundaryKernelType.name + [.param `u] : Expr).app prbValidationAlpha).app (.bvar 0) + ).instantiateRev #[Expr.fvar prbValidationNextInternalBId] = + prbValidationFamilyApp + (.fvar prbValidationNextInternalBId) by + simp [prbValidationFamilyApp, Expr.instantiateRev_eq, + Expr.instantiate_eq, Expr.instantiate1_eq, Expr.instantiate1']] + simp only [Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rw [show TypeChecker.Inner.inferType + (prbValidationFamilyApp + (.fvar prbValidationNextInternalBId)) false + (TypeChecker.Methods.withFuel 9999) + prbValidationNextInternalContext.toTypeChecker + prbValidationNextBodyState = + TypeChecker.Inner.inferType' + (prbValidationFamilyApp + (.fvar prbValidationNextInternalBId)) false + (TypeChecker.Methods.withFuel 9998) + prbValidationNextInternalContext.toTypeChecker + prbValidationNextBodyState by rfl] + rw [bodyRun] + simp [Expr.sortLevel!, Pure.pure, ReaderT.pure, + StateT.pure, Except.pure] + have outerRun := prbInferTypeForallCore 9999 + prbValidationAContext.toTypeChecker ({} : TypeChecker.State) + bodyFinalState `b prbValidationAlpha + (prbValidationFamilyApp (.bvar 0)) (.sort .zero) .default + (by simp [prbValidationNextDomain, prbValidationFamilyApp, + Expr.hasLooseBVars, Expr.looseBVarRange']) + Std.HashMap.getElem?_empty + (by simpa [prbValidationNextDomain] using forallRun) + unfold AddInductive.CandidateCheckTypeStep.Valid + change TypeChecker.M.run prbValidationAContext.env + prbValidationAContext.safety prbValidationAContext.lctx + prbValidationAContext.lparams prbValidationAContext.fuel + (TypeChecker.checkType prbValidationNextDomain) = .ok (.sort .zero) + unfold TypeChecker.M.run TypeChecker.checkType TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' prbValidationNextDomain false + (TypeChecker.Methods.withFuel 9999) + prbValidationAContext.toTypeChecker ({} : TypeChecker.State)) = + .ok (.sort .zero) + simpa [prbValidationNextDomain, Functor.map, Except.map] using + congrArg (Except.map (fun x : Expr × TypeChecker.State => x.1)) outerRun + +theorem prbValidationInferFirstAppCore + (fuel : Nat) (context : AddInductive.Context) + (state : TypeChecker.State) (alphaId : FVarId) + (hconst : state.inferTypeC[ + (.const propRecursiveBoundaryKernelType.name [.param `u] : Expr)]? = + none) + (halpha : (prbValidationConstState state).inferTypeC[ + (.fvar alphaId : Expr)]? = none) + (happ : state.inferTypeC[ + prbValidationFirstApp (.fvar alphaId)]? = none) + (hfind : context.lctx.find? alphaId = + some (.cdecl index alphaId name + (.sort (.succ (.param `u))) bi kind)) + (henv : context.env = prbConstructorContext.env) + (hlparams : context.lparams = [`u]) + (hsafety : context.safety = .safe) : + TypeChecker.Inner.inferType' + (prbValidationFirstApp (.fvar alphaId)) false + (TypeChecker.Methods.withFuel fuel) context.toTypeChecker state = + .ok (prbValidationFamilyTail (.fvar alphaId), + prbValidationFirstAppState state alphaId) := by + have constRun := prbValidationInferTypeFamilyCore fuel context state hconst + henv hlparams hsafety + have alphaRun := prbValidationInferTypeFVarCore fuel context + (prbValidationConstState state) alphaId + (.sort (.succ (.param `u))) halpha hfind + have appRun := prbInferAppCoreOf fuel context.toTypeChecker state + (prbValidationConstState state) (prbValidationAlphaState state alphaId) + (.const propRecursiveBoundaryKernelType.name [.param `u]) + (.fvar alphaId) (.sort (.succ (.param `u))) + (.forallE prbValidationAName (.bvar 0) (.sort .zero) .default) + `α .default + (by simp [prbValidationFirstApp, Expr.hasLooseBVars, + Expr.looseBVarRange']) happ + (by simpa [prbValidationAName, propRecursiveBoundaryKernelType, + propRecursiveBoundaryInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, Expr.bindingBody!, + Expr.bindingName!] using constRun) + (by simpa [prbValidationAlphaState] using alphaRun) (by rfl) + simpa [prbValidationFirstAppState, prbValidationFirstApp, + prbValidationFamilyTail, prbReplayInsert, + Expr.instantiate1_eq, Expr.instantiate1'] using appRun + +theorem prbValidationFamilyAppCheckValid + (context : AddInductive.Context) (alphaId argId : FVarId) + (hne : alphaId ≠ argId) + (halphaExpr : (.fvar alphaId : Expr) = prbValidationAlpha) + (halpha : context.lctx.find? alphaId = + some (.cdecl alphaIndex alphaId alphaName + (.sort (.succ (.param `u))) alphaBi alphaKind)) + (harg : context.lctx.find? argId = + some (.cdecl argIndex argId argName (.fvar alphaId) argBi argKind)) + (henv : context.env = prbConstructorContext.env) + (hlparams : context.lparams = [`u]) + (hsafety : context.safety = .safe) + (hdepth : context.fuel.recDepth = 10000) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, prbValidationFamilyApp (.fvar argId), .sort .zero⟩ := by + let initial := ({} : TypeChecker.State) + have firstRun : TypeChecker.Inner.inferType' + (prbValidationFirstApp (.fvar alphaId)) false + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker initial = + .ok (prbValidationFamilyTail (.fvar alphaId), + prbValidationFirstAppState initial alphaId) := by + apply prbValidationInferFirstAppCore + · simp [initial] + · simp [initial, prbValidationConstState, + prbReplayInsert] + · simp [initial, prbValidationFirstApp] + · exact halpha + · exact henv + · exact hlparams + · exact hsafety + have argMiss : (prbValidationFirstAppState initial alphaId).inferTypeC[ + (.fvar argId : Expr)]? = none := by + have initialMiss : initial.inferTypeC[(.fvar argId : Expr)]? = none := by + simpa [initial] using + (Std.HashMap.getElem?_empty (k := (.fvar argId : Expr)) + (v := Expr)) + have idBeq : ((.fvar alphaId : Expr) == .fvar argId) = false := by + change Expr.eqv (.fvar alphaId) (.fvar argId) = false + rw [Expr.eqv_eq] + simp [Expr.eqv', hne] + simp [prbValidationFirstAppState, prbValidationAlphaState, + prbValidationConstState, prbReplayInsert, + prbValidationFirstApp, idBeq, initialMiss] + intro hmem + have hsome := Std.HashMap.mem_iff_isSome_getElem?.mp hmem + simp [initialMiss] at hsome + have argRun : TypeChecker.Inner.inferType' (.fvar argId) false + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker + (prbValidationFirstAppState initial alphaId) = + .ok (.fvar alphaId, + prbValidationArgumentState initial alphaId argId) := by + simpa [prbValidationArgumentState] using + prbValidationInferTypeFVarCore 9999 context + (prbValidationFirstAppState initial alphaId) argId + (.fvar alphaId) argMiss harg + have appRun := prbInferAppCoreOf 9999 context.toTypeChecker initial + (prbValidationFirstAppState initial alphaId) + (prbValidationArgumentState initial alphaId argId) + (prbValidationFirstApp (.fvar alphaId)) (.fvar argId) + (.fvar alphaId) (.sort .zero) prbValidationAName .default + (by simp [prbValidationFamilyApp, prbValidationFirstApp, + Expr.hasLooseBVars, Expr.looseBVarRange']) + (by simp [initial, prbValidationFamilyApp]) firstRun argRun (by rfl) + unfold AddInductive.CandidateCheckTypeStep.Valid + change TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel + (TypeChecker.checkType (prbValidationFamilyApp (.fvar argId))) = + .ok (.sort .zero) + unfold TypeChecker.M.run TypeChecker.checkType TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rw [hdepth] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' (prbValidationFamilyApp (.fvar argId)) + false (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State)) = .ok (.sort .zero) + simpa [prbValidationFamilyApp, prbValidationFirstApp, halphaExpr, initial, + Expr.instantiate1_eq, Expr.instantiate1', Functor.map, Except.map] using + congrArg (Except.map (fun x : Expr × TypeChecker.State => x.1)) appRun + +theorem prbValidationAlphaRootCheckValid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨prbValidationRootContext, prbValidationAlpha, + .sort (.succ (.param `u))⟩ := by + simpa [prbValidationAlpha_shape] using + prbCandidateCheckTypeFVar prbValidationRootContext + prbValidationAlphaId (.sort (.succ (.param `u))) + (by rfl) prbValidationAlphaFind + +theorem prbValidationAlphaACheckValid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨prbValidationAContext, prbValidationAlpha, + .sort (.succ (.param `u))⟩ := by + simpa [prbValidationAlpha_shape] using + prbCandidateCheckTypeFVar prbValidationAContext + prbValidationAlphaId (.sort (.succ (.param `u))) + (by rfl) prbValidationAlphaFindInA + +theorem prbValidationTerminalCheckValid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨prbValidationNextContext, prbValidationTerminal, + .sort .zero⟩ := by + simpa [prbValidationTerminal, + prbValidationAExpr_shape, prbValidationAlpha_shape] using + prbValidationFamilyAppCheckValid prbValidationNextContext + prbValidationAlphaId prbValidationAId + prbValidationAlphaNeA rfl prbValidationAlphaFindInNext + prbValidationAFindInNext rfl rfl rfl rfl + +theorem prbValidationTargetCheckValid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨prbValidationBContext, prbValidationTarget, + .sort .zero⟩ := by + simpa [prbValidationTarget, + prbValidationBExpr_shape, prbValidationAlpha_shape] using + prbValidationFamilyAppCheckValid prbValidationBContext + prbValidationAlphaId prbValidationBId + prbValidationAlphaNeB rfl prbValidationAlphaFindInB + prbValidationBFind rfl rfl rfl rfl + +private def prbCheckedOfValid + (context : AddInductive.Context) (source inferred : Expr) + (fvars : source.FVarsIn + (fun fv => (context.lctx.find? fv).isSome = true)) + (valid : AddInductive.CandidateCheckTypeStep.Valid + ⟨context, source, inferred⟩) : + AddInductive.ConstructorCheckedExpr context source := + .ofRun fvars valid + +private def prbValidationAlphaRootChecked : + AddInductive.ConstructorCheckedExpr prbValidationRootContext + prbValidationAlpha := + prbCheckedOfValid _ _ _ (by + rw [prbValidationAlpha_shape] + change (prbValidationRootContext.lctx.find? + prbValidationAlphaId).isSome = true + rw [prbValidationAlphaFind] + rfl) + prbValidationAlphaRootCheckValid + +private def prbValidationAlphaAChecked : + AddInductive.ConstructorCheckedExpr prbValidationAContext + prbValidationAlpha := + prbCheckedOfValid _ _ _ (by + rw [prbValidationAlpha_shape] + change (prbValidationAContext.lctx.find? + prbValidationAlphaId).isSome = true + rw [prbValidationAlphaFindInA] + rfl) + prbValidationAlphaACheckValid + +private def prbValidationAlphaAConsumedChecked : + AddInductive.ConstructorCheckedExpr prbValidationAContext + (AddInductive.consumeTypeAnnotations prbValidationAlpha) := + prbCheckedOfValid _ _ (.sort (.succ (.param `u))) (by + rw [prbValidationConsumeAlpha] + exact prbValidationAlphaAChecked.fvars) + (by simpa only [prbValidationConsumeAlpha] using + prbValidationAlphaACheckValid) + +private def prbValidationNextDomainChecked : + AddInductive.ConstructorCheckedExpr prbValidationAContext + prbValidationNextDomain := + prbCheckedOfValid _ _ _ (by + simp [prbValidationNextDomain, prbValidationFamilyApp, + prbValidationAlpha, FVarsIn, Level.hasMVar'] + change (prbValidationAContext.lctx.find? + prbValidationAlphaId).isSome = true + rw [prbValidationAlphaFindInA] + rfl) + prbValidationNextDomainCheckValid + +private def prbValidationTerminalChecked : + AddInductive.ConstructorCheckedExpr prbValidationNextContext + prbValidationTerminal := + prbCheckedOfValid _ _ _ (by + simp [prbValidationTerminal, prbValidationFamilyApp, + prbValidationAlpha, prbValidationAExpr, + FVarsIn, Level.hasMVar'] + constructor + · change (prbValidationNextContext.lctx.find? + prbValidationAlphaId).isSome = true + rw [prbValidationAlphaFindInNext] + rfl + · change (prbValidationNextContext.lctx.find? + prbValidationAId).isSome = true + rw [prbValidationAFindInNext] + rfl) + prbValidationTerminalCheckValid + +private def prbValidationTargetChecked : + AddInductive.ConstructorCheckedExpr prbValidationBContext + prbValidationTarget := + prbCheckedOfValid _ _ _ (by + simp [prbValidationTarget, prbValidationFamilyApp, + prbValidationAlpha, prbValidationBExpr, + FVarsIn, Level.hasMVar'] + constructor + · change (prbValidationBContext.lctx.find? + prbValidationAlphaId).isSome = true + rw [prbValidationAlphaFindInB] + rfl + · change (prbValidationBContext.lctx.find? + prbValidationBId).isSome = true + rw [prbValidationBFind] + rfl) + prbValidationTargetCheckValid + +private theorem prbValidationAlphaRootWhnfSelf : + AddInductive.CandidateWhnfStep.Valid + ⟨prbValidationRootContext, prbValidationAlpha, + prbValidationAlpha⟩ := by + rw [prbValidationAlpha_shape] + apply TypeChecker.candidateWhnfFVar_refl _ _ 9999 + · rfl + · unfold TypeChecker.Inner.isLetFVar + rw [prbValidationAlphaFind] + +private theorem prbValidationAlphaAWhnfSelf : + AddInductive.CandidateWhnfStep.Valid + ⟨prbValidationAContext, prbValidationAlpha, + prbValidationAlpha⟩ := by + rw [prbValidationAlpha_shape] + apply TypeChecker.candidateWhnfFVar_refl _ _ 9999 + · rfl + · unfold TypeChecker.Inner.isLetFVar + rw [prbValidationAlphaFindInA] + +private theorem prbValidationNextDomainWhnfSelf : + AddInductive.CandidateWhnfStep.Valid + ⟨prbValidationAContext, prbValidationNextDomain, + prbValidationNextDomain⟩ := by + apply TypeChecker.CandidateExprIdentityReplay.Shaped.candidateWhnfForallSource_refl + _ _ 9999 + · rfl + · rfl + +private theorem prbValidationTargetWhnfSelf : + AddInductive.CandidateWhnfStep.Valid + ⟨prbValidationBContext, prbValidationTarget, + prbValidationTarget⟩ := by + rw [prbValidationTarget, prbValidationFamilyApp, + prbValidationAlpha_shape, prbValidationBExpr_shape] + apply prbCtorFamilyWhnf prbValidationBContext prbValidationAlphaId + prbValidationBId rfl rfl rfl + rw [show prbValidationBContext.env = prbConstructorContext.env by rfl] + rw [prbFamilyStage.quotInit_eq] + rfl + +private theorem prbValidationTerminalWhnfSelf : + AddInductive.CandidateWhnfStep.Valid + ⟨prbValidationNextContext, prbValidationTerminal, + prbValidationTerminal⟩ := by + rw [prbValidationTerminal, prbValidationFamilyApp, + prbValidationAlpha_shape, prbValidationAExpr_shape] + apply prbCtorFamilyWhnf prbValidationNextContext prbValidationAlphaId + prbValidationAId rfl rfl rfl + rw [show prbValidationNextContext.env = prbConstructorContext.env by rfl] + rw [prbFamilyStage.quotInit_eq] + rfl + +private theorem prbCandidateWhnfResult_eq + (self : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, source⟩) + (other : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, result⟩) : + result = source := by + unfold AddInductive.CandidateWhnfStep.Valid at self other + rw [self] at other + exact (Except.ok.inj other).symm + +noncomputable def prbConstructorValidation : + AddInductive.ConstructorValidationRun propRecursiveBoundaryKernelType + prbFamilyValidationRun.stats false + prbConstructorValidationContext := + AddInductive.ConstructorValidationRun.of_run (by + simpa [prbConstructorValidationContext] using prbCheckConstructorsRun) + +noncomputable def prbStagedUniverseInput : + VInductDecl.StagedNormalizationCandidateUniverseInput + prbFamilyContext prbConstructorContext VEnv.empty [`u] + prbCandidate propRecursiveBoundaryDecl where + staged := { + raw := propRecursiveBoundaryType + raw_types_eq := rfl + declaration_uvars_eq := rfl + preFamily := prbPreFamilyStage + family := prbFamilyStage + validation_nparams_eq := rfl + constructorValidation := prbConstructorValidation + constructors := prbConstructorsStage + familyTypesProduced := prbFamilyTypesProduced + familiesProduced := prbFamiliesProduced } + universeRun := by + simpa [prbFamilyStage, prbConstructorValidationContext] using + prbUniverseRun + +theorem prbStagedStats_eq : + prbStagedUniverseInput.staged.family.validation.stats = + prbFamilyValidationRun.stats := by + rfl + +private theorem prbStagedIndConsts_eq : + prbStagedUniverseInput.staged.family.validation.stats.indConsts = + #[.const propRecursiveBoundaryKernelType.name [.param `u]] := by + rw [prbStagedStats_eq, prbFamilyValidationRun.stats_eq] + simp only [prbFamilyValidationRun, + AddInductive.CandidateExprTrace.singletonCandidateInductiveStats] + rw [show + prbCandidate.families.singleton.familyType.type.context.lparams = [`u] by + rw [prbFamilyCandidateContext_eq] + rfl] + rfl + +private theorem prbValidationAlphaHasNoIndOcc : + AddInductive.hasIndOcc + prbStagedUniverseInput.staged.family.validation.stats.indConsts + prbValidationAlpha = false := by + rw [prbStagedIndConsts_eq] + simp [AddInductive.hasIndOcc, prbValidationAlpha_shape] + +private theorem prbValidationNextDomainHasIndOcc : + AddInductive.hasIndOcc + prbStagedUniverseInput.staged.family.validation.stats.indConsts + prbValidationNextDomain = true := by + rw [prbStagedIndConsts_eq] + simp [AddInductive.hasIndOcc, prbValidationNextDomain, + prbValidationFamilyApp, Expr.constName!] + +private theorem prbValidationTargetHasIndOcc : + AddInductive.hasIndOcc + prbStagedUniverseInput.staged.family.validation.stats.indConsts + prbValidationTarget = true := by + rw [prbStagedIndConsts_eq] + simp [AddInductive.hasIndOcc, prbValidationTarget, + prbValidationFamilyApp, Expr.constName!] + +private def prbValidationAlphaRootAnnotations : + AddInductive.CandidateIsDefEqObservation prbValidationRootContext + prbValidationAlpha prbValidationAlpha := + ⟨AddInductive.candidateIsDefEqRefl prbValidationRootContext + prbValidationAlpha⟩ + +private def prbValidationAlphaAAnnotations : + AddInductive.CandidateIsDefEqObservation prbValidationAContext + prbValidationAlpha prbValidationAlpha := + ⟨AddInductive.candidateIsDefEqRefl prbValidationAContext + prbValidationAlpha⟩ + +private def prbValidationNextDomainAnnotations : + AddInductive.CandidateIsDefEqObservation prbValidationAContext + prbValidationNextDomain prbValidationNextDomain := + ⟨AddInductive.candidateIsDefEqRefl prbValidationAContext + prbValidationNextDomain⟩ + +private noncomputable def prbValidationAlphaPositivityAlignment + (trace : AddInductive.ConstructorPositivityModeTrace + prbStagedUniverseInput.staged.family.validation.stats false + propRecursiveBoundaryKernelCtor.name 1 prbValidationRootContext + prbValidationAlpha) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := by + cases trace with + | skipped unsafeEq => contradiction + | safe unsafeEq positivityTrace => + apply AddInductive.ConstructorPositivityModeAlignmentTrace.safe + cases positivityTrace with + | absent context source result fuel whnf occurs => + have result_eq := prbCandidateWhnfResult_eq + prbValidationAlphaRootWhnfSelf whnf + subst result + exact .absent prbValidationAlphaRootChecked + | forallE context source fuel name domain body binderInfo whnf occurs + domainFree tail => + have result_eq := prbCandidateWhnfResult_eq + prbValidationAlphaRootWhnfSelf whnf + have impossible := congrArg Expr.isForall result_eq + simp [prbValidationAlpha_shape, Expr.isForall] at impossible + | target context source result fuel targetIdx whnf occurs terminal valid => + have result_eq := prbCandidateWhnfResult_eq + prbValidationAlphaRootWhnfSelf whnf + subst result + rw [prbValidationAlphaHasNoIndOcc] at occurs + contradiction + +private def prbTransportPositivityTrace + {context context' : AddInductive.Context} + (context_eq : context = context') + {source source' : Expr} (source_eq : source = source') + (trace : AddInductive.ConstructorPositivityTrace stats ctor argIdx + context source fuel) : + AddInductive.ConstructorPositivityTrace stats ctor argIdx + context' source' fuel := by + subst context' + subst source' + exact trace + +private def prbTransportPositivityAlignment + {context context' : AddInductive.Context} + (context_eq : context = context') + {source source' : Expr} (source_eq : source = source') + (trace : AddInductive.ConstructorPositivityTrace stats ctor argIdx + context source fuel) + (alignment : AddInductive.ConstructorPositivityAlignmentTrace + (prbTransportPositivityTrace context_eq source_eq trace)) : + AddInductive.ConstructorPositivityAlignmentTrace trace := by + subst context' + subst source' + exact alignment + +private noncomputable def prbValidationNextPositivityAlignment + (trace : AddInductive.ConstructorPositivityModeTrace + prbStagedUniverseInput.staged.family.validation.stats false + propRecursiveBoundaryKernelCtor.name 2 prbValidationAContext + prbValidationNextDomain) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := by + cases trace with + | skipped unsafeEq => contradiction + | safe unsafeEq positivityTrace => + apply AddInductive.ConstructorPositivityModeAlignmentTrace.safe + cases positivityTrace with + | absent context source result fuel whnf occurs => + have result_eq := prbCandidateWhnfResult_eq + prbValidationNextDomainWhnfSelf whnf + subst result + rw [prbValidationNextDomainHasIndOcc] at occurs + contradiction + | forallE context source fuel name domain body binderInfo whnf occurs + domainFree tail => + have result_eq := prbCandidateWhnfResult_eq + prbValidationNextDomainWhnfSelf whnf + change (Expr.forallE name domain body binderInfo) = + (Expr.forallE `b prbValidationAlpha + (prbValidationFamilyApp (.bvar 0)) .default) at result_eq + injection result_eq with name_eq domain_eq body_eq binderInfo_eq + subst name + subst domain + subst body + subst binderInfo + have tailContext_eq : + prbValidationAContext.pushLocalDecl `b .default + (AddInductive.consumeTypeAnnotations prbValidationAlpha) = + prbValidationBContext := by + rw [prbValidationConsumeAlpha] + rfl + have tailSource_eq : + (prbValidationFamilyApp (.bvar 0)).instantiate1 + prbValidationAContext.freshExpr = + prbValidationTarget := by + simpa [prbValidationNextDomain, Expr.bindingBody!, + prbValidationBExpr] using prbValidationTarget_shape + let tailNormalized := prbTransportPositivityTrace + tailContext_eq tailSource_eq tail + have tailNormalizedAlignment : + AddInductive.ConstructorPositivityAlignmentTrace + tailNormalized := by + cases htail : tailNormalized with + | absent context source result fuel whnf occurs => + have result_eq := prbCandidateWhnfResult_eq + prbValidationTargetWhnfSelf whnf + subst result + rw [prbValidationTargetHasIndOcc] at occurs + contradiction + | forallE context source fuel name domain body binderInfo whnf + occurs domainFree tail => + have result_eq := prbCandidateWhnfResult_eq + prbValidationTargetWhnfSelf whnf + have impossible := congrArg Expr.isForall result_eq + simp [prbValidationTarget, prbValidationFamilyApp, + Expr.isForall] at impossible + | target context source result fuel targetIdx whnf occurs + terminal valid => + have result_eq := prbCandidateWhnfResult_eq + prbValidationTargetWhnfSelf whnf + subst result + exact .target prbValidationTargetChecked + have tailAlignment := prbTransportPositivityAlignment + tailContext_eq tailSource_eq tail tailNormalizedAlignment + exact .forallE prbValidationNextDomainChecked + prbValidationAlphaAChecked + prbValidationAlphaAConsumedChecked + (.succ (.param `u)) rfl prbValidationAFresh + (by simpa only [prbValidationConsumeAlpha] using + prbValidationAlphaAAnnotations) + tail tailAlignment + | target context source result fuel targetIdx whnf occurs terminal valid => + have result_eq := prbCandidateWhnfResult_eq + prbValidationNextDomainWhnfSelf whnf + subst result + simp [prbValidationNextDomain, Expr.isForall] at terminal + +private def prbTransportValidationTrace + {context context' : AddInductive.Context} + (context_eq : context = context') + {source source' : Expr} (source_eq : source = source') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) : + AddInductive.ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context' source' argIdx fuel := by + subst context' + subst source' + exact trace + +private def prbTransportViewAlignment + {context context' : AddInductive.Context} + (context_eq : context = context') + {source source' view view' : Expr} + (source_eq : source = source') (view_eq : view = view') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) + (alignment : AddInductive.ConstructorViewAlignmentTrace + (prbTransportValidationTrace context_eq source_eq trace) view') : + AddInductive.ConstructorViewAlignmentTrace trace view := by + subst context' + subst source' + subst view' + exact alignment + +@[simp] private theorem prbTransportValidationTrace_spineLength + {context context' : AddInductive.Context} + (context_eq : context = context') + {source source' : Expr} (source_eq : source = source') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) : + (prbTransportValidationTrace context_eq source_eq trace).spineLength = + trace.spineLength := by + subst context' + subst source' + rfl + +private def prbTransportValidationTraceIndexed + {context context' : AddInductive.Context} + (context_eq : context = context') + {source source' : Expr} (source_eq : source = source') + {argIdx argIdx' : Nat} (argIdx_eq : argIdx = argIdx') + {fuel fuel' : Nat} (fuel_eq : fuel = fuel') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) : + AddInductive.ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context' source' argIdx' fuel' := by + subst context' + subst source' + subst argIdx' + subst fuel' + exact trace + +private def prbTransportViewAlignmentIndexed + {context context' : AddInductive.Context} + (context_eq : context = context') + {source source' view view' : Expr} + (source_eq : source = source') (view_eq : view = view') + {argIdx argIdx' : Nat} (argIdx_eq : argIdx = argIdx') + {fuel fuel' : Nat} (fuel_eq : fuel = fuel') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) + (alignment : AddInductive.ConstructorViewAlignmentTrace + (prbTransportValidationTraceIndexed context_eq source_eq argIdx_eq + fuel_eq trace) view') : + AddInductive.ConstructorViewAlignmentTrace trace view := by + subst context' + subst source' + subst view' + subst argIdx' + subst fuel' + exact alignment + +@[simp] private theorem prbTransportValidationTraceIndexed_spineLength + {context context' : AddInductive.Context} + (context_eq : context = context') + {source source' : Expr} (source_eq : source = source') + {argIdx argIdx' : Nat} (argIdx_eq : argIdx = argIdx') + {fuel fuel' : Nat} (fuel_eq : fuel = fuel') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) : + (prbTransportValidationTraceIndexed context_eq source_eq argIdx_eq + fuel_eq trace).spineLength = trace.spineLength := by + subst context' + subst source' + subst argIdx' + subst fuel' + rfl + +set_option pp.universes false in +set_option pp.all false in +noncomputable def prbStagedPostFamilyInput : + VInductDecl.StagedNormalizationCandidatePostFamilyInput + prbFamilyContext prbConstructorContext VEnv.empty [`u] + prbCandidate propRecursiveBoundaryDecl where + universeInput := prbStagedUniverseInput + alignment := by + rw [AddInductive.CandidateList.singleton_eta + prbCandidate.families.singleton.constructors] + change AddInductive.ConstructorCandidateAlignmentTrace + prbStagedUniverseInput.staged.family.validation.stats false 0 + { prbCandidate.families.singleton.familyType.type.trace.terminalContext with + env := prbConstructorContext.env } + prbStagedUniverseInput.staged.constructorValidation.trace + (.cons prbCandidate.families.singleton.constructors.singleton .nil) + generalize htrace : + prbStagedUniverseInput.staged.constructorValidation.trace = trace + cases trace with + | cons seen head constructors fresh closed rootCheck typeTrace tailTrace => + clear htrace + have rootContext_eq : + { prbCandidate.families.singleton.familyType.type.trace.terminalContext with + env := prbConstructorContext.env } = + prbValidationRootContext := by + rw [prbFamilyTerminalContext_eq] + rfl + have rootFuel_eq : + { prbCandidate.families.singleton.familyType.type.trace.terminalContext with + env := prbConstructorContext.env }.fuel.inductiveFuel = 1000 := by + rw [prbFamilyTerminalContext_eq] + rfl + let rootNormalized : + AddInductive.ConstructorTypeValidationTrace + prbStagedUniverseInput.staged.family.validation.stats false 0 + propRecursiveBoundaryKernelCtor.name prbValidationRootContext + propRecursiveBoundaryKernelCtor.type 0 1000 := + prbTransportValidationTraceIndexed rootContext_eq (by rfl) + (by rfl) rootFuel_eq typeTrace + let rootNormalizedTrace := rootNormalized + have rootSpine : typeTrace.spineLength = + rootNormalizedTrace.spineLength := by + exact (prbTransportValidationTraceIndexed_spineLength rootContext_eq + (by rfl) (by rfl) rootFuel_eq typeTrace).symm + cases hroot : rootNormalizedTrace with + | parameter context fuel argIdx name domain body binderInfo param + parameterType parameterAt parameterTypeRun defeq tail => + simp [hroot, + AddInductive.ConstructorTypeValidationTrace.spineLength] at rootSpine + rw [prbStagedStats_eq, prbStatsParams_eq] at parameterAt + simp at parameterAt + subst param + change AddInductive.getType prbValidationAlpha + prbValidationRootContext = .ok parameterType at parameterTypeRun + rw [prbValidationGetTypeAlpha] at parameterTypeRun + injection parameterTypeRun with parameterType_eq + subst parameterType + let afterParamNormalized := prbTransportValidationTrace (by rfl) + prbValidationAfterParam_shape tail + let afterParamNormalizedTrace := afterParamNormalized + have afterParamSpine : tail.spineLength = + afterParamNormalizedTrace.spineLength := by + exact (prbTransportValidationTrace_spineLength (by rfl) + prbValidationAfterParam_shape tail).symm + cases hafterParam : afterParamNormalizedTrace with + | parameter context fuel argIdx name domain body binderInfo param + parameterType parameterAt parameterTypeRun defeq tail => + rw [prbStagedStats_eq, prbStatsParams_eq] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity afterATrace => + simp [hafterParam, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at afterParamSpine + have aContext_eq : + prbValidationRootContext.pushLocalDecl `a .default + (AddInductive.consumeTypeAnnotations + prbValidationAlpha) = + prbValidationAContext := by + rw [prbValidationConsumeAlpha] + rfl + let afterANormalized : + AddInductive.ConstructorTypeValidationTrace + prbStagedUniverseInput.staged.family.validation.stats + false 0 propRecursiveBoundaryKernelCtor.name + prbValidationAContext prbValidationAfterA 2 998 := + prbTransportValidationTrace aContext_eq + prbValidationAfterA_shape afterATrace + let afterANormalizedTrace := afterANormalized + have afterASpine : afterATrace.spineLength = + afterANormalizedTrace.spineLength := by + exact (prbTransportValidationTrace_spineLength aContext_eq + prbValidationAfterA_shape afterATrace).symm + cases hafterA : afterANormalizedTrace with + | parameter context fuel argIdx name domain body binderInfo param + parameterType parameterAt parameterTypeRun defeq tail => + rw [prbStagedStats_eq, prbStatsParams_eq] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo + sortResult noParameter ensureType universeTrace + nextPositivity terminalTrace => + simp [hafterA, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at afterASpine + have nextPositivityAlignment := + prbValidationNextPositivityAlignment nextPositivity + have terminalContext_eq : + prbValidationAContext.pushLocalDecl `next .default + (AddInductive.consumeTypeAnnotations + prbValidationNextDomain) = + prbValidationNextContext := by + rw [prbValidationConsumeNextDomain] + rfl + let terminalNormalized : + AddInductive.ConstructorTypeValidationTrace + prbStagedUniverseInput.staged.family.validation.stats + false 0 propRecursiveBoundaryKernelCtor.name + prbValidationNextContext prbValidationTerminal 3 997 := + prbTransportValidationTrace terminalContext_eq + prbValidationTerminal_shape terminalTrace + let terminalNormalizedTrace := terminalNormalized + have terminalSpine : terminalTrace.spineLength = + terminalNormalizedTrace.spineLength := by + exact (prbTransportValidationTrace_spineLength + terminalContext_eq prbValidationTerminal_shape + terminalTrace).symm + cases hterminal : terminalNormalizedTrace with + | terminal context source fuel argIdx terminal valid => + simp [hterminal, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at terminalSpine + have terminalNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + terminalNormalizedTrace prbValidationTerminal := by + rw [hterminal] + exact .terminal prbValidationTerminalChecked + prbValidationTerminalChecked terminal valid + have terminalAlignment := prbTransportViewAlignment + terminalContext_eq prbValidationTerminal_shape + prbValidationTerminal_shape terminalTrace + terminalNormalizedAlignment + have afterANormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + afterANormalizedTrace prbValidationAfterA := by + rw [hafterA] + exact .ordinary prbValidationNextDomainChecked + prbValidationNextDomainChecked + prbValidationNextDomainAnnotations + (by simpa only [prbValidationConsumeNextDomain] using + prbValidationNextDomainChecked) + nextPositivity nextPositivityAlignment + prbValidationAFresh + (by simpa only [prbValidationConsumeNextDomain] using + prbValidationNextDomainAnnotations) + terminalTrace terminalAlignment + have afterAAlignment := prbTransportViewAlignment + aContext_eq prbValidationAfterA_shape + prbValidationAfterA_shape afterATrace + afterANormalizedAlignment + have afterParamNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + afterParamNormalizedTrace + prbValidationAfterParam := by + rw [hafterParam] + exact .ordinary prbValidationAlphaRootChecked + prbValidationAlphaRootChecked + prbValidationAlphaRootAnnotations + (by simpa only [prbValidationConsumeAlpha] using + prbValidationAlphaRootChecked) + positivity + (prbValidationAlphaPositivityAlignment positivity) + prbValidationRootFresh + (by simpa only [prbValidationConsumeAlpha] using + prbValidationAlphaRootAnnotations) + afterATrace afterAAlignment + have afterParamAlignment := prbTransportViewAlignment + (by rfl) prbValidationAfterParam_shape + prbValidationAfterParam_shape tail + afterParamNormalizedAlignment + have rootNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + rootNormalizedTrace + propRecursiveBoundaryKernelCtor.type := by + rw [hroot] + exact .parameter prbValidationSortChecked + prbValidationSortChecked prbValidationSortChecked + prbValidationAlpha_shape + (by rw [prbValidationAlphaFind]; rfl) + tail afterParamAlignment + have headAlignment := prbTransportViewAlignmentIndexed + rootContext_eq (by rfl) prbCtorView_eq (by rfl) + rootFuel_eq typeTrace rootNormalizedAlignment + let rootScope : + AddInductive.ConstructorCheckedExpr + ({ prbCandidate.families.singleton.familyType.type.trace.terminalContext with + env := prbConstructorContext.env }).withEmptyLocalContext + propRecursiveBoundaryKernelCtor.type := + AddInductive.ConstructorCheckedExpr.ofClosedRoot + closed rootCheck + cases tailTrace with + | nil finalSeen => + exact + AddInductive.ConstructorCandidateAlignmentTrace.cons + rootScope + (by + change + prbCandidate.families.singleton.constructors.singleton.type.trace.storedSpine = + true + exact prbCtorIdentityEvidence.identity.storedSpine) + (by + change + prbCandidate.families.singleton.constructors.singleton.type.trace.spineLength = + typeTrace.spineLength + have candidateSpine := + prbCtorIdentityEvidence.spineLength_eq.trans + prbCtorIdentityReplay_shape.1 + omega) + (by + rw [prbCtorWhnfDepth, rootContext_eq] + rfl) + headAlignment + (AddInductive.ConstructorCandidateAlignmentTrace.nil + ((∅ : NameSet).insert + propRecursiveBoundaryKernelCtor.name)) + | terminal context source fuel argIdx terminal valid => + simp [prbValidationAfterA, Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [prbValidationAfterParam, Expr.isForall] at terminal + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity tail => + rw [prbStagedStats_eq, prbStatsParams_eq] at noParameter + simp at noParameter + | terminal context source fuel argIdx terminal valid => + simp [propRecursiveBoundaryKernelType, propRecursiveBoundaryKernelCtor, + propRecursiveBoundaryMkInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, Expr.isForall] at terminal + +def prbPreFamilyContextReplay : AddInductive.Context := + prbValidationFamilyContext + +def prbPreFamilyAContextReplay : AddInductive.Context := + prbPreFamilyContextReplay.pushLocalDecl `a .default prbValidationAlpha + +def prbPreFamilyBContextReplay : AddInductive.Context := + prbPreFamilyAContextReplay.pushLocalDecl `b .default prbValidationAlpha + +def prbPreFamilyResultContextReplay : AddInductive.Context := + prbPreFamilyAContextReplay.advanceFresh + +def prbPreFamilyIndexTelescopeReplay : Expr := + .forallE prbValidationAName prbValidationAlpha (.sort .zero) .default + +theorem prbPreFamilyContextReplay_eq : + prbPreFamilyContextReplay = prbValidationFamilyContext := by + rfl + +theorem prbPreFamilyAContextReplay_eq : + prbPreFamilyAContextReplay = + { prbValidationAContext with env := prbPreFamilyContextReplay.env } := by + rw [prbPreFamilyAContextReplay, prbValidationAContext, + prbValidationRootContext, prbPreFamilyContextReplay_eq] + rfl + +theorem prbPreFamilyBContextReplay_eq : + prbPreFamilyBContextReplay = + { prbValidationBContext with env := prbPreFamilyContextReplay.env } := by + rw [prbPreFamilyBContextReplay, prbPreFamilyAContextReplay_eq, + prbValidationBContext] + rfl + +theorem prbPreFamilyResultContextReplay_eq : + prbPreFamilyResultContextReplay = + { prbValidationAContext.advanceFresh with + env := prbPreFamilyContextReplay.env } := by + rw [prbPreFamilyResultContextReplay, prbPreFamilyAContextReplay_eq] + rfl + +theorem prbFamilyViewReplay_eq : + prbCandidate.families.singleton.familyType.type.view = + propRecursiveBoundaryKernelType.type := by + apply prbFamilyIdentityEvidence.identity.view_eq_source + · apply TypeChecker.CandidateLocalContextRun.empty + rw [prbFamilyCandidateContext_eq] + rfl + · rw [prbFamilyCandidateContext_eq] + simp [propRecursiveBoundaryKernelType, + propRecursiveBoundaryInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, FVarsIn, Level.hasMVar'] + +theorem prbStagedParamsReplay_eq : + prbStagedUniverseInput.staged.family.validation.stats.params = + #[prbValidationAlpha] := by + rw [prbStagedStats_eq, prbStatsParams_eq] + rfl + +theorem prbStagedNindicesReplay_eq : + prbStagedUniverseInput.staged.family.validation.stats.nindices = #[1] := by + rw [prbStagedStats_eq, prbStatsNindices_eq] + +theorem prbStagedIndConstsReplay_eq : + prbStagedUniverseInput.staged.family.validation.stats.indConsts = + #[.const propRecursiveBoundaryKernelType.name [.param `u]] := by + rw [prbStagedStats_eq, prbFamilyValidationRun.stats_eq] + simp only [prbFamilyValidationRun, + AddInductive.CandidateExprTrace.singletonCandidateInductiveStats] + rw [show + prbCandidate.families.singleton.familyType.type.context.lparams = [`u] by + rw [prbFamilyCandidateContext_eq] + rfl] + rfl + +def prbPreFamilyFVarInferOnlyStateReplay + (id : FVarId) (type : Expr) : TypeChecker.State := + { ({} : TypeChecker.State) with + inferTypeI := ({} : TypeChecker.State).inferTypeI.insert + (.fvar id) type } + +theorem prbPreFamilyFVarInferOnlyReplay + (context : AddInductive.Context) (id : FVarId) (type : Expr) + (find : context.lctx.find? id = + some (.cdecl index id name type bi kind)) + (depth : context.fuel.recDepth = 10000) : + TypeChecker.Inner.inferType (.fvar id) true + (TypeChecker.Methods.withFuel context.fuel.recDepth) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (type, prbPreFamilyFVarInferOnlyStateReplay id type) := by + rw [depth] + change TypeChecker.Inner.inferType' (.fvar id) true + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker + ({} : TypeChecker.State) = _ + unfold TypeChecker.Inner.inferType' + simp [prbPreFamilyFVarInferOnlyStateReplay, + Expr.hasLooseBVars, Expr.looseBVarRange', + TypeChecker.Inner.inferFVar, AddInductive.Context.toTypeChecker, + find, LocalDecl.type, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + +theorem prbPreFamilyFVarEnsureValidReplay + (context : AddInductive.Context) (id : FVarId) (level : Level) + (find : context.lctx.find? id = + some (.cdecl index id name (.sort level) bi kind)) + (depth : context.fuel.recDepth = 10000) : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨context, .fvar id, .sort level⟩ := by + unfold AddInductive.ConstructorEnsureTypeStep.Valid + TypeChecker.ensureType TypeChecker.inferType TypeChecker.ensureSort + TypeChecker.RecM.run TypeChecker.M.run + simp only [readThe, MonadReaderOf.read, ReaderT.read, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind, + Pure.pure, StateT.pure, Except.pure, StateT.run', + Functor.map, Except.map] + rw [show TypeChecker.Inner.inferType (.fvar id) true + (TypeChecker.Methods.withFuel context.fuel.recDepth) + { env := context.env, lctx := context.lctx, + safety := context.safety, lparams := context.lparams, + fuel := context.fuel } + ({} : TypeChecker.State) = + .ok (.sort level, + prbPreFamilyFVarInferOnlyStateReplay id (.sort level)) by + simpa [AddInductive.Context.toTypeChecker] using + prbPreFamilyFVarInferOnlyReplay context id (.sort level) find depth] + rfl + +theorem prbPreFamilyCheckLevelSuccParamReplay + (context : AddInductive.Context) + (lparams : context.lparams = [`u]) : + TypeChecker.Inner.checkLevel context.toTypeChecker + (.succ (.param `u)) = .ok () := by + simp [TypeChecker.Inner.checkLevel, AddInductive.Context.toTypeChecker, + lparams, Level.getUndefParam, Level.forEach, + Level.hasParam_eq, Level.hasParam'] + rfl + +theorem prbPreFamilySortCheckValidReplay + (context : AddInductive.Context) + (lparams : context.lparams = [`u]) + (depth : context.fuel.recDepth = 10000) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, .sort (.succ (.param `u)), + .sort (.succ (.succ (.param `u)))⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + change TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel + (TypeChecker.checkType (.sort (.succ (.param `u)))) = _ + unfold TypeChecker.M.run TypeChecker.checkType TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rw [depth] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' + (.sort (.succ (.param `u))) false + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State)) = _ + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + prbPreFamilyCheckLevelSuccParamReplay context lparams, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rfl + +theorem prbPreFamilySortZeroCheckValidReplay + (context : AddInductive.Context) + (depth : context.fuel.recDepth = 10000) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, .sort .zero, .sort (.succ .zero)⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + change TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel (TypeChecker.checkType (.sort .zero)) = _ + unfold TypeChecker.M.run TypeChecker.checkType TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rw [depth] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' (.sort .zero) false + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State)) = _ + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + TypeChecker.Inner.checkLevel, Level.getUndefParam, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rfl + +@[simp] theorem prbPreFamilyCheckLevelZeroReplay + (context : TypeChecker.Context) : + TypeChecker.Inner.checkLevel context .zero = .ok () := by + simp [TypeChecker.Inner.checkLevel, Level.getUndefParam, + Level.forEach, Level.hasParam_eq, Level.hasParam'] + rfl + +@[simp] theorem prbFVarBeqSortReplay (id : FVarId) (level : Level) : + ((.fvar id : Expr) == .sort level) = false := by + change Expr.eqv (.fvar id) (.sort level) = false + rw [Expr.eqv_eq] + rfl + +def prbPreFamilyTelescopeAlphaStateReplay : TypeChecker.State := + prbReplayInsert ({} : TypeChecker.State) prbValidationAlpha + (.sort (.succ (.param `u))) + +def prbPreFamilyTelescopeInternalIdReplay : FVarId := + ⟨prbPreFamilyTelescopeAlphaStateReplay.ngen.curr⟩ + +def prbPreFamilyTelescopeInternalStateReplay : TypeChecker.State := + { prbPreFamilyTelescopeAlphaStateReplay with + ngen := prbPreFamilyTelescopeAlphaStateReplay.ngen.next } + +def prbPreFamilyTelescopeFinalStateReplay : TypeChecker.State := + prbReplayInsert prbPreFamilyTelescopeInternalStateReplay + (.sort .zero) (.sort (.succ .zero)) + +theorem prbPreFamilyInferSortZeroCoreReplay + (fuel : Nat) (context : TypeChecker.Context) + (state : TypeChecker.State) + (miss : state.inferTypeC[(.sort .zero : Expr)]? = none) : + TypeChecker.Inner.inferType' (.sort .zero) false + (TypeChecker.Methods.withFuel fuel) context state = + .ok (.sort (.succ .zero), + prbReplayInsert state (.sort .zero) (.sort (.succ .zero))) := by + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', miss, + prbPreFamilyCheckLevelZeroReplay, + prbReplayInsert, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + +theorem prbPreFamilyIndexTelescopeCheckValidReplay + (context : AddInductive.Context) + (alphaFind : context.lctx.find? prbValidationAlphaId = + some (.cdecl alphaIndex prbValidationAlphaId alphaName + (.sort (.succ (.param `u))) alphaBi alphaKind)) + (depth : context.fuel.recDepth = 10000) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, prbPreFamilyIndexTelescopeReplay, + .sort (mkLevelIMax' (.succ (.param `u)) (.succ .zero))⟩ := by + have domainRun : TypeChecker.Inner.inferType' + prbValidationAlpha false (TypeChecker.Methods.withFuel 9998) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (.sort (.succ (.param `u)), + prbPreFamilyTelescopeAlphaStateReplay) := by + simpa [prbPreFamilyTelescopeAlphaStateReplay, + prbValidationAlpha_shape] using + prbValidationInferTypeFVarCore 9998 context + ({} : TypeChecker.State) prbValidationAlphaId + (.sort (.succ (.param `u))) Std.HashMap.getElem?_empty alphaFind + have bodyMiss : prbPreFamilyTelescopeInternalStateReplay.inferTypeC[ + (.sort .zero : Expr)]? = none := by + simp [prbPreFamilyTelescopeInternalStateReplay, + prbPreFamilyTelescopeAlphaStateReplay, prbReplayInsert, + prbValidationAlpha_shape] + have bodyRun : TypeChecker.Inner.inferType' + (.sort .zero) false (TypeChecker.Methods.withFuel 9998) + { context.toTypeChecker with + lctx := context.lctx.mkLocalDecl + prbPreFamilyTelescopeInternalIdReplay prbValidationAName + prbValidationAlpha .default } + prbPreFamilyTelescopeInternalStateReplay = + .ok (.sort (.succ .zero), + prbPreFamilyTelescopeFinalStateReplay) := by + simpa [prbPreFamilyTelescopeFinalStateReplay] using + prbPreFamilyInferSortZeroCoreReplay 9998 _ + prbPreFamilyTelescopeInternalStateReplay bodyMiss + have forallRun : TypeChecker.Inner.inferForall + prbPreFamilyIndexTelescopeReplay false + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker + ({} : TypeChecker.State) = + .ok (.sort + (mkLevelIMax' (.succ (.param `u)) (.succ .zero)), + prbPreFamilyTelescopeFinalStateReplay) := by + unfold prbPreFamilyIndexTelescopeReplay TypeChecker.Inner.inferForall + simp only [TypeChecker.Inner.inferForall.loop] + rw [show prbValidationAlpha.instantiateRev #[] = + prbValidationAlpha by + simp [Expr.instantiateRev_eq, Expr.instantiate_eq]] + simp only [Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rw [show TypeChecker.Inner.inferType prbValidationAlpha false + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker + ({} : TypeChecker.State) = + TypeChecker.Inner.inferType' prbValidationAlpha false + (TypeChecker.Methods.withFuel 9998) context.toTypeChecker + ({} : TypeChecker.State) by rfl] + rw [domainRun] + simp only [prbEnsureSortExact] + rw [prbWithLocalDeclEq] + change TypeChecker.Inner.inferForall.loop false + #[Expr.fvar prbPreFamilyTelescopeInternalIdReplay] + #[Level.succ (.param `u)] (.sort .zero) + (TypeChecker.Methods.withFuel 9999) + { context.toTypeChecker with + lctx := context.lctx.mkLocalDecl + prbPreFamilyTelescopeInternalIdReplay prbValidationAName + prbValidationAlpha .default } + prbPreFamilyTelescopeInternalStateReplay = _ + simp only [TypeChecker.Inner.inferForall.loop] + rw [show (.sort .zero : Expr).instantiateRev + #[Expr.fvar prbPreFamilyTelescopeInternalIdReplay] = + .sort .zero by + simp [Expr.instantiateRev_eq, Expr.instantiate_eq]] + simp only [Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rw [show TypeChecker.Inner.inferType (.sort .zero) false + (TypeChecker.Methods.withFuel 9999) _ + prbPreFamilyTelescopeInternalStateReplay = + TypeChecker.Inner.inferType' (.sort .zero) false + (TypeChecker.Methods.withFuel 9998) _ + prbPreFamilyTelescopeInternalStateReplay by rfl] + rw [bodyRun] + simp [Expr.sortLevel!, Pure.pure, ReaderT.pure, + StateT.pure, Except.pure] + have outerRun := prbInferTypeForallCore 9999 context.toTypeChecker + ({} : TypeChecker.State) prbPreFamilyTelescopeFinalStateReplay + prbValidationAName prbValidationAlpha (.sort .zero) + (.sort (mkLevelIMax' (.succ (.param `u)) (.succ .zero))) + .default + (by simp [prbPreFamilyIndexTelescopeReplay, + prbValidationAlpha_shape, Expr.hasLooseBVars, + Expr.looseBVarRange']) Std.HashMap.getElem?_empty forallRun + unfold AddInductive.CandidateCheckTypeStep.Valid + change TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel + (TypeChecker.checkType prbPreFamilyIndexTelescopeReplay) = _ + unfold TypeChecker.M.run TypeChecker.checkType TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rw [depth] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' prbPreFamilyIndexTelescopeReplay false + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker + ({} : TypeChecker.State)) = _ + simpa [prbPreFamilyIndexTelescopeReplay, + Functor.map, Except.map] using + congrArg (Except.map (fun x : Expr × TypeChecker.State => x.1)) + outerRun + +theorem prbPreFamilyAlphaFindReplay : + prbPreFamilyContextReplay.lctx.find? prbValidationAlphaId = + some (.cdecl 0 prbValidationAlphaId `α + (.sort (.succ (.param `u))) .default .default) := by + rw [prbPreFamilyContextReplay_eq] + simpa [prbValidationRootContext] using prbValidationAlphaFind + +theorem prbPreFamilyAlphaFindInAReplay : + prbPreFamilyAContextReplay.lctx.find? prbValidationAlphaId = + some (.cdecl 0 prbValidationAlphaId `α + (.sort (.succ (.param `u))) .default .default) := by + rw [prbPreFamilyAContextReplay_eq] + exact prbValidationAlphaFindInA + +theorem prbPreFamilyAlphaFindInBReplay : + prbPreFamilyBContextReplay.lctx.find? prbValidationAlphaId = + some (.cdecl 0 prbValidationAlphaId `α + (.sort (.succ (.param `u))) .default .default) := by + rw [prbPreFamilyBContextReplay_eq] + exact prbValidationAlphaFindInB + +theorem prbPreFamilyAlphaFindInResultReplay : + prbPreFamilyResultContextReplay.lctx.find? prbValidationAlphaId = + some (.cdecl 0 prbValidationAlphaId `α + (.sort (.succ (.param `u))) .default .default) := by + rw [prbPreFamilyResultContextReplay_eq] + simpa [AddInductive.Context.advanceFresh] using + prbValidationAlphaFindInA + +theorem prbPreFamilyAFindInResultReplay : + prbPreFamilyResultContextReplay.lctx.find? prbValidationAId = + some (.cdecl prbValidationRootContext.lctx.decls.size + prbValidationAId `a prbValidationAlpha .default .default) := by + rw [prbPreFamilyResultContextReplay_eq] + simpa [AddInductive.Context.advanceFresh] using prbValidationAFind + +theorem prbPreFamilyBFindReplay : + prbPreFamilyBContextReplay.lctx.find? prbValidationBId = + some (.cdecl prbValidationAContext.lctx.decls.size + prbValidationBId `b prbValidationAlpha .default .default) := by + rw [prbPreFamilyBContextReplay_eq] + exact prbValidationBFind + +theorem prbPreFamilyRootFreshReplay : + prbPreFamilyContextReplay.lctx.find? + prbPreFamilyContextReplay.freshFVarId = none := by + rw [prbPreFamilyContextReplay_eq] + simpa [prbValidationRootContext, + AddInductive.Context.freshFVarId] using prbValidationRootFresh + +theorem prbPreFamilyAFreshReplay : + prbPreFamilyAContextReplay.lctx.find? + prbPreFamilyAContextReplay.freshFVarId = none := by + rw [prbPreFamilyAContextReplay_eq] + exact prbValidationAFresh + +theorem prbPreFamilyBFreshReplay : + prbPreFamilyBContextReplay.lctx.find? + prbPreFamilyBContextReplay.freshFVarId = none := by + rw [prbPreFamilyBContextReplay_eq] + exact prbValidationBFresh + +theorem prbPreFamilyRootDepthReplay : + prbPreFamilyContextReplay.fuel.recDepth = 10000 := by + rw [prbPreFamilyContextReplay_eq] + rfl + +theorem prbPreFamilyADepthReplay : + prbPreFamilyAContextReplay.fuel.recDepth = 10000 := by + rw [prbPreFamilyAContextReplay_eq] + rfl + +theorem prbPreFamilyBDepthReplay : + prbPreFamilyBContextReplay.fuel.recDepth = 10000 := by + rw [prbPreFamilyBContextReplay_eq] + rfl + +theorem prbPreFamilyResultDepthReplay : + prbPreFamilyResultContextReplay.fuel.recDepth = 10000 := by + rw [prbPreFamilyResultContextReplay_eq] + rfl + +theorem prbPreFamilyRootInductiveFuelReplay : + prbPreFamilyContextReplay.fuel.inductiveFuel = 1000 := by + rw [prbPreFamilyContextReplay_eq] + rfl + +theorem prbPreFamilyAInductiveFuelReplay : + prbPreFamilyAContextReplay.fuel.inductiveFuel = 1000 := by + rw [prbPreFamilyAContextReplay_eq] + rfl + +theorem prbPreFamilyAFreshExprReplay : + prbPreFamilyAContextReplay.freshExpr = prbValidationBExpr := by + rw [prbPreFamilyAContextReplay_eq] + rfl + +theorem prbPreFamilyRootFreshExprReplay : + prbPreFamilyContextReplay.freshExpr = prbValidationAExpr := by + rfl + +theorem prbPreFamilyAlphaHasNoIndOccReplay : + AddInductive.hasIndOcc + prbStagedUniverseInput.staged.family.validation.stats.indConsts + prbValidationAlpha = false := by + rw [prbStagedIndConstsReplay_eq] + simp [AddInductive.hasIndOcc, prbValidationAlpha_shape] + +theorem prbPreFamilyNextDomainHasIndOccReplay : + AddInductive.hasIndOcc + prbStagedUniverseInput.staged.family.validation.stats.indConsts + prbValidationNextDomain = true := by + rw [prbStagedIndConstsReplay_eq] + simp [AddInductive.hasIndOcc, prbValidationNextDomain, + prbValidationFamilyApp, Expr.constName!] + +@[simp] theorem prbValidationFamilyAppGetAppFnReplay (arg : Expr) : + (prbValidationFamilyApp arg).getAppFn = + .const propRecursiveBoundaryKernelType.name [.param `u] := by + rfl + +@[simp] theorem prbValidationFamilyAppGetAppArgsReplay (arg : Expr) : + (prbValidationFamilyApp arg).getAppArgs = + #[prbValidationAlpha, arg] := by + rfl + +@[simp] theorem prbExprBneSelfReplay (source : Expr) : + (source != source) = false := by + change (!Expr.eqv source source) = false + rw [show Expr.eqv source source = true by exact Expr.eqv_refl source] + rfl + +theorem prbPreFamilyFamilyAppValidReplay (arg : Expr) + (argFree : AddInductive.hasIndOcc + prbStagedUniverseInput.staged.family.validation.stats.indConsts + arg = false) : + AddInductive.isValidIndAppIdx + prbStagedUniverseInput.staged.family.validation.stats + (prbValidationFamilyApp arg) 0 = true := by + have parameterSelf : (prbValidationAlpha != prbValidationAlpha) = false := by + change (!Expr.eqv prbValidationAlpha prbValidationAlpha) = false + rw [show Expr.eqv prbValidationAlpha prbValidationAlpha = true by + exact Expr.eqv_refl prbValidationAlpha] + rfl + have argFree' : AddInductive.hasIndOcc + #[.const propRecursiveBoundaryKernelType.name [.param `u]] arg = + false := by + simpa [prbStagedIndConstsReplay_eq] using argFree + simp +decide [AddInductive.isValidIndAppIdx, + prbStagedParamsReplay_eq, prbStagedNindicesReplay_eq, + prbStagedIndConstsReplay_eq, + prbValidationFamilyAppGetAppFnReplay, + prbValidationFamilyAppGetAppArgsReplay, + prbExprBneSelfReplay, parameterSelf, argFree', Expr.constName!] + +theorem prbPreFamilyTargetValidReplay : + AddInductive.isValidIndAppIdx + prbStagedUniverseInput.staged.family.validation.stats + prbValidationTarget 0 = true := by + apply prbPreFamilyFamilyAppValidReplay + rw [prbStagedIndConstsReplay_eq] + simp [AddInductive.hasIndOcc, prbValidationTarget, + prbValidationFamilyApp, prbValidationBExpr_shape] + +theorem prbPreFamilyTerminalValidReplay : + AddInductive.isValidIndAppIdx + prbStagedUniverseInput.staged.family.validation.stats + prbValidationTerminal 0 = true := by + apply prbPreFamilyFamilyAppValidReplay + rw [prbStagedIndConstsReplay_eq] + simp [AddInductive.hasIndOcc, prbValidationTerminal, + prbValidationFamilyApp, prbValidationAExpr_shape] + +theorem prbPreFamilyAIdNeRemovedReplay : + prbValidationAId ≠ prbPreFamilyAContextReplay.freshFVarId := by + intro equality + have fresh := prbPreFamilyAFreshReplay + rw [← equality] at fresh + have found : prbPreFamilyAContextReplay.lctx.find? prbValidationAId = + some (.cdecl prbValidationRootContext.lctx.decls.size + prbValidationAId `a prbValidationAlpha .default .default) := by + rw [prbPreFamilyAContextReplay_eq] + exact prbValidationAFind + rw [found] at fresh + contradiction + +theorem prbPreFamilyAlphaIdNeRemovedReplay : + prbValidationAlphaId ≠ prbPreFamilyAContextReplay.freshFVarId := by + intro equality + have fresh := prbPreFamilyAFreshReplay + rw [← equality, prbPreFamilyAlphaFindInAReplay] at fresh + contradiction + +theorem prbSafetyRunDirect : + AddInductive.checkConstructorPreFamilySafety + prbStagedUniverseInput.staged.family.validation.stats + prbCandidate.families.singleton.familyType.type.view + prbCandidate.families.singleton.constructors + prbCandidate.families.singleton.familyType.type.trace.terminalContext = + .ok () := by + rw [prbFamilyViewReplay_eq] + rw [AddInductive.CandidateList.singleton_eta + prbCandidate.families.singleton.constructors] + rw [prbFamilyTerminalContext_eq] + change AddInductive.checkConstructorPreFamilySafety + prbStagedUniverseInput.staged.family.validation.stats + propRecursiveBoundaryKernelType.type + (.cons prbCandidate.families.singleton.constructors.singleton .nil) + prbPreFamilyContextReplay = .ok () + let rootAlpha : AddInductive.ConstructorCheckedExpr + prbPreFamilyContextReplay prbValidationAlpha := + .ofRun (by + rw [prbValidationAlpha_shape] + change (prbPreFamilyContextReplay.lctx.find? + prbValidationAlphaId).isSome = true + rw [prbPreFamilyAlphaFindReplay] + rfl) + (by + simpa [prbValidationAlpha_shape] using + prbCandidateCheckTypeFVar prbPreFamilyContextReplay + prbValidationAlphaId (.sort (.succ (.param `u))) + prbPreFamilyRootDepthReplay prbPreFamilyAlphaFindReplay) + let rootAlphaEnsure : AddInductive.ConstructorEnsureTypeObservation + prbPreFamilyContextReplay prbValidationAlpha := + ⟨.sort (.succ (.param `u)), by + simpa [prbValidationAlpha_shape] using + prbPreFamilyFVarEnsureValidReplay prbPreFamilyContextReplay + prbValidationAlphaId (.succ (.param `u)) + prbPreFamilyAlphaFindReplay prbPreFamilyRootDepthReplay⟩ + let rootAlphaConsumed : AddInductive.ConstructorCheckedExpr + prbPreFamilyContextReplay + (AddInductive.consumeTypeAnnotations prbValidationAlpha) := by + rw [prbValidationConsumeAlpha] + exact rootAlpha + let rootAlphaAnnotations : AddInductive.CandidateIsDefEqObservation + prbPreFamilyContextReplay prbValidationAlpha + (AddInductive.consumeTypeAnnotations prbValidationAlpha) := by + rw [prbValidationConsumeAlpha] + exact ⟨AddInductive.candidateIsDefEqRefl + prbPreFamilyContextReplay prbValidationAlpha⟩ + let aAlpha : AddInductive.ConstructorCheckedExpr + prbPreFamilyAContextReplay prbValidationAlpha := + .ofRun (by + rw [prbValidationAlpha_shape] + change (prbPreFamilyAContextReplay.lctx.find? + prbValidationAlphaId).isSome = true + rw [prbPreFamilyAlphaFindInAReplay] + rfl) + (by + simpa [prbValidationAlpha_shape] using + prbCandidateCheckTypeFVar prbPreFamilyAContextReplay + prbValidationAlphaId (.sort (.succ (.param `u))) + prbPreFamilyADepthReplay prbPreFamilyAlphaFindInAReplay) + let aAlphaEnsure : AddInductive.ConstructorEnsureTypeObservation + prbPreFamilyAContextReplay prbValidationAlpha := + ⟨.sort (.succ (.param `u)), by + simpa [prbValidationAlpha_shape] using + prbPreFamilyFVarEnsureValidReplay prbPreFamilyAContextReplay + prbValidationAlphaId (.succ (.param `u)) + prbPreFamilyAlphaFindInAReplay prbPreFamilyADepthReplay⟩ + let aAlphaConsumed : AddInductive.ConstructorCheckedExpr + prbPreFamilyAContextReplay + (AddInductive.consumeTypeAnnotations prbValidationAlpha) := by + rw [prbValidationConsumeAlpha] + exact aAlpha + let aAlphaAnnotations : AddInductive.CandidateIsDefEqObservation + prbPreFamilyAContextReplay prbValidationAlpha + (AddInductive.consumeTypeAnnotations prbValidationAlpha) := by + rw [prbValidationConsumeAlpha] + exact ⟨AddInductive.candidateIsDefEqRefl + prbPreFamilyAContextReplay prbValidationAlpha⟩ + let bTelescope : AddInductive.ConstructorCheckedExpr + prbPreFamilyBContextReplay prbPreFamilyIndexTelescopeReplay := + .ofRun (by + simp [prbPreFamilyIndexTelescopeReplay, + prbValidationAlpha_shape, FVarsIn, Level.hasMVar'] + change (prbPreFamilyBContextReplay.lctx.find? + prbValidationAlphaId).isSome = true + rw [prbPreFamilyAlphaFindInBReplay] + rfl) + (prbPreFamilyIndexTelescopeCheckValidReplay + prbPreFamilyBContextReplay prbPreFamilyAlphaFindInBReplay + prbPreFamilyBDepthReplay) + let bArgument : AddInductive.ConstructorCheckedExpr + prbPreFamilyBContextReplay prbValidationBExpr := + .ofRun (by + rw [prbValidationBExpr_shape] + change (prbPreFamilyBContextReplay.lctx.find? + prbValidationBId).isSome = true + rw [prbPreFamilyBFindReplay] + rfl) + (by + simpa [prbValidationBExpr_shape, prbValidationAlpha_shape] using + prbCandidateCheckTypeFVar prbPreFamilyBContextReplay + prbValidationBId prbValidationAlpha prbPreFamilyBDepthReplay + prbPreFamilyBFindReplay) + let bAlpha : AddInductive.ConstructorCheckedExpr + prbPreFamilyBContextReplay prbValidationAlpha := + .ofRun (by + rw [prbValidationAlpha_shape] + change (prbPreFamilyBContextReplay.lctx.find? + prbValidationAlphaId).isSome = true + rw [prbPreFamilyAlphaFindInBReplay] + rfl) + (by + simpa [prbValidationAlpha_shape] using + prbCandidateCheckTypeFVar prbPreFamilyBContextReplay + prbValidationAlphaId (.sort (.succ (.param `u))) + prbPreFamilyBDepthReplay prbPreFamilyAlphaFindInBReplay) + let bSortZero : AddInductive.ConstructorCheckedExpr + prbPreFamilyBContextReplay (.sort .zero) := + .ofRun (by simp [FVarsIn, Level.hasMVar']) + (prbPreFamilySortZeroCheckValidReplay + prbPreFamilyBContextReplay prbPreFamilyBDepthReplay) + let bComparison : AddInductive.CandidateIsDefEqObservation + prbPreFamilyBContextReplay prbValidationAlpha prbValidationAlpha := + ⟨AddInductive.candidateIsDefEqRefl + prbPreFamilyBContextReplay prbValidationAlpha⟩ + let targetSpine : AddInductive.ConstructorPreFamilyIndexSpineTrace + prbPreFamilyBContextReplay prbPreFamilyIndexTelescopeReplay + [prbValidationBExpr] := by + unfold prbPreFamilyIndexTelescopeReplay + exact .cons prbPreFamilyBContextReplay prbValidationAName + prbValidationAlpha (.sort .zero) .default + prbValidationBExpr [] bTelescope + ⟨bArgument, bAlpha, bComparison⟩ + (by + simpa [Expr.instantiate1_eq, Expr.instantiate1'] using + (AddInductive.ConstructorPreFamilyIndexSpineTrace.nil + prbPreFamilyBContextReplay (.sort .zero) bSortZero rfl)) + have targetArgs : prbValidationTarget.getAppArgs.toList.drop + prbStagedUniverseInput.staged.family.validation.stats.params.size = + [prbValidationBExpr] := by + rw [prbStagedParamsReplay_eq] + simp [prbValidationTarget, + prbValidationFamilyAppGetAppArgsReplay] + obtain ⟨targetSpineExact, targetSpineRun⟩ : + ∃ targetSpineExact : + AddInductive.ConstructorPreFamilyIndexSpineTrace + prbPreFamilyBContextReplay prbPreFamilyIndexTelescopeReplay + (prbValidationTarget.getAppArgs.toList.drop + prbStagedUniverseInput.staged.family.validation.stats.params.size), + AddInductive.ConstructorPreFamilyIndexSpineTrace.build + prbPreFamilyBContextReplay prbPreFamilyIndexTelescopeReplay + (prbValidationTarget.getAppArgs.toList.drop + prbStagedUniverseInput.staged.family.validation.stats.params.size) = + .ok targetSpineExact := by + rw [targetArgs] + exact ⟨targetSpine, targetSpine.build_eq⟩ + let targetTrace : AddInductive.ConstructorPreFamilyRecursiveTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyBContextReplay + prbValidationTarget 999 := + .target prbPreFamilyBContextReplay prbValidationTarget + prbPreFamilyTargetValidReplay targetSpineExact + have targetRun : AddInductive.ConstructorPreFamilyRecursiveTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyBContextReplay + prbValidationTarget 999 = .ok targetTrace := by + exact AddInductive.ConstructorPreFamilyRecursiveTrace.target_build_eq + (fuel := 998) rfl prbPreFamilyTargetValidReplay targetSpineExact + obtain ⟨recursiveTargetTrace, recursiveTargetRun⟩ : + ∃ recursiveTargetTrace : AddInductive.ConstructorPreFamilyRecursiveTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyBContextReplay + (prbValidationNextDomain.bindingBody!.instantiate1 + prbPreFamilyAContextReplay.freshExpr) 999, + AddInductive.ConstructorPreFamilyRecursiveTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyBContextReplay + (prbValidationNextDomain.bindingBody!.instantiate1 + prbPreFamilyAContextReplay.freshExpr) 999 = + .ok recursiveTargetTrace := by + rw [show prbValidationNextDomain.bindingBody!.instantiate1 + prbPreFamilyAContextReplay.freshExpr = prbValidationTarget by + rw [prbPreFamilyAFreshExprReplay] + exact prbValidationTarget_shape] + exact ⟨targetTrace, targetRun⟩ + have recursiveTailContext_eq : + prbPreFamilyAContextReplay.pushLocalDecl `b .default + (AddInductive.consumeTypeAnnotations prbValidationAlpha) = + prbPreFamilyBContextReplay := by + rw [prbValidationConsumeAlpha] + rfl + have recursiveTailSource_eq : + (prbValidationFamilyApp (.bvar 0)).instantiate1 + prbPreFamilyAContextReplay.freshExpr = + prbValidationTarget := by + rw [prbPreFamilyAFreshExprReplay] + simpa [prbValidationNextDomain, Expr.bindingBody!] using + prbValidationTarget_shape + let recursiveTailSpineExact : + AddInductive.ConstructorPreFamilyIndexSpineTrace + (prbPreFamilyAContextReplay.pushLocalDecl `b .default + (AddInductive.consumeTypeAnnotations prbValidationAlpha)) + prbPreFamilyIndexTelescopeReplay + (((prbValidationFamilyApp (.bvar 0)).instantiate1 + prbPreFamilyAContextReplay.freshExpr).getAppArgs.toList.drop + prbStagedUniverseInput.staged.family.validation.stats.params.size) := by + rw [recursiveTailContext_eq, recursiveTailSource_eq] + exact targetSpineExact + have recursiveTailValid : AddInductive.isValidIndAppIdx + prbStagedUniverseInput.staged.family.validation.stats + ((prbValidationFamilyApp (.bvar 0)).instantiate1 + prbPreFamilyAContextReplay.freshExpr) 0 = true := by + rw [recursiveTailSource_eq] + exact prbPreFamilyTargetValidReplay + let recursiveTargetTraceExact : + AddInductive.ConstructorPreFamilyRecursiveTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay + (prbPreFamilyAContextReplay.pushLocalDecl `b .default + (AddInductive.consumeTypeAnnotations prbValidationAlpha)) + ((prbValidationFamilyApp (.bvar 0)).instantiate1 + prbPreFamilyAContextReplay.freshExpr) 999 := + .target _ _ recursiveTailValid recursiveTailSpineExact + have recursiveTargetRunExact : + AddInductive.ConstructorPreFamilyRecursiveTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay + (prbPreFamilyAContextReplay.pushLocalDecl `b .default + (AddInductive.consumeTypeAnnotations prbValidationAlpha)) + ((prbValidationFamilyApp (.bvar 0)).instantiate1 + prbPreFamilyAContextReplay.freshExpr) 999 = + .ok recursiveTargetTraceExact := by + exact AddInductive.ConstructorPreFamilyRecursiveTrace.target_build_eq + (fuel := 998) (by rw [recursiveTailSource_eq]; rfl) + recursiveTailValid recursiveTailSpineExact + let recursiveFieldTrace : + AddInductive.ConstructorPreFamilyRecursiveTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyAContextReplay + prbValidationNextDomain 1000 := + .forallE prbPreFamilyAContextReplay `b prbValidationAlpha + (prbValidationFamilyApp (.bvar 0)) .default aAlpha aAlphaEnsure + aAlphaConsumed aAlphaAnnotations prbPreFamilyAFreshReplay + recursiveTargetTraceExact + have recursiveFieldRun : + AddInductive.ConstructorPreFamilyRecursiveTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyAContextReplay + prbValidationNextDomain 1000 = .ok recursiveFieldTrace := by + unfold prbValidationNextDomain + exact AddInductive.ConstructorPreFamilyRecursiveTrace.forallE_build_eq + aAlpha aAlphaEnsure aAlphaConsumed aAlphaAnnotations + prbPreFamilyAFreshReplay recursiveTargetTraceExact + recursiveTargetRunExact + obtain ⟨recursiveFieldTraceAtContext, recursiveFieldRunAtContext⟩ : + ∃ recursiveFieldTraceAtContext : + AddInductive.ConstructorPreFamilyRecursiveTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyAContextReplay + prbValidationNextDomain + prbPreFamilyAContextReplay.fuel.inductiveFuel, + AddInductive.ConstructorPreFamilyRecursiveTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyAContextReplay + prbValidationNextDomain + prbPreFamilyAContextReplay.fuel.inductiveFuel = + .ok recursiveFieldTraceAtContext := by + rw [prbPreFamilyAInductiveFuelReplay] + exact ⟨recursiveFieldTrace, recursiveFieldRun⟩ + let resultTelescope : AddInductive.ConstructorCheckedExpr + prbPreFamilyResultContextReplay prbPreFamilyIndexTelescopeReplay := + .ofRun (by + simp [prbPreFamilyIndexTelescopeReplay, + prbValidationAlpha_shape, FVarsIn, Level.hasMVar'] + change (prbPreFamilyResultContextReplay.lctx.find? + prbValidationAlphaId).isSome = true + rw [prbPreFamilyAlphaFindInResultReplay] + rfl) + (prbPreFamilyIndexTelescopeCheckValidReplay + prbPreFamilyResultContextReplay prbPreFamilyAlphaFindInResultReplay + prbPreFamilyResultDepthReplay) + let resultArgument : AddInductive.ConstructorCheckedExpr + prbPreFamilyResultContextReplay prbValidationAExpr := + .ofRun (by + rw [prbValidationAExpr_shape] + change (prbPreFamilyResultContextReplay.lctx.find? + prbValidationAId).isSome = true + rw [prbPreFamilyAFindInResultReplay] + rfl) + (by + simpa [prbValidationAExpr_shape, prbValidationAlpha_shape] using + prbCandidateCheckTypeFVar prbPreFamilyResultContextReplay + prbValidationAId prbValidationAlpha + prbPreFamilyResultDepthReplay prbPreFamilyAFindInResultReplay) + let resultAlpha : AddInductive.ConstructorCheckedExpr + prbPreFamilyResultContextReplay prbValidationAlpha := + .ofRun (by + rw [prbValidationAlpha_shape] + change (prbPreFamilyResultContextReplay.lctx.find? + prbValidationAlphaId).isSome = true + rw [prbPreFamilyAlphaFindInResultReplay] + rfl) + (by + simpa [prbValidationAlpha_shape] using + prbCandidateCheckTypeFVar prbPreFamilyResultContextReplay + prbValidationAlphaId (.sort (.succ (.param `u))) + prbPreFamilyResultDepthReplay + prbPreFamilyAlphaFindInResultReplay) + let resultSortZero : AddInductive.ConstructorCheckedExpr + prbPreFamilyResultContextReplay (.sort .zero) := + .ofRun (by simp [FVarsIn, Level.hasMVar']) + (prbPreFamilySortZeroCheckValidReplay + prbPreFamilyResultContextReplay prbPreFamilyResultDepthReplay) + let resultComparison : AddInductive.CandidateIsDefEqObservation + prbPreFamilyResultContextReplay prbValidationAlpha + prbValidationAlpha := + ⟨AddInductive.candidateIsDefEqRefl + prbPreFamilyResultContextReplay prbValidationAlpha⟩ + let resultSpine : AddInductive.ConstructorPreFamilyIndexSpineTrace + prbPreFamilyResultContextReplay prbPreFamilyIndexTelescopeReplay + [prbValidationAExpr] := by + unfold prbPreFamilyIndexTelescopeReplay + exact .cons prbPreFamilyResultContextReplay prbValidationAName + prbValidationAlpha (.sort .zero) .default + prbValidationAExpr [] resultTelescope + ⟨resultArgument, resultAlpha, resultComparison⟩ + (by + simpa [Expr.instantiate1_eq, Expr.instantiate1'] using + (AddInductive.ConstructorPreFamilyIndexSpineTrace.nil + prbPreFamilyResultContextReplay (.sort .zero) + resultSortZero rfl)) + have resultArgs : prbValidationTerminal.getAppArgs.toList.drop + prbStagedUniverseInput.staged.family.validation.stats.params.size = + [prbValidationAExpr] := by + rw [prbStagedParamsReplay_eq] + simp [prbValidationTerminal, + prbValidationFamilyAppGetAppArgsReplay] + obtain ⟨resultSpineExact, resultSpineRun⟩ : + ∃ resultSpineExact : + AddInductive.ConstructorPreFamilyIndexSpineTrace + prbPreFamilyResultContextReplay prbPreFamilyIndexTelescopeReplay + (prbValidationTerminal.getAppArgs.toList.drop + prbStagedUniverseInput.staged.family.validation.stats.params.size), + AddInductive.ConstructorPreFamilyIndexSpineTrace.build + prbPreFamilyResultContextReplay prbPreFamilyIndexTelescopeReplay + (prbValidationTerminal.getAppArgs.toList.drop + prbStagedUniverseInput.staged.family.validation.stats.params.size) = + .ok resultSpineExact := by + rw [resultArgs] + exact ⟨resultSpine, resultSpine.build_eq⟩ + have resultIndependent : AddInductive.constructorIndependentOf + prbValidationTerminal + [prbPreFamilyAContextReplay.freshFVarId] = true := by + simp [AddInductive.constructorIndependentOf, + prbValidationTerminal, prbValidationFamilyApp, + Expr.fvarsList, prbValidationAlpha_shape, + prbValidationAExpr_shape, + prbPreFamilyAlphaIdNeRemovedReplay, + prbPreFamilyAIdNeRemovedReplay] + let resultTrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyResultContextReplay + prbValidationTerminal 3 + [prbPreFamilyAContextReplay.freshFVarId] true := + .terminal prbPreFamilyResultContextReplay prbValidationTerminal 3 + [prbPreFamilyAContextReplay.freshFVarId] true + prbPreFamilyTerminalValidReplay resultIndependent resultSpineExact + have resultRun : AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyResultContextReplay + prbValidationTerminal 3 + [prbPreFamilyAContextReplay.freshFVarId] true 997 = + .ok resultTrace := by + exact AddInductive.ConstructorPreFamilyViewTrace.terminal_build_eq + (fuel := 996) rfl prbPreFamilyTerminalValidReplay resultIndependent + resultSpineExact + obtain ⟨recursiveViewTailTrace, recursiveViewTailRun⟩ : + ∃ recursiveViewTailTrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay + prbPreFamilyAContextReplay.advanceFresh + (prbValidationAfterA.bindingBody!.instantiate1 + prbPreFamilyAContextReplay.freshExpr) 3 + [prbPreFamilyAContextReplay.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay + prbPreFamilyAContextReplay.advanceFresh + (prbValidationAfterA.bindingBody!.instantiate1 + prbPreFamilyAContextReplay.freshExpr) 3 + [prbPreFamilyAContextReplay.freshFVarId] true 997 = + .ok recursiveViewTailTrace := by + rw [show prbPreFamilyAContextReplay.advanceFresh = + prbPreFamilyResultContextReplay by rfl] + rw [show prbValidationAfterA.bindingBody!.instantiate1 + prbPreFamilyAContextReplay.freshExpr = prbValidationTerminal by + simp [prbValidationAfterA, prbValidationTerminal, + prbValidationFamilyApp, Expr.bindingBody!, + Expr.instantiate1_eq, Expr.instantiate1']] + exact ⟨resultTrace, resultRun⟩ + obtain ⟨recursiveViewTailTraceExact, recursiveViewTailRunExact⟩ : + ∃ recursiveViewTailTraceExact : + AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay + prbPreFamilyAContextReplay.advanceFresh + ((prbValidationFamilyApp prbValidationAExpr).instantiate1 + prbPreFamilyAContextReplay.freshExpr) 3 + [prbPreFamilyAContextReplay.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay + prbPreFamilyAContextReplay.advanceFresh + ((prbValidationFamilyApp prbValidationAExpr).instantiate1 + prbPreFamilyAContextReplay.freshExpr) 3 + [prbPreFamilyAContextReplay.freshFVarId] true 997 = + .ok recursiveViewTailTraceExact := by + change ∃ recursiveViewTailTraceExact : + AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay + prbPreFamilyAContextReplay.advanceFresh + (prbValidationAfterA.bindingBody!.instantiate1 + prbPreFamilyAContextReplay.freshExpr) 3 + [prbPreFamilyAContextReplay.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay + prbPreFamilyAContextReplay.advanceFresh + (prbValidationAfterA.bindingBody!.instantiate1 + prbPreFamilyAContextReplay.freshExpr) 3 + [prbPreFamilyAContextReplay.freshFVarId] true 997 = + .ok recursiveViewTailTraceExact + exact ⟨recursiveViewTailTrace, recursiveViewTailRun⟩ + have noParameterTwo : + prbStagedUniverseInput.staged.family.validation.stats.params[2]? = + none := by + rw [prbStagedParamsReplay_eq] + rfl + have recursiveIndependent : AddInductive.constructorIndependentOf + prbValidationNextDomain [] = true := by + simp [AddInductive.constructorIndependentOf] + let recursiveViewTrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyAContextReplay + (.forallE `next prbValidationNextDomain + (prbValidationFamilyApp prbValidationAExpr) .default) + 2 [] false := + .recursive prbPreFamilyAContextReplay 2 [] false `next + prbValidationNextDomain (prbValidationFamilyApp prbValidationAExpr) + .default noParameterTwo prbPreFamilyNextDomainHasIndOccReplay + recursiveIndependent recursiveFieldTraceAtContext + prbPreFamilyAFreshReplay recursiveViewTailTraceExact + have recursiveViewRun : AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyAContextReplay + (.forallE `next prbValidationNextDomain + (prbValidationFamilyApp prbValidationAExpr) .default) + 2 [] false 998 = + .ok recursiveViewTrace := by + simp only [prbValidationAfterA, + AddInductive.ConstructorPreFamilyViewTrace.build] + split + · rename_i parameter parameterAt + rw [noParameterTwo] at parameterAt + contradiction + · split + · rename_i nonrecursive + rw [prbPreFamilyNextDomainHasIndOccReplay] at nonrecursive + contradiction + · rw [dif_pos recursiveIndependent] + rw [recursiveFieldRunAtContext] + simp only [Bind.bind, Except.bind] + rw [dif_pos prbPreFamilyAFreshReplay] + rw [recursiveViewTailRunExact] + rfl + obtain ⟨afterATrace, afterARun⟩ : + ∃ afterATrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyAContextReplay + prbValidationAfterA 2 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyAContextReplay + prbValidationAfterA 2 [] false 998 = .ok afterATrace := by + change ∃ afterATrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyAContextReplay + (.forallE `next prbValidationNextDomain + (prbValidationFamilyApp prbValidationAExpr) .default) + 2 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyAContextReplay + (.forallE `next prbValidationNextDomain + (prbValidationFamilyApp prbValidationAExpr) .default) + 2 [] false 998 = .ok afterATrace + exact ⟨recursiveViewTrace, recursiveViewRun⟩ + obtain ⟨ordinaryTailTrace, ordinaryTailRun⟩ : + ∃ ordinaryTailTrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay + (prbPreFamilyContextReplay.pushLocalDecl `a .default + (AddInductive.consumeTypeAnnotations prbValidationAlpha)) + (prbValidationAfterParam.bindingBody!.instantiate1 + prbPreFamilyContextReplay.freshExpr) 2 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay + (prbPreFamilyContextReplay.pushLocalDecl `a .default + (AddInductive.consumeTypeAnnotations prbValidationAlpha)) + (prbValidationAfterParam.bindingBody!.instantiate1 + prbPreFamilyContextReplay.freshExpr) 2 [] false 998 = + .ok ordinaryTailTrace := by + rw [prbValidationConsumeAlpha] + rw [show prbPreFamilyContextReplay.pushLocalDecl `a .default + prbValidationAlpha = prbPreFamilyAContextReplay by rfl] + rw [show prbValidationAfterParam.bindingBody!.instantiate1 + prbPreFamilyContextReplay.freshExpr = prbValidationAfterA by + rw [prbPreFamilyRootFreshExprReplay] + exact prbValidationAfterA_shape] + exact ⟨afterATrace, afterARun⟩ + have noParameterOne : + prbStagedUniverseInput.staged.family.validation.stats.params[1]? = + none := by + rw [prbStagedParamsReplay_eq] + rfl + have rootIndependent : AddInductive.constructorIndependentOf + prbValidationAlpha [] = true := by + simp [AddInductive.constructorIndependentOf] + let ordinaryViewTrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + (.forallE `a prbValidationAlpha + (.forallE `next prbValidationNextDomain + (prbValidationFamilyApp (.bvar 1)) .default) .default) + 1 [] false := + .ordinary prbPreFamilyContextReplay 1 [] false `a + prbValidationAlpha + (.forallE `next prbValidationNextDomain + (prbValidationFamilyApp (.bvar 1)) .default) + .default noParameterOne prbPreFamilyAlphaHasNoIndOccReplay + rootIndependent rootAlpha rootAlphaEnsure rootAlphaConsumed + rootAlphaAnnotations prbPreFamilyRootFreshReplay ordinaryTailTrace + have ordinaryViewRun : AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + (.forallE `a prbValidationAlpha + (.forallE `next prbValidationNextDomain + (prbValidationFamilyApp (.bvar 1)) .default) .default) + 1 [] false 999 = .ok ordinaryViewTrace := by + simp only [AddInductive.ConstructorPreFamilyViewTrace.build] + split + · rename_i parameter parameterAt + rw [noParameterOne] at parameterAt + contradiction + · split + · rw [dif_pos rootIndependent] + rw [rootAlpha.check_eq, rootAlphaEnsure.observe_eq, + rootAlphaConsumed.check_eq] + simp only [Bind.bind, Except.bind] + rw [rootAlphaAnnotations.observe_eq] + simp only [Bind.bind, Except.bind] + rw [dif_pos prbPreFamilyRootFreshReplay] + have ordinaryTailRun' : + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay + (prbPreFamilyContextReplay.pushLocalDecl `a .default + (AddInductive.consumeTypeAnnotations prbValidationAlpha)) + ((Expr.forallE `next prbValidationNextDomain + (prbValidationFamilyApp (.bvar 1)) .default).instantiate1 + prbPreFamilyContextReplay.freshExpr) + 2 [] false 998 = .ok ordinaryTailTrace := by + simpa only [prbValidationAfterParam, Expr.bindingBody!] using + ordinaryTailRun + rw [ordinaryTailRun'] + rfl + · rename_i recursive + rw [prbPreFamilyAlphaHasNoIndOccReplay] at recursive + contradiction + obtain ⟨afterParamTrace, afterParamRun⟩ : + ∃ afterParamTrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + prbValidationAfterParam 1 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + prbValidationAfterParam 1 [] false 999 = + .ok afterParamTrace := by + change ∃ afterParamTrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + (.forallE `a prbValidationAlpha + (.forallE `next prbValidationNextDomain + (prbValidationFamilyApp (.bvar 1)) .default) .default) + 1 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + (.forallE `a prbValidationAlpha + (.forallE `next prbValidationNextDomain + (prbValidationFamilyApp (.bvar 1)) .default) .default) + 1 [] false 999 = .ok afterParamTrace + exact ⟨ordinaryViewTrace, ordinaryViewRun⟩ + obtain ⟨parameterTailTrace, parameterTailRun⟩ : + ∃ parameterTailTrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + (propRecursiveBoundaryKernelCtor.type.bindingBody!.instantiate1 + prbValidationAlpha) 1 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + (propRecursiveBoundaryKernelCtor.type.bindingBody!.instantiate1 + prbValidationAlpha) 1 [] false 999 = + .ok parameterTailTrace := by + rw [prbValidationAfterParam_shape] + exact ⟨afterParamTrace, afterParamRun⟩ + have parameterAtZero : + prbStagedUniverseInput.staged.family.validation.stats.params[0]? = + some prbValidationAlpha := by + rw [prbStagedParamsReplay_eq] + rfl + obtain ⟨rawViewTrace, rawViewRun⟩ : + ∃ rawViewTrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + propRecursiveBoundaryKernelCtor.type 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + propRecursiveBoundaryKernelCtor.type 0 [] false 1000 = + .ok rawViewTrace := by + change ∃ rawViewTrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + (.forallE `α (.sort (.succ (.param `u))) + propRecursiveBoundaryKernelCtor.type.bindingBody! .implicit) + 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + (.forallE `α (.sort (.succ (.param `u))) + propRecursiveBoundaryKernelCtor.type.bindingBody! .implicit) + 0 [] false 1000 = .ok rawViewTrace + let rawViewTrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + (.forallE `α (.sort (.succ (.param `u))) + propRecursiveBoundaryKernelCtor.type.bindingBody! .implicit) + 0 [] false := + .parameter prbPreFamilyContextReplay 0 [] false `α + (.sort (.succ (.param `u))) + propRecursiveBoundaryKernelCtor.type.bindingBody! .implicit + prbValidationAlpha parameterAtZero parameterTailTrace + refine ⟨rawViewTrace, ?_⟩ + simp only [AddInductive.ConstructorPreFamilyViewTrace.build] + split + · rename_i parameter parameterAt + rw [parameterAtZero] at parameterAt + cases parameterAt + rw [parameterTailRun] + rfl + · rename_i noParameter + rw [parameterAtZero] at noParameter + contradiction + obtain ⟨headTrace, headRun⟩ : + ∃ headTrace : AddInductive.ConstructorPreFamilyViewTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + prbCandidate.families.singleton.constructors.singleton.type.view + 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + prbCandidate.families.singleton.constructors.singleton.type.view + 0 [] false 1000 = .ok headTrace := by + rw [prbCtorView_eq] + exact ⟨rawViewTrace, rawViewRun⟩ + let listTrace : AddInductive.ConstructorPreFamilyListTrace + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + (.cons prbCandidate.families.singleton.constructors.singleton .nil) := + .cons headTrace .nil + have listRun : AddInductive.ConstructorPreFamilyListTrace.build + prbStagedUniverseInput.staged.family.validation.stats 0 + prbPreFamilyIndexTelescopeReplay prbPreFamilyContextReplay + (.cons prbCandidate.families.singleton.constructors.singleton .nil) = + .ok listTrace := by + exact AddInductive.ConstructorPreFamilyListTrace.cons_build_eq + headTrace (by + rw [prbPreFamilyRootInductiveFuelReplay] + exact headRun) + .nil rfl + have parametersRun : AddInductive.instantiateFamilyParameters + propRecursiveBoundaryKernelType.type + prbStagedUniverseInput.staged.family.validation.stats.params.toList = + .ok prbPreFamilyIndexTelescopeReplay := by + rw [prbStagedParamsReplay_eq] + simp [propRecursiveBoundaryKernelType, + propRecursiveBoundaryInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, + AddInductive.instantiateFamilyParameters, + prbPreFamilyIndexTelescopeReplay, prbValidationAlpha, + prbValidationAName, Expr.bindingName!, + Expr.instantiate1_eq, Expr.instantiate1', + Pure.pure, Except.pure] + unfold AddInductive.checkConstructorPreFamilySafety + have translationUnique : + (AddInductive.theoryTranslationUnique + propRecursiveBoundaryKernelType.type && + (AddInductive.CandidateList.cons + prbCandidate.families.singleton.constructors.singleton + (AddInductive.CandidateList.nil : AddInductive.CandidateList + AddInductive.CandidateConstructor [])).viewTranslationUnique) = + true := by + change (AddInductive.theoryTranslationUnique + propRecursiveBoundaryKernelType.type && + (prbCandidate.families.singleton.constructors.singleton.type.trace.viewTranslationUnique && + true)) = true + rw [prbCandidate.families.singleton.constructors.singleton.type.trace.viewTranslationUnique_eq] + change (AddInductive.theoryTranslationUnique + propRecursiveBoundaryKernelType.type && + (AddInductive.theoryTranslationUnique + prbCandidate.families.singleton.constructors.singleton.type.view && + true)) = true + rw [prbCtorView_eq] + simp [AddInductive.theoryTranslationUnique, + propRecursiveBoundaryKernelType, propRecursiveBoundaryKernelCtor, + propRecursiveBoundaryInfo, propRecursiveBoundaryMkInfo, + ConstantInfo.type, ConstantInfo.toConstantVal] + rw [if_pos translationUnique] + rw [parametersRun] + simp only [Bind.bind, Except.bind] + rw [listRun] + rfl + +theorem prbSafetyRun : + AddInductive.checkConstructorPreFamilySafety + prbStagedPostFamilyInput.universeInput.staged.family.validation.stats + prbCandidate.families.singleton.familyType.type.view + prbCandidate.families.singleton.constructors + prbCandidate.families.singleton.familyType.type.trace.terminalContext = + .ok () := by + simpa [prbStagedPostFamilyInput, + VInductDecl.StagedNormalizationCandidatePostFamilyInput.ofRun] using + prbSafetyRunDirect + +noncomputable def prbStagedPreFamilyInput : + VInductDecl.StagedNormalizationCandidatePreFamilyInput + prbFamilyContext prbConstructorContext VEnv.empty [`u] + prbCandidate propRecursiveBoundaryDecl := + VInductDecl.StagedNormalizationCandidatePreFamilyInput.ofRun + prbStagedPostFamilyInput prbSafetyRun + +/-! ## Structural CVM constructor-validity replay -/ + +def cvmValidationAlphaContextTest : AddInductive.Context := + cvmFamilyContext.pushLocalDecl `α .default (.sort (.succ (.param `u))) + +def cvmValidationIndexNameTest : Name := + constructorValidityMatrixKernelType.type.bindingBody! + |>.bindingDomain!.bindingName! + +def cvmValidationPDomainTest : Expr := + .forallE cvmValidationIndexNameTest cvmFamilyContext.freshExpr + (.sort .zero) .default + +def cvmValidationFamilyContextTest : AddInductive.Context := + cvmValidationAlphaContextTest.pushLocalDecl `P .default + cvmValidationPDomainTest + +theorem cvmFamilyTerminalContextTest_eq : + cvmCandidate.families.singleton.familyType.type.trace.terminalContext = + cvmValidationFamilyContextTest := by + have identity := cvmFamilyIdentityEvidence.identity + have spineLength := cvmFamilyIdentityEvidence.spineLength_eq + generalize htrace : + cvmCandidate.families.singleton.familyType.type.trace = trace at identity spineLength ⊢ + cases identity with + | terminal result_eq => + simp only [AddInductive.CandidateExprTrace.spineLength] at spineLength + rw [cvmFamilyIdentityReplay_shape.1] at spineLength + omega + | forallE domainCandidate bodyCandidate source_eq consumed_eq + domainIdentity bodyIdentity => + simp only [AddInductive.CandidateExprTrace.spineLength, + AddInductive.CandidateExprTrace.terminalContext] + cases bodyIdentity with + | terminal result_eq => + simp only [AddInductive.CandidateExprTrace.spineLength] at spineLength + rw [cvmFamilyIdentityReplay_shape.1] at spineLength + omega + | forallE domainCandidate' bodyCandidate' source_eq' consumed_eq' + domainIdentity' bodyIdentity' => + cases bodyIdentity' with + | terminal result_eq => + simp only [AddInductive.CandidateExprTrace.terminalContext] + simp [constructorValidityMatrixKernelType, + constructorValidityMatrixInfo, ConstantInfo.type, + ConstantInfo.toConstantVal] at source_eq + rcases source_eq with ⟨rfl, rfl, rfl, rfl⟩ + simp [Expr.instantiate1_eq, Expr.instantiate1'] at source_eq' + rcases source_eq' with ⟨rfl, rfl, rfl, rfl⟩ + rw [consumed_eq, consumed_eq', cvmFamilyCandidateContext_eq] + rfl + | forallE domainCandidate'' bodyCandidate'' source_eq'' consumed_eq'' + domainIdentity'' bodyIdentity'' => + simp only [AddInductive.CandidateExprTrace.spineLength] at spineLength + rw [cvmFamilyIdentityReplay_shape.1] at spineLength + omega + +def cvmConstructorValidationContextTest : AddInductive.Context := + { cvmCandidate.families.singleton.familyType.type.trace.terminalContext with + env := cvmConstructorContext.env } + +theorem cvmConstructorValidationContextTest_eq : + cvmConstructorValidationContextTest = + { cvmValidationFamilyContextTest with env := cvmConstructorContext.env } := by + rw [cvmConstructorValidationContextTest, cvmFamilyTerminalContextTest_eq] + +def cvmValidationRootContextTest : AddInductive.Context := + { cvmValidationFamilyContextTest with env := cvmConstructorContext.env } + +theorem cvmConstructorValidationContextTest_root : + cvmConstructorValidationContextTest = cvmValidationRootContextTest := by + rw [cvmConstructorValidationContextTest_eq] + rfl + +def cvmValidationAlphaLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmValidationAlphaContextTest := + (TypeChecker.CandidateLocalContextRun.empty cvmFamilyContext rfl).push + `α .default (.sort (.succ (.param `u))) + +def cvmValidationFamilyLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmValidationFamilyContextTest := + cvmValidationAlphaLocalRunTest.push `P .default cvmValidationPDomainTest + +def cvmValidationRootLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmValidationRootContextTest where + wf := cvmValidationFamilyLocalRunTest.wf + reserves := cvmValidationFamilyLocalRunTest.reserves + +def cvmValidationAlphaIdTest : FVarId := cvmFamilyContext.freshFVarId + +def cvmValidationPIdTest : FVarId := + cvmValidationAlphaContextTest.freshFVarId + +theorem cvmValidationPDomainShapeTest : + cvmValidationPDomainTest = + .forallE cvmValidationIndexNameTest + (.fvar cvmValidationAlphaIdTest) (.sort .zero) .default := by + rfl + +theorem cvmValidationAlphaFindTest : + cvmValidationRootContextTest.lctx.find? cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := by + have first := + (TypeChecker.CandidateLocalContextRun.empty cvmFamilyContext rfl).push_findNew + `α .default (.sort (.succ (.param `u))) + have old := cvmValidationAlphaLocalRunTest.push_findOld + `P .default cvmValidationPDomainTest first + simpa [cvmValidationRootContextTest, cvmValidationFamilyContextTest, + cvmValidationAlphaContextTest, cvmValidationAlphaIdTest, + cvmFamilyContext, constructorValidityMatrixContext, + AddInductive.Context.pushLocalDecl] using old + +theorem cvmValidationPFindTest : + cvmValidationRootContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := by + have found := cvmValidationAlphaLocalRunTest.push_findNew + `P .default cvmValidationPDomainTest + simpa [cvmValidationRootContextTest, cvmValidationFamilyContextTest, + cvmValidationPIdTest] using found + +theorem cvmValidationRootDepthTest : + cvmValidationRootContextTest.fuel.recDepth = 10000 := by + rw [← cvmConstructorValidationContextTest_root] + rw [cvmConstructorValidationContextTest, + cvmCandidate.families.singleton.familyType.type.trace.terminalContext_fuel, + cvmFamilyContext_eq] + rfl + +theorem cvmValidationRootLparamsTest : + cvmValidationRootContextTest.lparams = [`u] := by + rw [← cvmConstructorValidationContextTest_root] + rw [cvmConstructorValidationContextTest, cvmTerminalLparams_eq] + rfl + +theorem cvmStatsResultLevelTest : + cvmFamilyValidationRun.stats.resultLevel = .succ (.param `u) := by + rfl + +theorem cvmCtorXDomainValidationShapeTest : + cvmCtorXDomain = .fvar cvmValidationAlphaIdTest := by + simp_cvm_ctor_expr + rfl + +theorem cvmValidationXEnsureTest : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨cvmValidationRootContextTest, cvmCtorXDomain, + .sort (.succ (.param `u))⟩ := by + rw [cvmCtorXDomainValidationShapeTest] + exact prbPreFamilyFVarEnsureValidReplay + cvmValidationRootContextTest cvmValidationAlphaIdTest + (.succ (.param `u)) cvmValidationAlphaFindTest + cvmValidationRootDepthTest + +theorem cvmEnsureTypeResultEqTest + (actual : AddInductive.ConstructorEnsureTypeStep.Valid + ⟨context, source, result⟩) + (expected : AddInductive.ConstructorEnsureTypeStep.Valid + ⟨context, source, expectedResult⟩) : + result = expectedResult := by + change TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel (TypeChecker.ensureType source) = + .ok result at actual + change TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel (TypeChecker.ensureType source) = + .ok expectedResult at expected + rw [expected] at actual + exact (Except.ok.inj actual).symm + +def cvmValidationXContextTest : AddInductive.Context := + cvmValidationRootContextTest.pushLocalDecl `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) + +theorem cvmValidationRootFreshEqTest : + cvmValidationRootContextTest.freshExpr = + cvmCtorPContext.freshExpr := by + simp [cvmValidationRootContextTest, cvmValidationFamilyContextTest, + cvmValidationAlphaContextTest, cvmValidationPDomainTest, + cvmCtorPContext, cvmCtorAlphaContext, cvmCtorAlphaDomain, + cvmFamilyContext, cvmConstructorContext, + constructorValidityMatrixContext, + AddInductive.Context.pushLocalDecl, AddInductive.Context.freshExpr, + AddInductive.Context.freshFVarId] + +theorem cvmFirstFieldSourceTest : + cvmCtorAfterP.bindingBody!.instantiate1 + cvmValidationRootContextTest.freshExpr = cvmCtorAfterX := by + unfold cvmCtorAfterX + rw [cvmValidationRootFreshEqTest] + +theorem cvmCtorAfterXForallTest : + cvmCtorAfterX = .forallE `proof cvmCtorProofDomain + cvmCtorAfterX.bindingBody! .default := by + simp_cvm_ctor_expr + +theorem cvmUniverseSemanticsCastSourceTest + {source source' : Expr} + (sourceEq : source = source') + (trace : AddInductive.ConstructorTypeValidationTrace + stats isUnsafe familyIdx ctor context source argIdx fuel) : + (sourceEq ▸ trace).universeSemantics = trace.universeSemantics := by + cases sourceEq + rfl + +theorem cvmConstructorValidationFuelTest : + cvmConstructorValidationContextTest.fuel.inductiveFuel = 1000 := by + rw [cvmConstructorValidationContextTest, + cvmCandidate.families.singleton.familyType.type.trace.terminalContext_fuel, + cvmFamilyContext_eq] + rfl + +theorem cvmStatsParamsTest : + cvmFamilyValidationRun.stats.params = + #[cvmFamilyContext.freshExpr, + (cvmFamilyContext.pushLocalDecl `α .default + (.sort (.succ (.param `u)))).freshExpr] := by + rw [cvmFamilyValidationRun.stats_eq] + change + (cvmCandidate.families.singleton.familyType.type.trace.parameterList 2).toArray = _ + have identity := cvmFamilyIdentityEvidence.identity + have spineLength := cvmFamilyIdentityEvidence.spineLength_eq + generalize htrace : + cvmCandidate.families.singleton.familyType.type.trace = trace at identity spineLength ⊢ + cases identity with + | terminal result_eq => + simp only [AddInductive.CandidateExprTrace.spineLength] at spineLength + rw [cvmFamilyIdentityReplay_shape.1] at spineLength + omega + | forallE domainCandidate bodyCandidate source_eq consumed_eq + domainIdentity bodyIdentity => + cases bodyIdentity with + | terminal result_eq => + simp only [AddInductive.CandidateExprTrace.spineLength] at spineLength + rw [cvmFamilyIdentityReplay_shape.1] at spineLength + omega + | forallE domainCandidate' bodyCandidate' source_eq' consumed_eq' + domainIdentity' bodyIdentity' => + simp only [AddInductive.CandidateExprTrace.parameterList] + rw [cvmFamilyCandidateContext_eq, consumed_eq] + rfl + +theorem cvmFirstParameterSourceTest : + constructorValidityMatrixKernelCtor.type.bindingBody!.instantiate1 + cvmFamilyContext.freshExpr = cvmCtorAfterAlpha := by + simp_cvm_ctor_expr + rfl + +theorem cvmCtorAfterAlphaForallTest : + cvmCtorAfterAlpha = + .forallE `P cvmCtorPDomain cvmCtorAfterAlpha.bindingBody! .implicit := by + simp_cvm_ctor_expr + +theorem cvmSecondParameterSourceTest : + cvmCtorAfterAlpha.bindingBody!.instantiate1 + cvmValidationAlphaContextTest.freshExpr = cvmCtorAfterP := by + simp_cvm_ctor_expr + rfl + +theorem cvmCtorAfterPForallTest : + cvmCtorAfterP = + .forallE `x cvmCtorXDomain cvmCtorAfterP.bindingBody! .default := by + simp_cvm_ctor_expr + +def cvmInferOnlyInsertTest + (state : TypeChecker.State) (source type : Expr) : TypeChecker.State := + { state with inferTypeI := state.inferTypeI.insert source type } + +theorem cvmInferTypeFVarOnlyCoreTest + (fuel : Nat) (context : AddInductive.Context) + (state : TypeChecker.State) (id : FVarId) (type : Expr) + (hcache : state.inferTypeI[(.fvar id : Expr)]? = none) + (hfind : context.lctx.find? id = + some (.cdecl index id name type bi kind)) : + TypeChecker.Inner.inferType' (.fvar id) true + (TypeChecker.Methods.withFuel fuel) context.toTypeChecker state = + .ok (type, cvmInferOnlyInsertTest state (.fvar id) type) := by + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', hcache, + TypeChecker.Inner.inferFVar, AddInductive.Context.toTypeChecker, + hfind, LocalDecl.type, cvmInferOnlyInsertTest, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +theorem cvmEnsureTypeOfInferOnlyTest + (context : AddInductive.Context) (source : Expr) (level : Level) + (finalState : TypeChecker.State) + (run : TypeChecker.Inner.inferType source true + (TypeChecker.Methods.withFuel context.fuel.recDepth) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (.sort level, finalState)) : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨context, source, .sort level⟩ := by + unfold AddInductive.ConstructorEnsureTypeStep.Valid + TypeChecker.ensureType TypeChecker.inferType TypeChecker.ensureSort + TypeChecker.RecM.run TypeChecker.M.run + simp only [readThe, MonadReaderOf.read, ReaderT.read, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind, + Pure.pure, StateT.pure, Except.pure, StateT.run', + Functor.map, Except.map] + rw [show TypeChecker.Inner.inferType source true + (TypeChecker.Methods.withFuel context.fuel.recDepth) + { env := context.env, lctx := context.lctx, + safety := context.safety, lparams := context.lparams, + fuel := context.fuel } + ({} : TypeChecker.State) = .ok (.sort level, finalState) by + simpa [AddInductive.Context.toTypeChecker] using run] + rfl + +def cvmValidationXLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmValidationXContextTest := + cvmValidationRootLocalRunTest.push `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) + +def cvmValidationXIdTest : FVarId := + cvmValidationRootContextTest.freshFVarId + +theorem cvmValidationPFindInXTest : + cvmValidationXContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := + cvmValidationRootLocalRunTest.push_findOld `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) + cvmValidationPFindTest + +theorem cvmCtorProofDomainValidationShapeTest : + cvmCtorProofDomain = + .app (.fvar cvmValidationPIdTest) (.fvar cvmValidationXIdTest) := by + simp [cvmCtorProofDomain, cvmCtorAfterX, cvmCtorAfterP, + cvmCtorAfterAlpha, cvmValidationPIdTest, cvmValidationXIdTest, + cvmValidationRootContextTest, cvmValidationFamilyContextTest, + cvmValidationAlphaContextTest, cvmFamilyContext, + cvmCtorPContext, cvmCtorAlphaContext, cvmConstructorContext, + constructorValidityMatrixContext, + constructorValidityMatrixKernelCtor, constructorValidityMatrixMkInfo, + ConstantInfo.type, ConstantInfo.toConstantVal, + AddInductive.Context.pushLocalDecl, AddInductive.Context.freshExpr, + AddInductive.Context.freshFVarId, Expr.bindingDomain!, Expr.bindingBody!, + Expr.instantiate1_eq, Expr.instantiate1'] + +def cvmValidationProofPStateTest : TypeChecker.State := + cvmInferOnlyInsertTest ({} : TypeChecker.State) + (.fvar cvmValidationPIdTest) cvmValidationPDomainTest + +def cvmValidationProofFinalStateTest : TypeChecker.State := + cvmInferOnlyInsertTest cvmValidationProofPStateTest cvmCtorProofDomain + (.sort .zero) + +theorem cvmValidationProofInferOnlyTest : + TypeChecker.Inner.inferType cvmCtorProofDomain true + (TypeChecker.Methods.withFuel cvmValidationXContextTest.fuel.recDepth) + cvmValidationXContextTest.toTypeChecker ({} : TypeChecker.State) = + .ok (.sort .zero, cvmValidationProofFinalStateTest) := by + rw [cvmCtorProofDomainValidationShapeTest] + change TypeChecker.Inner.inferType' + (.app (.fvar cvmValidationPIdTest) (.fvar cvmValidationXIdTest)) true + (TypeChecker.Methods.withFuel 9999) + cvmValidationXContextTest.toTypeChecker ({} : TypeChecker.State) = _ + have pRun : TypeChecker.Inner.inferType' + (.fvar cvmValidationPIdTest) true + (TypeChecker.Methods.withFuel 9998) + cvmValidationXContextTest.toTypeChecker ({} : TypeChecker.State) = + .ok (cvmValidationPDomainTest, cvmValidationProofPStateTest) := by + simpa [cvmValidationProofPStateTest] using + cvmInferTypeFVarOnlyCoreTest 9998 cvmValidationXContextTest + ({} : TypeChecker.State) cvmValidationPIdTest + cvmValidationPDomainTest Std.HashMap.getElem?_empty + cvmValidationPFindInXTest + have appFn : + ((.app (.fvar cvmValidationPIdTest) + (.fvar cvmValidationXIdTest) : Expr).getAppFn) = + .fvar cvmValidationPIdTest := by + rfl + have appArgs : + ((.app (.fvar cvmValidationPIdTest) + (.fvar cvmValidationXIdTest) : Expr).getAppArgs) = + #[.fvar cvmValidationXIdTest] := by + rfl + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + TypeChecker.Inner.inferApp, TypeChecker.Inner.inferApp.loop, + appFn, appArgs, pRun, cvmValidationPDomainTest, + cvmValidationProofFinalStateTest, + cvmValidationProofPStateTest, cvmInferOnlyInsertTest, + cvmCtorProofDomainValidationShapeTest, Expr.instantiateRev_eq, + Expr.instantiate_eq, Expr.instantiate1_eq, Expr.instantiate1', + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +theorem cvmValidationProofEnsureTest : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨cvmValidationXContextTest, cvmCtorProofDomain, .sort .zero⟩ := + cvmEnsureTypeOfInferOnlyTest cvmValidationXContextTest + cvmCtorProofDomain .zero cvmValidationProofFinalStateTest + cvmValidationProofInferOnlyTest + +def cvmValidationProofContextTest : AddInductive.Context := + cvmValidationXContextTest.pushLocalDecl `proof .default + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) + +theorem cvmValidationXFreshEqTest : + cvmValidationXContextTest.freshExpr = cvmCtorXContext.freshExpr := by + simp [cvmValidationXContextTest, cvmValidationRootContextTest, + cvmValidationFamilyContextTest, cvmValidationAlphaContextTest, + cvmValidationPDomainTest, cvmCtorXContext, cvmCtorPContext, + cvmCtorAlphaContext, cvmCtorXDomain, cvmCtorAfterP, + cvmCtorAfterAlpha, cvmFamilyContext, cvmConstructorContext, + constructorValidityMatrixContext, constructorValidityMatrixKernelCtor, + constructorValidityMatrixMkInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, + AddInductive.consumeTypeAnnotations, Expr.bindingDomain!, + Expr.bindingBody!, Expr.instantiate1_eq, Expr.instantiate1'] + +theorem cvmSecondFieldSourceTest : + cvmCtorAfterX.bindingBody!.instantiate1 + cvmValidationXContextTest.freshExpr = cvmCtorAfterProof := by + unfold cvmCtorAfterProof + rw [cvmValidationXFreshEqTest] + +theorem cvmCtorAfterProofForallTest : + cvmCtorAfterProof = .forallE `direct cvmCtorDirectDomain + cvmCtorAfterProof.bindingBody! .default := by + simp_cvm_ctor_expr + +@[simp] theorem cvmInferConstantFamilyOnlyTest + (context : AddInductive.Context) + (envEq : context.env = cvmConstructorContext.env) : + TypeChecker.Inner.inferConstant context.toTypeChecker + constructorValidityMatrixKernelType.name [.param `u] true = + .ok constructorValidityMatrixKernelType.type := by + have familyGet : cvmConstructorContext.env.get + constructorValidityMatrixKernelType.name = .ok cvmDeclaredInfo := by + unfold Kernel.Environment.get + rw [cvmCtorFamilyLookup] + rfl + unfold TypeChecker.Inner.inferConstant + simp only [AddInductive.Context.toTypeChecker] + rw [envEq, familyGet] + have terminalLparams : + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.lparams = + [`u] := by + exact cvmTerminalLparams_eq + unfold cvmDeclaredInfo AddInductive.singletonDeclaredInfo + rw [terminalLparams] + simp [constructorValidityMatrixKernelType, + constructorValidityMatrixInfo, ConstantInfo.levelParams, + ConstantInfo.instantiateTypeLevelParams, ConstantInfo.toConstantVal, + ConstantVal.instantiateTypeLevelParams, + Expr.instantiateLevelParams_eq, Expr.instantiateLevelParamsCore', + Level.substParams', Bind.bind, Except.bind, Pure.pure, Except.pure] + simp [Expr.instantiateLevelParamsCore', Level.substParams', + constructorValidityMatrixKernelType, constructorValidityMatrixInfo, + ConstantInfo.type, ConstantInfo.toConstantVal] + +theorem cvmKernelFamilyTypeShapeTest : + constructorValidityMatrixKernelType.type = + .forallE `α (.sort (.succ (.param `u))) + (.forallE `P + (.forallE cvmValidationIndexNameTest (.bvar 0) (.sort .zero) + .default) + (.sort (.succ (.param `u))) .default) + .default := by + rfl + +open private mkLevelIMaxCore mkLevelMaxCore from Lean.Level in +@[simp] theorem cvmMkLevelIMaxSuccParamSelfTest : + mkLevelIMax' (.succ (.param `u)) (.succ (.param `u)) = + .succ (.param `u) := by + simp [mkLevelIMax', mkLevelIMaxCore, mkLevelMax', mkLevelMaxCore] + +def cvmValidationFamilyOnlyStateTest : TypeChecker.State := + cvmInferOnlyInsertTest ({} : TypeChecker.State) + (.const constructorValidityMatrixKernelType.name [.param `u]) + constructorValidityMatrixKernelType.type + +theorem cvmInferTypeFamilyOnlyCoreTest + (fuel : Nat) (context : AddInductive.Context) + (state : TypeChecker.State) + (cacheMiss : state.inferTypeI[ + (.const constructorValidityMatrixKernelType.name + [.param `u] : Expr)]? = none) + (envEq : context.env = cvmConstructorContext.env) : + TypeChecker.Inner.inferType' + (.const constructorValidityMatrixKernelType.name [.param `u]) true + (TypeChecker.Methods.withFuel fuel) context.toTypeChecker state = + .ok (constructorValidityMatrixKernelType.type, + cvmInferOnlyInsertTest state + (.const constructorValidityMatrixKernelType.name [.param `u]) + constructorValidityMatrixKernelType.type) := by + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', cacheMiss, + cvmInferConstantFamilyOnlyTest context envEq, + cvmInferOnlyInsertTest, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + +def cvmValidationFamilyApplicationTest (alpha predicate : Expr) : Expr := + .app + (.app (.const constructorValidityMatrixKernelType.name [.param `u]) alpha) + predicate + +def cvmValidationFamilyApplicationStateTest + (alpha predicate : Expr) : TypeChecker.State := + cvmInferOnlyInsertTest cvmValidationFamilyOnlyStateTest + (cvmValidationFamilyApplicationTest alpha predicate) + (.sort (.succ (.param `u))) + +theorem cvmInferTypeFamilyApplicationOnlyTest + (context : AddInductive.Context) (alpha predicate : Expr) + (envEq : context.env = cvmConstructorContext.env) + (depth : context.fuel.recDepth = 10000) + (closed : + (cvmValidationFamilyApplicationTest alpha predicate).hasLooseBVars = + false) : + TypeChecker.Inner.inferType + (cvmValidationFamilyApplicationTest alpha predicate) true + (TypeChecker.Methods.withFuel context.fuel.recDepth) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (.sort (.succ (.param `u)), + cvmValidationFamilyApplicationStateTest alpha predicate) := by + rw [depth] + unfold cvmValidationFamilyApplicationTest at closed ⊢ + change TypeChecker.Inner.inferType' + (.app + (.app (.const constructorValidityMatrixKernelType.name [.param `u]) + alpha) predicate) true + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker + ({} : TypeChecker.State) = _ + have familyRun : TypeChecker.Inner.inferType' + (.const constructorValidityMatrixKernelType.name [.param `u]) true + (TypeChecker.Methods.withFuel 9998) context.toTypeChecker + ({} : TypeChecker.State) = + .ok (constructorValidityMatrixKernelType.type, + cvmValidationFamilyOnlyStateTest) := by + simpa [cvmValidationFamilyOnlyStateTest] using + cvmInferTypeFamilyOnlyCoreTest 9998 context + ({} : TypeChecker.State) Std.HashMap.getElem?_empty envEq + have appFn : + ((.app + (.app (.const constructorValidityMatrixKernelType.name [.param `u]) + alpha) predicate : Expr).getAppFn) = + .const constructorValidityMatrixKernelType.name [.param `u] := by + rfl + have appArgs : + ((.app + (.app (.const constructorValidityMatrixKernelType.name [.param `u]) + alpha) predicate : Expr).getAppArgs) = + #[alpha, predicate] := by + rfl + unfold TypeChecker.Inner.inferType' + rw [closed] + simp [TypeChecker.Inner.inferApp, TypeChecker.Inner.inferApp.loop, + appFn, appArgs, familyRun, + cvmValidationFamilyApplicationTest, + cvmValidationFamilyApplicationStateTest, + cvmValidationFamilyOnlyStateTest, cvmInferOnlyInsertTest, + cvmKernelFamilyTypeShapeTest, + Expr.instantiateRev_eq, Expr.instantiate_eq, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +def cvmValidationFamilyOnlyStateFromTest + (state : TypeChecker.State) : TypeChecker.State := + cvmInferOnlyInsertTest state + (.const constructorValidityMatrixKernelType.name [.param `u]) + constructorValidityMatrixKernelType.type + +def cvmValidationFamilyApplicationStateFromTest + (state : TypeChecker.State) (alpha predicate : Expr) : + TypeChecker.State := + cvmInferOnlyInsertTest (cvmValidationFamilyOnlyStateFromTest state) + (cvmValidationFamilyApplicationTest alpha predicate) + (.sort (.succ (.param `u))) + +theorem cvmInferTypeFamilyApplicationOnlyCoreTest + (fuel : Nat) (context : AddInductive.Context) + (state : TypeChecker.State) (alpha predicate : Expr) + (familyMiss : state.inferTypeI[ + (.const constructorValidityMatrixKernelType.name + [.param `u] : Expr)]? = none) + (applicationMiss : state.inferTypeI[ + cvmValidationFamilyApplicationTest alpha predicate]? = none) + (envEq : context.env = cvmConstructorContext.env) + (closed : + (cvmValidationFamilyApplicationTest alpha predicate).hasLooseBVars = + false) : + TypeChecker.Inner.inferType' + (cvmValidationFamilyApplicationTest alpha predicate) true + (TypeChecker.Methods.withFuel (fuel + 1)) context.toTypeChecker state = + .ok (.sort (.succ (.param `u)), + cvmValidationFamilyApplicationStateFromTest state alpha predicate) := by + have familyRun : TypeChecker.Inner.inferType' + (.const constructorValidityMatrixKernelType.name [.param `u]) true + (TypeChecker.Methods.withFuel fuel) context.toTypeChecker state = + .ok (constructorValidityMatrixKernelType.type, + cvmValidationFamilyOnlyStateFromTest state) := by + simpa [cvmValidationFamilyOnlyStateFromTest] using + cvmInferTypeFamilyOnlyCoreTest fuel context state familyMiss envEq + unfold cvmValidationFamilyApplicationTest at applicationMiss closed ⊢ + have appFn : + ((.app + (.app (.const constructorValidityMatrixKernelType.name [.param `u]) + alpha) predicate : Expr).getAppFn) = + .const constructorValidityMatrixKernelType.name [.param `u] := by + rfl + have appArgs : + ((.app + (.app (.const constructorValidityMatrixKernelType.name [.param `u]) + alpha) predicate : Expr).getAppArgs) = #[alpha, predicate] := by + rfl + unfold TypeChecker.Inner.inferType' + rw [closed] + simp [applicationMiss, TypeChecker.Inner.inferApp, + TypeChecker.Inner.inferApp.loop, appFn, appArgs, familyRun, + cvmValidationFamilyApplicationTest, + cvmValidationFamilyApplicationStateFromTest, + cvmValidationFamilyOnlyStateFromTest, cvmInferOnlyInsertTest, + cvmKernelFamilyTypeShapeTest, + Expr.instantiateRev_eq, Expr.instantiate_eq, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +theorem cvmInferTypeForallOnlyCoreTest + (fuel : Nat) (context : TypeChecker.Context) + (state finalState : TypeChecker.State) + (name : Name) (domain body result : Expr) (bi : BinderInfo) + (closed : (.forallE name domain body bi : Expr).hasLooseBVars = false) + (cacheMiss : state.inferTypeI[ + (.forallE name domain body bi : Expr)]? = none) + (forallRun : TypeChecker.Inner.inferForall + (.forallE name domain body bi) true + (TypeChecker.Methods.withFuel fuel) context state = + .ok (result, finalState)) : + TypeChecker.Inner.inferType' + (.forallE name domain body bi) true + (TypeChecker.Methods.withFuel fuel) context state = + .ok (result, cvmInferOnlyInsertTest finalState + (.forallE name domain body bi) result) := by + unfold TypeChecker.Inner.inferType' + simp [closed, cacheMiss, forallRun, cvmInferOnlyInsertTest, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +theorem cvmCtorDirectDomainValidationShapeTest : + cvmCtorDirectDomain = cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest) := by + simp [cvmCtorDirectDomain, cvmCtorAfterProof, cvmCtorAfterX, + cvmCtorAfterP, cvmCtorAfterAlpha, cvmValidationFamilyApplicationTest, + cvmValidationAlphaIdTest, cvmValidationPIdTest, + cvmValidationAlphaContextTest, cvmFamilyContext, + cvmCtorXContext, cvmCtorPContext, cvmCtorAlphaContext, + cvmConstructorContext, constructorValidityMatrixContext, + constructorValidityMatrixKernelCtor, constructorValidityMatrixKernelType, + constructorValidityMatrixMkInfo, constructorValidityMatrixInfo, + ConstantInfo.name, ConstantInfo.type, ConstantInfo.toConstantVal, + AddInductive.Context.pushLocalDecl, AddInductive.Context.freshExpr, + AddInductive.Context.freshFVarId, Expr.bindingDomain!, + Expr.bindingBody!, Expr.instantiate1_eq, Expr.instantiate1'] + +theorem cvmValidationProofEnvTest : + cvmValidationProofContextTest.env = cvmConstructorContext.env := by + rfl + +theorem cvmValidationProofDepthTest : + cvmValidationProofContextTest.fuel.recDepth = 10000 := by + rfl + +theorem cvmValidationDirectEnsureTest : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨cvmValidationProofContextTest, cvmCtorDirectDomain, + .sort (.succ (.param `u))⟩ := by + rw [cvmCtorDirectDomainValidationShapeTest] + exact cvmEnsureTypeOfInferOnlyTest cvmValidationProofContextTest + (cvmValidationFamilyApplicationTest (.fvar cvmValidationAlphaIdTest) + (.fvar cvmValidationPIdTest)) (.succ (.param `u)) + (cvmValidationFamilyApplicationStateTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + (cvmInferTypeFamilyApplicationOnlyTest cvmValidationProofContextTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest) + cvmValidationProofEnvTest cvmValidationProofDepthTest + (by simp [cvmValidationFamilyApplicationTest, + Expr.hasLooseBVars, Expr.looseBVarRange'])) + +def cvmValidationDirectContextTest : AddInductive.Context := + cvmValidationProofContextTest.pushLocalDecl `direct .default + (AddInductive.consumeTypeAnnotations cvmCtorDirectDomain) + +theorem cvmValidationProofFreshEqTest : + cvmValidationProofContextTest.freshExpr = + cvmCtorProofContext.freshExpr := by + simp [cvmValidationProofContextTest, cvmValidationXContextTest, + cvmValidationRootContextTest, cvmValidationFamilyContextTest, + cvmValidationAlphaContextTest, cvmValidationPDomainTest, + cvmCtorProofContext, cvmCtorXContext, cvmCtorPContext, + cvmCtorAlphaContext, cvmCtorProofDomain, cvmCtorAfterX, + cvmCtorAfterP, cvmCtorAfterAlpha, cvmCtorXDomain, + cvmFamilyContext, cvmConstructorContext, + constructorValidityMatrixContext, constructorValidityMatrixKernelCtor, + constructorValidityMatrixMkInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, + AddInductive.consumeTypeAnnotations, Expr.bindingDomain!, + Expr.bindingBody!, Expr.instantiate1_eq, Expr.instantiate1'] + +theorem cvmThirdFieldSourceTest : + cvmCtorAfterProof.bindingBody!.instantiate1 + cvmValidationProofContextTest.freshExpr = cvmCtorAfterDirect := by + unfold cvmCtorAfterDirect + rw [cvmValidationProofFreshEqTest] + +theorem cvmCtorAfterDirectForallTest : + cvmCtorAfterDirect = .forallE `function cvmCtorFunctionDomain + cvmCtorAfterDirect.bindingBody! .default := by + simp_cvm_ctor_expr + +def cvmValidationProofLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmValidationProofContextTest := + cvmValidationXLocalRunTest.push `proof .default + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) + +def cvmValidationDirectLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmValidationDirectContextTest := + cvmValidationProofLocalRunTest.push `direct .default + (AddInductive.consumeTypeAnnotations cvmCtorDirectDomain) + +theorem cvmValidationAlphaFindInXTest : + cvmValidationXContextTest.lctx.find? cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := + cvmValidationRootLocalRunTest.push_findOld `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) + cvmValidationAlphaFindTest + +theorem cvmValidationAlphaFindInProofTest : + cvmValidationProofContextTest.lctx.find? cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := + cvmValidationXLocalRunTest.push_findOld `proof .default + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) + cvmValidationAlphaFindInXTest + +theorem cvmValidationAlphaFindInDirectTest : + cvmValidationDirectContextTest.lctx.find? cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := + cvmValidationProofLocalRunTest.push_findOld `direct .default + (AddInductive.consumeTypeAnnotations cvmCtorDirectDomain) + cvmValidationAlphaFindInProofTest + +theorem cvmCtorFunctionDomainValidationShapeTest : + cvmCtorFunctionDomain = + .forallE `y (.fvar cvmValidationAlphaIdTest) + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + .default := by + simp [cvmCtorFunctionDomain, cvmCtorAfterDirect, cvmCtorAfterProof, + cvmCtorAfterX, cvmCtorAfterP, cvmCtorAfterAlpha, + cvmValidationFamilyApplicationTest, cvmValidationAlphaIdTest, + cvmValidationPIdTest, cvmValidationAlphaContextTest, + cvmFamilyContext, cvmCtorProofContext, cvmCtorXContext, + cvmCtorPContext, cvmCtorAlphaContext, cvmConstructorContext, + constructorValidityMatrixContext, constructorValidityMatrixKernelCtor, + constructorValidityMatrixKernelType, constructorValidityMatrixMkInfo, + constructorValidityMatrixInfo, ConstantInfo.name, ConstantInfo.type, + ConstantInfo.toConstantVal, AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, + Expr.bindingDomain!, Expr.bindingBody!, Expr.instantiate1_eq, + Expr.instantiate1'] + +def cvmValidationFunctionAlphaStateTest : TypeChecker.State := + cvmInferOnlyInsertTest ({} : TypeChecker.State) + (.fvar cvmValidationAlphaIdTest) (.sort (.succ (.param `u))) + +def cvmValidationFunctionInternalIdTest : FVarId := + ⟨cvmValidationFunctionAlphaStateTest.ngen.curr⟩ + +def cvmValidationFunctionInternalStateTest : TypeChecker.State := + { cvmValidationFunctionAlphaStateTest with + ngen := cvmValidationFunctionAlphaStateTest.ngen.next } + +def cvmValidationFunctionInternalContextTest : AddInductive.Context := + { cvmValidationDirectContextTest with + lctx := cvmValidationDirectContextTest.lctx.mkLocalDecl + cvmValidationFunctionInternalIdTest `y + (.fvar cvmValidationAlphaIdTest) .default } + +def cvmValidationFunctionBodyFinalStateTest : TypeChecker.State := + cvmValidationFamilyApplicationStateFromTest + cvmValidationFunctionInternalStateTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest) + +def cvmValidationFunctionFinalStateTest : TypeChecker.State := + cvmInferOnlyInsertTest cvmValidationFunctionBodyFinalStateTest + cvmCtorFunctionDomain (.sort (.succ (.param `u))) + +theorem cvmValidationFunctionInferOnlyTest : + TypeChecker.Inner.inferType cvmCtorFunctionDomain true + (TypeChecker.Methods.withFuel + cvmValidationDirectContextTest.fuel.recDepth) + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State) = + .ok (.sort (.succ (.param `u)), + cvmValidationFunctionFinalStateTest) := by + have domainRun : TypeChecker.Inner.inferType' + (.fvar cvmValidationAlphaIdTest) true + (TypeChecker.Methods.withFuel 9998) + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State) = + .ok (.sort (.succ (.param `u)), + cvmValidationFunctionAlphaStateTest) := by + simpa [cvmValidationFunctionAlphaStateTest] using + cvmInferTypeFVarOnlyCoreTest 9998 cvmValidationDirectContextTest + ({} : TypeChecker.State) cvmValidationAlphaIdTest + (.sort (.succ (.param `u))) Std.HashMap.getElem?_empty + cvmValidationAlphaFindInDirectTest + have familyMiss : cvmValidationFunctionInternalStateTest.inferTypeI[ + (.const constructorValidityMatrixKernelType.name + [.param `u] : Expr)]? = none := by + simp [cvmValidationFunctionInternalStateTest, + cvmValidationFunctionAlphaStateTest, cvmInferOnlyInsertTest] + have applicationMiss : + cvmValidationFunctionInternalStateTest.inferTypeI[ + cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) + (.fvar cvmValidationPIdTest)]? = none := by + simp [cvmValidationFunctionInternalStateTest, + cvmValidationFunctionAlphaStateTest, cvmInferOnlyInsertTest, + cvmValidationFamilyApplicationTest] + have bodyRun : TypeChecker.Inner.inferType' + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) true + (TypeChecker.Methods.withFuel 9998) + cvmValidationFunctionInternalContextTest.toTypeChecker + cvmValidationFunctionInternalStateTest = + .ok (.sort (.succ (.param `u)), + cvmValidationFunctionBodyFinalStateTest) := by + simpa [cvmValidationFunctionBodyFinalStateTest] using + cvmInferTypeFamilyApplicationOnlyCoreTest 9997 + cvmValidationFunctionInternalContextTest + cvmValidationFunctionInternalStateTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest) + familyMiss applicationMiss (by rfl) + (by simp [cvmValidationFamilyApplicationTest, + Expr.hasLooseBVars, Expr.looseBVarRange']) + have forallRun : TypeChecker.Inner.inferForall + (.forallE `y (.fvar cvmValidationAlphaIdTest) + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + .default) true + (TypeChecker.Methods.withFuel 9999) + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State) = + .ok (.sort (.succ (.param `u)), + cvmValidationFunctionBodyFinalStateTest) := by + unfold TypeChecker.Inner.inferForall + simp only [cvmValidationFamilyApplicationTest, + TypeChecker.Inner.inferForall.loop] + rw [show (.fvar cvmValidationAlphaIdTest : Expr).instantiateRev #[] = + .fvar cvmValidationAlphaIdTest by + simp [Expr.instantiateRev_eq, Expr.instantiate_eq]] + simp only [Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rw [show TypeChecker.Inner.inferType + (.fvar cvmValidationAlphaIdTest) true + (TypeChecker.Methods.withFuel 9999) + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State) = + TypeChecker.Inner.inferType' + (.fvar cvmValidationAlphaIdTest) true + (TypeChecker.Methods.withFuel 9998) + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State) by rfl] + rw [domainRun] + simp only [prbEnsureSortExact] + rw [prbWithLocalDeclEq] + change TypeChecker.Inner.inferForall.loop true + #[Expr.fvar cvmValidationFunctionInternalIdTest] + #[Level.succ (.param `u)] + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + (TypeChecker.Methods.withFuel 9999) + cvmValidationFunctionInternalContextTest.toTypeChecker + cvmValidationFunctionInternalStateTest = _ + simp only [cvmValidationFamilyApplicationTest, + TypeChecker.Inner.inferForall.loop] + rw [show (((.const constructorValidityMatrixKernelType.name + [.param `u] : Expr).app (.fvar cvmValidationAlphaIdTest)).app + (.fvar cvmValidationPIdTest)).instantiateRev + #[Expr.fvar cvmValidationFunctionInternalIdTest] = + ((.const constructorValidityMatrixKernelType.name + [.param `u] : Expr).app (.fvar cvmValidationAlphaIdTest)).app + (.fvar cvmValidationPIdTest) by + simp [Expr.instantiateRev_eq, Expr.instantiate_eq, + Expr.instantiate1_eq, Expr.instantiate1']] + simp only [Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + have bodyRunExplicit : TypeChecker.Inner.inferType' + (((.const constructorValidityMatrixKernelType.name + [.param `u] : Expr).app (.fvar cvmValidationAlphaIdTest)).app + (.fvar cvmValidationPIdTest)) true + (TypeChecker.Methods.withFuel 9998) + cvmValidationFunctionInternalContextTest.toTypeChecker + cvmValidationFunctionInternalStateTest = + .ok (.sort (.succ (.param `u)), + cvmValidationFunctionBodyFinalStateTest) := by + simpa [cvmValidationFamilyApplicationTest] using bodyRun + rw [show TypeChecker.Inner.inferType + (((.const constructorValidityMatrixKernelType.name + [.param `u] : Expr).app (.fvar cvmValidationAlphaIdTest)).app + (.fvar cvmValidationPIdTest)) true + (TypeChecker.Methods.withFuel 9999) + cvmValidationFunctionInternalContextTest.toTypeChecker + cvmValidationFunctionInternalStateTest = + TypeChecker.Inner.inferType' + (((.const constructorValidityMatrixKernelType.name + [.param `u] : Expr).app + (.fvar cvmValidationAlphaIdTest)).app + (.fvar cvmValidationPIdTest)) true + (TypeChecker.Methods.withFuel 9998) + cvmValidationFunctionInternalContextTest.toTypeChecker + cvmValidationFunctionInternalStateTest by rfl] + rw [bodyRunExplicit] + simp [Expr.sortLevel!, Pure.pure, ReaderT.pure, + StateT.pure, Except.pure] + have outerRun := cvmInferTypeForallOnlyCoreTest 9999 + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State) cvmValidationFunctionBodyFinalStateTest + `y (.fvar cvmValidationAlphaIdTest) + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + (.sort (.succ (.param `u))) .default + (by simp [cvmValidationFamilyApplicationTest, + Expr.hasLooseBVars, Expr.looseBVarRange']) + Std.HashMap.getElem?_empty forallRun + change TypeChecker.Inner.inferType' cvmCtorFunctionDomain true + (TypeChecker.Methods.withFuel 9999) + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State) = _ + simpa [cvmCtorFunctionDomainValidationShapeTest, + cvmValidationFunctionFinalStateTest] using outerRun + +theorem cvmValidationFunctionEnsureTest : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨cvmValidationDirectContextTest, cvmCtorFunctionDomain, + .sort (.succ (.param `u))⟩ := + cvmEnsureTypeOfInferOnlyTest cvmValidationDirectContextTest + cvmCtorFunctionDomain (.succ (.param `u)) + cvmValidationFunctionFinalStateTest + cvmValidationFunctionInferOnlyTest + +def cvmValidationFunctionContextTest : AddInductive.Context := + cvmValidationDirectContextTest.pushLocalDecl `function .default + (AddInductive.consumeTypeAnnotations cvmCtorFunctionDomain) + +theorem cvmValidationDirectFreshEqTest : + cvmValidationDirectContextTest.freshExpr = + cvmCtorDirectContext.freshExpr := by + simp [cvmValidationDirectContextTest, cvmValidationProofContextTest, + cvmValidationXContextTest, cvmValidationRootContextTest, + cvmValidationFamilyContextTest, cvmValidationAlphaContextTest, + cvmValidationPDomainTest, cvmCtorDirectContext, + cvmCtorProofContext, cvmCtorXContext, cvmCtorPContext, + cvmCtorAlphaContext, cvmCtorDirectDomain, cvmCtorAfterProof, + cvmCtorProofDomain, cvmCtorAfterX, cvmCtorXDomain, cvmCtorAfterP, + cvmCtorAfterAlpha, cvmFamilyContext, cvmConstructorContext, + constructorValidityMatrixContext, constructorValidityMatrixKernelCtor, + constructorValidityMatrixMkInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, + AddInductive.consumeTypeAnnotations, Expr.bindingDomain!, + Expr.bindingBody!, Expr.instantiate1_eq, Expr.instantiate1'] + +theorem cvmFourthFieldSourceTest : + cvmCtorAfterDirect.bindingBody!.instantiate1 + cvmValidationDirectContextTest.freshExpr = cvmCtorAfterFunction := by + unfold cvmCtorAfterFunction + rw [cvmValidationDirectFreshEqTest] + +theorem cvmCtorAfterFunctionForallTest : + cvmCtorAfterFunction = .forallE `later cvmCtorLaterDomain + cvmCtorAfterFunction.bindingBody! .default := by + simp_cvm_ctor_expr + +def cvmValidationFunctionLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmValidationFunctionContextTest := + cvmValidationDirectLocalRunTest.push `function .default + (AddInductive.consumeTypeAnnotations cvmCtorFunctionDomain) + +theorem cvmValidationAlphaFindInFunctionTest : + cvmValidationFunctionContextTest.lctx.find? cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := + cvmValidationDirectLocalRunTest.push_findOld `function .default + (AddInductive.consumeTypeAnnotations cvmCtorFunctionDomain) + cvmValidationAlphaFindInDirectTest + +theorem cvmCtorLaterDomainValidationShapeTest : + cvmCtorLaterDomain = .fvar cvmValidationAlphaIdTest := by + simp [cvmCtorLaterDomain, cvmCtorAfterFunction, cvmCtorAfterDirect, + cvmCtorAfterProof, cvmCtorAfterX, cvmCtorAfterP, cvmCtorAfterAlpha, + cvmValidationAlphaIdTest, cvmFamilyContext, + cvmCtorDirectContext, cvmCtorProofContext, cvmCtorXContext, + cvmCtorPContext, cvmCtorAlphaContext, cvmConstructorContext, + constructorValidityMatrixContext, constructorValidityMatrixKernelCtor, + constructorValidityMatrixMkInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, + Expr.bindingDomain!, Expr.bindingBody!, Expr.instantiate1_eq, + Expr.instantiate1'] + +theorem cvmValidationFunctionDepthTest : + cvmValidationFunctionContextTest.fuel.recDepth = 10000 := by + rfl + +theorem cvmValidationLaterEnsureTest : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨cvmValidationFunctionContextTest, cvmCtorLaterDomain, + .sort (.succ (.param `u))⟩ := by + rw [cvmCtorLaterDomainValidationShapeTest] + exact prbPreFamilyFVarEnsureValidReplay + cvmValidationFunctionContextTest cvmValidationAlphaIdTest + (.succ (.param `u)) cvmValidationAlphaFindInFunctionTest + cvmValidationFunctionDepthTest + +def cvmValidationLaterContextTest : AddInductive.Context := + cvmValidationFunctionContextTest.pushLocalDecl `later .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) + +theorem cvmValidationFunctionFreshEqTest : + cvmValidationFunctionContextTest.freshExpr = + cvmCtorFunctionContext.freshExpr := by + simp [cvmValidationFunctionContextTest, cvmValidationDirectContextTest, + cvmValidationProofContextTest, cvmValidationXContextTest, + cvmValidationRootContextTest, cvmValidationFamilyContextTest, + cvmValidationAlphaContextTest, cvmValidationPDomainTest, + cvmCtorFunctionContext, cvmCtorDirectContext, + cvmCtorProofContext, cvmCtorXContext, cvmCtorPContext, + cvmCtorAlphaContext, cvmCtorFunctionDomain, cvmCtorAfterDirect, + cvmCtorDirectDomain, cvmCtorAfterProof, cvmCtorProofDomain, + cvmCtorAfterX, cvmCtorXDomain, cvmCtorAfterP, cvmCtorAfterAlpha, + cvmFamilyContext, cvmConstructorContext, + constructorValidityMatrixContext, constructorValidityMatrixKernelCtor, + constructorValidityMatrixMkInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, + AddInductive.consumeTypeAnnotations, Expr.bindingDomain!, + Expr.bindingBody!, Expr.instantiate1_eq, Expr.instantiate1'] + +theorem cvmFifthFieldSourceTest : + cvmCtorAfterFunction.bindingBody!.instantiate1 + cvmValidationFunctionContextTest.freshExpr = cvmCtorAfterLater := by + unfold cvmCtorAfterLater + rw [cvmValidationFunctionFreshEqTest] + +theorem cvmCtorAfterLaterForallTest : + cvmCtorAfterLater = .forallE `laterProof cvmCtorLaterProofDomain + cvmCtorAfterLater.bindingBody! .default := by + simp_cvm_ctor_expr + +def cvmValidationPredicateApplicationTest + (predicate : FVarId) (argument : Expr) : Expr := + .app (.fvar predicate) argument + +def cvmValidationPredicateStateTest + (predicate : FVarId) : TypeChecker.State := + cvmInferOnlyInsertTest ({} : TypeChecker.State) (.fvar predicate) + cvmValidationPDomainTest + +def cvmValidationPredicateApplicationStateTest + (predicate : FVarId) (argument : Expr) : TypeChecker.State := + cvmInferOnlyInsertTest (cvmValidationPredicateStateTest predicate) + (cvmValidationPredicateApplicationTest predicate argument) + (.sort .zero) + +theorem cvmInferTypePredicateApplicationOnlyTest + (context : AddInductive.Context) (predicate : FVarId) + (argument : Expr) + (find : context.lctx.find? predicate = + some (.cdecl index predicate name cvmValidationPDomainTest bi kind)) + (depth : context.fuel.recDepth = 10000) + (closed : + (cvmValidationPredicateApplicationTest predicate argument).hasLooseBVars = + false) : + TypeChecker.Inner.inferType + (cvmValidationPredicateApplicationTest predicate argument) true + (TypeChecker.Methods.withFuel context.fuel.recDepth) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (.sort .zero, + cvmValidationPredicateApplicationStateTest predicate argument) := by + rw [depth] + unfold cvmValidationPredicateApplicationTest at closed ⊢ + change TypeChecker.Inner.inferType' + (.app (.fvar predicate) argument) true + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker + ({} : TypeChecker.State) = _ + have predicateRun : TypeChecker.Inner.inferType' + (.fvar predicate) true (TypeChecker.Methods.withFuel 9998) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (cvmValidationPDomainTest, + cvmValidationPredicateStateTest predicate) := by + simpa [cvmValidationPredicateStateTest] using + cvmInferTypeFVarOnlyCoreTest 9998 context + ({} : TypeChecker.State) predicate cvmValidationPDomainTest + Std.HashMap.getElem?_empty find + have appFn : ((.app (.fvar predicate) argument : Expr).getAppFn) = + .fvar predicate := by + rfl + have appArgs : ((.app (.fvar predicate) argument : Expr).getAppArgs) = + #[argument] := by + rfl + unfold TypeChecker.Inner.inferType' + rw [closed] + simp [TypeChecker.Inner.inferApp, TypeChecker.Inner.inferApp.loop, + appFn, appArgs, predicateRun, cvmValidationPDomainTest, + cvmValidationPredicateApplicationTest, + cvmValidationPredicateApplicationStateTest, + cvmValidationPredicateStateTest, cvmInferOnlyInsertTest, + Expr.instantiateRev_eq, Expr.instantiate_eq, + Expr.instantiate1_eq, Expr.instantiate1', + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +theorem cvmValidationPFindInProofTest : + cvmValidationProofContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := + cvmValidationXLocalRunTest.push_findOld `proof .default + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) + cvmValidationPFindInXTest + +theorem cvmValidationPFindInDirectTest : + cvmValidationDirectContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := + cvmValidationProofLocalRunTest.push_findOld `direct .default + (AddInductive.consumeTypeAnnotations cvmCtorDirectDomain) + cvmValidationPFindInProofTest + +theorem cvmValidationPFindInFunctionTest : + cvmValidationFunctionContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := + cvmValidationDirectLocalRunTest.push_findOld `function .default + (AddInductive.consumeTypeAnnotations cvmCtorFunctionDomain) + cvmValidationPFindInDirectTest + +def cvmValidationLaterLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmValidationLaterContextTest := + cvmValidationFunctionLocalRunTest.push `later .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) + +theorem cvmValidationPFindInLaterTest : + cvmValidationLaterContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := + cvmValidationFunctionLocalRunTest.push_findOld `later .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) + cvmValidationPFindInFunctionTest + +def cvmValidationLaterIdTest : FVarId := + cvmValidationFunctionContextTest.freshFVarId + +theorem cvmCtorLaterProofDomainValidationShapeTest : + cvmCtorLaterProofDomain = cvmValidationPredicateApplicationTest + cvmValidationPIdTest (.fvar cvmValidationLaterIdTest) := by + simp [cvmCtorLaterProofDomain, cvmCtorAfterLater, + cvmCtorAfterFunction, cvmCtorAfterDirect, cvmCtorAfterProof, + cvmCtorAfterX, cvmCtorAfterP, cvmCtorAfterAlpha, + cvmValidationPredicateApplicationTest, cvmValidationPIdTest, + cvmValidationLaterIdTest, cvmValidationFunctionContextTest, + cvmValidationDirectContextTest, cvmValidationProofContextTest, + cvmValidationXContextTest, cvmValidationRootContextTest, + cvmValidationFamilyContextTest, cvmValidationAlphaContextTest, + cvmValidationPDomainTest, cvmFamilyContext, + cvmCtorFunctionContext, cvmCtorDirectContext, + cvmCtorProofContext, cvmCtorXContext, cvmCtorPContext, + cvmCtorAlphaContext, cvmConstructorContext, + constructorValidityMatrixContext, constructorValidityMatrixKernelCtor, + constructorValidityMatrixMkInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, + AddInductive.consumeTypeAnnotations, Expr.bindingDomain!, + Expr.bindingBody!, Expr.instantiate1_eq, Expr.instantiate1'] + +theorem cvmValidationLaterDepthTest : + cvmValidationLaterContextTest.fuel.recDepth = 10000 := by + rfl + +theorem cvmValidationLaterProofEnsureTest : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨cvmValidationLaterContextTest, cvmCtorLaterProofDomain, + .sort .zero⟩ := by + rw [cvmCtorLaterProofDomainValidationShapeTest] + exact cvmEnsureTypeOfInferOnlyTest cvmValidationLaterContextTest + (cvmValidationPredicateApplicationTest cvmValidationPIdTest + (.fvar cvmValidationLaterIdTest)) .zero + (cvmValidationPredicateApplicationStateTest cvmValidationPIdTest + (.fvar cvmValidationLaterIdTest)) + (cvmInferTypePredicateApplicationOnlyTest cvmValidationLaterContextTest + cvmValidationPIdTest (.fvar cvmValidationLaterIdTest) + cvmValidationPFindInLaterTest cvmValidationLaterDepthTest + (by simp [cvmValidationPredicateApplicationTest, + Expr.hasLooseBVars, Expr.looseBVarRange'])) + +def cvmValidationLaterProofContextTest : AddInductive.Context := + cvmValidationLaterContextTest.pushLocalDecl `laterProof .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) + +theorem cvmValidationLaterFreshEqTest : + cvmValidationLaterContextTest.freshExpr = + cvmCtorLaterContext.freshExpr := by + simp [cvmValidationLaterContextTest, cvmValidationFunctionContextTest, + cvmValidationDirectContextTest, cvmValidationProofContextTest, + cvmValidationXContextTest, cvmValidationRootContextTest, + cvmValidationFamilyContextTest, cvmValidationAlphaContextTest, + cvmValidationPDomainTest, cvmCtorLaterContext, + cvmCtorFunctionContext, cvmCtorDirectContext, + cvmCtorProofContext, cvmCtorXContext, cvmCtorPContext, + cvmCtorAlphaContext, cvmCtorLaterDomain, cvmCtorAfterFunction, + cvmCtorFunctionDomain, cvmCtorAfterDirect, cvmCtorDirectDomain, + cvmCtorAfterProof, cvmCtorProofDomain, cvmCtorAfterX, + cvmCtorXDomain, cvmCtorAfterP, cvmCtorAfterAlpha, + cvmFamilyContext, cvmConstructorContext, + constructorValidityMatrixContext, constructorValidityMatrixKernelCtor, + constructorValidityMatrixMkInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, + AddInductive.consumeTypeAnnotations, Expr.bindingDomain!, + Expr.bindingBody!, Expr.instantiate1_eq, Expr.instantiate1'] + +theorem cvmSixthFieldSourceTest : + cvmCtorAfterLater.bindingBody!.instantiate1 + cvmValidationLaterContextTest.freshExpr = cvmCtorTerminal := by + unfold cvmCtorTerminal + rw [cvmValidationLaterFreshEqTest] + +theorem cvmCtorTerminalValidationShapeTest : + cvmCtorTerminal = cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest) := by + simp [cvmCtorTerminal, cvmCtorAfterLater, cvmCtorAfterFunction, + cvmCtorAfterDirect, cvmCtorAfterProof, cvmCtorAfterX, + cvmCtorAfterP, cvmCtorAfterAlpha, + cvmValidationFamilyApplicationTest, cvmValidationAlphaIdTest, + cvmValidationPIdTest, cvmValidationAlphaContextTest, + cvmFamilyContext, cvmCtorLaterContext, cvmCtorFunctionContext, + cvmCtorDirectContext, cvmCtorProofContext, cvmCtorXContext, + cvmCtorPContext, cvmCtorAlphaContext, cvmConstructorContext, + constructorValidityMatrixContext, constructorValidityMatrixKernelCtor, + constructorValidityMatrixKernelType, constructorValidityMatrixMkInfo, + constructorValidityMatrixInfo, ConstantInfo.name, ConstantInfo.type, + ConstantInfo.toConstantVal, AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, + Expr.bindingBody!, Expr.instantiate1_eq, Expr.instantiate1'] + +noncomputable def cvmConstructorValidationTest : + AddInductive.ConstructorValidationRun + constructorValidityMatrixKernelType cvmFamilyValidationRun.stats false + cvmValidationRootContextTest := + AddInductive.ConstructorValidationRun.of_run (by + have run : AddInductive.checkConstructors + #[constructorValidityMatrixKernelType] + cvmFamilyValidationRun.stats false + cvmConstructorValidationContextTest = .ok () := by + simpa [cvmConstructorValidationContextTest] using cvmCheckConstructorsRun + rw [cvmConstructorValidationContextTest_root] at run + exact run) + +theorem cvmUniverseSemanticsTest : + cvmConstructorValidationTest.trace.universeSemantics = true := by + generalize htrace : cvmConstructorValidationTest.trace = trace + cases trace with + | cons seen head tail freshName closed rootCheck typeTrace tailTrace => + cases tailTrace with + | nil finalSeen => + simp only [AddInductive.ConstructorListValidationTrace.universeSemantics, + Bool.and_true] + cases typeTrace with + | parameter context fuel argIdx name domain body binderInfo parameter + parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStatsParamsTest] at parameterAt + simp at parameterAt + cases parameterAt + simp only [AddInductive.ConstructorTypeValidationTrace.universeSemantics] + change AddInductive.ConstructorTypeValidationTrace + cvmFamilyValidationRun.stats false 0 + constructorValidityMatrixKernelCtor.name + cvmValidationRootContextTest + (constructorValidityMatrixKernelCtor.type.bindingBody!.instantiate1 + cvmFamilyContext.freshExpr) 1 999 at tail + let sourceEq := cvmFirstParameterSourceTest.trans + cvmCtorAfterAlphaForallTest + let tail' := sourceEq ▸ tail + refine (cvmUniverseSemanticsCastSourceTest sourceEq tail).symm.trans ?_ + change tail'.universeSemantics = true + cases tail' with + | parameter context fuel argIdx name domain body binderInfo parameter + parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStatsParamsTest] at parameterAt + simp at parameterAt + cases parameterAt + simp only [AddInductive.ConstructorTypeValidationTrace.universeSemantics] + change AddInductive.ConstructorTypeValidationTrace + cvmFamilyValidationRun.stats false 0 + constructorValidityMatrixKernelCtor.name + cvmValidationRootContextTest + (cvmCtorAfterAlpha.bindingBody!.instantiate1 + cvmValidationAlphaContextTest.freshExpr) 2 998 at tail + let sourceEq := cvmSecondParameterSourceTest.trans + cvmCtorAfterPForallTest + let tail' := sourceEq ▸ tail + refine (cvmUniverseSemanticsCastSourceTest sourceEq tail).symm.trans ?_ + change tail'.universeSemantics = true + cases tail' with + | parameter context fuel argIdx name domain body binderInfo parameter + parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStatsParamsTest] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity tail => + have ensureTypeRoot : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨cvmValidationRootContextTest, cvmCtorXDomain, + sortResult⟩ := by + exact ensureType + have sortResultEq : + sortResult = .sort (.succ (.param `u)) := + cvmEnsureTypeResultEqTest ensureTypeRoot + cvmValidationXEnsureTest + subst sortResult + simp only [AddInductive.ConstructorTypeValidationTrace.universeSemantics] + have universeSemantic : universeTrace.semantic = true := by + unfold AddInductive.ConstructorUniverseTrace.semantic + rw [cvmStatsResultLevelTest] + simp [Expr.sortLevel!, + AddInductive.ConstructorUniverseTrace.semantic, + AddInductive.constructorUniverseSemanticGe, + AddInductive.levelStructGe, + AddInductive.levelStructEq] + rw [universeSemantic] + simp only [Bool.true_and] + let sourceEq := cvmFirstFieldSourceTest.trans + cvmCtorAfterXForallTest + let tail' := sourceEq ▸ tail + refine (cvmUniverseSemanticsCastSourceTest sourceEq tail).symm.trans ?_ + change tail'.universeSemantics = true + cases tail' with + | parameter context fuel argIdx name domain body binderInfo parameter + parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStatsParamsTest] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity tail => + have ensureTypeProof : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨cvmValidationXContextTest, + cvmCtorProofDomain, sortResult⟩ := by + exact ensureType + have sortResultEq : sortResult = .sort .zero := + cvmEnsureTypeResultEqTest ensureTypeProof + cvmValidationProofEnsureTest + subst sortResult + simp only [AddInductive.ConstructorTypeValidationTrace.universeSemantics] + have universeSemantic : universeTrace.semantic = true := by + unfold AddInductive.ConstructorUniverseTrace.semantic + rw [cvmStatsResultLevelTest] + simp [Expr.sortLevel!, + AddInductive.constructorUniverseSemanticGe, + AddInductive.levelStructGe, + AddInductive.levelStructEq] + rw [universeSemantic] + simp only [Bool.true_and] + let sourceEq := cvmSecondFieldSourceTest.trans + cvmCtorAfterProofForallTest + let tail' := sourceEq ▸ tail + refine (cvmUniverseSemanticsCastSourceTest + sourceEq tail).symm.trans ?_ + change tail'.universeSemantics = true + cases tail' with + | parameter context fuel argIdx name domain body binderInfo + parameter parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStatsParamsTest] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo + sortResult noParameter ensureType universeTrace positivity tail => + have ensureTypeDirect : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨cvmValidationProofContextTest, + cvmCtorDirectDomain, sortResult⟩ := by + exact ensureType + have sortResultEq : + sortResult = .sort (.succ (.param `u)) := + cvmEnsureTypeResultEqTest ensureTypeDirect + cvmValidationDirectEnsureTest + subst sortResult + simp only [AddInductive.ConstructorTypeValidationTrace.universeSemantics] + have universeSemantic : universeTrace.semantic = true := by + unfold AddInductive.ConstructorUniverseTrace.semantic + rw [cvmStatsResultLevelTest] + simp [Expr.sortLevel!, + AddInductive.constructorUniverseSemanticGe, + AddInductive.levelStructGe, + AddInductive.levelStructEq] + rw [universeSemantic] + simp only [Bool.true_and] + let sourceEq := cvmThirdFieldSourceTest.trans + cvmCtorAfterDirectForallTest + let tail' := sourceEq ▸ tail + refine (cvmUniverseSemanticsCastSourceTest + sourceEq tail).symm.trans ?_ + change tail'.universeSemantics = true + cases tail' with + | parameter context fuel argIdx name domain body binderInfo + parameter parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStatsParamsTest] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo + sortResult noParameter ensureType universeTrace positivity tail => + have ensureTypeFunction : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨cvmValidationDirectContextTest, + cvmCtorFunctionDomain, sortResult⟩ := by + exact ensureType + have sortResultEq : + sortResult = .sort (.succ (.param `u)) := + cvmEnsureTypeResultEqTest ensureTypeFunction + cvmValidationFunctionEnsureTest + subst sortResult + simp only [AddInductive.ConstructorTypeValidationTrace.universeSemantics] + have universeSemantic : universeTrace.semantic = true := by + unfold AddInductive.ConstructorUniverseTrace.semantic + rw [cvmStatsResultLevelTest] + simp [Expr.sortLevel!, + AddInductive.constructorUniverseSemanticGe, + AddInductive.levelStructGe, + AddInductive.levelStructEq] + rw [universeSemantic] + simp only [Bool.true_and] + let sourceEq := cvmFourthFieldSourceTest.trans + cvmCtorAfterFunctionForallTest + let tail' := sourceEq ▸ tail + refine (cvmUniverseSemanticsCastSourceTest + sourceEq tail).symm.trans ?_ + change tail'.universeSemantics = true + cases tail' with + | parameter context fuel argIdx name domain body binderInfo + parameter parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStatsParamsTest] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo + sortResult noParameter ensureType universeTrace positivity tail => + have ensureTypeLater : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨cvmValidationFunctionContextTest, + cvmCtorLaterDomain, sortResult⟩ := by + exact ensureType + have sortResultEq : + sortResult = .sort (.succ (.param `u)) := + cvmEnsureTypeResultEqTest ensureTypeLater + cvmValidationLaterEnsureTest + subst sortResult + simp only [AddInductive.ConstructorTypeValidationTrace.universeSemantics] + have universeSemantic : universeTrace.semantic = true := by + unfold AddInductive.ConstructorUniverseTrace.semantic + rw [cvmStatsResultLevelTest] + simp [Expr.sortLevel!, + AddInductive.constructorUniverseSemanticGe, + AddInductive.levelStructGe, + AddInductive.levelStructEq] + rw [universeSemantic] + simp only [Bool.true_and] + let sourceEq := cvmFifthFieldSourceTest.trans + cvmCtorAfterLaterForallTest + let tail' := sourceEq ▸ tail + refine (cvmUniverseSemanticsCastSourceTest + sourceEq tail).symm.trans ?_ + change tail'.universeSemantics = true + cases tail' with + | parameter context fuel argIdx name domain body binderInfo + parameter parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStatsParamsTest] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo + sortResult noParameter ensureType universeTrace positivity tail => + have ensureTypeLaterProof : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨cvmValidationLaterContextTest, + cvmCtorLaterProofDomain, sortResult⟩ := by + exact ensureType + have sortResultEq : + sortResult = .sort .zero := + cvmEnsureTypeResultEqTest + ensureTypeLaterProof + cvmValidationLaterProofEnsureTest + subst sortResult + simp only [AddInductive.ConstructorTypeValidationTrace.universeSemantics] + have universeSemantic : universeTrace.semantic = true := by + unfold AddInductive.ConstructorUniverseTrace.semantic + rw [cvmStatsResultLevelTest] + simp [Expr.sortLevel!, + AddInductive.constructorUniverseSemanticGe, + AddInductive.levelStructGe, + AddInductive.levelStructEq] + rw [universeSemantic] + simp only [Bool.true_and] + let sourceEq := cvmSixthFieldSourceTest.trans + cvmCtorTerminalValidationShapeTest + let tail' := sourceEq ▸ tail + refine (cvmUniverseSemanticsCastSourceTest + sourceEq tail).symm.trans ?_ + change tail'.universeSemantics = true + cases tail' with + | terminal context source fuel argIdx terminal valid => + rfl + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity tail => + rw [cvmStatsParamsTest] at noParameter + simp at noParameter + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity tail => + rw [cvmStatsParamsTest] at noParameter + contradiction + | terminal context source fuel argIdx terminal valid => + simp [constructorValidityMatrixKernelCtor, + constructorValidityMatrixMkInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, Expr.isForall] at terminal + +theorem cvmUniverseRunTest : + AddInductive.checkConstructorUniverseListSemantics + cvmFamilyValidationRun.stats constructorValidityMatrixKernelType.ctors + cvmValidationRootContextTest = .ok () := + cvmConstructorValidationTest.trace.universeRun_of_semantics + cvmUniverseSemanticsTest + +theorem cvmValidationGetTypeAlphaTest : + AddInductive.getType (.fvar cvmValidationAlphaIdTest) + cvmValidationRootContextTest = + .ok (.sort (.succ (.param `u))) := by + unfold AddInductive.getType + simp only [getLCtx, ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] + change Except.ok ((cvmValidationRootContextTest.lctx.get! + cvmValidationAlphaIdTest).type) = _ + simp [LocalContext.get!, cvmValidationAlphaFindTest, LocalDecl.type] + +theorem cvmValidationGetTypePTest : + AddInductive.getType (.fvar cvmValidationPIdTest) + cvmValidationRootContextTest = .ok cvmValidationPDomainTest := by + unfold AddInductive.getType + simp only [getLCtx, ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] + change Except.ok ((cvmValidationRootContextTest.lctx.get! + cvmValidationPIdTest).type) = _ + simp [LocalContext.get!, cvmValidationPFindTest, LocalDecl.type] + +theorem cvmValidationRootSortCheckTest : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationRootContextTest, .sort (.succ (.param `u)), + .sort (.succ (.succ (.param `u)))⟩ := + prbPreFamilySortCheckValidReplay cvmValidationRootContextTest + cvmValidationRootLparamsTest cvmValidationRootDepthTest + +def cvmValidationPDomainAlphaStateTest : TypeChecker.State := + prbReplayInsert ({} : TypeChecker.State) + (.fvar cvmValidationAlphaIdTest) (.sort (.succ (.param `u))) + +def cvmValidationPDomainInternalIdTest : FVarId := + ⟨cvmValidationPDomainAlphaStateTest.ngen.curr⟩ + +def cvmValidationPDomainInternalStateTest : TypeChecker.State := + { cvmValidationPDomainAlphaStateTest with + ngen := cvmValidationPDomainAlphaStateTest.ngen.next } + +def cvmValidationPDomainFinalStateTest : TypeChecker.State := + prbReplayInsert cvmValidationPDomainInternalStateTest + (.sort .zero) (.sort (.succ .zero)) + +theorem cvmValidationAlphaToPropCheckTest (indexName : Name) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationRootContextTest, + .forallE indexName (.fvar cvmValidationAlphaIdTest) + (.sort .zero) .default, + .sort (mkLevelIMax' (.succ (.param `u)) (.succ .zero))⟩ := by + have domainRun : TypeChecker.Inner.inferType' + (.fvar cvmValidationAlphaIdTest) false + (TypeChecker.Methods.withFuel 9998) + cvmValidationRootContextTest.toTypeChecker + ({} : TypeChecker.State) = + .ok (.sort (.succ (.param `u)), + cvmValidationPDomainAlphaStateTest) := by + simpa [cvmValidationPDomainAlphaStateTest] using + prbValidationInferTypeFVarCore 9998 cvmValidationRootContextTest + ({} : TypeChecker.State) cvmValidationAlphaIdTest + (.sort (.succ (.param `u))) Std.HashMap.getElem?_empty + cvmValidationAlphaFindTest + have bodyMiss : cvmValidationPDomainInternalStateTest.inferTypeC[ + (.sort .zero : Expr)]? = none := by + simp [cvmValidationPDomainInternalStateTest, + cvmValidationPDomainAlphaStateTest, prbReplayInsert] + have bodyRun : TypeChecker.Inner.inferType' + (.sort .zero) false (TypeChecker.Methods.withFuel 9998) + { cvmValidationRootContextTest.toTypeChecker with + lctx := cvmValidationRootContextTest.lctx.mkLocalDecl + cvmValidationPDomainInternalIdTest indexName + (.fvar cvmValidationAlphaIdTest) .default } + cvmValidationPDomainInternalStateTest = + .ok (.sort (.succ .zero), cvmValidationPDomainFinalStateTest) := by + simpa [cvmValidationPDomainFinalStateTest] using + prbPreFamilyInferSortZeroCoreReplay 9998 _ + cvmValidationPDomainInternalStateTest bodyMiss + have forallRun : TypeChecker.Inner.inferForall + (.forallE indexName + (.fvar cvmValidationAlphaIdTest) (.sort .zero) .default) false + (TypeChecker.Methods.withFuel 9999) + cvmValidationRootContextTest.toTypeChecker + ({} : TypeChecker.State) = + .ok (.sort + (mkLevelIMax' (.succ (.param `u)) (.succ .zero)), + cvmValidationPDomainFinalStateTest) := by + unfold TypeChecker.Inner.inferForall + simp only [TypeChecker.Inner.inferForall.loop] + rw [show (.fvar cvmValidationAlphaIdTest : Expr).instantiateRev #[] = + .fvar cvmValidationAlphaIdTest by + simp [Expr.instantiateRev_eq, Expr.instantiate_eq]] + simp only [Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rw [show TypeChecker.Inner.inferType + (.fvar cvmValidationAlphaIdTest) false + (TypeChecker.Methods.withFuel 9999) + cvmValidationRootContextTest.toTypeChecker + ({} : TypeChecker.State) = + TypeChecker.Inner.inferType' + (.fvar cvmValidationAlphaIdTest) false + (TypeChecker.Methods.withFuel 9998) + cvmValidationRootContextTest.toTypeChecker + ({} : TypeChecker.State) by rfl] + rw [domainRun] + simp only [prbEnsureSortExact] + rw [prbWithLocalDeclEq] + change TypeChecker.Inner.inferForall.loop false + #[Expr.fvar cvmValidationPDomainInternalIdTest] + #[Level.succ (.param `u)] (.sort .zero) + (TypeChecker.Methods.withFuel 9999) + { cvmValidationRootContextTest.toTypeChecker with + lctx := cvmValidationRootContextTest.lctx.mkLocalDecl + cvmValidationPDomainInternalIdTest indexName + (.fvar cvmValidationAlphaIdTest) .default } + cvmValidationPDomainInternalStateTest = _ + simp only [TypeChecker.Inner.inferForall.loop] + rw [show (.sort .zero : Expr).instantiateRev + #[Expr.fvar cvmValidationPDomainInternalIdTest] = .sort .zero by + simp [Expr.instantiateRev_eq, Expr.instantiate_eq]] + simp only [Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rw [show TypeChecker.Inner.inferType (.sort .zero) false + (TypeChecker.Methods.withFuel 9999) _ + cvmValidationPDomainInternalStateTest = + TypeChecker.Inner.inferType' (.sort .zero) false + (TypeChecker.Methods.withFuel 9998) _ + cvmValidationPDomainInternalStateTest by rfl] + rw [bodyRun] + simp [Expr.sortLevel!, Pure.pure, ReaderT.pure, + StateT.pure, Except.pure] + have outerRun := prbInferTypeForallCore 9999 + cvmValidationRootContextTest.toTypeChecker ({} : TypeChecker.State) + cvmValidationPDomainFinalStateTest indexName + (.fvar cvmValidationAlphaIdTest) (.sort .zero) + (.sort (mkLevelIMax' (.succ (.param `u)) (.succ .zero))) .default + (by simp [Expr.hasLooseBVars, + Expr.looseBVarRange']) Std.HashMap.getElem?_empty + forallRun + unfold AddInductive.CandidateCheckTypeStep.Valid + change TypeChecker.M.run cvmValidationRootContextTest.env + cvmValidationRootContextTest.safety cvmValidationRootContextTest.lctx + cvmValidationRootContextTest.lparams cvmValidationRootContextTest.fuel + (TypeChecker.checkType (.forallE indexName + (.fvar cvmValidationAlphaIdTest) (.sort .zero) .default)) = _ + unfold TypeChecker.M.run TypeChecker.checkType TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rw [cvmValidationRootDepthTest] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' (.forallE indexName + (.fvar cvmValidationAlphaIdTest) (.sort .zero) .default) false + (TypeChecker.Methods.withFuel 9999) + cvmValidationRootContextTest.toTypeChecker + ({} : TypeChecker.State)) = _ + simpa [Functor.map, Except.map] using + congrArg (Except.map (fun x : Expr × TypeChecker.State => x.1)) + outerRun + +theorem cvmValidationPDomainCheckTest : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationRootContextTest, cvmValidationPDomainTest, + .sort (mkLevelIMax' (.succ (.param `u)) (.succ .zero))⟩ := by + rw [cvmValidationPDomainShapeTest] + exact cvmValidationAlphaToPropCheckTest cvmValidationIndexNameTest + +theorem cvmValidationFamilyGetTest : + cvmConstructorContext.env.get + constructorValidityMatrixKernelType.name = + .ok cvmDeclaredInfo := by + unfold Kernel.Environment.get + rw [cvmCtorFamilyLookup] + rfl + +@[simp] theorem cvmValidationCheckLevelParamTest + (context : AddInductive.Context) + (lparams : context.lparams = [`u]) : + TypeChecker.Inner.checkLevel context.toTypeChecker (.param `u) = + .ok () := by + simp [TypeChecker.Inner.checkLevel, AddInductive.Context.toTypeChecker, + lparams, Level.getUndefParam, Level.forEach, + Level.hasParam_eq, Level.hasParam'] + rfl + +@[simp] theorem cvmInferConstantFamilyFullTest + (context : AddInductive.Context) + (envEq : context.env = cvmConstructorContext.env) + (lparams : context.lparams = [`u]) + (safety : context.safety = .safe) : + TypeChecker.Inner.inferConstant context.toTypeChecker + constructorValidityMatrixKernelType.name [.param `u] false = + .ok constructorValidityMatrixKernelType.type := by + unfold TypeChecker.Inner.inferConstant + simp only [AddInductive.Context.toTypeChecker] + rw [envEq, cvmValidationFamilyGetTest] + have terminalLparams : + cvmCandidate.families.singleton.familyType.type.trace.terminalContext.lparams = + [`u] := cvmTerminalLparams_eq + unfold cvmDeclaredInfo AddInductive.singletonDeclaredInfo + rw [terminalLparams] + have levelCheck : TypeChecker.Inner.checkLevel + ({ env := cvmConstructorContext.env + lctx := context.lctx + safety := .safe + lparams := [`u] + fuel := context.fuel } : TypeChecker.Context) + (.param `u) = .ok () := by + simp [TypeChecker.Inner.checkLevel, + Level.getUndefParam, Level.forEach, + Level.hasParam_eq, Level.hasParam'] + rfl + simp [constructorValidityMatrixKernelType, + constructorValidityMatrixInfo, ConstantInfo.levelParams, + ConstantInfo.isUnsafe, ConstantInfo.instantiateTypeLevelParams, + ConstantInfo.toConstantVal, ConstantVal.instantiateTypeLevelParams, + Expr.instantiateLevelParams_eq, Expr.instantiateLevelParamsCore', + Syntax.structEq_eq, Level.substParams', safety, lparams, + levelCheck, Bind.bind, Except.bind, Pure.pure, Except.pure] + simp [Expr.instantiateLevelParamsCore', Level.substParams', + constructorValidityMatrixKernelType, constructorValidityMatrixInfo, + ConstantInfo.type, ConstantInfo.toConstantVal] + +def cvmValidationFamilyConstStateTest + (state : TypeChecker.State) : TypeChecker.State := + prbReplayInsert state + (.const constructorValidityMatrixKernelType.name [.param `u]) + constructorValidityMatrixKernelType.type + +theorem cvmValidationInferTypeFamilyCoreTest + (fuel : Nat) (context : AddInductive.Context) + (state : TypeChecker.State) + (cacheMiss : state.inferTypeC[ + (.const constructorValidityMatrixKernelType.name + [.param `u] : Expr)]? = none) + (envEq : context.env = cvmConstructorContext.env) + (lparams : context.lparams = [`u]) + (safety : context.safety = .safe) : + TypeChecker.Inner.inferType' + (.const constructorValidityMatrixKernelType.name [.param `u]) false + (TypeChecker.Methods.withFuel fuel) context.toTypeChecker state = + .ok (constructorValidityMatrixKernelType.type, + cvmValidationFamilyConstStateTest state) := by + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', cacheMiss, + cvmValidationFamilyConstStateTest, prbReplayInsert, + cvmInferConstantFamilyFullTest context envEq lparams safety, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +def cvmValidationFamilyTailFullTest (alpha : Expr) : Expr := + .forallE `P + (.forallE cvmValidationIndexNameTest alpha (.sort .zero) .default) + (.sort (.succ (.param `u))) .default + +def cvmValidationFirstAppFullTest (alpha : Expr) : Expr := + .app (.const constructorValidityMatrixKernelType.name [.param `u]) alpha + +def cvmValidationFamilyAlphaStateTest + (state : TypeChecker.State) (alphaId : FVarId) : TypeChecker.State := + prbReplayInsert (cvmValidationFamilyConstStateTest state) + (.fvar alphaId) (.sort (.succ (.param `u))) + +def cvmValidationFamilyFirstAppStateTest + (state : TypeChecker.State) (alphaId : FVarId) : TypeChecker.State := + prbReplayInsert (cvmValidationFamilyAlphaStateTest state alphaId) + (cvmValidationFirstAppFullTest (.fvar alphaId)) + (cvmValidationFamilyTailFullTest (.fvar alphaId)) + +def cvmValidationFamilyPredicateStateTest + (state : TypeChecker.State) (alphaId predicateId : FVarId) : + TypeChecker.State := + prbReplayInsert (cvmValidationFamilyFirstAppStateTest state alphaId) + (.fvar predicateId) + (.forallE cvmValidationIndexNameTest (.fvar alphaId) + (.sort .zero) .default) + +def cvmValidationFamilyFullAppStateTest + (state : TypeChecker.State) (alphaId predicateId : FVarId) : + TypeChecker.State := + prbReplayInsert + (cvmValidationFamilyPredicateStateTest state alphaId predicateId) + (cvmValidationFamilyApplicationTest + (.fvar alphaId) (.fvar predicateId)) + (.sort (.succ (.param `u))) + +theorem cvmValidationFamilyApplicationCheckTest + (context : AddInductive.Context) (alphaId predicateId : FVarId) + (alphaEq : alphaId = cvmValidationAlphaIdTest) + (idsNe : alphaId ≠ predicateId) + (alphaFind : context.lctx.find? alphaId = + some (.cdecl alphaIndex alphaId alphaName + (.sort (.succ (.param `u))) alphaBi alphaKind)) + (predicateFind : context.lctx.find? predicateId = + some (.cdecl predicateIndex predicateId predicateName + cvmValidationPDomainTest predicateBi predicateKind)) + (envEq : context.env = cvmConstructorContext.env) + (lparams : context.lparams = [`u]) + (safety : context.safety = .safe) + (depth : context.fuel.recDepth = 10000) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, cvmValidationFamilyApplicationTest + (.fvar alphaId) (.fvar predicateId), + .sort (.succ (.param `u))⟩ := by + let initial := ({} : TypeChecker.State) + have familyRun : TypeChecker.Inner.inferType' + (.const constructorValidityMatrixKernelType.name [.param `u]) false + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker initial = + .ok (constructorValidityMatrixKernelType.type, + cvmValidationFamilyConstStateTest initial) := by + apply cvmValidationInferTypeFamilyCoreTest + · simp [initial] + · exact envEq + · exact lparams + · exact safety + have alphaMiss : + (cvmValidationFamilyConstStateTest initial).inferTypeC[ + (.fvar alphaId : Expr)]? = none := by + simp [cvmValidationFamilyConstStateTest, prbReplayInsert, initial] + have alphaRun : TypeChecker.Inner.inferType' (.fvar alphaId) false + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker + (cvmValidationFamilyConstStateTest initial) = + .ok (.sort (.succ (.param `u)), + cvmValidationFamilyAlphaStateTest initial alphaId) := by + simpa [cvmValidationFamilyAlphaStateTest] using + prbValidationInferTypeFVarCore 9999 context + (cvmValidationFamilyConstStateTest initial) alphaId + (.sort (.succ (.param `u))) alphaMiss alphaFind + have firstRun := prbInferAppCoreOf 9999 context.toTypeChecker initial + (cvmValidationFamilyConstStateTest initial) + (cvmValidationFamilyAlphaStateTest initial alphaId) + (.const constructorValidityMatrixKernelType.name [.param `u]) + (.fvar alphaId) (.sort (.succ (.param `u))) + (.forallE `P + (.forallE cvmValidationIndexNameTest (.bvar 0) + (.sort .zero) .default) + (.sort (.succ (.param `u))) .default) + `α .default + (by simp [Expr.hasLooseBVars, Expr.looseBVarRange']) + (by simp [initial, cvmValidationFirstAppFullTest]) + (by simpa [cvmKernelFamilyTypeShapeTest] using familyRun) + alphaRun (by rfl) + have firstRun' : TypeChecker.Inner.inferType' + (cvmValidationFirstAppFullTest (.fvar alphaId)) false + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker initial = + .ok (cvmValidationFamilyTailFullTest (.fvar alphaId), + cvmValidationFamilyFirstAppStateTest initial alphaId) := by + simpa [cvmValidationFirstAppFullTest, + cvmValidationFamilyTailFullTest, + cvmValidationFamilyFirstAppStateTest, + cvmValidationFamilyAlphaStateTest, prbReplayInsert, + Expr.instantiate1_eq, Expr.instantiate1'] using firstRun + have predicateMiss : + (cvmValidationFamilyFirstAppStateTest initial alphaId).inferTypeC[ + (.fvar predicateId : Expr)]? = none := by + have idsBeq : ((.fvar alphaId : Expr) == .fvar predicateId) = false := by + change Expr.eqv (.fvar alphaId) (.fvar predicateId) = false + rw [Expr.eqv_eq] + simp [Expr.eqv', idsNe] + simp [cvmValidationFamilyFirstAppStateTest, + cvmValidationFamilyAlphaStateTest, + cvmValidationFamilyConstStateTest, + cvmValidationFirstAppFullTest, prbReplayInsert, initial, idsBeq] + have predicateRun : TypeChecker.Inner.inferType' (.fvar predicateId) false + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker + (cvmValidationFamilyFirstAppStateTest initial alphaId) = + .ok (.forallE cvmValidationIndexNameTest (.fvar alphaId) + (.sort .zero) .default, + cvmValidationFamilyPredicateStateTest initial alphaId predicateId) := by + simpa [cvmValidationFamilyPredicateStateTest, + cvmValidationPDomainShapeTest, alphaEq] using + prbValidationInferTypeFVarCore 9999 context + (cvmValidationFamilyFirstAppStateTest initial alphaId) + predicateId cvmValidationPDomainTest predicateMiss predicateFind + have fullRun := prbInferAppCoreOf 9999 context.toTypeChecker initial + (cvmValidationFamilyFirstAppStateTest initial alphaId) + (cvmValidationFamilyPredicateStateTest initial alphaId predicateId) + (cvmValidationFirstAppFullTest (.fvar alphaId)) + (.fvar predicateId) + (.forallE cvmValidationIndexNameTest (.fvar alphaId) + (.sort .zero) .default) + (.sort (.succ (.param `u))) `P .default + (by simp [cvmValidationFamilyApplicationTest, + cvmValidationFirstAppFullTest, Expr.hasLooseBVars, + Expr.looseBVarRange']) + (by simp [initial, cvmValidationFamilyApplicationTest]) + firstRun' predicateRun (by rfl) + unfold AddInductive.CandidateCheckTypeStep.Valid + change TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel + (TypeChecker.checkType (cvmValidationFamilyApplicationTest + (.fvar alphaId) (.fvar predicateId))) = + .ok (.sort (.succ (.param `u))) + unfold TypeChecker.M.run TypeChecker.checkType TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rw [depth] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' + (cvmValidationFamilyApplicationTest + (.fvar alphaId) (.fvar predicateId)) false + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker initial) = _ + simpa [cvmValidationFamilyApplicationTest, + cvmValidationFirstAppFullTest, + cvmValidationFamilyFullAppStateTest, + cvmValidationFamilyPredicateStateTest, prbReplayInsert, + Expr.instantiate1_eq, Expr.instantiate1', Functor.map, Except.map] using + congrArg (Except.map (fun x : Expr × TypeChecker.State => x.1)) + fullRun + +def cvmValidationPredicateFullStateTest + (state : TypeChecker.State) (predicateId : FVarId) : + TypeChecker.State := + prbReplayInsert state (.fvar predicateId) cvmValidationPDomainTest + +def cvmValidationPredicateArgumentStateTest + (state : TypeChecker.State) (predicateId argumentId : FVarId) : + TypeChecker.State := + prbReplayInsert (cvmValidationPredicateFullStateTest state predicateId) + (.fvar argumentId) (.fvar cvmValidationAlphaIdTest) + +def cvmValidationPredicateFullAppStateTest + (state : TypeChecker.State) (predicateId argumentId : FVarId) : + TypeChecker.State := + prbReplayInsert + (cvmValidationPredicateArgumentStateTest state predicateId argumentId) + (cvmValidationPredicateApplicationTest predicateId (.fvar argumentId)) + (.sort .zero) + +theorem cvmValidationPredicateApplicationCheckTest + (context : AddInductive.Context) (predicateId argumentId : FVarId) + (idsNe : predicateId ≠ argumentId) + (predicateFind : context.lctx.find? predicateId = + some (.cdecl predicateIndex predicateId predicateName + cvmValidationPDomainTest predicateBi predicateKind)) + (argumentFind : context.lctx.find? argumentId = + some (.cdecl argumentIndex argumentId argumentName + (.fvar cvmValidationAlphaIdTest) argumentBi argumentKind)) + (depth : context.fuel.recDepth = 10000) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, + cvmValidationPredicateApplicationTest predicateId (.fvar argumentId), + .sort .zero⟩ := by + let initial := ({} : TypeChecker.State) + have predicateRun : TypeChecker.Inner.inferType' + (.fvar predicateId) false (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker initial = + .ok (.forallE cvmValidationIndexNameTest + (.fvar cvmValidationAlphaIdTest) (.sort .zero) .default, + cvmValidationPredicateFullStateTest initial predicateId) := by + simpa [cvmValidationPredicateFullStateTest, + cvmValidationPDomainShapeTest] using + prbValidationInferTypeFVarCore 9999 context initial predicateId + cvmValidationPDomainTest (by simp [initial]) predicateFind + have argumentMiss : + (cvmValidationPredicateFullStateTest initial predicateId).inferTypeC[ + (.fvar argumentId : Expr)]? = none := by + have idsBeq : ((.fvar predicateId : Expr) == .fvar argumentId) = false := by + change Expr.eqv (.fvar predicateId) (.fvar argumentId) = false + rw [Expr.eqv_eq] + simp [Expr.eqv', idsNe] + simp [cvmValidationPredicateFullStateTest, prbReplayInsert, + initial, idsBeq] + have argumentRun : TypeChecker.Inner.inferType' + (.fvar argumentId) false (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker + (cvmValidationPredicateFullStateTest initial predicateId) = + .ok (.fvar cvmValidationAlphaIdTest, + cvmValidationPredicateArgumentStateTest + initial predicateId argumentId) := by + simpa [cvmValidationPredicateArgumentStateTest] using + prbValidationInferTypeFVarCore 9999 context + (cvmValidationPredicateFullStateTest initial predicateId) + argumentId (.fvar cvmValidationAlphaIdTest) + argumentMiss argumentFind + have appRun := prbInferAppCoreOf 9999 context.toTypeChecker initial + (cvmValidationPredicateFullStateTest initial predicateId) + (cvmValidationPredicateArgumentStateTest initial predicateId argumentId) + (.fvar predicateId) (.fvar argumentId) + (.fvar cvmValidationAlphaIdTest) (.sort .zero) + cvmValidationIndexNameTest .default + (by simp [cvmValidationPredicateApplicationTest, + Expr.hasLooseBVars, Expr.looseBVarRange']) + (by simp [initial, cvmValidationPredicateApplicationTest]) + predicateRun argumentRun (by rfl) + unfold AddInductive.CandidateCheckTypeStep.Valid + change TypeChecker.M.run context.env context.safety context.lctx + context.lparams context.fuel + (TypeChecker.checkType + (cvmValidationPredicateApplicationTest predicateId + (.fvar argumentId))) = .ok (.sort .zero) + unfold TypeChecker.M.run TypeChecker.checkType TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + rw [depth] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' + (cvmValidationPredicateApplicationTest predicateId + (.fvar argumentId)) false + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker initial) = _ + simpa [cvmValidationPredicateApplicationTest, + cvmValidationPredicateFullAppStateTest, + cvmValidationPredicateArgumentStateTest, prbReplayInsert, + Expr.instantiate1_eq, Expr.instantiate1', Functor.map, Except.map] using + congrArg (Except.map (fun x : Expr × TypeChecker.State => x.1)) + appRun + +theorem cvmValidationRootFreshTest : + cvmValidationRootContextTest.lctx.find? + cvmValidationRootContextTest.freshFVarId = none := + cvmValidationRootLocalRunTest.fresh + +theorem cvmValidationFunctionFreshTest : + cvmValidationFunctionContextTest.lctx.find? + cvmValidationFunctionContextTest.freshFVarId = none := + cvmValidationFunctionLocalRunTest.fresh + +theorem cvmValidationAlphaFindInAlphaTest : + cvmValidationAlphaContextTest.lctx.find? cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := by + simpa [cvmValidationAlphaIdTest, cvmValidationAlphaContextTest, + cvmFamilyContext] using + (TypeChecker.CandidateLocalContextRun.empty cvmFamilyContext rfl + |>.push_findNew `α .default (.sort (.succ (.param `u)))) + +theorem cvmValidationAlphaNePTest : + cvmValidationAlphaIdTest ≠ cvmValidationPIdTest := by + intro equal + have fresh := cvmValidationAlphaLocalRunTest.fresh + change cvmValidationAlphaContextTest.lctx.find? + cvmValidationPIdTest = none at fresh + rw [← equal, cvmValidationAlphaFindInAlphaTest] at fresh + contradiction + +theorem cvmValidationXFindTest : + cvmValidationXContextTest.lctx.find? cvmValidationXIdTest = + some (.cdecl cvmValidationRootContextTest.lctx.decls.size + cvmValidationXIdTest `x (.fvar cvmValidationAlphaIdTest) + .default .default) := by + have found := cvmValidationRootLocalRunTest.push_findNew `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) + simpa [cvmValidationXContextTest, cvmValidationXIdTest, + cvmCtorXDomainValidationShapeTest, + AddInductive.consumeTypeAnnotations] using found + +theorem cvmValidationPNeXTest : + cvmValidationPIdTest ≠ cvmValidationXIdTest := by + intro equal + have fresh := cvmValidationRootFreshTest + change cvmValidationRootContextTest.lctx.find? + cvmValidationXIdTest = none at fresh + rw [← equal, cvmValidationPFindTest] at fresh + contradiction + +theorem cvmValidationLaterFindTest : + cvmValidationLaterContextTest.lctx.find? cvmValidationLaterIdTest = + some (.cdecl cvmValidationFunctionContextTest.lctx.decls.size + cvmValidationLaterIdTest `later (.fvar cvmValidationAlphaIdTest) + .default .default) := by + have found := cvmValidationFunctionLocalRunTest.push_findNew `later .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) + simpa [cvmValidationLaterContextTest, cvmValidationLaterIdTest, + cvmCtorLaterDomainValidationShapeTest, + AddInductive.consumeTypeAnnotations] using found + +theorem cvmValidationPNeLaterTest : + cvmValidationPIdTest ≠ cvmValidationLaterIdTest := by + intro equal + have fresh := cvmValidationFunctionFreshTest + change cvmValidationFunctionContextTest.lctx.find? + cvmValidationLaterIdTest = none at fresh + rw [← equal, cvmValidationPFindInFunctionTest] at fresh + contradiction + +theorem cvmValidationProofCheckTest : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationXContextTest, cvmCtorProofDomain, .sort .zero⟩ := by + rw [cvmCtorProofDomainValidationShapeTest] + exact cvmValidationPredicateApplicationCheckTest + cvmValidationXContextTest cvmValidationPIdTest + cvmValidationXIdTest cvmValidationPNeXTest + cvmValidationPFindInXTest cvmValidationXFindTest (by rfl) + +theorem cvmValidationLaterProofCheckTest : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationLaterContextTest, cvmCtorLaterProofDomain, + .sort .zero⟩ := by + rw [cvmCtorLaterProofDomainValidationShapeTest] + exact cvmValidationPredicateApplicationCheckTest + cvmValidationLaterContextTest cvmValidationPIdTest + cvmValidationLaterIdTest cvmValidationPNeLaterTest + cvmValidationPFindInLaterTest cvmValidationLaterFindTest (by rfl) + +theorem cvmValidationDirectCheckTest : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationProofContextTest, cvmCtorDirectDomain, + .sort (.succ (.param `u))⟩ := by + rw [cvmCtorDirectDomainValidationShapeTest] + exact cvmValidationFamilyApplicationCheckTest + cvmValidationProofContextTest cvmValidationAlphaIdTest + cvmValidationPIdTest rfl cvmValidationAlphaNePTest + cvmValidationAlphaFindInProofTest cvmValidationPFindInProofTest + (by rfl) (by rfl) (by rfl) (by rfl) + +def cvmValidationLaterProofLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmValidationLaterProofContextTest := + cvmValidationLaterLocalRunTest.push `laterProof .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) + +theorem cvmValidationAlphaFindInLaterTest : + cvmValidationLaterContextTest.lctx.find? cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := + cvmValidationFunctionLocalRunTest.push_findOld `later .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) + cvmValidationAlphaFindInFunctionTest + +theorem cvmValidationAlphaFindInLaterProofTest : + cvmValidationLaterProofContextTest.lctx.find? + cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := + cvmValidationLaterLocalRunTest.push_findOld `laterProof .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) + cvmValidationAlphaFindInLaterTest + +theorem cvmValidationPFindInLaterProofTest : + cvmValidationLaterProofContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := + cvmValidationLaterLocalRunTest.push_findOld `laterProof .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) + cvmValidationPFindInLaterTest + +theorem cvmValidationTerminalCheckTest : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationLaterProofContextTest, cvmCtorTerminal, + .sort (.succ (.param `u))⟩ := by + rw [cvmCtorTerminalValidationShapeTest] + exact cvmValidationFamilyApplicationCheckTest + cvmValidationLaterProofContextTest cvmValidationAlphaIdTest + cvmValidationPIdTest rfl cvmValidationAlphaNePTest + cvmValidationAlphaFindInLaterProofTest + cvmValidationPFindInLaterProofTest + (by rfl) (by rfl) (by rfl) (by rfl) + +def cvmValidationFamilyCachedFirstAppStateTest + (state : TypeChecker.State) (alphaId : FVarId) : TypeChecker.State := + prbReplayInsert (cvmValidationFamilyConstStateTest state) + (cvmValidationFirstAppFullTest (.fvar alphaId)) + (cvmValidationFamilyTailFullTest (.fvar alphaId)) + +def cvmValidationFamilyCachedPredicateStateTest + (state : TypeChecker.State) (alphaId predicateId : FVarId) : + TypeChecker.State := + prbReplayInsert (cvmValidationFamilyCachedFirstAppStateTest state alphaId) + (.fvar predicateId) + (.forallE cvmValidationIndexNameTest (.fvar alphaId) + (.sort .zero) .default) + +def cvmValidationFamilyCachedFullAppStateTest + (state : TypeChecker.State) (alphaId predicateId : FVarId) : + TypeChecker.State := + prbReplayInsert + (cvmValidationFamilyCachedPredicateStateTest state alphaId predicateId) + (cvmValidationFamilyApplicationTest + (.fvar alphaId) (.fvar predicateId)) + (.sort (.succ (.param `u))) + +theorem cvmValidationInferFirstAppAlphaCachedCoreTest + (fuel : Nat) (context : AddInductive.Context) + (state : TypeChecker.State) (alphaId : FVarId) + (alphaCache : state.inferTypeC[(.fvar alphaId : Expr)]? = + some (.sort (.succ (.param `u)))) + (constMiss : state.inferTypeC[ + (.const constructorValidityMatrixKernelType.name + [.param `u] : Expr)]? = none) + (firstMiss : state.inferTypeC[ + cvmValidationFirstAppFullTest (.fvar alphaId)]? = none) + (envEq : context.env = cvmConstructorContext.env) + (lparams : context.lparams = [`u]) + (safety : context.safety = .safe) : + TypeChecker.Inner.inferType' + (cvmValidationFirstAppFullTest (.fvar alphaId)) false + (TypeChecker.Methods.withFuel fuel) context.toTypeChecker state = + .ok (cvmValidationFamilyTailFullTest (.fvar alphaId), + cvmValidationFamilyCachedFirstAppStateTest state alphaId) := by + have familyRun := cvmValidationInferTypeFamilyCoreTest fuel context state + constMiss envEq lparams safety + have alphaCache' : + (cvmValidationFamilyConstStateTest state).inferTypeC[ + (.fvar alphaId : Expr)]? = + some (.sort (.succ (.param `u))) := by + simp only [cvmValidationFamilyConstStateTest, prbReplayInsert, + Std.HashMap.getElem?_insert] + rw [prbConstBeqFVar] + exact alphaCache + have alphaRun := prbValidationInferTypeCachedCore fuel context + (cvmValidationFamilyConstStateTest state) (.fvar alphaId) + (.sort (.succ (.param `u))) + (by simp [Expr.hasLooseBVars, Expr.looseBVarRange']) alphaCache' + have appRun := prbInferAppCoreOf fuel context.toTypeChecker state + (cvmValidationFamilyConstStateTest state) + (cvmValidationFamilyConstStateTest state) + (.const constructorValidityMatrixKernelType.name [.param `u]) + (.fvar alphaId) (.sort (.succ (.param `u))) + (.forallE `P + (.forallE cvmValidationIndexNameTest (.bvar 0) + (.sort .zero) .default) + (.sort (.succ (.param `u))) .default) + `α .default + (by simp [cvmValidationFirstAppFullTest, + Expr.hasLooseBVars, Expr.looseBVarRange']) + firstMiss + (by simpa [cvmKernelFamilyTypeShapeTest] using familyRun) + alphaRun (by rfl) + simpa [cvmValidationFirstAppFullTest, + cvmValidationFamilyTailFullTest, + cvmValidationFamilyCachedFirstAppStateTest, prbReplayInsert, + Expr.instantiate1_eq, Expr.instantiate1'] using appRun + +theorem cvmValidationFamilyApplicationAlphaCachedCoreTest + (fuel : Nat) (context : AddInductive.Context) + (state : TypeChecker.State) (alphaId predicateId : FVarId) + (alphaEq : alphaId = cvmValidationAlphaIdTest) + (alphaCache : state.inferTypeC[(.fvar alphaId : Expr)]? = + some (.sort (.succ (.param `u)))) + (constMiss : state.inferTypeC[ + (.const constructorValidityMatrixKernelType.name + [.param `u] : Expr)]? = none) + (firstMiss : state.inferTypeC[ + cvmValidationFirstAppFullTest (.fvar alphaId)]? = none) + (predicateMiss : + (cvmValidationFamilyCachedFirstAppStateTest state alphaId).inferTypeC[ + (.fvar predicateId : Expr)]? = none) + (applicationMiss : state.inferTypeC[ + cvmValidationFamilyApplicationTest + (.fvar alphaId) (.fvar predicateId)]? = none) + (predicateFind : context.lctx.find? predicateId = + some (.cdecl predicateIndex predicateId predicateName + cvmValidationPDomainTest predicateBi predicateKind)) + (envEq : context.env = cvmConstructorContext.env) + (lparams : context.lparams = [`u]) + (safety : context.safety = .safe) : + TypeChecker.Inner.inferType' + (cvmValidationFamilyApplicationTest + (.fvar alphaId) (.fvar predicateId)) false + (TypeChecker.Methods.withFuel fuel) context.toTypeChecker state = + .ok (.sort (.succ (.param `u)), + cvmValidationFamilyCachedFullAppStateTest + state alphaId predicateId) := by + have firstRun := cvmValidationInferFirstAppAlphaCachedCoreTest + fuel context state alphaId alphaCache constMiss firstMiss + envEq lparams safety + have predicateRun : TypeChecker.Inner.inferType' (.fvar predicateId) false + (TypeChecker.Methods.withFuel fuel) context.toTypeChecker + (cvmValidationFamilyCachedFirstAppStateTest state alphaId) = + .ok (.forallE cvmValidationIndexNameTest (.fvar alphaId) + (.sort .zero) .default, + cvmValidationFamilyCachedPredicateStateTest + state alphaId predicateId) := by + simpa [cvmValidationFamilyCachedPredicateStateTest, + cvmValidationPDomainShapeTest, alphaEq] using + prbValidationInferTypeFVarCore fuel context + (cvmValidationFamilyCachedFirstAppStateTest state alphaId) + predicateId cvmValidationPDomainTest predicateMiss predicateFind + have appRun := prbInferAppCoreOf fuel context.toTypeChecker state + (cvmValidationFamilyCachedFirstAppStateTest state alphaId) + (cvmValidationFamilyCachedPredicateStateTest state alphaId predicateId) + (cvmValidationFirstAppFullTest (.fvar alphaId)) + (.fvar predicateId) + (.forallE cvmValidationIndexNameTest (.fvar alphaId) + (.sort .zero) .default) + (.sort (.succ (.param `u))) `P .default + (by simp [cvmValidationFamilyApplicationTest, + cvmValidationFirstAppFullTest, + Expr.hasLooseBVars, Expr.looseBVarRange']) + applicationMiss firstRun predicateRun (by rfl) + simpa [cvmValidationFamilyApplicationTest, + cvmValidationFirstAppFullTest, + cvmValidationFamilyCachedFullAppStateTest, + cvmValidationFamilyCachedPredicateStateTest, prbReplayInsert, + Expr.instantiate1_eq, Expr.instantiate1'] using appRun + +def cvmValidationFunctionFullAlphaStateTest : TypeChecker.State := + prbReplayInsert ({} : TypeChecker.State) + (.fvar cvmValidationAlphaIdTest) (.sort (.succ (.param `u))) + +def cvmValidationFunctionFullInternalIdTest : FVarId := + ⟨cvmValidationFunctionFullAlphaStateTest.ngen.curr⟩ + +def cvmValidationFunctionFullInternalStateTest : TypeChecker.State := + { cvmValidationFunctionFullAlphaStateTest with + ngen := cvmValidationFunctionFullAlphaStateTest.ngen.next } + +def cvmValidationFunctionFullInternalContextTest : AddInductive.Context := + { cvmValidationDirectContextTest with + lctx := cvmValidationDirectContextTest.lctx.mkLocalDecl + cvmValidationFunctionFullInternalIdTest `y + (.fvar cvmValidationAlphaIdTest) .default } + +def cvmValidationFunctionFullBodyStateTest : TypeChecker.State := + cvmValidationFamilyCachedFullAppStateTest + cvmValidationFunctionFullInternalStateTest + cvmValidationAlphaIdTest cvmValidationPIdTest + +def cvmValidationFunctionFullFinalStateTest : TypeChecker.State := + prbReplayInsert cvmValidationFunctionFullBodyStateTest + (.forallE `y (.fvar cvmValidationAlphaIdTest) + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + .default) + (.sort (.succ (.param `u))) + +theorem cvmValidationFunctionFullInternalFreshTest : + cvmValidationDirectContextTest.lctx.find? + cvmValidationFunctionFullInternalIdTest = none := by + rw [cvmValidationDirectLocalRunTest.wf.find?_eq_find?_toList, + List.find?_eq_none] + intro decl membership equal + simp only [cvmValidationDirectContextTest, + cvmValidationProofContextTest, cvmValidationXContextTest, + cvmValidationRootContextTest, cvmValidationFamilyContextTest, + cvmValidationAlphaContextTest, AddInductive.Context.pushLocalDecl, + LocalContext.mkLocalDecl_toList, List.mem_cons] at membership + rw [show cvmFamilyContext.lctx.toList = [] by rfl] at membership + simp only [List.not_mem_nil, or_false] at membership + rcases membership with rfl | rfl | rfl | rfl | rfl + all_goals + simp [LocalDecl.fvarId, cvmValidationFunctionFullInternalIdTest, + cvmValidationFunctionFullAlphaStateTest, prbReplayInsert, + cvmValidationXIdTest, cvmValidationPIdTest, + cvmValidationAlphaIdTest, cvmValidationRootContextTest, + cvmValidationFamilyContextTest, cvmValidationAlphaContextTest, + cvmFamilyContext, constructorValidityMatrixContext, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId] + at equal + all_goals injection equal + all_goals simp [NameGenerator.next] at * + +@[simp] theorem cvmValidationAlphaPBeqFalseTest : + ((.fvar cvmValidationAlphaIdTest : Expr) == + .fvar cvmValidationPIdTest) = false := by + change Expr.eqv (.fvar cvmValidationAlphaIdTest) + (.fvar cvmValidationPIdTest) = false + rw [Expr.eqv_eq] + simp [Expr.eqv', cvmValidationAlphaNePTest] + +theorem cvmValidationPFindInFunctionFullInternalTest : + cvmValidationFunctionFullInternalContextTest.lctx.find? + cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := by + exact TypeChecker.localContextFindOld + cvmValidationDirectContextTest.lctx cvmValidationPIdTest + cvmValidationFunctionFullInternalIdTest `y + (.fvar cvmValidationAlphaIdTest) .default .default _ + cvmValidationDirectLocalRunTest.wf + cvmValidationFunctionFullInternalFreshTest + cvmValidationPFindInDirectTest + +theorem cvmValidationFunctionCheckTest : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationDirectContextTest, cvmCtorFunctionDomain, + .sort (.succ (.param `u))⟩ := by + have domainRun : TypeChecker.Inner.inferType' + (.fvar cvmValidationAlphaIdTest) false + (TypeChecker.Methods.withFuel 9998) + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State) = + .ok (.sort (.succ (.param `u)), + cvmValidationFunctionFullAlphaStateTest) := by + simpa [cvmValidationFunctionFullAlphaStateTest] using + prbValidationInferTypeFVarCore 9998 cvmValidationDirectContextTest + ({} : TypeChecker.State) cvmValidationAlphaIdTest + (.sort (.succ (.param `u))) Std.HashMap.getElem?_empty + cvmValidationAlphaFindInDirectTest + have bodyRun : TypeChecker.Inner.inferType' + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) false + (TypeChecker.Methods.withFuel 9998) + cvmValidationFunctionFullInternalContextTest.toTypeChecker + cvmValidationFunctionFullInternalStateTest = + .ok (.sort (.succ (.param `u)), + cvmValidationFunctionFullBodyStateTest) := by + apply cvmValidationFamilyApplicationAlphaCachedCoreTest + · rfl + · simp [cvmValidationFunctionFullInternalStateTest, + cvmValidationFunctionFullAlphaStateTest, prbReplayInsert] + · simp [cvmValidationFunctionFullInternalStateTest, + cvmValidationFunctionFullAlphaStateTest, prbReplayInsert] + · simp [cvmValidationFunctionFullInternalStateTest, + cvmValidationFunctionFullAlphaStateTest, + cvmValidationFirstAppFullTest, prbReplayInsert] + · simp [cvmValidationFamilyCachedFirstAppStateTest, + cvmValidationFamilyConstStateTest, + cvmValidationFunctionFullInternalStateTest, + cvmValidationFunctionFullAlphaStateTest, + cvmValidationFirstAppFullTest, prbReplayInsert, + cvmValidationAlphaNePTest] + · simp [cvmValidationFunctionFullInternalStateTest, + cvmValidationFunctionFullAlphaStateTest, + cvmValidationFamilyApplicationTest, prbReplayInsert] + · exact cvmValidationPFindInFunctionFullInternalTest + · rfl + · rfl + · rfl + have forallRun : TypeChecker.Inner.inferForall + (.forallE `y (.fvar cvmValidationAlphaIdTest) + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + .default) false + (TypeChecker.Methods.withFuel 9999) + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State) = + .ok (.sort (.succ (.param `u)), + cvmValidationFunctionFullBodyStateTest) := by + unfold TypeChecker.Inner.inferForall + simp only [cvmValidationFamilyApplicationTest, + TypeChecker.Inner.inferForall.loop] + rw [show (.fvar cvmValidationAlphaIdTest : Expr).instantiateRev #[] = + .fvar cvmValidationAlphaIdTest by + simp [Expr.instantiateRev_eq, Expr.instantiate_eq]] + simp only [Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rw [show TypeChecker.Inner.inferType + (.fvar cvmValidationAlphaIdTest) false + (TypeChecker.Methods.withFuel 9999) + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State) = + TypeChecker.Inner.inferType' + (.fvar cvmValidationAlphaIdTest) false + (TypeChecker.Methods.withFuel 9998) + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State) by rfl] + rw [domainRun] + simp only [prbEnsureSortExact] + rw [prbWithLocalDeclEq] + change TypeChecker.Inner.inferForall.loop false + #[Expr.fvar cvmValidationFunctionFullInternalIdTest] + #[Level.succ (.param `u)] + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + (TypeChecker.Methods.withFuel 9999) + cvmValidationFunctionFullInternalContextTest.toTypeChecker + cvmValidationFunctionFullInternalStateTest = _ + simp only [cvmValidationFamilyApplicationTest, + TypeChecker.Inner.inferForall.loop] + rw [show (((.const constructorValidityMatrixKernelType.name + [.param `u] : Expr).app (.fvar cvmValidationAlphaIdTest)).app + (.fvar cvmValidationPIdTest)).instantiateRev + #[Expr.fvar cvmValidationFunctionFullInternalIdTest] = + ((.const constructorValidityMatrixKernelType.name + [.param `u] : Expr).app (.fvar cvmValidationAlphaIdTest)).app + (.fvar cvmValidationPIdTest) by + simp [Expr.instantiateRev_eq, Expr.instantiate_eq, + Expr.instantiate1_eq, Expr.instantiate1']] + simp only [Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + have bodyRunExplicit : TypeChecker.Inner.inferType' + (((.const constructorValidityMatrixKernelType.name + [.param `u] : Expr).app (.fvar cvmValidationAlphaIdTest)).app + (.fvar cvmValidationPIdTest)) false + (TypeChecker.Methods.withFuel 9998) + cvmValidationFunctionFullInternalContextTest.toTypeChecker + cvmValidationFunctionFullInternalStateTest = + .ok (.sort (.succ (.param `u)), + cvmValidationFunctionFullBodyStateTest) := by + simpa [cvmValidationFamilyApplicationTest] using bodyRun + rw [show TypeChecker.Inner.inferType + (((.const constructorValidityMatrixKernelType.name + [.param `u] : Expr).app (.fvar cvmValidationAlphaIdTest)).app + (.fvar cvmValidationPIdTest)) false + (TypeChecker.Methods.withFuel 9999) + cvmValidationFunctionFullInternalContextTest.toTypeChecker + cvmValidationFunctionFullInternalStateTest = + TypeChecker.Inner.inferType' + (((.const constructorValidityMatrixKernelType.name + [.param `u] : Expr).app + (.fvar cvmValidationAlphaIdTest)).app + (.fvar cvmValidationPIdTest)) false + (TypeChecker.Methods.withFuel 9998) + cvmValidationFunctionFullInternalContextTest.toTypeChecker + cvmValidationFunctionFullInternalStateTest by rfl] + rw [bodyRunExplicit] + simp [Expr.sortLevel!, Pure.pure, ReaderT.pure, + StateT.pure, Except.pure] + have outerRun := prbInferTypeForallCore 9999 + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State) cvmValidationFunctionFullBodyStateTest + `y (.fvar cvmValidationAlphaIdTest) + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + (.sort (.succ (.param `u))) .default + (by simp [cvmValidationFamilyApplicationTest, + Expr.hasLooseBVars, Expr.looseBVarRange']) + Std.HashMap.getElem?_empty forallRun + rw [cvmCtorFunctionDomainValidationShapeTest] + unfold AddInductive.CandidateCheckTypeStep.Valid + change TypeChecker.M.run cvmValidationDirectContextTest.env + cvmValidationDirectContextTest.safety cvmValidationDirectContextTest.lctx + cvmValidationDirectContextTest.lparams cvmValidationDirectContextTest.fuel + (TypeChecker.checkType (.forallE `y + (.fvar cvmValidationAlphaIdTest) + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + .default)) = .ok (.sort (.succ (.param `u))) + unfold TypeChecker.M.run TypeChecker.checkType TypeChecker.RecM.run + simp [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, StateT.bind, Except.bind, Bind.bind, + StateT.pure, Except.pure, Pure.pure, + StateT.run', Functor.map, Except.map] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' + (.forallE `y (.fvar cvmValidationAlphaIdTest) + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + .default) false + (TypeChecker.Methods.withFuel 9999) + cvmValidationDirectContextTest.toTypeChecker + ({} : TypeChecker.State)) = _ + simpa [cvmValidationFunctionFullFinalStateTest, + prbReplayInsert, Functor.map, Except.map] using + congrArg (Except.map (fun x : Expr × TypeChecker.State => x.1)) + outerRun + +theorem cvmValidationAlphaRootCheckTest : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationRootContextTest, .fvar cvmValidationAlphaIdTest, + .sort (.succ (.param `u))⟩ := + prbCandidateCheckTypeFVar cvmValidationRootContextTest + cvmValidationAlphaIdTest (.sort (.succ (.param `u))) + cvmValidationRootDepthTest cvmValidationAlphaFindTest + +theorem cvmValidationAlphaFunctionCheckTest : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationFunctionContextTest, .fvar cvmValidationAlphaIdTest, + .sort (.succ (.param `u))⟩ := + prbCandidateCheckTypeFVar cvmValidationFunctionContextTest + cvmValidationAlphaIdTest (.sort (.succ (.param `u))) + cvmValidationFunctionDepthTest cvmValidationAlphaFindInFunctionTest + +def cvmCheckedOfValidTest + (context : AddInductive.Context) (source inferred : Expr) + (fvars : source.FVarsIn + (fun fv => (context.lctx.find? fv).isSome = true)) + (valid : AddInductive.CandidateCheckTypeStep.Valid + ⟨context, source, inferred⟩) : + AddInductive.ConstructorCheckedExpr context source := + .ofRun fvars valid + +def cvmValidationSortCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationRootContextTest + (.sort (.succ (.param `u))) := + cvmCheckedOfValidTest _ _ _ + (by simp [FVarsIn, Level.hasMVar']) cvmValidationRootSortCheckTest + +def cvmValidationPDomainCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationRootContextTest + cvmValidationPDomainTest := + cvmCheckedOfValidTest _ _ _ (by + rw [cvmValidationPDomainShapeTest] + simp [FVarsIn, Level.hasMVar'] + change (cvmValidationRootContextTest.lctx.find? + cvmValidationAlphaIdTest).isSome = true + rw [cvmValidationAlphaFindTest] + rfl) cvmValidationPDomainCheckTest + +def cvmValidationAlphaRootCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationRootContextTest + (.fvar cvmValidationAlphaIdTest) := + cvmCheckedOfValidTest _ _ _ (by + change (cvmValidationRootContextTest.lctx.find? + cvmValidationAlphaIdTest).isSome = true + rw [cvmValidationAlphaFindTest] + rfl) cvmValidationAlphaRootCheckTest + +def cvmValidationProofCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationXContextTest + cvmCtorProofDomain := + cvmCheckedOfValidTest _ _ _ (by + rw [cvmCtorProofDomainValidationShapeTest] + simp [cvmValidationPredicateApplicationTest, FVarsIn, Level.hasMVar'] + constructor + · change (cvmValidationXContextTest.lctx.find? + cvmValidationPIdTest).isSome = true + rw [cvmValidationPFindInXTest] + rfl + · change (cvmValidationXContextTest.lctx.find? + cvmValidationXIdTest).isSome = true + rw [cvmValidationXFindTest] + rfl) cvmValidationProofCheckTest + +def cvmValidationDirectCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationProofContextTest + cvmCtorDirectDomain := + cvmCheckedOfValidTest _ _ _ (by + rw [cvmCtorDirectDomainValidationShapeTest] + simp [cvmValidationFamilyApplicationTest, FVarsIn, Level.hasMVar'] + constructor + · change (cvmValidationProofContextTest.lctx.find? + cvmValidationAlphaIdTest).isSome = true + rw [cvmValidationAlphaFindInProofTest] + rfl + · change (cvmValidationProofContextTest.lctx.find? + cvmValidationPIdTest).isSome = true + rw [cvmValidationPFindInProofTest] + rfl) cvmValidationDirectCheckTest + +def cvmValidationFunctionCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationDirectContextTest + cvmCtorFunctionDomain := + cvmCheckedOfValidTest _ _ _ (by + rw [cvmCtorFunctionDomainValidationShapeTest] + simp [cvmValidationFamilyApplicationTest, FVarsIn, Level.hasMVar'] + constructor + · change (cvmValidationDirectContextTest.lctx.find? + cvmValidationAlphaIdTest).isSome = true + rw [cvmValidationAlphaFindInDirectTest] + rfl + · change (cvmValidationDirectContextTest.lctx.find? + cvmValidationPIdTest).isSome = true + rw [cvmValidationPFindInDirectTest] + rfl) cvmValidationFunctionCheckTest + +def cvmValidationAlphaFunctionCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationFunctionContextTest + (.fvar cvmValidationAlphaIdTest) := + cvmCheckedOfValidTest _ _ _ (by + change (cvmValidationFunctionContextTest.lctx.find? + cvmValidationAlphaIdTest).isSome = true + rw [cvmValidationAlphaFindInFunctionTest] + rfl) cvmValidationAlphaFunctionCheckTest + +def cvmValidationLaterProofCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationLaterContextTest + cvmCtorLaterProofDomain := + cvmCheckedOfValidTest _ _ _ (by + rw [cvmCtorLaterProofDomainValidationShapeTest] + simp [cvmValidationPredicateApplicationTest, FVarsIn, Level.hasMVar'] + constructor + · change (cvmValidationLaterContextTest.lctx.find? + cvmValidationPIdTest).isSome = true + rw [cvmValidationPFindInLaterTest] + rfl + · change (cvmValidationLaterContextTest.lctx.find? + cvmValidationLaterIdTest).isSome = true + rw [cvmValidationLaterFindTest] + rfl) cvmValidationLaterProofCheckTest + +def cvmValidationTerminalCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationLaterProofContextTest + cvmCtorTerminal := + cvmCheckedOfValidTest _ _ _ (by + rw [cvmCtorTerminalValidationShapeTest] + simp [cvmValidationFamilyApplicationTest, FVarsIn, Level.hasMVar'] + constructor + · change (cvmValidationLaterProofContextTest.lctx.find? + cvmValidationAlphaIdTest).isSome = true + rw [cvmValidationAlphaFindInLaterProofTest] + rfl + · change (cvmValidationLaterProofContextTest.lctx.find? + cvmValidationPIdTest).isSome = true + rw [cvmValidationPFindInLaterProofTest] + rfl) cvmValidationTerminalCheckTest + +@[simp] theorem cvmValidationConsumeXTest : + AddInductive.consumeTypeAnnotations cvmCtorXDomain = + cvmCtorXDomain := by + rw [cvmCtorXDomainValidationShapeTest] + simp [AddInductive.consumeTypeAnnotations] + +@[simp] theorem cvmValidationConsumeProofTest : + AddInductive.consumeTypeAnnotations cvmCtorProofDomain = + cvmCtorProofDomain := by + rw [cvmCtorProofDomainValidationShapeTest] + simp [cvmValidationPredicateApplicationTest, + AddInductive.consumeTypeAnnotations] + +@[simp] theorem cvmValidationConsumeDirectTest : + AddInductive.consumeTypeAnnotations cvmCtorDirectDomain = + cvmCtorDirectDomain := by + rw [cvmCtorDirectDomainValidationShapeTest] + simp [cvmValidationFamilyApplicationTest, + AddInductive.consumeTypeAnnotations, + constructorValidityMatrixKernelType, + constructorValidityMatrixInfo, ConstantInfo.name, + ConstantInfo.toConstantVal] + +@[simp] theorem cvmValidationConsumeFunctionTest : + AddInductive.consumeTypeAnnotations cvmCtorFunctionDomain = + cvmCtorFunctionDomain := by + rw [cvmCtorFunctionDomainValidationShapeTest] + simp [AddInductive.consumeTypeAnnotations] + +@[simp] theorem cvmValidationConsumeLaterTest : + AddInductive.consumeTypeAnnotations cvmCtorLaterDomain = + cvmCtorLaterDomain := by + rw [cvmCtorLaterDomainValidationShapeTest] + simp [AddInductive.consumeTypeAnnotations] + +@[simp] theorem cvmValidationConsumeLaterProofTest : + AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain = + cvmCtorLaterProofDomain := by + rw [cvmCtorLaterProofDomainValidationShapeTest] + simp [cvmValidationPredicateApplicationTest, + AddInductive.consumeTypeAnnotations] + +theorem cvmCtorPDomainValidationShapeTest : + cvmCtorPDomain = .forallE cvmCtorPDomain.bindingName! + (.fvar cvmValidationAlphaIdTest) (.sort .zero) .default := by + simp_cvm_ctor_expr + simp [cvmValidationAlphaIdTest, cvmFamilyContext, + cvmConstructorContext, constructorValidityMatrixContext, + AddInductive.Context.freshFVarId] + +theorem cvmValidationCtorPDomainCheckTest : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationRootContextTest, cvmCtorPDomain, + .sort (mkLevelIMax' (.succ (.param `u)) (.succ .zero))⟩ := by + rw [cvmCtorPDomainValidationShapeTest] + exact cvmValidationAlphaToPropCheckTest cvmCtorPDomain.bindingName! + +def cvmValidationXCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationRootContextTest + cvmCtorXDomain := by + rw [cvmCtorXDomainValidationShapeTest] + exact cvmValidationAlphaRootCheckedTest + +def cvmValidationXConsumedCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationRootContextTest + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) := by + rw [cvmValidationConsumeXTest] + exact cvmValidationXCheckedTest + +def cvmValidationProofConsumedCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationXContextTest + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) := by + rw [cvmValidationConsumeProofTest] + exact cvmValidationProofCheckedTest + +def cvmValidationDirectConsumedCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationProofContextTest + (AddInductive.consumeTypeAnnotations cvmCtorDirectDomain) := by + rw [cvmValidationConsumeDirectTest] + exact cvmValidationDirectCheckedTest + +def cvmValidationFunctionConsumedCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationDirectContextTest + (AddInductive.consumeTypeAnnotations cvmCtorFunctionDomain) := by + rw [cvmValidationConsumeFunctionTest] + exact cvmValidationFunctionCheckedTest + +def cvmValidationLaterCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationFunctionContextTest + cvmCtorLaterDomain := by + rw [cvmCtorLaterDomainValidationShapeTest] + exact cvmValidationAlphaFunctionCheckedTest + +def cvmValidationLaterConsumedCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationFunctionContextTest + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) := by + rw [cvmValidationConsumeLaterTest] + exact cvmValidationLaterCheckedTest + +def cvmValidationLaterProofConsumedCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationLaterContextTest + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) := by + rw [cvmValidationConsumeLaterProofTest] + exact cvmValidationLaterProofCheckedTest + +def cvmValidationReflObservationTest + (context : AddInductive.Context) (source : Expr) : + AddInductive.CandidateIsDefEqObservation context source source := + ⟨AddInductive.candidateIsDefEqRefl context source⟩ + +def cvmValidationXAnnotationsTest : + AddInductive.CandidateIsDefEqObservation cvmValidationRootContextTest + cvmCtorXDomain + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) := by + rw [cvmValidationConsumeXTest] + exact cvmValidationReflObservationTest _ _ + +def cvmValidationProofAnnotationsTest : + AddInductive.CandidateIsDefEqObservation cvmValidationXContextTest + cvmCtorProofDomain + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) := by + rw [cvmValidationConsumeProofTest] + exact cvmValidationReflObservationTest _ _ + +def cvmValidationDirectAnnotationsTest : + AddInductive.CandidateIsDefEqObservation cvmValidationProofContextTest + cvmCtorDirectDomain + (AddInductive.consumeTypeAnnotations cvmCtorDirectDomain) := by + rw [cvmValidationConsumeDirectTest] + exact cvmValidationReflObservationTest _ _ + +def cvmValidationFunctionAnnotationsTest : + AddInductive.CandidateIsDefEqObservation cvmValidationDirectContextTest + cvmCtorFunctionDomain + (AddInductive.consumeTypeAnnotations cvmCtorFunctionDomain) := by + rw [cvmValidationConsumeFunctionTest] + exact cvmValidationReflObservationTest _ _ + +def cvmValidationLaterAnnotationsTest : + AddInductive.CandidateIsDefEqObservation cvmValidationFunctionContextTest + cvmCtorLaterDomain + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) := by + rw [cvmValidationConsumeLaterTest] + exact cvmValidationReflObservationTest _ _ + +def cvmValidationLaterProofAnnotationsTest : + AddInductive.CandidateIsDefEqObservation cvmValidationLaterContextTest + cvmCtorLaterProofDomain + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) := by + rw [cvmValidationConsumeLaterProofTest] + exact cvmValidationReflObservationTest _ _ + +theorem cvmValidationXFreshTest : + cvmValidationXContextTest.lctx.find? + cvmValidationXContextTest.freshFVarId = none := + cvmValidationXLocalRunTest.fresh + +theorem cvmValidationProofFreshTest : + cvmValidationProofContextTest.lctx.find? + cvmValidationProofContextTest.freshFVarId = none := + cvmValidationProofLocalRunTest.fresh + +theorem cvmValidationDirectFreshTest : + cvmValidationDirectContextTest.lctx.find? + cvmValidationDirectContextTest.freshFVarId = none := + cvmValidationDirectLocalRunTest.fresh + +theorem cvmValidationLaterFreshTest : + cvmValidationLaterContextTest.lctx.find? + cvmValidationLaterContextTest.freshFVarId = none := + cvmValidationLaterLocalRunTest.fresh + +def cvmValidationFunctionPosContextTest : AddInductive.Context := + cvmValidationDirectContextTest.pushLocalDecl `y .default + (.fvar cvmValidationAlphaIdTest) + +def cvmValidationFunctionPosLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmValidationFunctionPosContextTest := + cvmValidationDirectLocalRunTest.push `y .default + (.fvar cvmValidationAlphaIdTest) + +theorem cvmValidationAlphaFindInFunctionPosTest : + cvmValidationFunctionPosContextTest.lctx.find? + cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := + cvmValidationDirectLocalRunTest.push_findOld `y .default + (.fvar cvmValidationAlphaIdTest) cvmValidationAlphaFindInDirectTest + +theorem cvmValidationPFindInFunctionPosTest : + cvmValidationFunctionPosContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := + cvmValidationDirectLocalRunTest.push_findOld `y .default + (.fvar cvmValidationAlphaIdTest) cvmValidationPFindInDirectTest + +theorem cvmValidationFunctionPosBodyCheckTest : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationFunctionPosContextTest, + cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest), + .sort (.succ (.param `u))⟩ := + cvmValidationFamilyApplicationCheckTest + cvmValidationFunctionPosContextTest cvmValidationAlphaIdTest + cvmValidationPIdTest rfl cvmValidationAlphaNePTest + cvmValidationAlphaFindInFunctionPosTest + cvmValidationPFindInFunctionPosTest + (by rfl) (by rfl) (by rfl) (by rfl) + +def cvmValidationFunctionPosBodyCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationFunctionPosContextTest + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) := + cvmCheckedOfValidTest _ _ _ (by + simp [cvmValidationFamilyApplicationTest, FVarsIn, Level.hasMVar'] + constructor + · change (cvmValidationFunctionPosContextTest.lctx.find? + cvmValidationAlphaIdTest).isSome = true + rw [cvmValidationAlphaFindInFunctionPosTest] + rfl + · change (cvmValidationFunctionPosContextTest.lctx.find? + cvmValidationPIdTest).isSome = true + rw [cvmValidationPFindInFunctionPosTest] + rfl) cvmValidationFunctionPosBodyCheckTest + +noncomputable def cvmStagedUniverseInputTest : + VInductDecl.StagedNormalizationCandidateUniverseInput + cvmFamilyContext cvmConstructorContext VEnv.empty [`u] + cvmCandidate constructorValidityMatrixDecl where + staged := { + raw := constructorValidityMatrixType + raw_types_eq := rfl + declaration_uvars_eq := rfl + preFamily := cvmPreFamilyStage + family := cvmFamilyStage + validation_nparams_eq := rfl + constructorValidation := by + simpa [cvmFamilyStage, cvmConstructorValidationContextTest, + cvmValidationRootContextTest, cvmFamilyTerminalContextTest_eq] using + cvmConstructorValidationTest + constructors := cvmConstructorsStage + familyTypesProduced := cvmFamilyTypesProduced + familiesProduced := cvmFamiliesProduced } + universeRun := by + simpa [cvmFamilyStage, cvmConstructorValidationContextTest, + cvmValidationRootContextTest, cvmFamilyTerminalContextTest_eq] using + cvmUniverseRunTest + +theorem cvmStagedStatsTest_eq : + cvmStagedUniverseInputTest.staged.family.validation.stats = + cvmFamilyValidationRun.stats := by + rfl + +theorem cvmStagedIndConstsTest_eq : + cvmStagedUniverseInputTest.staged.family.validation.stats.indConsts = + #[.const constructorValidityMatrixKernelType.name [.param `u]] := by + rw [cvmStagedStatsTest_eq, cvmFamilyValidationRun.stats_eq] + simp only [cvmFamilyValidationRun, + AddInductive.CandidateExprTrace.singletonCandidateInductiveStats] + rw [show + cvmCandidate.families.singleton.familyType.type.context.lparams = [`u] by + rw [cvmFamilyCandidateContext_eq] + rfl] + rfl + +theorem cvmValidationAlphaHasNoIndOccTest : + AddInductive.hasIndOcc + cvmStagedUniverseInputTest.staged.family.validation.stats.indConsts + (.fvar cvmValidationAlphaIdTest) = false := by + rw [cvmStagedIndConstsTest_eq] + simp [AddInductive.hasIndOcc] + +theorem cvmValidationProofHasNoIndOccTest : + AddInductive.hasIndOcc + cvmStagedUniverseInputTest.staged.family.validation.stats.indConsts + cvmCtorProofDomain = false := by + rw [cvmStagedIndConstsTest_eq, + cvmCtorProofDomainValidationShapeTest] + simp [AddInductive.hasIndOcc, + cvmValidationPredicateApplicationTest] + +theorem cvmValidationDirectHasIndOccTest : + AddInductive.hasIndOcc + cvmStagedUniverseInputTest.staged.family.validation.stats.indConsts + cvmCtorDirectDomain = true := by + rw [cvmStagedIndConstsTest_eq, + cvmCtorDirectDomainValidationShapeTest] + simp [AddInductive.hasIndOcc, + cvmValidationFamilyApplicationTest, Expr.constName!] + +theorem cvmValidationFunctionHasIndOccTest : + AddInductive.hasIndOcc + cvmStagedUniverseInputTest.staged.family.validation.stats.indConsts + cvmCtorFunctionDomain = true := by + rw [cvmStagedIndConstsTest_eq, + cvmCtorFunctionDomainValidationShapeTest] + simp [AddInductive.hasIndOcc, + cvmValidationFamilyApplicationTest, Expr.constName!] + +theorem cvmValidationLaterProofHasNoIndOccTest : + AddInductive.hasIndOcc + cvmStagedUniverseInputTest.staged.family.validation.stats.indConsts + cvmCtorLaterProofDomain = false := by + rw [cvmStagedIndConstsTest_eq, + cvmCtorLaterProofDomainValidationShapeTest] + simp [AddInductive.hasIndOcc, + cvmValidationPredicateApplicationTest] + +theorem cvmValidationFunctionPosBodyHasIndOccTest : + AddInductive.hasIndOcc + cvmStagedUniverseInputTest.staged.family.validation.stats.indConsts + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) = + true := by + rw [cvmStagedIndConstsTest_eq] + simp [AddInductive.hasIndOcc, + cvmValidationFamilyApplicationTest, Expr.constName!] + +theorem cvmCandidateWhnfResultEqTest + (self : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, source⟩) + (other : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, result⟩) : + result = source := by + unfold AddInductive.CandidateWhnfStep.Valid at self other + rw [self] at other + exact (Except.ok.inj other).symm + +theorem cvmValidationAlphaRootWhnfSelfTest : + AddInductive.CandidateWhnfStep.Valid + ⟨cvmValidationRootContextTest, .fvar cvmValidationAlphaIdTest, + .fvar cvmValidationAlphaIdTest⟩ := by + apply TypeChecker.candidateWhnfFVar_refl _ _ 9999 + · rfl + · unfold TypeChecker.Inner.isLetFVar + rw [cvmValidationAlphaFindTest] + +theorem cvmValidationProofWhnfSelfTest : + AddInductive.CandidateWhnfStep.Valid + ⟨cvmValidationXContextTest, cvmCtorProofDomain, + cvmCtorProofDomain⟩ := by + rw [cvmCtorProofDomainValidationShapeTest] + apply TypeChecker.candidateWhnfFVarAppFVar_refl + cvmValidationXContextTest cvmValidationPIdTest cvmValidationXIdTest + · rfl + · rfl + · rw [show cvmValidationXContextTest.env = + cvmConstructorContext.env by rfl] + exact cvmCtorQuotInit + · unfold TypeChecker.Inner.isLetFVar + rw [cvmValidationPFindInXTest] + +theorem cvmValidationDirectWhnfSelfTest : + AddInductive.CandidateWhnfStep.Valid + ⟨cvmValidationProofContextTest, cvmCtorDirectDomain, + cvmCtorDirectDomain⟩ := by + rw [cvmCtorDirectDomainValidationShapeTest] + unfold cvmValidationFamilyApplicationTest + apply cvmCtorFamilyWhnf cvmValidationProofContextTest + cvmValidationAlphaIdTest cvmValidationPIdTest + (by rfl) (by rfl) (by rfl) + rw [show cvmValidationProofContextTest.env = + cvmConstructorContext.env by rfl] + exact cvmCtorQuotInit + +theorem cvmValidationFunctionWhnfSelfTest : + AddInductive.CandidateWhnfStep.Valid + ⟨cvmValidationDirectContextTest, cvmCtorFunctionDomain, + cvmCtorFunctionDomain⟩ := by + apply TypeChecker.CandidateExprIdentityReplay.Shaped.candidateWhnfForallSource_refl + _ _ 9999 + · rfl + · rw [cvmCtorFunctionDomainValidationShapeTest] + rfl + +theorem cvmValidationAlphaFunctionWhnfSelfTest : + AddInductive.CandidateWhnfStep.Valid + ⟨cvmValidationFunctionContextTest, + .fvar cvmValidationAlphaIdTest, + .fvar cvmValidationAlphaIdTest⟩ := by + apply TypeChecker.candidateWhnfFVar_refl _ _ 9999 + · rfl + · unfold TypeChecker.Inner.isLetFVar + rw [cvmValidationAlphaFindInFunctionTest] + +theorem cvmValidationLaterProofWhnfSelfTest : + AddInductive.CandidateWhnfStep.Valid + ⟨cvmValidationLaterContextTest, cvmCtorLaterProofDomain, + cvmCtorLaterProofDomain⟩ := by + rw [cvmCtorLaterProofDomainValidationShapeTest] + unfold cvmValidationPredicateApplicationTest + apply TypeChecker.candidateWhnfFVarAppFVar_refl + cvmValidationLaterContextTest cvmValidationPIdTest + cvmValidationLaterIdTest + · rfl + · rfl + · rw [show cvmValidationLaterContextTest.env = + cvmConstructorContext.env by rfl] + exact cvmCtorQuotInit + · unfold TypeChecker.Inner.isLetFVar + rw [cvmValidationPFindInLaterTest] + +theorem cvmValidationFunctionPosBodyWhnfSelfTest : + AddInductive.CandidateWhnfStep.Valid + ⟨cvmValidationFunctionPosContextTest, + cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest), + cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)⟩ := by + unfold cvmValidationFamilyApplicationTest + apply cvmCtorFamilyWhnf cvmValidationFunctionPosContextTest + cvmValidationAlphaIdTest cvmValidationPIdTest + (by rfl) (by rfl) (by rfl) + rw [show cvmValidationFunctionPosContextTest.env = + cvmConstructorContext.env by rfl] + exact cvmCtorQuotInit + +theorem cvmValidationAlphaDirectCheckTest : + AddInductive.CandidateCheckTypeStep.Valid + ⟨cvmValidationDirectContextTest, .fvar cvmValidationAlphaIdTest, + .sort (.succ (.param `u))⟩ := + prbCandidateCheckTypeFVar cvmValidationDirectContextTest + cvmValidationAlphaIdTest (.sort (.succ (.param `u))) + (by rfl) cvmValidationAlphaFindInDirectTest + +def cvmValidationAlphaDirectCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationDirectContextTest + (.fvar cvmValidationAlphaIdTest) := + cvmCheckedOfValidTest _ _ _ (by + change (cvmValidationDirectContextTest.lctx.find? + cvmValidationAlphaIdTest).isSome = true + rw [cvmValidationAlphaFindInDirectTest] + rfl) cvmValidationAlphaDirectCheckTest + +def cvmValidationAlphaDirectConsumedCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationDirectContextTest + (AddInductive.consumeTypeAnnotations + (.fvar cvmValidationAlphaIdTest)) := by + simp [AddInductive.consumeTypeAnnotations] + exact cvmValidationAlphaDirectCheckedTest + +def cvmValidationAlphaDirectAnnotationsTest : + AddInductive.CandidateIsDefEqObservation cvmValidationDirectContextTest + (.fvar cvmValidationAlphaIdTest) + (AddInductive.consumeTypeAnnotations + (.fvar cvmValidationAlphaIdTest)) := by + simp [AddInductive.consumeTypeAnnotations] + exact cvmValidationReflObservationTest _ _ + +theorem cvmValidationXWhnfSelfTest : + AddInductive.CandidateWhnfStep.Valid + ⟨cvmValidationRootContextTest, cvmCtorXDomain, + cvmCtorXDomain⟩ := by + simpa [cvmCtorXDomainValidationShapeTest] using + cvmValidationAlphaRootWhnfSelfTest + +theorem cvmValidationLaterWhnfSelfTest : + AddInductive.CandidateWhnfStep.Valid + ⟨cvmValidationFunctionContextTest, cvmCtorLaterDomain, + cvmCtorLaterDomain⟩ := by + simpa [cvmCtorLaterDomainValidationShapeTest] using + cvmValidationAlphaFunctionWhnfSelfTest + +theorem cvmValidationXHasNoIndOccTest : + AddInductive.hasIndOcc + cvmStagedUniverseInputTest.staged.family.validation.stats.indConsts + cvmCtorXDomain = false := by + rw [cvmCtorXDomainValidationShapeTest] + exact cvmValidationAlphaHasNoIndOccTest + +theorem cvmValidationLaterHasNoIndOccTest : + AddInductive.hasIndOcc + cvmStagedUniverseInputTest.staged.family.validation.stats.indConsts + cvmCtorLaterDomain = false := by + rw [cvmCtorLaterDomainValidationShapeTest] + exact cvmValidationAlphaHasNoIndOccTest + +def cvmTransportPositivityFuelTraceTest + {fuel fuel' : Nat} (fuelEq : fuel = fuel') + (trace : AddInductive.ConstructorPositivityTrace stats ctor argIdx + context source fuel) : + AddInductive.ConstructorPositivityTrace stats ctor argIdx + context source fuel' := by + subst fuel' + exact trace + +def cvmTransportPositivityFuelAlignmentTest + {fuel fuel' : Nat} (fuelEq : fuel = fuel') + (trace : AddInductive.ConstructorPositivityTrace stats ctor argIdx + context source fuel) + (alignment : AddInductive.ConstructorPositivityAlignmentTrace + (cvmTransportPositivityFuelTraceTest fuelEq trace)) : + AddInductive.ConstructorPositivityAlignmentTrace trace := by + subst fuel' + exact alignment + +noncomputable def cvmAbsentPositivityAlignmentCoreTest + (self : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, source⟩) + (notForall : source.isForall = false) + (noOccurrence : AddInductive.hasIndOcc stats.indConsts source = false) + (checked : AddInductive.ConstructorCheckedExpr context source) + (trace : AddInductive.ConstructorPositivityTrace stats ctor argIdx + context source 1000) : + AddInductive.ConstructorPositivityAlignmentTrace trace := by + cases trace with + | absent context source result fuel whnf occurs => + have resultEq := cvmCandidateWhnfResultEqTest self whnf + subst result + exact .absent checked + | forallE context source fuel name domain body binderInfo whnf occurs + domainFree tail => + have resultEq := cvmCandidateWhnfResultEqTest self whnf + have impossible := congrArg Expr.isForall resultEq + have forallEq : true = source.isForall := by + simpa only [Expr.isForall] using impossible + have : true = false := forallEq.trans notForall + contradiction + | target context source result fuel targetIdx whnf occurs terminal valid => + have resultEq := cvmCandidateWhnfResultEqTest self whnf + subst result + rw [noOccurrence] at occurs + contradiction + +noncomputable def cvmTargetPositivityAlignmentCoreTest + (self : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, source⟩) + (notForall : source.isForall = false) + (hasOccurrence : AddInductive.hasIndOcc stats.indConsts source = true) + (checked : AddInductive.ConstructorCheckedExpr context source) + (trace : AddInductive.ConstructorPositivityTrace stats ctor argIdx + context source 1000) : + AddInductive.ConstructorPositivityAlignmentTrace trace := by + cases trace with + | absent context source result fuel whnf occurs => + have resultEq := cvmCandidateWhnfResultEqTest self whnf + subst result + rw [hasOccurrence] at occurs + contradiction + | forallE context source fuel name domain body binderInfo whnf occurs + domainFree tail => + have resultEq := cvmCandidateWhnfResultEqTest self whnf + have impossible := congrArg Expr.isForall resultEq + have forallEq : true = source.isForall := by + simpa only [Expr.isForall] using impossible + have : true = false := forallEq.trans notForall + contradiction + | target context source result fuel targetIdx whnf occurs terminal valid => + have resultEq := cvmCandidateWhnfResultEqTest self whnf + subst result + exact .target checked + +noncomputable def cvmAbsentPositivityModeAlignmentTest + (self : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, source⟩) + (notForall : source.isForall = false) + (noOccurrence : AddInductive.hasIndOcc stats.indConsts source = false) + (checked : AddInductive.ConstructorCheckedExpr context source) + (inductiveFuel : context.fuel.inductiveFuel = 1000) + (trace : AddInductive.ConstructorPositivityModeTrace stats false ctor + argIdx context source) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := by + cases trace with + | skipped unsafeEq => contradiction + | safe unsafeEq positivityTrace => + apply AddInductive.ConstructorPositivityModeAlignmentTrace.safe + let normalized := cvmTransportPositivityFuelTraceTest + inductiveFuel positivityTrace + have normalizedAlignment := cvmAbsentPositivityAlignmentCoreTest + self notForall noOccurrence checked normalized + exact cvmTransportPositivityFuelAlignmentTest + inductiveFuel positivityTrace normalizedAlignment + +noncomputable def cvmTargetPositivityModeAlignmentTest + (self : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, source⟩) + (notForall : source.isForall = false) + (hasOccurrence : AddInductive.hasIndOcc stats.indConsts source = true) + (checked : AddInductive.ConstructorCheckedExpr context source) + (inductiveFuel : context.fuel.inductiveFuel = 1000) + (trace : AddInductive.ConstructorPositivityModeTrace stats false ctor + argIdx context source) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := by + cases trace with + | skipped unsafeEq => contradiction + | safe unsafeEq positivityTrace => + apply AddInductive.ConstructorPositivityModeAlignmentTrace.safe + let normalized := cvmTransportPositivityFuelTraceTest + inductiveFuel positivityTrace + have normalizedAlignment := cvmTargetPositivityAlignmentCoreTest + self notForall hasOccurrence checked normalized + exact cvmTransportPositivityFuelAlignmentTest + inductiveFuel positivityTrace normalizedAlignment + +noncomputable def cvmValidationXPositivityAlignmentTest + (trace : AddInductive.ConstructorPositivityModeTrace + cvmStagedUniverseInputTest.staged.family.validation.stats false + constructorValidityMatrixKernelCtor.name 2 + cvmValidationRootContextTest cvmCtorXDomain) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := + cvmAbsentPositivityModeAlignmentTest cvmValidationXWhnfSelfTest + (by rw [cvmCtorXDomainValidationShapeTest]; rfl) + cvmValidationXHasNoIndOccTest cvmValidationXCheckedTest (by rfl) trace + +noncomputable def cvmValidationProofPositivityAlignmentTest + (trace : AddInductive.ConstructorPositivityModeTrace + cvmStagedUniverseInputTest.staged.family.validation.stats false + constructorValidityMatrixKernelCtor.name 3 + cvmValidationXContextTest cvmCtorProofDomain) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := + cvmAbsentPositivityModeAlignmentTest cvmValidationProofWhnfSelfTest + (by rw [cvmCtorProofDomainValidationShapeTest]; rfl) + cvmValidationProofHasNoIndOccTest cvmValidationProofCheckedTest + (by rfl) trace + +noncomputable def cvmValidationDirectPositivityAlignmentTest + (trace : AddInductive.ConstructorPositivityModeTrace + cvmStagedUniverseInputTest.staged.family.validation.stats false + constructorValidityMatrixKernelCtor.name 4 + cvmValidationProofContextTest cvmCtorDirectDomain) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := + cvmTargetPositivityModeAlignmentTest cvmValidationDirectWhnfSelfTest + (by rw [cvmCtorDirectDomainValidationShapeTest]; rfl) + cvmValidationDirectHasIndOccTest cvmValidationDirectCheckedTest + (by rfl) trace + +noncomputable def cvmValidationLaterPositivityAlignmentTest + (trace : AddInductive.ConstructorPositivityModeTrace + cvmStagedUniverseInputTest.staged.family.validation.stats false + constructorValidityMatrixKernelCtor.name 6 + cvmValidationFunctionContextTest cvmCtorLaterDomain) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := + cvmAbsentPositivityModeAlignmentTest cvmValidationLaterWhnfSelfTest + (by rw [cvmCtorLaterDomainValidationShapeTest]; rfl) + cvmValidationLaterHasNoIndOccTest cvmValidationLaterCheckedTest + (by rfl) trace + +noncomputable def cvmValidationLaterProofPositivityAlignmentTest + (trace : AddInductive.ConstructorPositivityModeTrace + cvmStagedUniverseInputTest.staged.family.validation.stats false + constructorValidityMatrixKernelCtor.name 7 + cvmValidationLaterContextTest cvmCtorLaterProofDomain) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := + cvmAbsentPositivityModeAlignmentTest cvmValidationLaterProofWhnfSelfTest + (by rw [cvmCtorLaterProofDomainValidationShapeTest]; rfl) + cvmValidationLaterProofHasNoIndOccTest + cvmValidationLaterProofCheckedTest (by rfl) trace + +def cvmTransportPositivityTraceTest + {context context' : AddInductive.Context} + (contextEq : context = context') + {source source' : Expr} (sourceEq : source = source') + (trace : AddInductive.ConstructorPositivityTrace stats ctor argIdx + context source fuel) : + AddInductive.ConstructorPositivityTrace stats ctor argIdx + context' source' fuel := by + subst context' + subst source' + exact trace + +def cvmTransportPositivityAlignmentTest + {context context' : AddInductive.Context} + (contextEq : context = context') + {source source' : Expr} (sourceEq : source = source') + (trace : AddInductive.ConstructorPositivityTrace stats ctor argIdx + context source fuel) + (alignment : AddInductive.ConstructorPositivityAlignmentTrace + (cvmTransportPositivityTraceTest contextEq sourceEq trace)) : + AddInductive.ConstructorPositivityAlignmentTrace trace := by + subst context' + subst source' + exact alignment + +noncomputable def cvmValidationFunctionPositivityAlignmentTest + (trace : AddInductive.ConstructorPositivityModeTrace + cvmStagedUniverseInputTest.staged.family.validation.stats false + constructorValidityMatrixKernelCtor.name 5 + cvmValidationDirectContextTest cvmCtorFunctionDomain) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := by + cases trace with + | skipped unsafeEq => contradiction + | safe unsafeEq positivityTrace => + apply AddInductive.ConstructorPositivityModeAlignmentTrace.safe + cases positivityTrace with + | absent context source result fuel whnf occurs => + have resultEq := cvmCandidateWhnfResultEqTest + cvmValidationFunctionWhnfSelfTest whnf + subst result + rw [cvmValidationFunctionHasIndOccTest] at occurs + contradiction + | forallE context source fuel name domain body binderInfo whnf occurs + domainFree tail => + have resultEq := cvmCandidateWhnfResultEqTest + cvmValidationFunctionWhnfSelfTest whnf + rw [cvmCtorFunctionDomainValidationShapeTest] at resultEq + injection resultEq with nameEq domainEq bodyEq binderInfoEq + subst name + subst domain + subst body + subst binderInfo + have tailContextEq : + cvmValidationDirectContextTest.pushLocalDecl `y .default + (AddInductive.consumeTypeAnnotations + (.fvar cvmValidationAlphaIdTest)) = + cvmValidationFunctionPosContextTest := by + simp [cvmValidationFunctionPosContextTest, + AddInductive.consumeTypeAnnotations] + have tailSourceEq : + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) + (.fvar cvmValidationPIdTest)).instantiate1 + cvmValidationDirectContextTest.freshExpr = + cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) + (.fvar cvmValidationPIdTest) := by + simp [cvmValidationFamilyApplicationTest, + Expr.instantiate1_eq, Expr.instantiate1'] + let tailNormalized := cvmTransportPositivityTraceTest + tailContextEq tailSourceEq tail + have tailNormalizedAlignment : + AddInductive.ConstructorPositivityAlignmentTrace + tailNormalized := by + cases htail : tailNormalized with + | absent context source result fuel whnf occurs => + have resultEq := cvmCandidateWhnfResultEqTest + cvmValidationFunctionPosBodyWhnfSelfTest whnf + subst result + rw [cvmValidationFunctionPosBodyHasIndOccTest] at occurs + contradiction + | forallE context source fuel name domain body binderInfo whnf + occurs domainFree tail => + have resultEq := cvmCandidateWhnfResultEqTest + cvmValidationFunctionPosBodyWhnfSelfTest whnf + have impossible := congrArg Expr.isForall resultEq + simp [cvmValidationFamilyApplicationTest, + Expr.isForall] at impossible + | target context source result fuel targetIdx whnf occurs + terminal valid => + have resultEq := cvmCandidateWhnfResultEqTest + cvmValidationFunctionPosBodyWhnfSelfTest whnf + subst result + exact .target cvmValidationFunctionPosBodyCheckedTest + have tailAlignment := cvmTransportPositivityAlignmentTest + tailContextEq tailSourceEq tail tailNormalizedAlignment + exact .forallE cvmValidationFunctionCheckedTest + cvmValidationAlphaDirectCheckedTest + cvmValidationAlphaDirectConsumedCheckedTest + (.succ (.param `u)) + (cvmValidationAlphaDirectConsumedCheckedTest.inferred_eq_of_run + (by + simpa [AddInductive.consumeTypeAnnotations] using + cvmValidationAlphaDirectCheckTest)) + cvmValidationDirectFreshTest + cvmValidationAlphaDirectAnnotationsTest tail tailAlignment + | target context source result fuel targetIdx whnf occurs terminal valid => + have resultEq := cvmCandidateWhnfResultEqTest + cvmValidationFunctionWhnfSelfTest whnf + subst result + rw [cvmCtorFunctionDomainValidationShapeTest] at terminal + simp [Expr.isForall] at terminal + +def cvmValidationCtorPDomainCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationRootContextTest + cvmCtorPDomain := + cvmCheckedOfValidTest _ _ _ (by + rw [cvmCtorPDomainValidationShapeTest] + simp [FVarsIn, Level.hasMVar'] + change (cvmValidationRootContextTest.lctx.find? + cvmValidationAlphaIdTest).isSome = true + rw [cvmValidationAlphaFindTest] + rfl) cvmValidationCtorPDomainCheckTest + +def cvmValidationTerminalShapeCheckedTest : + AddInductive.ConstructorCheckedExpr cvmValidationLaterProofContextTest + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) := by + rw [← cvmCtorTerminalValidationShapeTest] + exact cvmValidationTerminalCheckedTest + +theorem cvmCtorViewTest_eq : + cvmCandidate.families.singleton.constructors.singleton.type.view = + constructorValidityMatrixKernelCtor.type := by + apply cvmCtorIdentityEvidence.identity.view_eq_source + · apply TypeChecker.CandidateLocalContextRun.empty + rw [cvmConstructorCandidateContext_eq] + rfl + · rw [cvmConstructorCandidateContext_eq] + simp [constructorValidityMatrixKernelCtor, + constructorValidityMatrixMkInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, FVarsIn, Level.hasMVar'] + +def cvmTransportValidationTraceTest + {context context' : AddInductive.Context} + (contextEq : context = context') + {source source' : Expr} (sourceEq : source = source') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) : + AddInductive.ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context' source' argIdx fuel := by + subst context' + subst source' + exact trace + +def cvmTransportViewAlignmentTest + {context context' : AddInductive.Context} + (contextEq : context = context') + {source source' view view' : Expr} + (sourceEq : source = source') (viewEq : view = view') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) + (alignment : AddInductive.ConstructorViewAlignmentTrace + (cvmTransportValidationTraceTest contextEq sourceEq trace) view') : + AddInductive.ConstructorViewAlignmentTrace trace view := by + subst context' + subst source' + subst view' + exact alignment + +@[simp] theorem cvmTransportValidationTraceSpineLengthTest + {context context' : AddInductive.Context} + (contextEq : context = context') + {source source' : Expr} (sourceEq : source = source') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) : + (cvmTransportValidationTraceTest contextEq sourceEq trace).spineLength = + trace.spineLength := by + subst context' + subst source' + rfl + +def cvmTransportValidationTraceIndexedTest + {context context' : AddInductive.Context} + (contextEq : context = context') + {source source' : Expr} (sourceEq : source = source') + {argIdx argIdx' : Nat} (argIdxEq : argIdx = argIdx') + {fuel fuel' : Nat} (fuelEq : fuel = fuel') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) : + AddInductive.ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context' source' argIdx' fuel' := by + subst context' + subst source' + subst argIdx' + subst fuel' + exact trace + +def cvmTransportViewAlignmentIndexedTest + {context context' : AddInductive.Context} + (contextEq : context = context') + {source source' view view' : Expr} + (sourceEq : source = source') (viewEq : view = view') + {argIdx argIdx' : Nat} (argIdxEq : argIdx = argIdx') + {fuel fuel' : Nat} (fuelEq : fuel = fuel') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) + (alignment : AddInductive.ConstructorViewAlignmentTrace + (cvmTransportValidationTraceIndexedTest contextEq sourceEq argIdxEq + fuelEq trace) view') : + AddInductive.ConstructorViewAlignmentTrace trace view := by + subst context' + subst source' + subst view' + subst argIdx' + subst fuel' + exact alignment + +@[simp] theorem cvmTransportValidationTraceIndexedSpineLengthTest + {context context' : AddInductive.Context} + (contextEq : context = context') + {source source' : Expr} (sourceEq : source = source') + {argIdx argIdx' : Nat} (argIdxEq : argIdx = argIdx') + {fuel fuel' : Nat} (fuelEq : fuel = fuel') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) : + (cvmTransportValidationTraceIndexedTest contextEq sourceEq argIdxEq + fuelEq trace).spineLength = trace.spineLength := by + subst context' + subst source' + subst argIdx' + subst fuel' + rfl + +set_option pp.universes false in +set_option pp.all false in +noncomputable def cvmStagedPostFamilyInputTest : + VInductDecl.StagedNormalizationCandidatePostFamilyInput + cvmFamilyContext cvmConstructorContext VEnv.empty [`u] + cvmCandidate constructorValidityMatrixDecl where + universeInput := cvmStagedUniverseInputTest + alignment := by + rw [AddInductive.CandidateList.singleton_eta + cvmCandidate.families.singleton.constructors] + change AddInductive.ConstructorCandidateAlignmentTrace + cvmStagedUniverseInputTest.staged.family.validation.stats false 0 + { cvmCandidate.families.singleton.familyType.type.trace.terminalContext with + env := cvmConstructorContext.env } + cvmStagedUniverseInputTest.staged.constructorValidation.trace + (.cons cvmCandidate.families.singleton.constructors.singleton .nil) + generalize htrace : + cvmStagedUniverseInputTest.staged.constructorValidation.trace = trace + cases trace with + | cons seen head constructors fresh closed rootCheck typeTrace tailTrace => + clear htrace + have rootContextEq : + { cvmCandidate.families.singleton.familyType.type.trace.terminalContext with + env := cvmConstructorContext.env } = + cvmValidationRootContextTest := by + rw [cvmFamilyTerminalContextTest_eq] + rfl + have rootFuelEq : + { cvmCandidate.families.singleton.familyType.type.trace.terminalContext with + env := cvmConstructorContext.env }.fuel.inductiveFuel = 1000 := by + rw [cvmFamilyTerminalContextTest_eq] + rfl + let rootNormalized := cvmTransportValidationTraceIndexedTest + rootContextEq (by rfl) (by rfl) rootFuelEq typeTrace + let rootNormalizedTrace := rootNormalized + have rootSpine : typeTrace.spineLength = + rootNormalizedTrace.spineLength := + (cvmTransportValidationTraceIndexedSpineLengthTest rootContextEq + (by rfl) (by rfl) rootFuelEq typeTrace).symm + cases hroot : rootNormalizedTrace with + | parameter context fuel argIdx name domain body binderInfo parameter + parameterType parameterAt parameterTypeRun defeq afterAlphaTrace => + simp [hroot, + AddInductive.ConstructorTypeValidationTrace.spineLength] at rootSpine + rw [cvmStagedStatsTest_eq, cvmStatsParamsTest] at parameterAt + simp at parameterAt + subst parameter + change AddInductive.getType (.fvar cvmValidationAlphaIdTest) + cvmValidationRootContextTest = .ok parameterType at parameterTypeRun + rw [cvmValidationGetTypeAlphaTest] at parameterTypeRun + injection parameterTypeRun with parameterTypeEq + subst parameterType + let afterAlphaSourceEq := cvmFirstParameterSourceTest.trans + cvmCtorAfterAlphaForallTest + let afterAlphaNormalized := cvmTransportValidationTraceTest (by rfl) + afterAlphaSourceEq afterAlphaTrace + let afterAlphaNormalizedTrace := afterAlphaNormalized + have afterAlphaSpine : afterAlphaTrace.spineLength = + afterAlphaNormalizedTrace.spineLength := + (cvmTransportValidationTraceSpineLengthTest (by rfl) + afterAlphaSourceEq afterAlphaTrace).symm + cases hafterAlpha : afterAlphaNormalizedTrace with + | parameter context fuel argIdx name domain body binderInfo parameter + parameterType parameterAt parameterTypeRun defeq afterPTrace => + simp [hafterAlpha, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at afterAlphaSpine + rw [cvmStagedStatsTest_eq, cvmStatsParamsTest] at parameterAt + simp at parameterAt + subst parameter + change AddInductive.getType (.fvar cvmValidationPIdTest) + cvmValidationRootContextTest = .ok parameterType at parameterTypeRun + rw [cvmValidationGetTypePTest] at parameterTypeRun + injection parameterTypeRun with parameterTypeEq + subst parameterType + let afterPSourceEq := cvmSecondParameterSourceTest.trans + cvmCtorAfterPForallTest + let afterPNormalized := cvmTransportValidationTraceTest (by rfl) + afterPSourceEq afterPTrace + let afterPNormalizedTrace := afterPNormalized + have afterPSpine : afterPTrace.spineLength = + afterPNormalizedTrace.spineLength := + (cvmTransportValidationTraceSpineLengthTest (by rfl) + afterPSourceEq afterPTrace).symm + cases hafterP : afterPNormalizedTrace with + | parameter context fuel argIdx name domain body binderInfo parameter + parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStagedStatsTest_eq, cvmStatsParamsTest] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace xPositivity afterXTrace => + simp [hafterP, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at afterPSpine + have xContextEq : + cvmValidationRootContextTest.pushLocalDecl `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) = + cvmValidationXContextTest := by rfl + let afterXSourceEq := cvmFirstFieldSourceTest.trans + cvmCtorAfterXForallTest + let afterXNormalized := cvmTransportValidationTraceTest xContextEq + afterXSourceEq afterXTrace + let afterXNormalizedTrace := afterXNormalized + have afterXSpine : afterXTrace.spineLength = + afterXNormalizedTrace.spineLength := + (cvmTransportValidationTraceSpineLengthTest xContextEq + afterXSourceEq afterXTrace).symm + cases hafterX : afterXNormalizedTrace with + | parameter context fuel argIdx name domain body binderInfo parameter + parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStagedStatsTest_eq, cvmStatsParamsTest] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace proofPositivity + afterProofTrace => + simp [hafterX, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at afterXSpine + have proofContextEq : + cvmValidationXContextTest.pushLocalDecl `proof .default + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) = + cvmValidationProofContextTest := by rfl + let afterProofSourceEq := cvmSecondFieldSourceTest.trans + cvmCtorAfterProofForallTest + let afterProofNormalized := cvmTransportValidationTraceTest + proofContextEq afterProofSourceEq afterProofTrace + let afterProofNormalizedTrace := afterProofNormalized + have afterProofSpine : afterProofTrace.spineLength = + afterProofNormalizedTrace.spineLength := + (cvmTransportValidationTraceSpineLengthTest proofContextEq + afterProofSourceEq afterProofTrace).symm + cases hafterProof : afterProofNormalizedTrace with + | parameter context fuel argIdx name domain body binderInfo parameter + parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStagedStatsTest_eq, cvmStatsParamsTest] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace directPositivity + afterDirectTrace => + simp [hafterProof, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at afterProofSpine + have directContextEq : + cvmValidationProofContextTest.pushLocalDecl `direct .default + (AddInductive.consumeTypeAnnotations cvmCtorDirectDomain) = + cvmValidationDirectContextTest := by rfl + let afterDirectSourceEq := cvmThirdFieldSourceTest.trans + cvmCtorAfterDirectForallTest + let afterDirectNormalized := cvmTransportValidationTraceTest + directContextEq afterDirectSourceEq afterDirectTrace + let afterDirectNormalizedTrace := afterDirectNormalized + have afterDirectSpine : afterDirectTrace.spineLength = + afterDirectNormalizedTrace.spineLength := + (cvmTransportValidationTraceSpineLengthTest directContextEq + afterDirectSourceEq afterDirectTrace).symm + cases hafterDirect : afterDirectNormalizedTrace with + | parameter context fuel argIdx name domain body binderInfo + parameter parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStagedStatsTest_eq, cvmStatsParamsTest] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace functionPositivity + afterFunctionTrace => + simp [hafterDirect, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at afterDirectSpine + have functionContextEq : + cvmValidationDirectContextTest.pushLocalDecl `function .default + (AddInductive.consumeTypeAnnotations + cvmCtorFunctionDomain) = + cvmValidationFunctionContextTest := by rfl + let afterFunctionSourceEq := cvmFourthFieldSourceTest.trans + cvmCtorAfterFunctionForallTest + let afterFunctionNormalized := cvmTransportValidationTraceTest + functionContextEq afterFunctionSourceEq afterFunctionTrace + let afterFunctionNormalizedTrace := afterFunctionNormalized + have afterFunctionSpine : afterFunctionTrace.spineLength = + afterFunctionNormalizedTrace.spineLength := + (cvmTransportValidationTraceSpineLengthTest + functionContextEq afterFunctionSourceEq + afterFunctionTrace).symm + cases hafterFunction : afterFunctionNormalizedTrace with + | parameter context fuel argIdx name domain body binderInfo + parameter parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStagedStatsTest_eq, cvmStatsParamsTest] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace laterPositivity + afterLaterTrace => + simp [hafterFunction, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at afterFunctionSpine + have laterContextEq : + cvmValidationFunctionContextTest.pushLocalDecl `later .default + (AddInductive.consumeTypeAnnotations + cvmCtorLaterDomain) = + cvmValidationLaterContextTest := by rfl + let afterLaterSourceEq := cvmFifthFieldSourceTest.trans + cvmCtorAfterLaterForallTest + let afterLaterNormalized := cvmTransportValidationTraceTest + laterContextEq afterLaterSourceEq afterLaterTrace + let afterLaterNormalizedTrace := afterLaterNormalized + have afterLaterSpine : afterLaterTrace.spineLength = + afterLaterNormalizedTrace.spineLength := + (cvmTransportValidationTraceSpineLengthTest laterContextEq + afterLaterSourceEq afterLaterTrace).symm + cases hafterLater : afterLaterNormalizedTrace with + | parameter context fuel argIdx name domain body binderInfo + parameter parameterType parameterAt parameterTypeRun defeq tail => + rw [cvmStagedStatsTest_eq, cvmStatsParamsTest] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace laterProofPositivity + terminalTrace => + simp [hafterLater, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at afterLaterSpine + have laterProofContextEq : + cvmValidationLaterContextTest.pushLocalDecl + `laterProof .default + (AddInductive.consumeTypeAnnotations + cvmCtorLaterProofDomain) = + cvmValidationLaterProofContextTest := by rfl + let terminalSourceEq := cvmSixthFieldSourceTest.trans + cvmCtorTerminalValidationShapeTest + let terminalNormalized := cvmTransportValidationTraceTest + laterProofContextEq terminalSourceEq terminalTrace + let terminalNormalizedTrace := terminalNormalized + have terminalSpine : terminalTrace.spineLength = + terminalNormalizedTrace.spineLength := + (cvmTransportValidationTraceSpineLengthTest + laterProofContextEq terminalSourceEq + terminalTrace).symm + cases hterminal : terminalNormalizedTrace with + | terminal context source fuel argIdx terminal valid => + simp [hterminal, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at terminalSpine + have terminalNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + terminalNormalizedTrace + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) + (.fvar cvmValidationPIdTest)) := by + rw [hterminal] + exact .terminal cvmValidationTerminalShapeCheckedTest + cvmValidationTerminalShapeCheckedTest terminal valid + have terminalAlignment := cvmTransportViewAlignmentTest + laterProofContextEq terminalSourceEq terminalSourceEq + terminalTrace terminalNormalizedAlignment + have afterLaterNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + afterLaterNormalizedTrace + (.forallE `laterProof cvmCtorLaterProofDomain + cvmCtorAfterLater.bindingBody! .default) := by + rw [hafterLater] + exact .ordinary cvmValidationLaterProofCheckedTest + cvmValidationLaterProofCheckedTest + (cvmValidationReflObservationTest _ _) + cvmValidationLaterProofConsumedCheckedTest + laterProofPositivity + (cvmValidationLaterProofPositivityAlignmentTest + laterProofPositivity) + cvmValidationLaterFreshTest + cvmValidationLaterProofAnnotationsTest + terminalTrace terminalAlignment + have afterLaterAlignment := cvmTransportViewAlignmentTest + laterContextEq afterLaterSourceEq afterLaterSourceEq + afterLaterTrace afterLaterNormalizedAlignment + have afterFunctionNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + afterFunctionNormalizedTrace + (.forallE `later cvmCtorLaterDomain + cvmCtorAfterFunction.bindingBody! .default) := by + rw [hafterFunction] + exact .ordinary cvmValidationLaterCheckedTest + cvmValidationLaterCheckedTest + (cvmValidationReflObservationTest _ _) + cvmValidationLaterConsumedCheckedTest laterPositivity + (cvmValidationLaterPositivityAlignmentTest + laterPositivity) + cvmValidationFunctionFreshTest + cvmValidationLaterAnnotationsTest + afterLaterTrace afterLaterAlignment + have afterFunctionAlignment := + cvmTransportViewAlignmentTest functionContextEq + afterFunctionSourceEq afterFunctionSourceEq + afterFunctionTrace afterFunctionNormalizedAlignment + have afterDirectNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + afterDirectNormalizedTrace + (.forallE `function cvmCtorFunctionDomain + cvmCtorAfterDirect.bindingBody! .default) := by + rw [hafterDirect] + exact .ordinary cvmValidationFunctionCheckedTest + cvmValidationFunctionCheckedTest + (cvmValidationReflObservationTest _ _) + cvmValidationFunctionConsumedCheckedTest + functionPositivity + (cvmValidationFunctionPositivityAlignmentTest + functionPositivity) + cvmValidationDirectFreshTest + cvmValidationFunctionAnnotationsTest + afterFunctionTrace afterFunctionAlignment + have afterDirectAlignment := + cvmTransportViewAlignmentTest directContextEq + afterDirectSourceEq afterDirectSourceEq + afterDirectTrace afterDirectNormalizedAlignment + have afterProofNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + afterProofNormalizedTrace + (.forallE `direct cvmCtorDirectDomain + cvmCtorAfterProof.bindingBody! .default) := by + rw [hafterProof] + exact .ordinary cvmValidationDirectCheckedTest + cvmValidationDirectCheckedTest + (cvmValidationReflObservationTest _ _) + cvmValidationDirectConsumedCheckedTest + directPositivity + (cvmValidationDirectPositivityAlignmentTest + directPositivity) + cvmValidationProofFreshTest + cvmValidationDirectAnnotationsTest + afterDirectTrace afterDirectAlignment + have afterProofAlignment := + cvmTransportViewAlignmentTest proofContextEq + afterProofSourceEq afterProofSourceEq + afterProofTrace afterProofNormalizedAlignment + have afterXNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + afterXNormalizedTrace + (.forallE `proof cvmCtorProofDomain + cvmCtorAfterX.bindingBody! .default) := by + rw [hafterX] + exact .ordinary cvmValidationProofCheckedTest + cvmValidationProofCheckedTest + (cvmValidationReflObservationTest _ _) + cvmValidationProofConsumedCheckedTest + proofPositivity + (cvmValidationProofPositivityAlignmentTest + proofPositivity) + cvmValidationXFreshTest + cvmValidationProofAnnotationsTest + afterProofTrace afterProofAlignment + have afterXAlignment := cvmTransportViewAlignmentTest + xContextEq afterXSourceEq afterXSourceEq + afterXTrace afterXNormalizedAlignment + have afterPNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + afterPNormalizedTrace + (.forallE `x cvmCtorXDomain + cvmCtorAfterP.bindingBody! .default) := by + rw [hafterP] + exact .ordinary cvmValidationXCheckedTest + cvmValidationXCheckedTest + (cvmValidationReflObservationTest _ _) + cvmValidationXConsumedCheckedTest xPositivity + (cvmValidationXPositivityAlignmentTest xPositivity) + cvmValidationRootFreshTest + cvmValidationXAnnotationsTest + afterXTrace afterXAlignment + have afterPAlignment := cvmTransportViewAlignmentTest + (by rfl) afterPSourceEq afterPSourceEq afterPTrace + afterPNormalizedAlignment + have afterAlphaNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + afterAlphaNormalizedTrace + (.forallE `P cvmCtorPDomain + cvmCtorAfterAlpha.bindingBody! .implicit) := by + rw [hafterAlpha] + exact .parameter cvmValidationCtorPDomainCheckedTest + cvmValidationCtorPDomainCheckedTest + cvmValidationPDomainCheckedTest rfl + (by + change (cvmValidationRootContextTest.lctx.find? + cvmValidationPIdTest).isSome = true + rw [cvmValidationPFindTest] + rfl) + afterPTrace afterPAlignment + have afterAlphaAlignment := + cvmTransportViewAlignmentTest (by rfl) + afterAlphaSourceEq afterAlphaSourceEq + afterAlphaTrace afterAlphaNormalizedAlignment + have rootNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + rootNormalizedTrace + constructorValidityMatrixKernelCtor.type := by + rw [hroot] + exact .parameter cvmValidationSortCheckedTest + cvmValidationSortCheckedTest + cvmValidationSortCheckedTest rfl + (by + change (cvmValidationRootContextTest.lctx.find? + cvmValidationAlphaIdTest).isSome = true + rw [cvmValidationAlphaFindTest] + rfl) + afterAlphaTrace afterAlphaAlignment + have headAlignment := + cvmTransportViewAlignmentIndexedTest rootContextEq + (by rfl) cvmCtorViewTest_eq (by rfl) rootFuelEq + typeTrace rootNormalizedAlignment + let rootScope : AddInductive.ConstructorCheckedExpr + ({ cvmCandidate.families.singleton.familyType.type.trace.terminalContext with + env := cvmConstructorContext.env }).withEmptyLocalContext + constructorValidityMatrixKernelCtor.type := + AddInductive.ConstructorCheckedExpr.ofClosedRoot + closed rootCheck + cases tailTrace with + | nil finalSeen => + exact AddInductive.ConstructorCandidateAlignmentTrace.cons + rootScope + (by + change + cvmCandidate.families.singleton.constructors.singleton.type.trace.storedSpine = + true + exact cvmCtorIdentityEvidence.identity.storedSpine) + (by + change + cvmCandidate.families.singleton.constructors.singleton.type.trace.spineLength = + typeTrace.spineLength + have candidateSpine := + cvmCtorIdentityEvidence.spineLength_eq.trans + cvmCtorIdentityReplay_shape.1 + omega) + (by + rw [cvmCtorWhnfDepth, rootContextEq] + rfl) + headAlignment + (AddInductive.ConstructorCandidateAlignmentTrace.nil + ((∅ : NameSet).insert + constructorValidityMatrixKernelCtor.name)) + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity tail => + rw [cvmStagedStatsTest_eq, cvmStatsParamsTest] at noParameter + simp at noParameter + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity tail => + rw [cvmStagedStatsTest_eq, cvmStatsParamsTest] at noParameter + simp at noParameter + | terminal context source fuel argIdx terminal valid => + simp [constructorValidityMatrixKernelCtor, + constructorValidityMatrixMkInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, Expr.isForall] at terminal + +def cvmPreFamilyContextTest : AddInductive.Context := + cvmValidationFamilyContextTest + +def cvmPreFamilyXContextTest : AddInductive.Context := + cvmPreFamilyContextTest.pushLocalDecl `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) + +def cvmPreFamilyProofContextTest : AddInductive.Context := + cvmPreFamilyXContextTest.pushLocalDecl `proof .default + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) + +def cvmPreFamilyAfterDirectContextTest : AddInductive.Context := + cvmPreFamilyProofContextTest.advanceFresh + +def cvmPreFamilyAfterFunctionContextTest : AddInductive.Context := + cvmPreFamilyAfterDirectContextTest.advanceFresh + +def cvmPreFamilyLaterContextTest : AddInductive.Context := + cvmPreFamilyAfterFunctionContextTest.pushLocalDecl `later .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) + +def cvmPreFamilyLaterProofContextTest : AddInductive.Context := + cvmPreFamilyLaterContextTest.pushLocalDecl `laterProof .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) + +def cvmPreFamilyFunctionInnerContextTest : AddInductive.Context := + cvmPreFamilyAfterDirectContextTest.pushLocalDecl `y .default + (.fvar cvmValidationAlphaIdTest) + +def cvmAdvanceLocalRunTest + (run : TypeChecker.CandidateLocalContextRun context) : + TypeChecker.CandidateLocalContextRun context.advanceFresh where + wf := run.wf + reserves := by + intro decl membership + exact NameGenerator.Reserves.mono NameGenerator.LE.next + (run.reserves decl membership) + +def cvmPreFamilyRootLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmPreFamilyContextTest := + cvmValidationFamilyLocalRunTest + +def cvmPreFamilyXLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmPreFamilyXContextTest := + cvmPreFamilyRootLocalRunTest.push `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) + +def cvmPreFamilyProofLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmPreFamilyProofContextTest := + cvmPreFamilyXLocalRunTest.push `proof .default + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) + +def cvmPreFamilyAfterDirectLocalRunTest : + TypeChecker.CandidateLocalContextRun + cvmPreFamilyAfterDirectContextTest := + cvmAdvanceLocalRunTest cvmPreFamilyProofLocalRunTest + +def cvmPreFamilyAfterFunctionLocalRunTest : + TypeChecker.CandidateLocalContextRun + cvmPreFamilyAfterFunctionContextTest := + cvmAdvanceLocalRunTest cvmPreFamilyAfterDirectLocalRunTest + +def cvmPreFamilyLaterLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmPreFamilyLaterContextTest := + cvmPreFamilyAfterFunctionLocalRunTest.push `later .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) + +def cvmPreFamilyLaterProofLocalRunTest : + TypeChecker.CandidateLocalContextRun cvmPreFamilyLaterProofContextTest := + cvmPreFamilyLaterLocalRunTest.push `laterProof .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) + +def cvmPreFamilyFunctionInnerLocalRunTest : + TypeChecker.CandidateLocalContextRun + cvmPreFamilyFunctionInnerContextTest := + cvmPreFamilyAfterDirectLocalRunTest.push `y .default + (.fvar cvmValidationAlphaIdTest) + +theorem cvmPreFamilyAlphaFindRootTest : + cvmPreFamilyContextTest.lctx.find? cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := by + simpa [cvmPreFamilyContextTest, cvmValidationRootContextTest] using + cvmValidationAlphaFindTest + +theorem cvmPreFamilyPFindRootTest : + cvmPreFamilyContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := by + simpa [cvmPreFamilyContextTest, cvmValidationRootContextTest] using + cvmValidationPFindTest + +theorem cvmPreFamilyAlphaFindXTest : + cvmPreFamilyXContextTest.lctx.find? cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := + cvmPreFamilyRootLocalRunTest.push_findOld `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) + cvmPreFamilyAlphaFindRootTest + +theorem cvmPreFamilyPFindXTest : + cvmPreFamilyXContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := + cvmPreFamilyRootLocalRunTest.push_findOld `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) + cvmPreFamilyPFindRootTest + +theorem cvmPreFamilyRootFreshIdTest : + cvmPreFamilyContextTest.freshFVarId = cvmValidationXIdTest := by + rfl + +theorem cvmPreFamilyXFindTest : + cvmPreFamilyXContextTest.lctx.find? cvmValidationXIdTest = + some (.cdecl cvmPreFamilyContextTest.lctx.decls.size + cvmValidationXIdTest `x (.fvar cvmValidationAlphaIdTest) + .default .default) := by + have found := cvmPreFamilyRootLocalRunTest.push_findNew `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) + rw [← cvmPreFamilyRootFreshIdTest] + simpa [cvmPreFamilyXContextTest, cvmValidationXIdTest, + cvmPreFamilyContextTest, + cvmValidationRootContextTest, cvmCtorXDomainValidationShapeTest, + AddInductive.consumeTypeAnnotations] using found + +theorem cvmPreFamilyAlphaFindProofTest : + cvmPreFamilyProofContextTest.lctx.find? cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := + cvmPreFamilyXLocalRunTest.push_findOld `proof .default + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) + cvmPreFamilyAlphaFindXTest + +theorem cvmPreFamilyPFindProofTest : + cvmPreFamilyProofContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := + cvmPreFamilyXLocalRunTest.push_findOld `proof .default + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) + cvmPreFamilyPFindXTest + +theorem cvmPreFamilyAlphaFindAfterDirectTest : + cvmPreFamilyAfterDirectContextTest.lctx.find? + cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := by + simpa [cvmPreFamilyAfterDirectContextTest, + AddInductive.Context.advanceFresh] using cvmPreFamilyAlphaFindProofTest + +theorem cvmPreFamilyPFindAfterDirectTest : + cvmPreFamilyAfterDirectContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := by + simpa [cvmPreFamilyAfterDirectContextTest, + AddInductive.Context.advanceFresh] using cvmPreFamilyPFindProofTest + +theorem cvmPreFamilyAlphaFindAfterFunctionTest : + cvmPreFamilyAfterFunctionContextTest.lctx.find? + cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := by + simpa [cvmPreFamilyAfterFunctionContextTest, + AddInductive.Context.advanceFresh] using + cvmPreFamilyAlphaFindAfterDirectTest + +theorem cvmPreFamilyPFindAfterFunctionTest : + cvmPreFamilyAfterFunctionContextTest.lctx.find? + cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := by + simpa [cvmPreFamilyAfterFunctionContextTest, + AddInductive.Context.advanceFresh] using cvmPreFamilyPFindAfterDirectTest + +theorem cvmPreFamilyAlphaFindLaterTest : + cvmPreFamilyLaterContextTest.lctx.find? cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := + cvmPreFamilyAfterFunctionLocalRunTest.push_findOld `later .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) + cvmPreFamilyAlphaFindAfterFunctionTest + +theorem cvmPreFamilyPFindLaterTest : + cvmPreFamilyLaterContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := + cvmPreFamilyAfterFunctionLocalRunTest.push_findOld `later .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) + cvmPreFamilyPFindAfterFunctionTest + +theorem cvmPreFamilyAfterFunctionFreshIdTest : + cvmPreFamilyAfterFunctionContextTest.freshFVarId = + cvmValidationLaterIdTest := by + rfl + +theorem cvmPreFamilyLaterFindTest : + cvmPreFamilyLaterContextTest.lctx.find? cvmValidationLaterIdTest = + some (.cdecl cvmPreFamilyAfterFunctionContextTest.lctx.decls.size + cvmValidationLaterIdTest `later (.fvar cvmValidationAlphaIdTest) + .default .default) := by + have found := cvmPreFamilyAfterFunctionLocalRunTest.push_findNew + `later .default (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) + rw [← cvmPreFamilyAfterFunctionFreshIdTest] + simpa [cvmPreFamilyLaterContextTest, cvmValidationLaterIdTest, + cvmPreFamilyAfterFunctionContextTest, cvmPreFamilyAfterDirectContextTest, + cvmPreFamilyProofContextTest, cvmPreFamilyXContextTest, + cvmPreFamilyContextTest, cvmValidationFunctionContextTest, + cvmValidationDirectContextTest, cvmValidationProofContextTest, + cvmValidationXContextTest, cvmValidationRootContextTest, + cvmCtorLaterDomainValidationShapeTest, + AddInductive.Context.advanceFresh, + AddInductive.consumeTypeAnnotations] using found + +theorem cvmPreFamilyAlphaFindLaterProofTest : + cvmPreFamilyLaterProofContextTest.lctx.find? + cvmValidationAlphaIdTest = + some (.cdecl 0 cvmValidationAlphaIdTest `α + (.sort (.succ (.param `u))) .default .default) := + cvmPreFamilyLaterLocalRunTest.push_findOld `laterProof .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) + cvmPreFamilyAlphaFindLaterTest + +theorem cvmPreFamilyPFindLaterProofTest : + cvmPreFamilyLaterProofContextTest.lctx.find? cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := + cvmPreFamilyLaterLocalRunTest.push_findOld `laterProof .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) + cvmPreFamilyPFindLaterTest + +theorem cvmPreFamilyPFindFunctionInnerTest : + cvmPreFamilyFunctionInnerContextTest.lctx.find? + cvmValidationPIdTest = + some (.cdecl cvmValidationAlphaContextTest.lctx.decls.size + cvmValidationPIdTest `P cvmValidationPDomainTest + .default .default) := + cvmPreFamilyAfterDirectLocalRunTest.push_findOld `y .default + (.fvar cvmValidationAlphaIdTest) cvmPreFamilyPFindAfterDirectTest + +theorem cvmPreFamilyRootFreshTest : + cvmPreFamilyContextTest.lctx.find? + cvmPreFamilyContextTest.freshFVarId = none := + cvmPreFamilyRootLocalRunTest.fresh + +theorem cvmPreFamilyXFreshTest : + cvmPreFamilyXContextTest.lctx.find? + cvmPreFamilyXContextTest.freshFVarId = none := + cvmPreFamilyXLocalRunTest.fresh + +theorem cvmPreFamilyProofFreshTest : + cvmPreFamilyProofContextTest.lctx.find? + cvmPreFamilyProofContextTest.freshFVarId = none := + cvmPreFamilyProofLocalRunTest.fresh + +theorem cvmPreFamilyAfterDirectFreshTest : + cvmPreFamilyAfterDirectContextTest.lctx.find? + cvmPreFamilyAfterDirectContextTest.freshFVarId = none := + cvmPreFamilyAfterDirectLocalRunTest.fresh + +theorem cvmPreFamilyAfterFunctionFreshTest : + cvmPreFamilyAfterFunctionContextTest.lctx.find? + cvmPreFamilyAfterFunctionContextTest.freshFVarId = none := + cvmPreFamilyAfterFunctionLocalRunTest.fresh + +theorem cvmPreFamilyLaterFreshTest : + cvmPreFamilyLaterContextTest.lctx.find? + cvmPreFamilyLaterContextTest.freshFVarId = none := + cvmPreFamilyLaterLocalRunTest.fresh + +theorem cvmPreFamilyFunctionInnerFreshTest : + cvmPreFamilyFunctionInnerContextTest.lctx.find? + cvmPreFamilyFunctionInnerContextTest.freshFVarId = none := + cvmPreFamilyFunctionInnerLocalRunTest.fresh + +theorem cvmPreFamilyDepthTest (context : AddInductive.Context) + (contextEq : context = cvmPreFamilyContextTest ∨ + context = cvmPreFamilyXContextTest ∨ + context = cvmPreFamilyProofContextTest ∨ + context = cvmPreFamilyAfterDirectContextTest ∨ + context = cvmPreFamilyAfterFunctionContextTest ∨ + context = cvmPreFamilyLaterContextTest ∨ + context = cvmPreFamilyLaterProofContextTest ∨ + context = cvmPreFamilyFunctionInnerContextTest) : + context.fuel.recDepth = 10000 := by + rcases contextEq with rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl <;> + rfl + +theorem cvmPreFamilyInductiveFuelTest (context : AddInductive.Context) + (contextEq : context = cvmPreFamilyContextTest ∨ + context = cvmPreFamilyProofContextTest ∨ + context = cvmPreFamilyAfterDirectContextTest) : + context.fuel.inductiveFuel = 1000 := by + rcases contextEq with rfl | rfl | rfl <;> rfl + +theorem cvmFamilyViewPreFamilyTest_eq : + cvmCandidate.families.singleton.familyType.type.view = + constructorValidityMatrixKernelType.type := by + apply cvmFamilyIdentityEvidence.identity.view_eq_source + · apply TypeChecker.CandidateLocalContextRun.empty + rw [cvmFamilyCandidateContext_eq] + rfl + · rw [cvmFamilyCandidateContext_eq] + simp [constructorValidityMatrixKernelType, + constructorValidityMatrixInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, FVarsIn, Level.hasMVar'] + +theorem cvmStagedParamsPreFamilyTest_eq : + cvmStagedUniverseInputTest.staged.family.validation.stats.params = + #[.fvar cvmValidationAlphaIdTest, .fvar cvmValidationPIdTest] := by + rw [cvmStagedStatsTest_eq, cvmStatsParamsTest] + rfl + +theorem cvmStagedNindicesPreFamilyTest_eq : + cvmStagedUniverseInputTest.staged.family.validation.stats.nindices = + #[0] := by + rw [cvmStagedStatsTest_eq, cvmStatsNindices_eq] + +def cvmPreFamilyIndicesTest : Expr := + .sort (.succ (.param `u)) + +theorem cvmPreFamilyParametersRunTest : + AddInductive.instantiateFamilyParameters + constructorValidityMatrixKernelType.type + cvmStagedUniverseInputTest.staged.family.validation.stats.params.toList = + .ok cvmPreFamilyIndicesTest := by + rw [cvmStagedParamsPreFamilyTest_eq] + simp [constructorValidityMatrixKernelType, + constructorValidityMatrixInfo, ConstantInfo.type, + ConstantInfo.toConstantVal, + AddInductive.instantiateFamilyParameters, + cvmPreFamilyIndicesTest, cvmValidationAlphaIdTest, + cvmValidationPIdTest, cvmValidationAlphaContextTest, + cvmFamilyContext, Expr.instantiate1_eq, Expr.instantiate1', + Pure.pure, Except.pure] + +@[simp] theorem cvmPreFamilyFamilyAppGetAppFnTest + (alpha predicate : Expr) : + (cvmValidationFamilyApplicationTest alpha predicate).getAppFn = + .const constructorValidityMatrixKernelType.name [.param `u] := by + rfl + +@[simp] theorem cvmPreFamilyFamilyAppGetAppArgsTest + (alpha predicate : Expr) : + (cvmValidationFamilyApplicationTest alpha predicate).getAppArgs = + #[alpha, predicate] := by + rfl + +theorem cvmPreFamilyFamilyAppValidTest : + AddInductive.isValidIndAppIdx + cvmStagedUniverseInputTest.staged.family.validation.stats + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) 0 = + true := by + simp +decide [AddInductive.isValidIndAppIdx, + cvmStagedParamsPreFamilyTest_eq, + cvmStagedNindicesPreFamilyTest_eq, + cvmStagedIndConstsTest_eq, + cvmPreFamilyFamilyAppGetAppFnTest, + cvmPreFamilyFamilyAppGetAppArgsTest, + prbExprBneSelfReplay] + +def cvmPreFamilyIndicesCheckedTest + (context : AddInductive.Context) + (lparams : context.lparams = [`u]) + (depth : context.fuel.recDepth = 10000) : + AddInductive.ConstructorCheckedExpr context cvmPreFamilyIndicesTest := + .ofRun (by simp [cvmPreFamilyIndicesTest, FVarsIn, Level.hasMVar']) + (by + unfold cvmPreFamilyIndicesTest + exact prbPreFamilySortCheckValidReplay context lparams depth) + +def cvmPreFamilyNilSpineTest + (context : AddInductive.Context) + (lparams : context.lparams = [`u]) + (depth : context.fuel.recDepth = 10000) : + AddInductive.ConstructorPreFamilyIndexSpineTrace context + cvmPreFamilyIndicesTest [] := + .nil context cvmPreFamilyIndicesTest + (cvmPreFamilyIndicesCheckedTest context lparams depth) rfl + +def cvmPreFamilyFVarCheckedTest + (context : AddInductive.Context) (id : FVarId) (type : Expr) + (find : context.lctx.find? id = + some (.cdecl index id name type bi kind)) + (depth : context.fuel.recDepth = 10000) : + AddInductive.ConstructorCheckedExpr context (.fvar id) := + .ofRun (by + change (context.lctx.find? id).isSome = true + rw [find] + rfl) + (prbCandidateCheckTypeFVar context id type depth find) + +def cvmPreFamilyFVarEnsureTest + (context : AddInductive.Context) (id : FVarId) (level : Level) + (find : context.lctx.find? id = + some (.cdecl index id name (.sort level) bi kind)) + (depth : context.fuel.recDepth = 10000) : + AddInductive.ConstructorEnsureTypeObservation context (.fvar id) := + ⟨.sort level, + prbPreFamilyFVarEnsureValidReplay context id level find depth⟩ + +def cvmPreFamilyPredicateCheckedTest + (context : AddInductive.Context) (argumentId : FVarId) + (idsNe : cvmValidationPIdTest ≠ argumentId) + (predicateFind : context.lctx.find? cvmValidationPIdTest = + some (.cdecl predicateIndex cvmValidationPIdTest predicateName + cvmValidationPDomainTest predicateBi predicateKind)) + (argumentFind : context.lctx.find? argumentId = + some (.cdecl argumentIndex argumentId argumentName + (.fvar cvmValidationAlphaIdTest) argumentBi argumentKind)) + (depth : context.fuel.recDepth = 10000) : + AddInductive.ConstructorCheckedExpr context + (cvmValidationPredicateApplicationTest cvmValidationPIdTest + (.fvar argumentId)) := + .ofRun (by + simp [cvmValidationPredicateApplicationTest, FVarsIn, Level.hasMVar'] + constructor + · change (context.lctx.find? cvmValidationPIdTest).isSome = true + rw [predicateFind] + rfl + · change (context.lctx.find? argumentId).isSome = true + rw [argumentFind] + rfl) + (cvmValidationPredicateApplicationCheckTest context + cvmValidationPIdTest argumentId idsNe predicateFind argumentFind depth) + +def cvmPreFamilyPredicateEnsureTest + (context : AddInductive.Context) (argumentId : FVarId) + (predicateFind : context.lctx.find? cvmValidationPIdTest = + some (.cdecl predicateIndex cvmValidationPIdTest predicateName + cvmValidationPDomainTest predicateBi predicateKind)) + (depth : context.fuel.recDepth = 10000) : + AddInductive.ConstructorEnsureTypeObservation context + (cvmValidationPredicateApplicationTest cvmValidationPIdTest + (.fvar argumentId)) := + ⟨.sort .zero, + cvmEnsureTypeOfInferOnlyTest context + (cvmValidationPredicateApplicationTest cvmValidationPIdTest + (.fvar argumentId)) .zero + (cvmValidationPredicateApplicationStateTest cvmValidationPIdTest + (.fvar argumentId)) + (cvmInferTypePredicateApplicationOnlyTest context + cvmValidationPIdTest (.fvar argumentId) predicateFind depth + (by simp [cvmValidationPredicateApplicationTest, + Expr.hasLooseBVars, Expr.looseBVarRange']))⟩ + +def cvmPreFamilyReflAnnotationsTest + (context : AddInductive.Context) (source : Expr) : + AddInductive.CandidateIsDefEqObservation context source source := + ⟨AddInductive.candidateIsDefEqRefl context source⟩ + +def cvmPreFamilyXCheckedTest : + AddInductive.ConstructorCheckedExpr cvmPreFamilyContextTest + cvmCtorXDomain := by + rw [cvmCtorXDomainValidationShapeTest] + exact cvmPreFamilyFVarCheckedTest _ _ _ cvmPreFamilyAlphaFindRootTest + (cvmPreFamilyDepthTest _ (Or.inl rfl)) + +def cvmPreFamilyXEnsureTest : + AddInductive.ConstructorEnsureTypeObservation cvmPreFamilyContextTest + cvmCtorXDomain := by + rw [cvmCtorXDomainValidationShapeTest] + exact cvmPreFamilyFVarEnsureTest _ _ _ cvmPreFamilyAlphaFindRootTest + (cvmPreFamilyDepthTest _ (Or.inl rfl)) + +def cvmPreFamilyXConsumedTest : + AddInductive.ConstructorCheckedExpr cvmPreFamilyContextTest + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) := by + rw [cvmValidationConsumeXTest] + exact cvmPreFamilyXCheckedTest + +def cvmPreFamilyXAnnotationsTest : + AddInductive.CandidateIsDefEqObservation cvmPreFamilyContextTest + cvmCtorXDomain (AddInductive.consumeTypeAnnotations cvmCtorXDomain) := by + rw [cvmValidationConsumeXTest] + exact cvmPreFamilyReflAnnotationsTest _ _ + +def cvmPreFamilyProofCheckedTest : + AddInductive.ConstructorCheckedExpr cvmPreFamilyXContextTest + cvmCtorProofDomain := by + rw [cvmCtorProofDomainValidationShapeTest] + exact cvmPreFamilyPredicateCheckedTest _ cvmValidationXIdTest + cvmValidationPNeXTest cvmPreFamilyPFindXTest cvmPreFamilyXFindTest + (cvmPreFamilyDepthTest _ (Or.inr (Or.inl rfl))) + +def cvmPreFamilyProofEnsureTest : + AddInductive.ConstructorEnsureTypeObservation cvmPreFamilyXContextTest + cvmCtorProofDomain := by + rw [cvmCtorProofDomainValidationShapeTest] + exact cvmPreFamilyPredicateEnsureTest _ cvmValidationXIdTest + cvmPreFamilyPFindXTest + (cvmPreFamilyDepthTest _ (Or.inr (Or.inl rfl))) + +def cvmPreFamilyProofConsumedTest : + AddInductive.ConstructorCheckedExpr cvmPreFamilyXContextTest + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) := by + rw [cvmValidationConsumeProofTest] + exact cvmPreFamilyProofCheckedTest + +def cvmPreFamilyProofAnnotationsTest : + AddInductive.CandidateIsDefEqObservation cvmPreFamilyXContextTest + cvmCtorProofDomain + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) := by + rw [cvmValidationConsumeProofTest] + exact cvmPreFamilyReflAnnotationsTest _ _ + +def cvmPreFamilyFunctionAlphaCheckedTest : + AddInductive.ConstructorCheckedExpr cvmPreFamilyAfterDirectContextTest + (.fvar cvmValidationAlphaIdTest) := + cvmPreFamilyFVarCheckedTest _ _ _ cvmPreFamilyAlphaFindAfterDirectTest + (cvmPreFamilyDepthTest _ (Or.inr (Or.inr (Or.inr (Or.inl rfl))))) + +def cvmPreFamilyFunctionAlphaEnsureTest : + AddInductive.ConstructorEnsureTypeObservation + cvmPreFamilyAfterDirectContextTest + (.fvar cvmValidationAlphaIdTest) := + cvmPreFamilyFVarEnsureTest _ _ _ cvmPreFamilyAlphaFindAfterDirectTest + (cvmPreFamilyDepthTest _ (Or.inr (Or.inr (Or.inr (Or.inl rfl))))) + +def cvmPreFamilyFunctionAlphaConsumedTest : + AddInductive.ConstructorCheckedExpr cvmPreFamilyAfterDirectContextTest + (AddInductive.consumeTypeAnnotations + (.fvar cvmValidationAlphaIdTest)) := by + simp [AddInductive.consumeTypeAnnotations] + exact cvmPreFamilyFunctionAlphaCheckedTest + +def cvmPreFamilyFunctionAlphaAnnotationsTest : + AddInductive.CandidateIsDefEqObservation + cvmPreFamilyAfterDirectContextTest (.fvar cvmValidationAlphaIdTest) + (AddInductive.consumeTypeAnnotations + (.fvar cvmValidationAlphaIdTest)) := by + simp [AddInductive.consumeTypeAnnotations] + exact cvmPreFamilyReflAnnotationsTest _ _ + +def cvmPreFamilyLaterCheckedTest : + AddInductive.ConstructorCheckedExpr cvmPreFamilyAfterFunctionContextTest + cvmCtorLaterDomain := by + rw [cvmCtorLaterDomainValidationShapeTest] + exact cvmPreFamilyFVarCheckedTest _ _ _ + cvmPreFamilyAlphaFindAfterFunctionTest + (cvmPreFamilyDepthTest _ + (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl rfl)))))) + +def cvmPreFamilyLaterEnsureTest : + AddInductive.ConstructorEnsureTypeObservation + cvmPreFamilyAfterFunctionContextTest cvmCtorLaterDomain := by + rw [cvmCtorLaterDomainValidationShapeTest] + exact cvmPreFamilyFVarEnsureTest _ _ _ + cvmPreFamilyAlphaFindAfterFunctionTest + (cvmPreFamilyDepthTest _ + (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl rfl)))))) + +def cvmPreFamilyLaterConsumedTest : + AddInductive.ConstructorCheckedExpr cvmPreFamilyAfterFunctionContextTest + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) := by + rw [cvmValidationConsumeLaterTest] + exact cvmPreFamilyLaterCheckedTest + +def cvmPreFamilyLaterAnnotationsTest : + AddInductive.CandidateIsDefEqObservation + cvmPreFamilyAfterFunctionContextTest cvmCtorLaterDomain + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) := by + rw [cvmValidationConsumeLaterTest] + exact cvmPreFamilyReflAnnotationsTest _ _ + +def cvmPreFamilyLaterProofCheckedTest : + AddInductive.ConstructorCheckedExpr cvmPreFamilyLaterContextTest + cvmCtorLaterProofDomain := by + rw [cvmCtorLaterProofDomainValidationShapeTest] + exact cvmPreFamilyPredicateCheckedTest _ cvmValidationLaterIdTest + cvmValidationPNeLaterTest cvmPreFamilyPFindLaterTest + cvmPreFamilyLaterFindTest + (cvmPreFamilyDepthTest _ + (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl rfl))))))) + +def cvmPreFamilyLaterProofEnsureTest : + AddInductive.ConstructorEnsureTypeObservation cvmPreFamilyLaterContextTest + cvmCtorLaterProofDomain := by + rw [cvmCtorLaterProofDomainValidationShapeTest] + exact cvmPreFamilyPredicateEnsureTest _ cvmValidationLaterIdTest + cvmPreFamilyPFindLaterTest + (cvmPreFamilyDepthTest _ + (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl rfl))))))) + +def cvmPreFamilyLaterProofConsumedTest : + AddInductive.ConstructorCheckedExpr cvmPreFamilyLaterContextTest + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) := by + rw [cvmValidationConsumeLaterProofTest] + exact cvmPreFamilyLaterProofCheckedTest + +def cvmPreFamilyLaterProofAnnotationsTest : + AddInductive.CandidateIsDefEqObservation cvmPreFamilyLaterContextTest + cvmCtorLaterProofDomain + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) := by + rw [cvmValidationConsumeLaterProofTest] + exact cvmPreFamilyReflAnnotationsTest _ _ + +theorem cvmPreFamilyFamilyArgsTest : + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) + (.fvar cvmValidationPIdTest)).getAppArgs.toList.drop + cvmStagedUniverseInputTest.staged.family.validation.stats.params.size = + [] := by + rw [cvmStagedParamsPreFamilyTest_eq] + simp [cvmPreFamilyFamilyAppGetAppArgsTest] + +def cvmPreFamilyFamilySpineTest + (context : AddInductive.Context) + (lparams : context.lparams = [`u]) + (depth : context.fuel.recDepth = 10000) : + AddInductive.ConstructorPreFamilyIndexSpineTrace context + cvmPreFamilyIndicesTest + ((cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) + (.fvar cvmValidationPIdTest)).getAppArgs.toList.drop + cvmStagedUniverseInputTest.staged.family.validation.stats.params.size) := by + rw [cvmPreFamilyFamilyArgsTest] + exact cvmPreFamilyNilSpineTest context lparams depth + +def cvmPreFamilyTargetTraceTest + (context : AddInductive.Context) + (lparams : context.lparams = [`u]) + (depth : context.fuel.recDepth = 10000) + (fuel : Nat) : + AddInductive.ConstructorPreFamilyRecursiveTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest context + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + (fuel + 1) := + .target context _ cvmPreFamilyFamilyAppValidTest + (cvmPreFamilyFamilySpineTest context lparams depth) + +theorem cvmPreFamilyTargetRunTest + (context : AddInductive.Context) + (lparams : context.lparams = [`u]) + (depth : context.fuel.recDepth = 10000) + (fuel : Nat) : + AddInductive.ConstructorPreFamilyRecursiveTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest context + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + (fuel + 1) = + .ok (cvmPreFamilyTargetTraceTest context lparams depth fuel) := + AddInductive.ConstructorPreFamilyRecursiveTrace.target_build_eq + rfl cvmPreFamilyFamilyAppValidTest + (cvmPreFamilyFamilySpineTest context lparams depth) + +theorem cvmPreFamilyRecursiveTraceBuildEqTest + (trace : AddInductive.ConstructorPreFamilyRecursiveTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest context source fuel) : + AddInductive.ConstructorPreFamilyRecursiveTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest context source fuel = .ok trace := by + induction trace with + | forallE context name domain body binderInfo domainCheck ensureType + consumedCheck annotations fresh tail ih => + exact AddInductive.ConstructorPreFamilyRecursiveTrace.forallE_build_eq + domainCheck ensureType consumedCheck annotations fresh tail ih + | target context source valid spine => + cases source <;> try + { exact AddInductive.ConstructorPreFamilyRecursiveTrace.target_build_eq + rfl valid spine } + rename_i binderName binderType body binderInfo + unfold AddInductive.isValidIndAppIdx at valid + rw [cvmStagedIndConstsTest_eq] at valid + have mismatch : + (((.forallE binderName binderType body binderInfo : Expr).getAppFn == + .const constructorValidityMatrixKernelType.name [.param `u])) = + false := by + change Expr.eqv (.forallE binderName binderType body binderInfo) + (.const constructorValidityMatrixKernelType.name [.param `u]) = false + rw [Expr.eqv_eq] + rfl + simp [mismatch] at valid + +def cvmPreFamilyDirectFieldTraceTest : + AddInductive.ConstructorPreFamilyRecursiveTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyProofContextTest + cvmCtorDirectDomain 1000 := by + rw [cvmCtorDirectDomainValidationShapeTest] + exact cvmPreFamilyTargetTraceTest cvmPreFamilyProofContextTest rfl + (cvmPreFamilyDepthTest _ + (Or.inr (Or.inr (Or.inl rfl)))) 999 + +theorem cvmPreFamilyDirectFieldRunTest : + AddInductive.ConstructorPreFamilyRecursiveTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyProofContextTest + cvmCtorDirectDomain 1000 = + .ok cvmPreFamilyDirectFieldTraceTest := by + exact cvmPreFamilyRecursiveTraceBuildEqTest + cvmPreFamilyDirectFieldTraceTest + +def cvmPreFamilyDirectFieldTraceAtFuelTest : + AddInductive.ConstructorPreFamilyRecursiveTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyProofContextTest + cvmCtorDirectDomain + cvmPreFamilyProofContextTest.fuel.inductiveFuel := by + rw [cvmPreFamilyInductiveFuelTest _ (Or.inr (Or.inl rfl))] + exact cvmPreFamilyDirectFieldTraceTest + +theorem cvmPreFamilyDirectFieldRunAtFuelTest : + AddInductive.ConstructorPreFamilyRecursiveTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyProofContextTest + cvmCtorDirectDomain + cvmPreFamilyProofContextTest.fuel.inductiveFuel = + .ok cvmPreFamilyDirectFieldTraceAtFuelTest := by + exact cvmPreFamilyRecursiveTraceBuildEqTest + cvmPreFamilyDirectFieldTraceAtFuelTest + +def cvmPreFamilyFunctionFieldTraceTest : + AddInductive.ConstructorPreFamilyRecursiveTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyAfterDirectContextTest + cvmCtorFunctionDomain 1000 := by + rw [cvmCtorFunctionDomainValidationShapeTest] + exact .forallE cvmPreFamilyAfterDirectContextTest `y + (.fvar cvmValidationAlphaIdTest) + (cvmValidationFamilyApplicationTest + (.fvar cvmValidationAlphaIdTest) (.fvar cvmValidationPIdTest)) + .default cvmPreFamilyFunctionAlphaCheckedTest + cvmPreFamilyFunctionAlphaEnsureTest + cvmPreFamilyFunctionAlphaConsumedTest + cvmPreFamilyFunctionAlphaAnnotationsTest + cvmPreFamilyAfterDirectFreshTest + (by + simpa [cvmPreFamilyFunctionInnerContextTest, + AddInductive.consumeTypeAnnotations, + cvmValidationFamilyApplicationTest, + Expr.instantiate1_eq, Expr.instantiate1'] using + (cvmPreFamilyTargetTraceTest cvmPreFamilyFunctionInnerContextTest rfl + (cvmPreFamilyDepthTest _ + (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr + (Or.inr (Or.inr rfl)))))))) 998)) + +theorem cvmPreFamilyFunctionFieldRunTest : + AddInductive.ConstructorPreFamilyRecursiveTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyAfterDirectContextTest + cvmCtorFunctionDomain 1000 = + .ok cvmPreFamilyFunctionFieldTraceTest := by + exact cvmPreFamilyRecursiveTraceBuildEqTest + cvmPreFamilyFunctionFieldTraceTest + +def cvmPreFamilyFunctionFieldTraceAtFuelTest : + AddInductive.ConstructorPreFamilyRecursiveTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyAfterDirectContextTest + cvmCtorFunctionDomain + cvmPreFamilyAfterDirectContextTest.fuel.inductiveFuel := by + rw [cvmPreFamilyInductiveFuelTest _ + (Or.inr (Or.inr rfl))] + exact cvmPreFamilyFunctionFieldTraceTest + +theorem cvmPreFamilyFunctionFieldRunAtFuelTest : + AddInductive.ConstructorPreFamilyRecursiveTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyAfterDirectContextTest + cvmCtorFunctionDomain + cvmPreFamilyAfterDirectContextTest.fuel.inductiveFuel = + .ok cvmPreFamilyFunctionFieldTraceAtFuelTest := by + exact cvmPreFamilyRecursiveTraceBuildEqTest + cvmPreFamilyFunctionFieldTraceAtFuelTest + +theorem cvmPreFamilyParameterBuildEqTest + (parameterAt : stats.params[argIdx]? = some parameter) + (tail : AddInductive.ConstructorPreFamilyViewTrace stats familyIdx + familyIndices context (body.instantiate1 parameter) (argIdx + 1) + removed recursiveStarted) + (tailRun : AddInductive.ConstructorPreFamilyViewTrace.build stats + familyIdx familyIndices context (body.instantiate1 parameter) + (argIdx + 1) removed recursiveStarted fuel = .ok tail) : + AddInductive.ConstructorPreFamilyViewTrace.build stats familyIdx + familyIndices context (.forallE name domain body binderInfo) argIdx + removed recursiveStarted (fuel + 1) = + .ok (.parameter context argIdx removed recursiveStarted name domain + body binderInfo parameter parameterAt tail) := by + simp only [AddInductive.ConstructorPreFamilyViewTrace.build] + split + · rename_i observed observedAt + rw [parameterAt] at observedAt + cases observedAt + rw [tailRun] + rfl + · rename_i noParameter + rw [parameterAt] at noParameter + contradiction + +theorem cvmPreFamilyOrdinaryBuildEqTest + (noParameter : stats.params[argIdx]? = none) + (nonrecursive : AddInductive.hasIndOcc stats.indConsts domain = false) + (independent : AddInductive.constructorIndependentOf domain removed = true) + (domainCheck : AddInductive.ConstructorCheckedExpr context domain) + (ensureType : AddInductive.ConstructorEnsureTypeObservation context domain) + (consumedCheck : AddInductive.ConstructorCheckedExpr context + (AddInductive.consumeTypeAnnotations domain)) + (annotations : AddInductive.CandidateIsDefEqObservation context domain + (AddInductive.consumeTypeAnnotations domain)) + (fresh : context.lctx.find? context.freshFVarId = none) + (tail : AddInductive.ConstructorPreFamilyViewTrace stats familyIdx + familyIndices + (context.pushLocalDecl name binderInfo + (AddInductive.consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) removed + recursiveStarted) + (tailRun : AddInductive.ConstructorPreFamilyViewTrace.build stats + familyIdx familyIndices + (context.pushLocalDecl name binderInfo + (AddInductive.consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) removed + recursiveStarted fuel = .ok tail) : + AddInductive.ConstructorPreFamilyViewTrace.build stats familyIdx + familyIndices context (.forallE name domain body binderInfo) argIdx + removed recursiveStarted (fuel + 1) = + .ok (.ordinary context argIdx removed recursiveStarted name domain + body binderInfo noParameter nonrecursive independent domainCheck + ensureType consumedCheck annotations fresh tail) := by + simp only [AddInductive.ConstructorPreFamilyViewTrace.build] + split + · rename_i parameter parameterAt + rw [noParameter] at parameterAt + contradiction + · split + · rw [dif_pos independent] + rw [domainCheck.check_eq, ensureType.observe_eq, + consumedCheck.check_eq] + simp only [Bind.bind, Except.bind] + rw [annotations.observe_eq] + simp only [Bind.bind, Except.bind] + rw [dif_pos fresh, tailRun] + rfl + · rename_i recursive + rw [nonrecursive] at recursive + contradiction + +theorem cvmPreFamilyRecursiveBuildEqTest + (noParameter : stats.params[argIdx]? = none) + (isRecursive : AddInductive.hasIndOcc stats.indConsts domain = true) + (independent : AddInductive.constructorIndependentOf domain removed = true) + (field : AddInductive.ConstructorPreFamilyRecursiveTrace stats familyIdx + familyIndices context domain context.fuel.inductiveFuel) + (fieldRun : AddInductive.ConstructorPreFamilyRecursiveTrace.build stats + familyIdx familyIndices context domain context.fuel.inductiveFuel = + .ok field) + (fresh : context.lctx.find? context.freshFVarId = none) + (tail : AddInductive.ConstructorPreFamilyViewTrace stats familyIdx + familyIndices context.advanceFresh + (body.instantiate1 context.freshExpr) (argIdx + 1) + (context.freshFVarId :: removed) true) + (tailRun : AddInductive.ConstructorPreFamilyViewTrace.build stats + familyIdx familyIndices context.advanceFresh + (body.instantiate1 context.freshExpr) (argIdx + 1) + (context.freshFVarId :: removed) true fuel = .ok tail) : + AddInductive.ConstructorPreFamilyViewTrace.build stats familyIdx + familyIndices context (.forallE name domain body binderInfo) argIdx + removed recursiveStarted (fuel + 1) = + .ok (.recursive context argIdx removed recursiveStarted name domain + body binderInfo noParameter isRecursive independent field fresh + tail) := by + simp only [AddInductive.ConstructorPreFamilyViewTrace.build] + split + · rename_i parameter parameterAt + rw [noParameter] at parameterAt + contradiction + · split + · rename_i nonrecursive + rw [isRecursive] at nonrecursive + contradiction + · rw [dif_pos independent, fieldRun] + simp only [Bind.bind, Except.bind] + rw [dif_pos fresh, tailRun] + rfl + +theorem cvmPreFamilyParameterAtZeroTest : + cvmStagedUniverseInputTest.staged.family.validation.stats.params[0]? = + some (.fvar cvmValidationAlphaIdTest) := by + rw [cvmStagedParamsPreFamilyTest_eq] + rfl + +theorem cvmPreFamilyParameterAtOneTest : + cvmStagedUniverseInputTest.staged.family.validation.stats.params[1]? = + some (.fvar cvmValidationPIdTest) := by + rw [cvmStagedParamsPreFamilyTest_eq] + rfl + +theorem cvmPreFamilyNoParameterTwoTest : + cvmStagedUniverseInputTest.staged.family.validation.stats.params[2]? = + none := by + rw [cvmStagedParamsPreFamilyTest_eq] + rfl + +theorem cvmPreFamilyNoParameterThreeTest : + cvmStagedUniverseInputTest.staged.family.validation.stats.params[3]? = + none := by + rw [cvmStagedParamsPreFamilyTest_eq] + rfl + +theorem cvmPreFamilyNoParameterFourTest : + cvmStagedUniverseInputTest.staged.family.validation.stats.params[4]? = + none := by + rw [cvmStagedParamsPreFamilyTest_eq] + rfl + +theorem cvmPreFamilyNoParameterFiveTest : + cvmStagedUniverseInputTest.staged.family.validation.stats.params[5]? = + none := by + rw [cvmStagedParamsPreFamilyTest_eq] + rfl + +theorem cvmPreFamilyNoParameterSixTest : + cvmStagedUniverseInputTest.staged.family.validation.stats.params[6]? = + none := by + rw [cvmStagedParamsPreFamilyTest_eq] + rfl + +theorem cvmPreFamilyNoParameterSevenTest : + cvmStagedUniverseInputTest.staged.family.validation.stats.params[7]? = + none := by + rw [cvmStagedParamsPreFamilyTest_eq] + rfl + +theorem cvmPreFamilyLaterHasNoIndOccTest : + AddInductive.hasIndOcc + cvmStagedUniverseInputTest.staged.family.validation.stats.indConsts + cvmCtorLaterDomain = false := by + rw [cvmCtorLaterDomainValidationShapeTest] + exact cvmValidationAlphaHasNoIndOccTest + +theorem cvmPreFamilyNeFreshOfFindTest + {context : AddInductive.Context} {id : FVarId} {decl : LocalDecl} + (fresh : context.lctx.find? context.freshFVarId = none) + (find : context.lctx.find? id = some decl) : + id ≠ context.freshFVarId := by + intro equality + rw [← equality, find] at fresh + contradiction + +theorem cvmPreFamilyAlphaNeDirectRemovedTest : + cvmValidationAlphaIdTest ≠ + cvmPreFamilyProofContextTest.freshFVarId := + cvmPreFamilyNeFreshOfFindTest cvmPreFamilyProofFreshTest + cvmPreFamilyAlphaFindProofTest + +theorem cvmPreFamilyPNeDirectRemovedTest : + cvmValidationPIdTest ≠ + cvmPreFamilyProofContextTest.freshFVarId := + cvmPreFamilyNeFreshOfFindTest cvmPreFamilyProofFreshTest + cvmPreFamilyPFindProofTest + +theorem cvmPreFamilyAlphaNeFunctionRemovedTest : + cvmValidationAlphaIdTest ≠ + cvmPreFamilyAfterDirectContextTest.freshFVarId := + cvmPreFamilyNeFreshOfFindTest cvmPreFamilyAfterDirectFreshTest + cvmPreFamilyAlphaFindAfterDirectTest + +theorem cvmPreFamilyPNeFunctionRemovedTest : + cvmValidationPIdTest ≠ + cvmPreFamilyAfterDirectContextTest.freshFVarId := + cvmPreFamilyNeFreshOfFindTest cvmPreFamilyAfterDirectFreshTest + cvmPreFamilyPFindAfterDirectTest + +theorem cvmPreFamilyNeFreshOfReservesTest + {context : AddInductive.Context} {id : FVarId} + (reserved : context.ngen.Reserves id) : + id ≠ context.freshFVarId := by + intro equality + apply NameGenerator.not_reserves_self (ngen := context.ngen) + change context.ngen.Reserves context.freshFVarId + rw [← equality] + exact reserved + +theorem cvmPreFamilyDirectReservedAfterFunctionTest : + cvmPreFamilyAfterFunctionContextTest.ngen.Reserves + cvmPreFamilyProofContextTest.freshFVarId := by + have first : cvmPreFamilyAfterDirectContextTest.ngen.Reserves + cvmPreFamilyProofContextTest.freshFVarId := by + simpa [cvmPreFamilyAfterDirectContextTest, + AddInductive.Context.advanceFresh, + AddInductive.Context.freshFVarId] using + (NameGenerator.next_reserves_self + (ngen := cvmPreFamilyProofContextTest.ngen)) + have second := NameGenerator.Reserves.mono NameGenerator.LE.next first + simpa [cvmPreFamilyAfterFunctionContextTest, + AddInductive.Context.advanceFresh] using second + +theorem cvmPreFamilyFunctionReservedAfterFunctionTest : + cvmPreFamilyAfterFunctionContextTest.ngen.Reserves + cvmPreFamilyAfterDirectContextTest.freshFVarId := by + simpa [cvmPreFamilyAfterFunctionContextTest, + AddInductive.Context.advanceFresh, + AddInductive.Context.freshFVarId] using + (NameGenerator.next_reserves_self + (ngen := cvmPreFamilyAfterDirectContextTest.ngen)) + +theorem cvmPreFamilyLaterNeDirectRemovedTest : + cvmValidationLaterIdTest ≠ + cvmPreFamilyProofContextTest.freshFVarId := by + apply Ne.symm + rw [← cvmPreFamilyAfterFunctionFreshIdTest] + exact cvmPreFamilyNeFreshOfReservesTest + cvmPreFamilyDirectReservedAfterFunctionTest + +theorem cvmPreFamilyLaterNeFunctionRemovedTest : + cvmValidationLaterIdTest ≠ + cvmPreFamilyAfterDirectContextTest.freshFVarId := by + apply Ne.symm + rw [← cvmPreFamilyAfterFunctionFreshIdTest] + exact cvmPreFamilyNeFreshOfReservesTest + cvmPreFamilyFunctionReservedAfterFunctionTest + +theorem cvmPreFamilyFunctionIndependentTest : + AddInductive.constructorIndependentOf cvmCtorFunctionDomain + [cvmPreFamilyProofContextTest.freshFVarId] = true := by + rw [cvmCtorFunctionDomainValidationShapeTest] + simp [AddInductive.constructorIndependentOf, + cvmValidationFamilyApplicationTest, Expr.fvarsList, + cvmPreFamilyAlphaNeDirectRemovedTest, + cvmPreFamilyPNeDirectRemovedTest] + +theorem cvmPreFamilyLaterIndependentTest : + AddInductive.constructorIndependentOf cvmCtorLaterDomain + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] = true := by + rw [cvmCtorLaterDomainValidationShapeTest] + simp [AddInductive.constructorIndependentOf, Expr.fvarsList, + cvmPreFamilyAlphaNeFunctionRemovedTest, + cvmPreFamilyAlphaNeDirectRemovedTest] + +theorem cvmPreFamilyLaterProofIndependentTest : + AddInductive.constructorIndependentOf cvmCtorLaterProofDomain + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] = true := by + rw [cvmCtorLaterProofDomainValidationShapeTest] + simp [AddInductive.constructorIndependentOf, + cvmValidationPredicateApplicationTest, Expr.fvarsList, + cvmPreFamilyPNeFunctionRemovedTest, + cvmPreFamilyPNeDirectRemovedTest, + cvmPreFamilyLaterNeFunctionRemovedTest, + cvmPreFamilyLaterNeDirectRemovedTest] + +theorem cvmPreFamilyTerminalIndependentTest : + AddInductive.constructorIndependentOf cvmCtorTerminal + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] = true := by + rw [cvmCtorTerminalValidationShapeTest] + simp [AddInductive.constructorIndependentOf, + cvmValidationFamilyApplicationTest, Expr.fvarsList, + cvmPreFamilyAlphaNeFunctionRemovedTest, + cvmPreFamilyAlphaNeDirectRemovedTest, + cvmPreFamilyPNeFunctionRemovedTest, + cvmPreFamilyPNeDirectRemovedTest] + +theorem cvmPreFamilyTerminalValidTest : + AddInductive.isValidIndAppIdx + cvmStagedUniverseInputTest.staged.family.validation.stats + cvmCtorTerminal 0 = true := by + rw [cvmCtorTerminalValidationShapeTest] + exact cvmPreFamilyFamilyAppValidTest + +def cvmPreFamilyTerminalSpineTest : + AddInductive.ConstructorPreFamilyIndexSpineTrace + cvmPreFamilyLaterProofContextTest cvmPreFamilyIndicesTest + (cvmCtorTerminal.getAppArgs.toList.drop + cvmStagedUniverseInputTest.staged.family.validation.stats.params.size) := by + rw [cvmCtorTerminalValidationShapeTest] + exact cvmPreFamilyFamilySpineTest cvmPreFamilyLaterProofContextTest rfl + (cvmPreFamilyDepthTest _ + (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr + (Or.inr (Or.inl rfl)))))))) + +def cvmPreFamilyTerminalTraceTest : + AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyLaterProofContextTest + cvmCtorTerminal 8 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true := + .terminal cvmPreFamilyLaterProofContextTest cvmCtorTerminal 8 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true + cvmPreFamilyTerminalValidTest cvmPreFamilyTerminalIndependentTest + cvmPreFamilyTerminalSpineTest + +theorem cvmPreFamilyTerminalRunTest : + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyLaterProofContextTest + cvmCtorTerminal 8 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true 992 = + .ok cvmPreFamilyTerminalTraceTest := by + exact AddInductive.ConstructorPreFamilyViewTrace.terminal_build_eq + (fuel := 991) (by rw [cvmCtorTerminalValidationShapeTest]; rfl) + cvmPreFamilyTerminalValidTest cvmPreFamilyTerminalIndependentTest + cvmPreFamilyTerminalSpineTest + +theorem cvmPreFamilyLaterFreshExprValidationTest : + cvmPreFamilyLaterContextTest.freshExpr = + cvmValidationLaterContextTest.freshExpr := by + rfl + +theorem cvmPreFamilyLaterProofTailSourceTest : + cvmCtorAfterLater.bindingBody!.instantiate1 + cvmPreFamilyLaterContextTest.freshExpr = cvmCtorTerminal := by + rw [cvmPreFamilyLaterFreshExprValidationTest] + exact cvmSixthFieldSourceTest + +theorem cvmPreFamilyLaterProofTraceRunTest : + ∃ trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyLaterContextTest + cvmCtorAfterLater 7 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyLaterContextTest + cvmCtorAfterLater 7 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true 993 = .ok trace := by + have tailContext : cvmPreFamilyLaterContextTest.pushLocalDecl + `laterProof .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain) = + cvmPreFamilyLaterProofContextTest := by + rfl + obtain ⟨tailTrace, tailRun⟩ : + ∃ tailTrace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest + (cvmPreFamilyLaterContextTest.pushLocalDecl `laterProof .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain)) + (cvmCtorAfterLater.bindingBody!.instantiate1 + cvmPreFamilyLaterContextTest.freshExpr) 8 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest + (cvmPreFamilyLaterContextTest.pushLocalDecl `laterProof .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterProofDomain)) + (cvmCtorAfterLater.bindingBody!.instantiate1 + cvmPreFamilyLaterContextTest.freshExpr) 8 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true 992 = + .ok tailTrace := by + rw [tailContext, cvmPreFamilyLaterProofTailSourceTest] + exact ⟨cvmPreFamilyTerminalTraceTest, cvmPreFamilyTerminalRunTest⟩ + rw [cvmCtorAfterLaterForallTest] + let trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyLaterContextTest + (.forallE `laterProof cvmCtorLaterProofDomain + cvmCtorAfterLater.bindingBody! .default) 7 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true := + .ordinary cvmPreFamilyLaterContextTest 7 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true + `laterProof cvmCtorLaterProofDomain cvmCtorAfterLater.bindingBody! + .default cvmPreFamilyNoParameterSevenTest + cvmValidationLaterProofHasNoIndOccTest + cvmPreFamilyLaterProofIndependentTest + cvmPreFamilyLaterProofCheckedTest cvmPreFamilyLaterProofEnsureTest + cvmPreFamilyLaterProofConsumedTest + cvmPreFamilyLaterProofAnnotationsTest cvmPreFamilyLaterFreshTest + tailTrace + refine ⟨trace, ?_⟩ + exact cvmPreFamilyOrdinaryBuildEqTest + cvmPreFamilyNoParameterSevenTest + cvmValidationLaterProofHasNoIndOccTest + cvmPreFamilyLaterProofIndependentTest + cvmPreFamilyLaterProofCheckedTest cvmPreFamilyLaterProofEnsureTest + cvmPreFamilyLaterProofConsumedTest + cvmPreFamilyLaterProofAnnotationsTest cvmPreFamilyLaterFreshTest + tailTrace tailRun + +theorem cvmPreFamilyAfterFunctionFreshExprValidationTest : + cvmPreFamilyAfterFunctionContextTest.freshExpr = + cvmValidationFunctionContextTest.freshExpr := by + rfl + +theorem cvmPreFamilyLaterTailSourceTest : + cvmCtorAfterFunction.bindingBody!.instantiate1 + cvmPreFamilyAfterFunctionContextTest.freshExpr = + cvmCtorAfterLater := by + rw [cvmPreFamilyAfterFunctionFreshExprValidationTest] + exact cvmFifthFieldSourceTest + +theorem cvmPreFamilyLaterTraceRunTest : + ∃ trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyAfterFunctionContextTest + cvmCtorAfterFunction 6 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyAfterFunctionContextTest + cvmCtorAfterFunction 6 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true 994 = .ok trace := by + obtain ⟨laterProofTrace, laterProofRun⟩ := + cvmPreFamilyLaterProofTraceRunTest + have tailContext : cvmPreFamilyAfterFunctionContextTest.pushLocalDecl + `later .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain) = + cvmPreFamilyLaterContextTest := by + rfl + obtain ⟨tailTrace, tailRun⟩ : + ∃ tailTrace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest + (cvmPreFamilyAfterFunctionContextTest.pushLocalDecl `later .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain)) + (cvmCtorAfterFunction.bindingBody!.instantiate1 + cvmPreFamilyAfterFunctionContextTest.freshExpr) 7 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest + (cvmPreFamilyAfterFunctionContextTest.pushLocalDecl `later .default + (AddInductive.consumeTypeAnnotations cvmCtorLaterDomain)) + (cvmCtorAfterFunction.bindingBody!.instantiate1 + cvmPreFamilyAfterFunctionContextTest.freshExpr) 7 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true 993 = + .ok tailTrace := by + rw [tailContext, cvmPreFamilyLaterTailSourceTest] + exact ⟨laterProofTrace, laterProofRun⟩ + rw [cvmCtorAfterFunctionForallTest] + let trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyAfterFunctionContextTest + (.forallE `later cvmCtorLaterDomain + cvmCtorAfterFunction.bindingBody! .default) 6 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true := + .ordinary cvmPreFamilyAfterFunctionContextTest 6 + [cvmPreFamilyAfterDirectContextTest.freshFVarId, + cvmPreFamilyProofContextTest.freshFVarId] true + `later cvmCtorLaterDomain cvmCtorAfterFunction.bindingBody! + .default cvmPreFamilyNoParameterSixTest + cvmPreFamilyLaterHasNoIndOccTest cvmPreFamilyLaterIndependentTest + cvmPreFamilyLaterCheckedTest cvmPreFamilyLaterEnsureTest + cvmPreFamilyLaterConsumedTest cvmPreFamilyLaterAnnotationsTest + cvmPreFamilyAfterFunctionFreshTest tailTrace + refine ⟨trace, ?_⟩ + exact cvmPreFamilyOrdinaryBuildEqTest cvmPreFamilyNoParameterSixTest + cvmPreFamilyLaterHasNoIndOccTest cvmPreFamilyLaterIndependentTest + cvmPreFamilyLaterCheckedTest cvmPreFamilyLaterEnsureTest + cvmPreFamilyLaterConsumedTest cvmPreFamilyLaterAnnotationsTest + cvmPreFamilyAfterFunctionFreshTest tailTrace tailRun + +theorem cvmPreFamilyAfterDirectFreshExprValidationTest : + cvmPreFamilyAfterDirectContextTest.freshExpr = + cvmValidationDirectContextTest.freshExpr := by + rfl + +theorem cvmPreFamilyFunctionTailSourceTest : + cvmCtorAfterDirect.bindingBody!.instantiate1 + cvmPreFamilyAfterDirectContextTest.freshExpr = + cvmCtorAfterFunction := by + rw [cvmPreFamilyAfterDirectFreshExprValidationTest] + exact cvmFourthFieldSourceTest + +theorem cvmPreFamilyFunctionTraceRunTest : + ∃ trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyAfterDirectContextTest + cvmCtorAfterDirect 5 + [cvmPreFamilyProofContextTest.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyAfterDirectContextTest + cvmCtorAfterDirect 5 + [cvmPreFamilyProofContextTest.freshFVarId] true 995 = .ok trace := by + obtain ⟨laterTrace, laterRun⟩ := cvmPreFamilyLaterTraceRunTest + obtain ⟨tailTrace, tailRun⟩ : + ∃ tailTrace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest + cvmPreFamilyAfterDirectContextTest.advanceFresh + (cvmCtorAfterDirect.bindingBody!.instantiate1 + cvmPreFamilyAfterDirectContextTest.freshExpr) 6 + (cvmPreFamilyAfterDirectContextTest.freshFVarId :: + [cvmPreFamilyProofContextTest.freshFVarId]) true, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest + cvmPreFamilyAfterDirectContextTest.advanceFresh + (cvmCtorAfterDirect.bindingBody!.instantiate1 + cvmPreFamilyAfterDirectContextTest.freshExpr) 6 + (cvmPreFamilyAfterDirectContextTest.freshFVarId :: + [cvmPreFamilyProofContextTest.freshFVarId]) true 994 = + .ok tailTrace := by + rw [show cvmPreFamilyAfterDirectContextTest.advanceFresh = + cvmPreFamilyAfterFunctionContextTest by rfl] + rw [cvmPreFamilyFunctionTailSourceTest] + exact ⟨laterTrace, laterRun⟩ + rw [cvmCtorAfterDirectForallTest] + let trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyAfterDirectContextTest + (.forallE `function cvmCtorFunctionDomain + cvmCtorAfterDirect.bindingBody! .default) 5 + [cvmPreFamilyProofContextTest.freshFVarId] true := + .recursive cvmPreFamilyAfterDirectContextTest 5 + [cvmPreFamilyProofContextTest.freshFVarId] true + `function cvmCtorFunctionDomain cvmCtorAfterDirect.bindingBody! + .default cvmPreFamilyNoParameterFiveTest + cvmValidationFunctionHasIndOccTest + cvmPreFamilyFunctionIndependentTest + cvmPreFamilyFunctionFieldTraceAtFuelTest + cvmPreFamilyAfterDirectFreshTest tailTrace + refine ⟨trace, ?_⟩ + exact cvmPreFamilyRecursiveBuildEqTest cvmPreFamilyNoParameterFiveTest + cvmValidationFunctionHasIndOccTest cvmPreFamilyFunctionIndependentTest + cvmPreFamilyFunctionFieldTraceAtFuelTest + cvmPreFamilyFunctionFieldRunAtFuelTest + cvmPreFamilyAfterDirectFreshTest tailTrace tailRun + +theorem cvmPreFamilyProofFreshExprValidationTest : + cvmPreFamilyProofContextTest.freshExpr = + cvmValidationProofContextTest.freshExpr := by + rfl + +theorem cvmPreFamilyDirectTailSourceTest : + cvmCtorAfterProof.bindingBody!.instantiate1 + cvmPreFamilyProofContextTest.freshExpr = cvmCtorAfterDirect := by + rw [cvmPreFamilyProofFreshExprValidationTest] + exact cvmThirdFieldSourceTest + +theorem cvmPreFamilyDirectIndependentTest : + AddInductive.constructorIndependentOf cvmCtorDirectDomain [] = true := by + simp [AddInductive.constructorIndependentOf] + +theorem cvmPreFamilyDirectTraceRunTest : + ∃ trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyProofContextTest + cvmCtorAfterProof 4 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyProofContextTest + cvmCtorAfterProof 4 [] false 996 = .ok trace := by + obtain ⟨functionTrace, functionRun⟩ := cvmPreFamilyFunctionTraceRunTest + obtain ⟨tailTrace, tailRun⟩ : + ∃ tailTrace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyProofContextTest.advanceFresh + (cvmCtorAfterProof.bindingBody!.instantiate1 + cvmPreFamilyProofContextTest.freshExpr) 5 + [cvmPreFamilyProofContextTest.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyProofContextTest.advanceFresh + (cvmCtorAfterProof.bindingBody!.instantiate1 + cvmPreFamilyProofContextTest.freshExpr) 5 + [cvmPreFamilyProofContextTest.freshFVarId] true 995 = + .ok tailTrace := by + rw [show cvmPreFamilyProofContextTest.advanceFresh = + cvmPreFamilyAfterDirectContextTest by rfl] + rw [cvmPreFamilyDirectTailSourceTest] + exact ⟨functionTrace, functionRun⟩ + rw [cvmCtorAfterProofForallTest] + let trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyProofContextTest + (.forallE `direct cvmCtorDirectDomain + cvmCtorAfterProof.bindingBody! .default) 4 [] false := + .recursive cvmPreFamilyProofContextTest 4 [] false + `direct cvmCtorDirectDomain cvmCtorAfterProof.bindingBody! + .default cvmPreFamilyNoParameterFourTest + cvmValidationDirectHasIndOccTest cvmPreFamilyDirectIndependentTest + cvmPreFamilyDirectFieldTraceAtFuelTest + cvmPreFamilyProofFreshTest tailTrace + refine ⟨trace, ?_⟩ + exact cvmPreFamilyRecursiveBuildEqTest cvmPreFamilyNoParameterFourTest + cvmValidationDirectHasIndOccTest cvmPreFamilyDirectIndependentTest + cvmPreFamilyDirectFieldTraceAtFuelTest + cvmPreFamilyDirectFieldRunAtFuelTest cvmPreFamilyProofFreshTest + tailTrace tailRun + +theorem cvmPreFamilyXFreshExprValidationTest : + cvmPreFamilyXContextTest.freshExpr = + cvmValidationXContextTest.freshExpr := by + rfl + +theorem cvmPreFamilyProofTailSourceTest : + cvmCtorAfterX.bindingBody!.instantiate1 + cvmPreFamilyXContextTest.freshExpr = cvmCtorAfterProof := by + rw [cvmPreFamilyXFreshExprValidationTest] + exact cvmSecondFieldSourceTest + +theorem cvmPreFamilyProofIndependentTest : + AddInductive.constructorIndependentOf cvmCtorProofDomain [] = true := by + simp [AddInductive.constructorIndependentOf] + +theorem cvmPreFamilyProofTraceRunTest : + ∃ trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyXContextTest + cvmCtorAfterX 3 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyXContextTest + cvmCtorAfterX 3 [] false 997 = .ok trace := by + obtain ⟨directTrace, directRun⟩ := cvmPreFamilyDirectTraceRunTest + obtain ⟨tailTrace, tailRun⟩ : + ∃ tailTrace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest + (cvmPreFamilyXContextTest.pushLocalDecl `proof .default + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain)) + (cvmCtorAfterX.bindingBody!.instantiate1 + cvmPreFamilyXContextTest.freshExpr) 4 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest + (cvmPreFamilyXContextTest.pushLocalDecl `proof .default + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain)) + (cvmCtorAfterX.bindingBody!.instantiate1 + cvmPreFamilyXContextTest.freshExpr) 4 [] false 996 = + .ok tailTrace := by + rw [show cvmPreFamilyXContextTest.pushLocalDecl `proof .default + (AddInductive.consumeTypeAnnotations cvmCtorProofDomain) = + cvmPreFamilyProofContextTest by rfl] + rw [cvmPreFamilyProofTailSourceTest] + exact ⟨directTrace, directRun⟩ + rw [cvmCtorAfterXForallTest] + let trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyXContextTest + (.forallE `proof cvmCtorProofDomain + cvmCtorAfterX.bindingBody! .default) 3 [] false := + .ordinary cvmPreFamilyXContextTest 3 [] false + `proof cvmCtorProofDomain cvmCtorAfterX.bindingBody! .default + cvmPreFamilyNoParameterThreeTest + cvmValidationProofHasNoIndOccTest cvmPreFamilyProofIndependentTest + cvmPreFamilyProofCheckedTest cvmPreFamilyProofEnsureTest + cvmPreFamilyProofConsumedTest cvmPreFamilyProofAnnotationsTest + cvmPreFamilyXFreshTest tailTrace + refine ⟨trace, ?_⟩ + exact cvmPreFamilyOrdinaryBuildEqTest cvmPreFamilyNoParameterThreeTest + cvmValidationProofHasNoIndOccTest cvmPreFamilyProofIndependentTest + cvmPreFamilyProofCheckedTest cvmPreFamilyProofEnsureTest + cvmPreFamilyProofConsumedTest cvmPreFamilyProofAnnotationsTest + cvmPreFamilyXFreshTest tailTrace tailRun + +theorem cvmPreFamilyRootFreshExprValidationTest : + cvmPreFamilyContextTest.freshExpr = + cvmValidationRootContextTest.freshExpr := by + rfl + +theorem cvmPreFamilyXTailSourceTest : + cvmCtorAfterP.bindingBody!.instantiate1 + cvmPreFamilyContextTest.freshExpr = cvmCtorAfterX := by + rw [cvmPreFamilyRootFreshExprValidationTest] + exact cvmFirstFieldSourceTest + +theorem cvmPreFamilyXIndependentTest : + AddInductive.constructorIndependentOf cvmCtorXDomain [] = true := by + simp [AddInductive.constructorIndependentOf] + +theorem cvmPreFamilyXTraceRunTest : + ∃ trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + cvmCtorAfterP 2 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + cvmCtorAfterP 2 [] false 998 = .ok trace := by + obtain ⟨proofTrace, proofRun⟩ := cvmPreFamilyProofTraceRunTest + obtain ⟨tailTrace, tailRun⟩ : + ∃ tailTrace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest + (cvmPreFamilyContextTest.pushLocalDecl `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain)) + (cvmCtorAfterP.bindingBody!.instantiate1 + cvmPreFamilyContextTest.freshExpr) 3 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest + (cvmPreFamilyContextTest.pushLocalDecl `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain)) + (cvmCtorAfterP.bindingBody!.instantiate1 + cvmPreFamilyContextTest.freshExpr) 3 [] false 997 = + .ok tailTrace := by + rw [show cvmPreFamilyContextTest.pushLocalDecl `x .default + (AddInductive.consumeTypeAnnotations cvmCtorXDomain) = + cvmPreFamilyXContextTest by rfl] + rw [cvmPreFamilyXTailSourceTest] + exact ⟨proofTrace, proofRun⟩ + rw [cvmCtorAfterPForallTest] + let trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + (.forallE `x cvmCtorXDomain cvmCtorAfterP.bindingBody! .default) + 2 [] false := + .ordinary cvmPreFamilyContextTest 2 [] false `x cvmCtorXDomain + cvmCtorAfterP.bindingBody! .default cvmPreFamilyNoParameterTwoTest + (by + rw [cvmCtorXDomainValidationShapeTest] + exact cvmValidationAlphaHasNoIndOccTest) + cvmPreFamilyXIndependentTest cvmPreFamilyXCheckedTest + cvmPreFamilyXEnsureTest cvmPreFamilyXConsumedTest + cvmPreFamilyXAnnotationsTest cvmPreFamilyRootFreshTest tailTrace + refine ⟨trace, ?_⟩ + exact cvmPreFamilyOrdinaryBuildEqTest cvmPreFamilyNoParameterTwoTest + (by + rw [cvmCtorXDomainValidationShapeTest] + exact cvmValidationAlphaHasNoIndOccTest) + cvmPreFamilyXIndependentTest cvmPreFamilyXCheckedTest + cvmPreFamilyXEnsureTest cvmPreFamilyXConsumedTest + cvmPreFamilyXAnnotationsTest cvmPreFamilyRootFreshTest tailTrace tailRun + +theorem cvmPreFamilyPTailSourceTest : + cvmCtorAfterAlpha.bindingBody!.instantiate1 + (.fvar cvmValidationPIdTest) = cvmCtorAfterP := by + exact cvmSecondParameterSourceTest + +theorem cvmPreFamilyPTraceRunTest : + ∃ trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + cvmCtorAfterAlpha 1 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + cvmCtorAfterAlpha 1 [] false 999 = .ok trace := by + obtain ⟨xTrace, xRun⟩ := cvmPreFamilyXTraceRunTest + obtain ⟨tailTrace, tailRun⟩ : + ∃ tailTrace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + (cvmCtorAfterAlpha.bindingBody!.instantiate1 + (.fvar cvmValidationPIdTest)) 2 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + (cvmCtorAfterAlpha.bindingBody!.instantiate1 + (.fvar cvmValidationPIdTest)) 2 [] false 998 = + .ok tailTrace := by + rw [cvmPreFamilyPTailSourceTest] + exact ⟨xTrace, xRun⟩ + rw [cvmCtorAfterAlphaForallTest] + let trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + (.forallE `P cvmCtorPDomain cvmCtorAfterAlpha.bindingBody! .implicit) + 1 [] false := + .parameter cvmPreFamilyContextTest 1 [] false `P cvmCtorPDomain + cvmCtorAfterAlpha.bindingBody! .implicit + (.fvar cvmValidationPIdTest) cvmPreFamilyParameterAtOneTest tailTrace + refine ⟨trace, ?_⟩ + exact cvmPreFamilyParameterBuildEqTest + cvmPreFamilyParameterAtOneTest tailTrace tailRun + +theorem cvmPreFamilyAlphaTailSourceTest : + constructorValidityMatrixKernelCtor.type.bindingBody!.instantiate1 + (.fvar cvmValidationAlphaIdTest) = cvmCtorAfterAlpha := by + exact cvmFirstParameterSourceTest + +theorem cvmCtorRootForallTest : + constructorValidityMatrixKernelCtor.type = + .forallE `α (.sort (.succ (.param `u))) + constructorValidityMatrixKernelCtor.type.bindingBody! .implicit := by + simp_cvm_ctor_expr + +theorem cvmPreFamilyRawTraceRunTest : + ∃ trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + constructorValidityMatrixKernelCtor.type 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + constructorValidityMatrixKernelCtor.type 0 [] false 1000 = + .ok trace := by + obtain ⟨pTrace, pRun⟩ := cvmPreFamilyPTraceRunTest + obtain ⟨tailTrace, tailRun⟩ : + ∃ tailTrace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + (constructorValidityMatrixKernelCtor.type.bindingBody!.instantiate1 + (.fvar cvmValidationAlphaIdTest)) 1 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + (constructorValidityMatrixKernelCtor.type.bindingBody!.instantiate1 + (.fvar cvmValidationAlphaIdTest)) 1 [] false 999 = + .ok tailTrace := by + rw [cvmPreFamilyAlphaTailSourceTest] + exact ⟨pTrace, pRun⟩ + rw [cvmCtorRootForallTest] + let trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + (.forallE `α (.sort (.succ (.param `u))) + constructorValidityMatrixKernelCtor.type.bindingBody! .implicit) + 0 [] false := + .parameter cvmPreFamilyContextTest 0 [] false `α + (.sort (.succ (.param `u))) + constructorValidityMatrixKernelCtor.type.bindingBody! .implicit + (.fvar cvmValidationAlphaIdTest) cvmPreFamilyParameterAtZeroTest + tailTrace + refine ⟨trace, ?_⟩ + exact cvmPreFamilyParameterBuildEqTest + cvmPreFamilyParameterAtZeroTest tailTrace tailRun + +theorem cvmPreFamilyCandidateTraceRunTest : + ∃ trace : AddInductive.ConstructorPreFamilyViewTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + cvmCandidate.families.singleton.constructors.singleton.type.view + 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + cvmCandidate.families.singleton.constructors.singleton.type.view + 0 [] false 1000 = .ok trace := by + rw [cvmCtorViewTest_eq] + exact cvmPreFamilyRawTraceRunTest + +theorem cvmSafetyRunDirectTest : + AddInductive.checkConstructorPreFamilySafety + cvmStagedUniverseInputTest.staged.family.validation.stats + cvmCandidate.families.singleton.familyType.type.view + cvmCandidate.families.singleton.constructors + cvmCandidate.families.singleton.familyType.type.trace.terminalContext = + .ok () := by + rw [cvmFamilyViewPreFamilyTest_eq] + rw [AddInductive.CandidateList.singleton_eta + cvmCandidate.families.singleton.constructors] + rw [cvmFamilyTerminalContextTest_eq] + change AddInductive.checkConstructorPreFamilySafety + cvmStagedUniverseInputTest.staged.family.validation.stats + constructorValidityMatrixKernelType.type + (.cons cvmCandidate.families.singleton.constructors.singleton .nil) + cvmPreFamilyContextTest = .ok () + obtain ⟨headTrace, headRun⟩ := cvmPreFamilyCandidateTraceRunTest + let listTrace : AddInductive.ConstructorPreFamilyListTrace + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + (.cons cvmCandidate.families.singleton.constructors.singleton .nil) := + .cons headTrace .nil + have headRunAtFuel : + AddInductive.ConstructorPreFamilyViewTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + cvmCandidate.families.singleton.constructors.singleton.type.view + 0 [] false cvmPreFamilyContextTest.fuel.inductiveFuel = + .ok headTrace := by + rw [cvmPreFamilyInductiveFuelTest _ (Or.inl rfl)] + exact headRun + have listRun : AddInductive.ConstructorPreFamilyListTrace.build + cvmStagedUniverseInputTest.staged.family.validation.stats 0 + cvmPreFamilyIndicesTest cvmPreFamilyContextTest + (.cons cvmCandidate.families.singleton.constructors.singleton .nil) = + .ok listTrace := + AddInductive.ConstructorPreFamilyListTrace.cons_build_eq headTrace + headRunAtFuel .nil rfl + have translationUnique : + (AddInductive.theoryTranslationUnique + constructorValidityMatrixKernelType.type && + (AddInductive.CandidateList.cons + cvmCandidate.families.singleton.constructors.singleton + (AddInductive.CandidateList.nil : AddInductive.CandidateList + AddInductive.CandidateConstructor [])).viewTranslationUnique) = + true := by + change (AddInductive.theoryTranslationUnique + constructorValidityMatrixKernelType.type && + (cvmCandidate.families.singleton.constructors.singleton.type.trace.viewTranslationUnique && + true)) = true + rw [cvmCandidate.families.singleton.constructors.singleton.type.trace.viewTranslationUnique_eq] + change (AddInductive.theoryTranslationUnique + constructorValidityMatrixKernelType.type && + (AddInductive.theoryTranslationUnique + cvmCandidate.families.singleton.constructors.singleton.type.view && + true)) = true + rw [cvmCtorViewTest_eq] + simp [AddInductive.theoryTranslationUnique, + constructorValidityMatrixKernelType, + constructorValidityMatrixKernelCtor, + constructorValidityMatrixInfo, constructorValidityMatrixMkInfo, + ConstantInfo.type, ConstantInfo.toConstantVal] + unfold AddInductive.checkConstructorPreFamilySafety + rw [if_pos translationUnique] + rw [cvmPreFamilyParametersRunTest] + simp only [Bind.bind, Except.bind] + rw [listRun] + rfl + +theorem cvmSafetyRunTest : + AddInductive.checkConstructorPreFamilySafety + cvmStagedPostFamilyInputTest.universeInput.staged.family.validation.stats + cvmCandidate.families.singleton.familyType.type.view + cvmCandidate.families.singleton.constructors + cvmCandidate.families.singleton.familyType.type.trace.terminalContext = + .ok () := by + simpa [cvmStagedPostFamilyInputTest] using cvmSafetyRunDirectTest + +noncomputable def cvmStagedPreFamilyInputTest : + VInductDecl.StagedNormalizationCandidatePreFamilyInput + cvmFamilyContext cvmConstructorContext VEnv.empty [`u] + cvmCandidate constructorValidityMatrixDecl := + VInductDecl.StagedNormalizationCandidatePreFamilyInput.ofRun + cvmStagedPostFamilyInputTest cvmSafetyRunTest + +/- Public CVM stage names now expose the structural D2--D4 replay above. -/ +theorem cvmUniverseRun : + AddInductive.checkConstructorUniverseListSemantics + cvmFamilyValidationRun.stats constructorValidityMatrixKernelType.ctors + { cvmCandidate.families.singleton.familyType.type.trace.terminalContext with + env := cvmConstructorContext.env } = .ok () := + by + change AddInductive.checkConstructorUniverseListSemantics + cvmFamilyValidationRun.stats constructorValidityMatrixKernelType.ctors + cvmConstructorValidationContextTest = .ok () + rw [cvmConstructorValidationContextTest_root] + exact cvmUniverseRunTest + +noncomputable def cvmConstructorValidation := cvmConstructorValidationTest + +noncomputable def cvmStagedUniverseInput := cvmStagedUniverseInputTest + +noncomputable def cvmStagedPostFamilyInput := cvmStagedPostFamilyInputTest + +theorem cvmSafetyRunDirect : + AddInductive.checkConstructorPreFamilySafety + cvmStagedUniverseInput.staged.family.validation.stats + cvmCandidate.families.singleton.familyType.type.view + cvmCandidate.families.singleton.constructors + cvmCandidate.families.singleton.familyType.type.trace.terminalContext = + .ok () := + cvmSafetyRunDirectTest + +theorem cvmSafetyRun : + AddInductive.checkConstructorPreFamilySafety + cvmStagedPostFamilyInput.universeInput.staged.family.validation.stats + cvmCandidate.families.singleton.familyType.type.view + cvmCandidate.families.singleton.constructors + cvmCandidate.families.singleton.familyType.type.trace.terminalContext = + .ok () := + cvmSafetyRunTest + +noncomputable 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 +stage-local native decision may re-enter constructor validation, universe +checking, alignment, or pre-family safety. -/ +/-- +info: 'Lean4Lean.InductiveReplayFixtures.cvmStagedPreFamilyInput' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert, + cvmExecutionResult_isOk._native.native_decide.ax_1_1] +-/ +#guard_msgs in +#print axioms cvmStagedPreFamilyInput + +/-! ## Exact produced generation packages -/ + +def cvmCanonicalFamily : + AddInductive.CandidateFamily constructorValidityMatrixKernelType where + familyType := cvmCandidate.families.singleton.familyType + constructors := .cons + cvmCandidate.families.singleton.constructors.singleton .nil + +def cvmCanonicalCandidate : + AddInductive.NormalizationCandidate [constructorValidityMatrixKernelType] where + families := .cons cvmCanonicalFamily .nil + +theorem cvmOneCtorCandidate_eta + (candidate : AddInductive.NormalizationCandidate + [constructorValidityMatrixKernelType]) : + candidate = { + families := .cons { + familyType := candidate.families.singleton.familyType + constructors := .cons + candidate.families.singleton.constructors.singleton .nil } + .nil } := by + cases candidate with + | mk families => + cases families with + | cons family tail => + cases tail + cases family with + | mk familyType constructors => + cases constructors with + | cons constructor tail => + cases tail + rfl + +theorem cvmCandidate_eq_canonical : cvmCandidate = cvmCanonicalCandidate := by + simpa [cvmCanonicalCandidate, cvmCanonicalFamily] using + cvmOneCtorCandidate_eta cvmCandidate + +theorem cvmCanonicalCandidate_produced : + AddInductive.buildNormalizationCandidate 2 + [constructorValidityMatrixKernelType] 0 false + constructorValidityMatrixContext = .ok cvmCanonicalCandidate := by + rw [← cvmCandidate_eq_canonical] + exact cvmCandidate_produced + +noncomputable abbrev cvmCanonicalStagedPreFamilyInput : + VInductDecl.StagedNormalizationCandidatePreFamilyInput + cvmFamilyContext cvmConstructorContext VEnv.empty [`u] + cvmCanonicalCandidate constructorValidityMatrixDecl := + cvmCandidate_eq_canonical ▸ cvmStagedPreFamilyInput + +def cvmFamilySemanticRootRun : + TypeChecker.CandidateExprSemanticRootRun VEnv.empty [`u] + cvmCanonicalCandidate.families.singleton.familyType.type + constructorValidityMatrixType.type := + cvmFamilyStage.type.rootInput.semanticOfIdentity + cvmFamilyIdentityEvidence.identity + +def cvmCtorSemanticRootRun : + TypeChecker.CandidateExprSemanticRootRun cvmTypeEnv [`u] + cvmCanonicalCandidate.families.singleton.constructors.singleton.type + constructorValidityMatrixType.ctors[0].type := + cvmCtorStagedInput.type.rootInput.semanticOfIdentity + cvmCtorIdentityEvidence.identity + +def cvmCtorSemanticRun : + VInductDecl.CandidateConstructorSemanticRun cvmTypeEnv [`u] + cvmCanonicalCandidate.families.singleton.constructors.singleton + constructorValidityMatrixType.ctors[0] where + name_eq := cvmCtorNames_eq + uvars_eq := rfl + type := cvmCtorSemanticRootRun + +def cvmConstructorSemanticListRun : + VInductDecl.CandidateConstructorSemanticListRun cvmTypeEnv [`u] + cvmCanonicalCandidate.families.singleton.constructors + constructorValidityMatrixType.ctors := + .cons cvmCtorSemanticRun .nil + +def cvmFamilySemanticRun : + VInductDecl.CandidateFamilySemanticRun VEnv.empty [`u] + cvmCanonicalCandidate.families.singleton constructorValidityMatrixType where + name_eq := cvmFamilyNames_eq + uvars_eq := rfl + type := cvmFamilySemanticRootRun + typeEnv := cvmTypeEnv + addType := cvmTypeEnv_add + constructors := cvmConstructorSemanticListRun + +def cvmReferenceNormalization : + VInductDecl.NormalizationCandidateSemanticRun VEnv.empty [`u] + cvmCanonicalCandidate constructorValidityMatrixDecl where + raw := constructorValidityMatrixType + raw_types_eq := rfl + uvars_eq := rfl + family := cvmFamilySemanticRun + +theorem cvmCandidate_generationShape : + VInductDecl.normalizationCandidateGenerationShape + constructorValidityMatrixDecl constructorValidityMatrixType + cvmCanonicalCandidate = true := by + rw [← cvmCandidate_eq_canonical] + unfold VInductDecl.normalizationCandidateGenerationShape + rw [AddInductive.CandidateList.singleton_eta + cvmCandidate.families.singleton.constructors] + have familyStored := cvmFamilyIdentityEvidence.identity.storedSpine + have familyLength := cvmFamilyIdentityEvidence.spineLength_eq.trans + cvmFamilyIdentityReplay_shape.1 + have ctorStored := cvmCtorIdentityEvidence.identity.storedSpine + have ctorLength := cvmCtorIdentityEvidence.spineLength_eq.trans + cvmCtorIdentityReplay_shape.1 + simp [VInductDecl.candidateConstructorSemanticGenerationShape, + constructorValidityMatrixDecl, constructorValidityMatrixType, + VExpr.telN, VExpr.dropN, VInductDecl.ctorFields, + familyStored, familyLength, ctorStored, ctorLength] + +abbrev cvmProducedGenerationShapeCandidate : + VInductDecl.ProducedGenerationShapeCandidate constructorValidityMatrixDecl + constructorValidityMatrixType constructorValidityMatrixKernelType 0 + false constructorValidityMatrixContext where + candidate := cvmCanonicalCandidate + produced := cvmCanonicalCandidate_produced + shape := cvmCandidate_generationShape + +private theorem cvmCandidate_analysis + (normalization : VInductDecl.NormalizationCandidateSemanticRun VEnv.empty + [`u] cvmCanonicalCandidate constructorValidityMatrixDecl) : + normalization.root.normalization.generation? = + some constructorValidityMatrixGenerationChecked := by + rw [cvmCanonicalStagedPreFamilyInput.normalization_eq normalization + cvmReferenceNormalization] + have hnorm : cvmReferenceNormalization.root.normalization = + VInductDecl.Normalization.identity constructorValidityMatrixDecl := by + apply normalization_eq_of_view_eq + rfl + rw [hnorm] + rfl + +theorem cvmExactProducedGenerationCandidatePackage_exists : + Nonempty (VInductDecl.ExactProducedGenerationCandidatePackage + VEnv.empty [`u] cvmProducedGenerationShapeCandidate + constructorValidityMatrixGenerationChecked) := + cvmProducedGenerationShapeCandidate.exactProducedPackage_nonempty + cvmCanonicalStagedPreFamilyInput + (stagedPreFamily_transport_raw cvmCandidate_eq_canonical + cvmStagedPreFamilyInput).symm + constructorValidityMatrixGenerationChecked + cvmCandidate_analysis + +private noncomputable def cvmExactProducedGenerationCandidatePackage : + VInductDecl.ExactProducedGenerationCandidatePackage VEnv.empty [`u] + cvmProducedGenerationShapeCandidate + constructorValidityMatrixGenerationChecked := + Classical.choice cvmExactProducedGenerationCandidatePackage_exists + +noncomputable def cvmGenerationCandidateSemanticRun : + VInductDecl.GenerationCandidateSemanticRun + cvmExactProducedGenerationCandidatePackage.normalization + constructorValidityMatrixGenerationChecked := + cvmExactProducedGenerationCandidatePackage.semantic + +noncomputable def cvmProducedGenerationCandidatePackage : + VInductDecl.ProducedGenerationCandidatePackage VEnv.empty [`u] := + cvmExactProducedGenerationCandidatePackage.package + +def cvmGenerationCertificate : + constructorValidityMatrixDecl.GenerationCertificate VEnv.empty where + generation := constructorValidityMatrixGenerationChecked + wf := cvmExactProducedGenerationCandidatePackage.semantic.run.wf + +def cvmCertifiedFinalEnv : VEnv := + (VEnv.empty.addInductGeneration + constructorValidityMatrixGenerationChecked).get! + +theorem cvm_addInductGeneration : + VEnv.empty.addInductGeneration + constructorValidityMatrixGenerationChecked = + some cvmCertifiedFinalEnv := by + rfl + +theorem cvm_addInductCertified : + VEnv.empty.addInductCertified cvmGenerationCertificate = + some cvmCertifiedFinalEnv := + cvm_addInductGeneration + +theorem cvmGeneration_trace : + Nonempty (VEnv.AddInductGenerationTrace VEnv.empty cvmCertifiedFinalEnv + constructorValidityMatrixGenerationChecked) := + VEnv.addInductGeneration_trace cvm_addInductGeneration + +theorem cvmCertified_trace : + Nonempty (VEnv.AddInductGenerationTrace VEnv.empty cvmCertifiedFinalEnv + constructorValidityMatrixGenerationChecked) := + cvmGeneration_trace + +theorem cvmCertified_ordered : cvmCertifiedFinalEnv.Ordered := + VEnv.addInductCertified_WF .empty cvm_addInductCertified + +def prbCanonicalFamily : + AddInductive.CandidateFamily propRecursiveBoundaryKernelType where + familyType := prbCandidate.families.singleton.familyType + constructors := .cons + prbCandidate.families.singleton.constructors.singleton .nil + +def prbCanonicalCandidate : + AddInductive.NormalizationCandidate [propRecursiveBoundaryKernelType] where + families := .cons prbCanonicalFamily .nil + +theorem prbOneCtorCandidate_eta + (candidate : AddInductive.NormalizationCandidate + [propRecursiveBoundaryKernelType]) : + candidate = { + families := .cons { + familyType := candidate.families.singleton.familyType + constructors := .cons + candidate.families.singleton.constructors.singleton .nil } + .nil } := by + cases candidate with + | mk families => + cases families with + | cons family tail => + cases tail + cases family with + | mk familyType constructors => + cases constructors with + | cons constructor tail => + cases tail + rfl + +theorem prbCandidate_eq_canonical : prbCandidate = prbCanonicalCandidate := by + simpa [prbCanonicalCandidate, prbCanonicalFamily] using + prbOneCtorCandidate_eta prbCandidate + +theorem prbCanonicalCandidate_produced : + AddInductive.buildNormalizationCandidate 1 + [propRecursiveBoundaryKernelType] 0 false + propRecursiveBoundaryContext = .ok prbCanonicalCandidate := by + rw [← prbCandidate_eq_canonical] + exact prbCandidate_produced + +noncomputable abbrev prbCanonicalStagedPreFamilyInput : + VInductDecl.StagedNormalizationCandidatePreFamilyInput + prbFamilyContext prbConstructorContext VEnv.empty [`u] + prbCanonicalCandidate propRecursiveBoundaryDecl := + prbCandidate_eq_canonical ▸ prbStagedPreFamilyInput + +def prbFamilySemanticRootRun : + TypeChecker.CandidateExprSemanticRootRun VEnv.empty [`u] + prbCanonicalCandidate.families.singleton.familyType.type + propRecursiveBoundaryType.type := + prbFamilyStage.type.rootInput.semanticOfIdentity + prbFamilyIdentityEvidence.identity + +def prbCtorSemanticRootRun : + TypeChecker.CandidateExprSemanticRootRun prbTypeEnv [`u] + prbCanonicalCandidate.families.singleton.constructors.singleton.type + propRecursiveBoundaryType.ctors[0].type := + prbCtorStagedInput.type.rootInput.semanticOfIdentity + prbCtorIdentityEvidence.identity + +def prbCtorSemanticRun : + VInductDecl.CandidateConstructorSemanticRun prbTypeEnv [`u] + prbCanonicalCandidate.families.singleton.constructors.singleton + propRecursiveBoundaryType.ctors[0] where + name_eq := prbCtorNames_eq + uvars_eq := rfl + type := prbCtorSemanticRootRun + +def prbConstructorSemanticListRun : + VInductDecl.CandidateConstructorSemanticListRun prbTypeEnv [`u] + prbCanonicalCandidate.families.singleton.constructors + propRecursiveBoundaryType.ctors := + .cons prbCtorSemanticRun .nil + +def prbFamilySemanticRun : + VInductDecl.CandidateFamilySemanticRun VEnv.empty [`u] + prbCanonicalCandidate.families.singleton propRecursiveBoundaryType where + name_eq := prbFamilyNames_eq + uvars_eq := rfl + type := prbFamilySemanticRootRun + typeEnv := prbTypeEnv + addType := prbTypeEnv_add + constructors := prbConstructorSemanticListRun + +def prbReferenceNormalization : + VInductDecl.NormalizationCandidateSemanticRun VEnv.empty [`u] + prbCanonicalCandidate propRecursiveBoundaryDecl where + raw := propRecursiveBoundaryType + raw_types_eq := rfl + uvars_eq := rfl + family := prbFamilySemanticRun + +theorem prbCandidate_generationShape : + VInductDecl.normalizationCandidateGenerationShape + propRecursiveBoundaryDecl propRecursiveBoundaryType + prbCanonicalCandidate = + true := by + rw [← prbCandidate_eq_canonical] + unfold VInductDecl.normalizationCandidateGenerationShape + rw [AddInductive.CandidateList.singleton_eta + prbCandidate.families.singleton.constructors] + have familyStored := prbFamilyIdentityEvidence.identity.storedSpine + have familyLength := prbFamilyIdentityEvidence.spineLength_eq.trans + prbFamilyIdentityReplay_shape.1 + have ctorStored := prbCtorIdentityEvidence.identity.storedSpine + have ctorLength := prbCtorIdentityEvidence.spineLength_eq.trans + prbCtorIdentityReplay_shape.1 + simp [VInductDecl.candidateConstructorSemanticGenerationShape, + propRecursiveBoundaryDecl, propRecursiveBoundaryType, + VExpr.telN, VExpr.dropN, VInductDecl.ctorFields, + familyStored, familyLength, ctorStored, ctorLength] + +abbrev prbProducedGenerationShapeCandidate : + VInductDecl.ProducedGenerationShapeCandidate propRecursiveBoundaryDecl + propRecursiveBoundaryType propRecursiveBoundaryKernelType 0 false + propRecursiveBoundaryContext where + candidate := prbCanonicalCandidate + produced := prbCanonicalCandidate_produced + shape := prbCandidate_generationShape + +private theorem prbCandidate_analysis + (normalization : VInductDecl.NormalizationCandidateSemanticRun VEnv.empty + [`u] prbCanonicalCandidate propRecursiveBoundaryDecl) : + normalization.root.normalization.generation? = + some propRecursiveBoundaryGenerationChecked := by + rw [prbCanonicalStagedPreFamilyInput.normalization_eq normalization + prbReferenceNormalization] + have hnorm : prbReferenceNormalization.root.normalization = + VInductDecl.Normalization.identity propRecursiveBoundaryDecl := by + apply normalization_eq_of_view_eq + rfl + rw [hnorm] + rfl + +theorem prbExactProducedGenerationCandidatePackage_exists : + Nonempty (VInductDecl.ExactProducedGenerationCandidatePackage + VEnv.empty [`u] prbProducedGenerationShapeCandidate + propRecursiveBoundaryGenerationChecked) := + prbProducedGenerationShapeCandidate.exactProducedPackage_nonempty + prbCanonicalStagedPreFamilyInput + (stagedPreFamily_transport_raw prbCandidate_eq_canonical + prbStagedPreFamilyInput).symm propRecursiveBoundaryGenerationChecked + prbCandidate_analysis + +private noncomputable def prbExactProducedGenerationCandidatePackage : + VInductDecl.ExactProducedGenerationCandidatePackage VEnv.empty [`u] + prbProducedGenerationShapeCandidate + propRecursiveBoundaryGenerationChecked := + Classical.choice prbExactProducedGenerationCandidatePackage_exists + +noncomputable def prbGenerationCandidateSemanticRun : + VInductDecl.GenerationCandidateSemanticRun + prbExactProducedGenerationCandidatePackage.normalization + propRecursiveBoundaryGenerationChecked := + prbExactProducedGenerationCandidatePackage.semantic + +noncomputable def prbProducedGenerationCandidatePackage : + VInductDecl.ProducedGenerationCandidatePackage VEnv.empty [`u] := + prbExactProducedGenerationCandidatePackage.package + +def prbGenerationCertificate : + propRecursiveBoundaryDecl.GenerationCertificate VEnv.empty where + generation := propRecursiveBoundaryGenerationChecked + wf := prbExactProducedGenerationCandidatePackage.semantic.run.wf + +def prbCertifiedFinalEnv : VEnv := + (VEnv.empty.addInductGeneration propRecursiveBoundaryGenerationChecked).get! + +theorem prb_addInductGeneration : + VEnv.empty.addInductGeneration propRecursiveBoundaryGenerationChecked = + some prbCertifiedFinalEnv := by + rfl + +theorem prb_addInductCertified : + VEnv.empty.addInductCertified prbGenerationCertificate = + some prbCertifiedFinalEnv := + prb_addInductGeneration + +theorem prbGeneration_trace : + Nonempty (VEnv.AddInductGenerationTrace VEnv.empty prbCertifiedFinalEnv + propRecursiveBoundaryGenerationChecked) := + VEnv.addInductGeneration_trace prb_addInductGeneration + +theorem prbCertified_trace : + Nonempty (VEnv.AddInductGenerationTrace VEnv.empty prbCertifiedFinalEnv + propRecursiveBoundaryGenerationChecked) := + prbGeneration_trace + +theorem prbCertified_ordered : prbCertifiedFinalEnv.Ordered := + VEnv.addInductCertified_WF .empty prb_addInductCertified + +/-! ## Actual kernel-metadata replay -/ + +def cvmReplayCtorEnv : VEnv := + (cvmTypeEnv.addConst constructorValidityMatrixType.ctors[0].name + constructorValidityMatrixType.ctors[0].toVConstant).get! + +def cvmReplayRecEnv : VEnv := + (cvmReplayCtorEnv.addConst ``ConstructorValidityMatrix.rec + constructorValidityMatrixGenerationChecked.recursor).get! + +theorem cvmRawCtor_wf : + constructorValidityMatrixType.ctors[0].toVConstant.WF cvmTypeEnv := + cvmRawCtor_isType + +theorem cvmReplayCtorEnv_ordered : cvmReplayCtorEnv.Ordered := + .const (n := constructorValidityMatrixType.ctors[0].name) + (ci := constructorValidityMatrixType.ctors[0].toVConstant) + cvmTypeEnv_ordered cvmRawCtor_wf rfl + +theorem cvmGenerationEnv : + VInductDecl.GenerationEnv constructorValidityMatrixGenerationChecked + cvmReplayCtorEnv := by + apply cvmGenerationCertificate.wf.toGenerationEnv (envT := cvmTypeEnv) + · rfl + · exact (VEnv.addConst_le cvmTypeEnv_add).trans + (VEnv.addConst_le (show + cvmTypeEnv.addConst constructorValidityMatrixType.ctors[0].name + constructorValidityMatrixType.ctors[0].toVConstant = + some cvmReplayCtorEnv from rfl)) + · exact VEnv.addConst_le (show + cvmTypeEnv.addConst constructorValidityMatrixType.ctors[0].name + constructorValidityMatrixType.ctors[0].toVConstant = + some cvmReplayCtorEnv from rfl) + · exact cvmReplayCtorEnv_ordered + · rfl + · intro ctor hctor + change ctor ∈ + [⟨constructorValidityMatrixType.ctors[0], + constructorValidityMatrixChecked.constructors[0]⟩] at hctor + obtain rfl := List.mem_singleton.1 hctor + rfl + +theorem cvmInfo_tr : + TrConstVal .safe VEnv.empty constructorValidityMatrixInfo + constructorValidityMatrixType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr VEnv.empty + constructorValidityMatrixInfo.levelParams [] + constructorValidityMatrixInfo.type + constructorValidityMatrixType.type := by + tr_type_expr_tac + obtain ⟨u, htype⟩ := cvmRawFamily_isType + exact hshape.to_trExprS .empty trivial ⟨.sort u, htype⟩ + +theorem cvmMkInfo_tr : + TrConstVal .safe cvmTypeEnv constructorValidityMatrixMkInfo + constructorValidityMatrixType.ctors[0] := by + exact ⟨⟨by decide, rfl, cvmCtorSource_tr⟩, rfl⟩ + +theorem cvmRecInfo_tr : + TrConstVal .safe cvmReplayCtorEnv constructorValidityMatrixRecInfo + (inductGenerationRecVal constructorValidityMatrixGenerationChecked) := by + have hfamily : cvmReplayCtorEnv.constants + ``ConstructorValidityMatrix = + some constructorValidityMatrixType.toVConstant := rfl + have hmk : cvmReplayCtorEnv.constants + ``ConstructorValidityMatrix.mk = + some constructorValidityMatrixType.ctors[0].toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr cvmReplayCtorEnv + constructorValidityMatrixRecInfo.levelParams [] + constructorValidityMatrixRecInfo.type + (inductGenerationRecVal + constructorValidityMatrixGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨u, hrec⟩ := cvmGenerationEnv.recursor_wf + exact hshape.to_trExprS cvmReplayCtorEnv_ordered trivial + ⟨.sort u, hrec⟩ + +def cvmReplayTypeMap : ConstMap := + ({} : ConstMap).insert constructorValidityMatrixType.name + constructorValidityMatrixInfo + +def cvmReplayCtorMap : ConstMap := + cvmReplayTypeMap.insert constructorValidityMatrixType.ctors[0].name + constructorValidityMatrixMkInfo + +def cvmReplayMap : ConstMap := + cvmReplayCtorMap.insert ``ConstructorValidityMatrix.rec + constructorValidityMatrixRecInfo + +theorem cvmReplayType_fresh : + ({} : ConstMap).find? constructorValidityMatrixType.name = none := by + simp [SMap.find?] + +theorem cvmReplayTypeMap_wf : cvmReplayTypeMap.WF := + SMap.WF.empty.insert _ _ cvmReplayType_fresh + +theorem cvmReplayMk_fresh : + cvmReplayTypeMap.find? constructorValidityMatrixType.ctors[0].name = + none := by + rw [cvmReplayTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [constructorValidityMatrixType, SMap.find?] + +theorem cvmReplayCtorMap_wf : cvmReplayCtorMap.WF := + cvmReplayTypeMap_wf.insert _ _ cvmReplayMk_fresh + +theorem cvmReplayRec_fresh : + cvmReplayCtorMap.find? ``ConstructorValidityMatrix.rec = none := by + rw [cvmReplayCtorMap, cvmReplayTypeMap_wf.find?_insert, + cvmReplayTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [constructorValidityMatrixType, SMap.find?] + +noncomputable def cvmAddInductTraceChecked : + AddInductTrace ({} : ConstMap) VEnv.empty constructorValidityMatrixDecl + cvmReplayMap cvmCertifiedFinalEnv := by + refine cvmProducedGenerationCandidatePackage.package.addInductTrace + cvmReplayTypeMap cvmTypeEnv cvmReplayCtorMap cvmReplayCtorEnv + cvmReplayRecEnv ?_ ?_ ?_ ?_ ⟨rfl⟩ + · exact { + info := constructorValidityMatrixInfo + kind_eq := by + simp [constructorValidityMatrixInfo, InductConstantKind.Matches] + tr := cvmInfo_tr + map_fresh := cvmReplayType_fresh + env_add := cvmTypeEnv_add + map_add := rfl } + · exact .cons { + info := constructorValidityMatrixMkInfo + kind_eq := by + simp [constructorValidityMatrixMkInfo, InductConstantKind.Matches] + tr := cvmMkInfo_tr + map_fresh := by + simpa [constructorValidityMatrixType] using cvmReplayMk_fresh + env_add := rfl + map_add := rfl } .nil + · exact { + info := constructorValidityMatrixRecInfo + kind_eq := by + simp [constructorValidityMatrixRecInfo, InductConstantKind.Matches] + tr := cvmRecInfo_tr + map_fresh := by + rw [show + (inductGenerationRecVal + cvmProducedGenerationCandidatePackage.package.generation).name = + ``ConstructorValidityMatrix.rec by rfl] + exact cvmReplayRec_fresh + env_add := rfl + map_add := rfl } + · decide + +theorem cvm_addInduct_checked : + AddInduct ({} : ConstMap) VEnv.empty constructorValidityMatrixDecl + cvmReplayMap cvmCertifiedFinalEnv := + ⟨cvmAddInductTraceChecked⟩ + +theorem cvm_trEnv'_checked : + TrEnv' .safe cvmReplayMap false cvmCertifiedFinalEnv := + .induct cvm_addInduct_checked .empty + +theorem cvm_env_wf_checked : cvmCertifiedFinalEnv.WF := + cvm_trEnv'_checked.wf + +theorem cvm_aligned_checked : + Aligned .safe cvmReplayMap cvmCertifiedFinalEnv := + cvm_trEnv'_checked.aligned + +theorem cvmReplay_type_map_lookup : + cvmReplayMap.find? constructorValidityMatrixType.name = + some constructorValidityMatrixInfo := by + rw [cvmReplayMap, cvmReplayCtorMap_wf.find?_insert, + cvmReplayCtorMap, cvmReplayTypeMap_wf.find?_insert, + cvmReplayTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [constructorValidityMatrixType] + +theorem cvmReplay_ctor_map_lookup : + cvmReplayMap.find? constructorValidityMatrixType.ctors[0].name = + some constructorValidityMatrixMkInfo := by + rw [cvmReplayMap, cvmReplayCtorMap_wf.find?_insert, + cvmReplayCtorMap, cvmReplayTypeMap_wf.find?_insert] + simp [constructorValidityMatrixType] + +theorem cvmReplay_rec_map_lookup : + cvmReplayMap.find? ``ConstructorValidityMatrix.rec = + some constructorValidityMatrixRecInfo := by + rw [cvmReplayMap, cvmReplayCtorMap_wf.find?_insert] + simp + +theorem cvmFinalEnv_type_lookup : + cvmCertifiedFinalEnv.constants constructorValidityMatrixType.name = + some constructorValidityMatrixType.toVConstant := by + rcases cvmCertified_trace with ⟨trace⟩ + exact trace.family_lookup + +theorem cvmFinalEnv_ctor_lookup : + cvmCertifiedFinalEnv.constants + constructorValidityMatrixType.ctors[0].name = + some constructorValidityMatrixType.ctors[0].toVConstant := by + rcases cvmCertified_trace with ⟨trace⟩ + exact trace.ctor_lookup (.head _) + +theorem cvmFinalEnv_rec_lookup : + cvmCertifiedFinalEnv.constants ``ConstructorValidityMatrix.rec = + some constructorValidityMatrixGenerationChecked.recursor := by + rcases cvmCertified_trace with ⟨trace⟩ + exact trace.rec_lookup + +theorem cvmReplay_type_lookup_unique : + constructorValidityMatrixInfo.name = + constructorValidityMatrixType.name ∧ + TrConstant .safe cvmCertifiedFinalEnv constructorValidityMatrixInfo + constructorValidityMatrixType.toVConstant := + cvm_aligned_checked.find?_uniq cvmReplay_type_map_lookup + cvmFinalEnv_type_lookup + +theorem cvmReplay_ctor_lookup_unique : + constructorValidityMatrixMkInfo.name = + constructorValidityMatrixType.ctors[0].name ∧ + TrConstant .safe cvmCertifiedFinalEnv constructorValidityMatrixMkInfo + constructorValidityMatrixType.ctors[0].toVConstant := + cvm_aligned_checked.find?_uniq cvmReplay_ctor_map_lookup + cvmFinalEnv_ctor_lookup + +theorem cvmReplay_rec_lookup_unique : + constructorValidityMatrixRecInfo.name = + ``ConstructorValidityMatrix.rec ∧ + TrConstant .safe cvmCertifiedFinalEnv constructorValidityMatrixRecInfo + constructorValidityMatrixGenerationChecked.recursor := + cvm_aligned_checked.find?_uniq cvmReplay_rec_map_lookup + cvmFinalEnv_rec_lookup + +theorem cvmFinalEnv_rule_mem : + ∀ df ∈ constructorValidityMatrixGenerationChecked.generatedRules, + cvmCertifiedFinalEnv.defeqs df := by + intro df hdf + rcases cvmCertified_trace with ⟨trace⟩ + exact trace.rule_mem hdf + +theorem cvmFinalEnv_iota_mem : + cvmCertifiedFinalEnv.defeqs + constructorValidityMatrixGenerationChecked.generatedRules[0] := by + apply cvmFinalEnv_rule_mem + exact .head _ + +def prbReplayCtorEnv : VEnv := + (prbTypeEnv.addConst propRecursiveBoundaryType.ctors[0].name + propRecursiveBoundaryType.ctors[0].toVConstant).get! + +def prbReplayRecEnv : VEnv := + (prbReplayCtorEnv.addConst ``PropRecursiveBoundary.rec + propRecursiveBoundaryGenerationChecked.recursor).get! + +theorem prbRawCtor_wf : + propRecursiveBoundaryType.ctors[0].toVConstant.WF prbTypeEnv := + prbRawCtor_isType + +theorem prbReplayCtorEnv_ordered : prbReplayCtorEnv.Ordered := + .const (n := propRecursiveBoundaryType.ctors[0].name) + (ci := propRecursiveBoundaryType.ctors[0].toVConstant) + prbTypeEnv_ordered prbRawCtor_wf rfl + +theorem prbGenerationEnv : + VInductDecl.GenerationEnv propRecursiveBoundaryGenerationChecked + prbReplayCtorEnv := by + apply prbGenerationCertificate.wf.toGenerationEnv (envT := prbTypeEnv) + · rfl + · exact (VEnv.addConst_le prbTypeEnv_add).trans + (VEnv.addConst_le (show + prbTypeEnv.addConst propRecursiveBoundaryType.ctors[0].name + propRecursiveBoundaryType.ctors[0].toVConstant = + some prbReplayCtorEnv from rfl)) + · exact VEnv.addConst_le (show + prbTypeEnv.addConst propRecursiveBoundaryType.ctors[0].name + propRecursiveBoundaryType.ctors[0].toVConstant = + some prbReplayCtorEnv from rfl) + · exact prbReplayCtorEnv_ordered + · rfl + · intro ctor hctor + change ctor ∈ + [⟨propRecursiveBoundaryType.ctors[0], + propRecursiveBoundaryChecked.constructors[0]⟩] at hctor + obtain rfl := List.mem_singleton.1 hctor + rfl + +theorem prbInfo_tr : + TrConstVal .safe VEnv.empty propRecursiveBoundaryInfo + propRecursiveBoundaryType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr VEnv.empty + propRecursiveBoundaryInfo.levelParams [] + propRecursiveBoundaryInfo.type propRecursiveBoundaryType.type := by + tr_type_expr_tac + obtain ⟨u, htype⟩ := prbRawFamily_isType + exact hshape.to_trExprS .empty trivial ⟨.sort u, htype⟩ + +theorem prbMkInfo_tr : + TrConstVal .safe prbTypeEnv propRecursiveBoundaryMkInfo + propRecursiveBoundaryType.ctors[0] := by + exact ⟨⟨by decide, rfl, prbCtorSource_tr⟩, rfl⟩ + +theorem prbRecInfo_tr : + TrConstVal .safe prbReplayCtorEnv propRecursiveBoundaryRecInfo + (inductGenerationRecVal propRecursiveBoundaryGenerationChecked) := by + have hfamily : prbReplayCtorEnv.constants ``PropRecursiveBoundary = + some propRecursiveBoundaryType.toVConstant := rfl + have hmk : prbReplayCtorEnv.constants ``PropRecursiveBoundary.mk = + some propRecursiveBoundaryType.ctors[0].toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr prbReplayCtorEnv + propRecursiveBoundaryRecInfo.levelParams [] + propRecursiveBoundaryRecInfo.type + (inductGenerationRecVal propRecursiveBoundaryGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨u, hrec⟩ := prbGenerationEnv.recursor_wf + exact hshape.to_trExprS prbReplayCtorEnv_ordered trivial + ⟨.sort u, hrec⟩ + +def prbReplayTypeMap : ConstMap := + ({} : ConstMap).insert propRecursiveBoundaryType.name + propRecursiveBoundaryInfo + +def prbReplayCtorMap : ConstMap := + prbReplayTypeMap.insert propRecursiveBoundaryType.ctors[0].name + propRecursiveBoundaryMkInfo + +def prbReplayMap : ConstMap := + prbReplayCtorMap.insert ``PropRecursiveBoundary.rec + propRecursiveBoundaryRecInfo + +theorem prbReplayType_fresh : + ({} : ConstMap).find? propRecursiveBoundaryType.name = none := by + simp [SMap.find?] + +theorem prbReplayTypeMap_wf : prbReplayTypeMap.WF := + SMap.WF.empty.insert _ _ prbReplayType_fresh + +theorem prbReplayMk_fresh : + prbReplayTypeMap.find? propRecursiveBoundaryType.ctors[0].name = + none := by + rw [prbReplayTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [propRecursiveBoundaryType, SMap.find?] + +theorem prbReplayCtorMap_wf : prbReplayCtorMap.WF := + prbReplayTypeMap_wf.insert _ _ prbReplayMk_fresh + +theorem prbReplayRec_fresh : + prbReplayCtorMap.find? ``PropRecursiveBoundary.rec = none := by + rw [prbReplayCtorMap, prbReplayTypeMap_wf.find?_insert, + prbReplayTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [propRecursiveBoundaryType, SMap.find?] + +noncomputable def prbAddInductTraceChecked : + AddInductTrace ({} : ConstMap) VEnv.empty propRecursiveBoundaryDecl + prbReplayMap prbCertifiedFinalEnv := by + refine prbProducedGenerationCandidatePackage.package.addInductTrace + prbReplayTypeMap prbTypeEnv prbReplayCtorMap prbReplayCtorEnv + prbReplayRecEnv ?_ ?_ ?_ ?_ ⟨rfl⟩ + · exact { + info := propRecursiveBoundaryInfo + kind_eq := by + simp [propRecursiveBoundaryInfo, InductConstantKind.Matches] + tr := prbInfo_tr + map_fresh := prbReplayType_fresh + env_add := prbTypeEnv_add + map_add := rfl } + · exact .cons { + info := propRecursiveBoundaryMkInfo + kind_eq := by + simp [propRecursiveBoundaryMkInfo, InductConstantKind.Matches] + tr := prbMkInfo_tr + map_fresh := by + simpa [propRecursiveBoundaryType] using prbReplayMk_fresh + env_add := rfl + map_add := rfl } .nil + · exact { + info := propRecursiveBoundaryRecInfo + kind_eq := by + simp [propRecursiveBoundaryRecInfo, InductConstantKind.Matches] + tr := prbRecInfo_tr + map_fresh := by + rw [show + (inductGenerationRecVal + prbProducedGenerationCandidatePackage.package.generation).name = + ``PropRecursiveBoundary.rec by rfl] + exact prbReplayRec_fresh + env_add := rfl + map_add := rfl } + · decide + +theorem prb_addInduct_checked : + AddInduct ({} : ConstMap) VEnv.empty propRecursiveBoundaryDecl + prbReplayMap prbCertifiedFinalEnv := + ⟨prbAddInductTraceChecked⟩ + +theorem prb_trEnv'_checked : + TrEnv' .safe prbReplayMap false prbCertifiedFinalEnv := + .induct prb_addInduct_checked .empty + +theorem prb_env_wf_checked : prbCertifiedFinalEnv.WF := + prb_trEnv'_checked.wf + +theorem prb_aligned_checked : + Aligned .safe prbReplayMap prbCertifiedFinalEnv := + prb_trEnv'_checked.aligned + +theorem prbReplay_type_map_lookup : + prbReplayMap.find? propRecursiveBoundaryType.name = + some propRecursiveBoundaryInfo := by + rw [prbReplayMap, prbReplayCtorMap_wf.find?_insert, + prbReplayCtorMap, prbReplayTypeMap_wf.find?_insert, + prbReplayTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [propRecursiveBoundaryType] + +theorem prbReplay_ctor_map_lookup : + prbReplayMap.find? propRecursiveBoundaryType.ctors[0].name = + some propRecursiveBoundaryMkInfo := by + rw [prbReplayMap, prbReplayCtorMap_wf.find?_insert, + prbReplayCtorMap, prbReplayTypeMap_wf.find?_insert] + simp [propRecursiveBoundaryType] + +theorem prbReplay_rec_map_lookup : + prbReplayMap.find? ``PropRecursiveBoundary.rec = + some propRecursiveBoundaryRecInfo := by + rw [prbReplayMap, prbReplayCtorMap_wf.find?_insert] + simp + +theorem prbFinalEnv_type_lookup : + prbCertifiedFinalEnv.constants propRecursiveBoundaryType.name = + some propRecursiveBoundaryType.toVConstant := by + rcases prbCertified_trace with ⟨trace⟩ + exact trace.family_lookup + +theorem prbFinalEnv_ctor_lookup : + prbCertifiedFinalEnv.constants propRecursiveBoundaryType.ctors[0].name = + some propRecursiveBoundaryType.ctors[0].toVConstant := by + rcases prbCertified_trace with ⟨trace⟩ + exact trace.ctor_lookup (.head _) + +theorem prbFinalEnv_rec_lookup : + prbCertifiedFinalEnv.constants ``PropRecursiveBoundary.rec = + some propRecursiveBoundaryGenerationChecked.recursor := by + rcases prbCertified_trace with ⟨trace⟩ + exact trace.rec_lookup + +theorem prbReplay_type_lookup_unique : + propRecursiveBoundaryInfo.name = propRecursiveBoundaryType.name ∧ + TrConstant .safe prbCertifiedFinalEnv propRecursiveBoundaryInfo + propRecursiveBoundaryType.toVConstant := + prb_aligned_checked.find?_uniq prbReplay_type_map_lookup + prbFinalEnv_type_lookup + +theorem prbReplay_ctor_lookup_unique : + propRecursiveBoundaryMkInfo.name = + propRecursiveBoundaryType.ctors[0].name ∧ + TrConstant .safe prbCertifiedFinalEnv propRecursiveBoundaryMkInfo + propRecursiveBoundaryType.ctors[0].toVConstant := + prb_aligned_checked.find?_uniq prbReplay_ctor_map_lookup + prbFinalEnv_ctor_lookup + +theorem prbReplay_rec_lookup_unique : + propRecursiveBoundaryRecInfo.name = ``PropRecursiveBoundary.rec ∧ + TrConstant .safe prbCertifiedFinalEnv propRecursiveBoundaryRecInfo + propRecursiveBoundaryGenerationChecked.recursor := + prb_aligned_checked.find?_uniq prbReplay_rec_map_lookup + prbFinalEnv_rec_lookup + +theorem prbFinalEnv_rule_mem : + ∀ df ∈ propRecursiveBoundaryGenerationChecked.generatedRules, + prbCertifiedFinalEnv.defeqs df := by + intro df hdf + rcases prbCertified_trace with ⟨trace⟩ + exact trace.rule_mem hdf + +theorem prbFinalEnv_iota_mem : + prbCertifiedFinalEnv.defeqs + propRecursiveBoundaryGenerationChecked.generatedRules[0] := by + apply prbFinalEnv_rule_mem + exact .head _ + +end Lean4Lean.InductiveReplayFixtures diff --git a/Lean4Lean/Verify/Environment/Elimination.lean b/Lean4Lean/Verify/Environment/Elimination.lean new file mode 100644 index 00000000..6f027e77 --- /dev/null +++ b/Lean4Lean/Verify/Environment/Elimination.lean @@ -0,0 +1,249 @@ +import Lean4Lean.Inductive.EliminationTrace +import Lean4Lean.Theory.Inductive + +namespace Lean4Lean +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 + +/-- Lightweight alignment for an exact `getElimLevel` execution when the +normalization statistics are already pinned independently. This is useful for +the never-zero branch, which returns before inspecting any constructor. -/ +structure CheckerElimLevelRun + {source : VInductDecl} (generation : VInductDecl.GenerationChecked source) + {stats : InductiveStats} {indTypes : Array InductiveType} + {context : Context} + (execution : ElimLevelExecution stats indTypes context) : Type where + sourceUvars_eq : source.uvars = context.lparams.length + mode_eq : generation.elimination = + checkerElimMode execution.large.result + recUvars_eq : generation.recUvars = + (getRecLevelParams execution.level context.lparams).length + recLevels_eq : + (getRecLevels execution.level stats.levels).mapM + (VLevel.ofLevel (getRecLevelParams execution.level context.lparams)) = + some generation.recLevels + +namespace CheckerElimLevelRun + +/-- Decide the complete mode and level-layout alignment from the retained +ordinary execution. -/ +def build? + {source : VInductDecl} (generation : VInductDecl.GenerationChecked source) + {stats : InductiveStats} {indTypes : Array InductiveType} + {context : Context} + (execution : ElimLevelExecution stats indTypes context) : + Option (CheckerElimLevelRun generation execution) := do + if huvars : source.uvars = context.lparams.length then + if hmode : generation.elimination = + checkerElimMode execution.large.result then + if hrecUvars : generation.recUvars = + (getRecLevelParams execution.level context.lparams).length then + if hlevels : + (getRecLevels execution.level stats.levels).mapM + (VLevel.ofLevel + (getRecLevelParams execution.level context.lparams)) = + some generation.recLevels then + some { + sourceUvars_eq := huvars + mode_eq := hmode + recUvars_eq := hrecUvars + recLevels_eq := hlevels } + else none + else none + else none + else none + +theorem large_result_iff + (run : CheckerElimLevelRun generation execution) : + execution.large.result = true ↔ + generation.elimination = VInductDecl.ElimMode.large := by + cases hresult : execution.large.result with + | false => + have hmode : generation.elimination = VInductDecl.ElimMode.small := by + simpa [checkerElimMode, hresult] using run.mode_eq + simp [hmode] + | true => + have hmode : generation.elimination = VInductDecl.ElimMode.large := by + simpa [checkerElimMode, hresult] using run.mode_eq + simp [hmode] + +theorem small_result_iff + (run : CheckerElimLevelRun generation execution) : + execution.large.result = false ↔ + generation.elimination = VInductDecl.ElimMode.small := by + cases hresult : execution.large.result with + | false => + have hmode : generation.elimination = VInductDecl.ElimMode.small := by + simpa [checkerElimMode, hresult] using run.mode_eq + simp [hmode] + | true => + have hmode : generation.elimination = VInductDecl.ElimMode.large := by + simpa [checkerElimMode, hresult] using run.mode_eq + simp [hmode] + +end CheckerElimLevelRun + +/-- Exact alignment between the ordinary K-target execution and the Boolean +retained by Theory generation. This flag is certified independently of the +elimination-mode decision. -/ +structure CheckerKTargetRun + {source : VInductDecl} (generation : VInductDecl.GenerationChecked source) + {stats : InductiveStats} {indTypes : Array InductiveType} + {context : Context} + (execution : KTargetExecution stats indTypes context) : Type where + result_eq : generation.kTarget = execution.result + +namespace CheckerKTargetRun + +def build? + {source : VInductDecl} (generation : VInductDecl.GenerationChecked source) + {stats : InductiveStats} {indTypes : Array InductiveType} + {context : Context} + (execution : KTargetExecution stats indTypes context) : + Option (CheckerKTargetRun generation execution) := + if h : generation.kTarget = execution.result then + some ⟨h⟩ + else + none + +theorem result_true_iff + (run : CheckerKTargetRun generation execution) : + execution.result = true ↔ generation.kTarget = true := by + rw [run.result_eq] + +theorem result_false_iff + (run : CheckerKTargetRun generation execution) : + execution.result = false ↔ generation.kTarget = false := by + rw [run.result_eq] + +end CheckerKTargetRun + +/-- Executable alignment between an exact ordinary elimination run and the +mode/K-target/universe layout consumed by one Theory generation artifact. + +The operational side owns the real `ensureType` observations, selected fresh +level name, K-target decision, recursive-call levels, and stored metadata +parameter order. The equations below are checked data, so a Theory generation +whose mode, K flag, or numeric universe layout disagrees with that run cannot +inhabit this record. -/ +structure CheckerEliminationRun + {source : VInductDecl} (generation : VInductDecl.GenerationChecked source) + {nparams : Nat} {types : List InductiveType} + {numNested : Nat} {isUnsafe : Bool} {candidateContext : Context} + (execution : NormalizationEliminationExecution nparams types numNested + isUnsafe candidateContext) : Type where + nparams_eq : nparams = source.nparams + sourceUvars_eq : source.uvars = + execution.normalization.validationContext.lparams.length + mode_eq : generation.elimination = + checkerElimMode execution.elimination.large.result + kTarget_eq : generation.kTarget = execution.kTarget.result + recUvars_eq : generation.recUvars = execution.recLevelParams.length + recLevels_eq : execution.recLevels.mapM + (VLevel.ofLevel execution.recLevelParams) = some generation.recLevels + +namespace CheckerEliminationRun + +/-- Build the alignment by deciding every equality rather than asking a +fixture or caller to supply a mode or level permutation. -/ +def build? + {source : VInductDecl} (generation : VInductDecl.GenerationChecked source) + {nparams : Nat} {types : List InductiveType} + {numNested : Nat} {isUnsafe : Bool} {candidateContext : Context} + (execution : NormalizationEliminationExecution nparams types numNested + isUnsafe candidateContext) : + Option (CheckerEliminationRun generation execution) := do + if hparams : nparams = source.nparams then + if huvars : source.uvars = + execution.normalization.validationContext.lparams.length then + if hmode : generation.elimination = + checkerElimMode execution.elimination.large.result then + if hkTarget : generation.kTarget = execution.kTarget.result then + if hrecUvars : generation.recUvars = + execution.recLevelParams.length then + if hlevels : execution.recLevels.mapM + (VLevel.ofLevel execution.recLevelParams) = + some generation.recLevels then + some { + nparams_eq := hparams + sourceUvars_eq := huvars + mode_eq := hmode + kTarget_eq := hkTarget + recUvars_eq := hrecUvars + recLevels_eq := hlevels } + else none + else none + else none + else none + else none + else none + +theorem large_result_iff + (run : CheckerEliminationRun generation execution) : + execution.elimination.large.result = true ↔ + generation.elimination = VInductDecl.ElimMode.large := by + cases hresult : execution.elimination.large.result with + | false => + have hmode : generation.elimination = VInductDecl.ElimMode.small := by + simpa [checkerElimMode, hresult] using run.mode_eq + simp [hmode] + | true => + have hmode : generation.elimination = VInductDecl.ElimMode.large := by + simpa [checkerElimMode, hresult] using run.mode_eq + simp [hmode] + +theorem small_result_iff + (run : CheckerEliminationRun generation execution) : + execution.elimination.large.result = false ↔ + generation.elimination = VInductDecl.ElimMode.small := by + cases hresult : execution.elimination.large.result with + | false => + have hmode : generation.elimination = VInductDecl.ElimMode.small := by + simpa [checkerElimMode, hresult] using run.mode_eq + simp [hmode] + | true => + have hmode : generation.elimination = VInductDecl.ElimMode.large := by + simpa [checkerElimMode, hresult] using run.mode_eq + simp [hmode] + +theorem kTarget_result_true_iff + (run : CheckerEliminationRun generation execution) : + execution.kTarget.result = true ↔ generation.kTarget = true := by + rw [run.kTarget_eq] + +theorem kTarget_result_false_iff + (run : CheckerEliminationRun generation execution) : + execution.kTarget.result = false ↔ generation.kTarget = false := by + rw [run.kTarget_eq] + +end CheckerEliminationRun + +/-- +info: 'Lean4Lean.AddInductive.CheckerEliminationRun.large_result_iff' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms CheckerEliminationRun.large_result_iff + +/-- +info: 'Lean4Lean.AddInductive.CheckerElimLevelRun.large_result_iff' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms CheckerElimLevelRun.large_result_iff + +/-- +info: 'Lean4Lean.AddInductive.CheckerKTargetRun.result_true_iff' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms CheckerKTargetRun.result_true_iff + +end AddInductive +end Lean4Lean diff --git a/Lean4Lean/Verify/Environment/EliminationFixtures.lean b/Lean4Lean/Verify/Environment/EliminationFixtures.lean new file mode 100644 index 00000000..880f5959 --- /dev/null +++ b/Lean4Lean/Verify/Environment/EliminationFixtures.lean @@ -0,0 +1,11 @@ +import Lean4Lean.Verify.Environment.SingletonParityReplay +import Lean4Lean.Verify.Environment.EliminationFixturesSmall + +/-! +Public singleton-inductive verification umbrella. + +`SingletonParityReplay` is the sole L4L-07 path for the fixed positive, +normalization, rejection, kernel-metadata, and environment-replay matrices. +The small synthetic elimination boundary cases remain alongside it because +they are not standard-library singleton declarations. +-/ diff --git a/Lean4Lean/Verify/Environment/EliminationFixturesCommon.lean b/Lean4Lean/Verify/Environment/EliminationFixturesCommon.lean new file mode 100644 index 00000000..4c71cd14 --- /dev/null +++ b/Lean4Lean/Verify/Environment/EliminationFixturesCommon.lean @@ -0,0 +1,59 @@ +import Lean4Lean.Verify.Environment.Elimination +import Lean4Lean.Verify.Environment.InductiveFixtures + +namespace Lean4Lean.InductiveReplayFixtures +open Lean Meta Elab Term +open Lean4Lean.InductiveFixtures + +universe u + +/-- A source-universe-bearing small eliminator. Or has no source universes, +so this fixture distinguishes "no fresh level" from "no levels at all". -/ +inductive L4L06SmallSource (α : Sort u) : Prop where + | left : L4L06SmallSource α + | right : L4L06SmallSource α + +def recursorShape06 (info : ConstantInfo) : + List Name × Nat × Nat × Nat × Nat × Bool × List (Name × Nat) := + match info with + | .recInfo rec => + (rec.levelParams, rec.numParams, rec.numIndices, rec.numMotives, + rec.numMinors, rec.k, + rec.rules.map fun rule => (rule.ctor, rule.nfields)) + | _ => ([], 0, 0, 0, 0, false, []) + +def l4l06KernelEnv : Kernel.Environment := + Kernel.Environment.ofConstants `_l4l06 {} + +def l4l06Context (lparams : List Name) : AddInductive.Context where + env := l4l06KernelEnv + lparams := lparams + safety := .safe + allowPrimitive := false + +example : AddInductive.getFreshElimParam [] = `u := by native_decide +example : AddInductive.getFreshElimParam [`u] = `u_1 := by native_decide +example : AddInductive.getFreshElimParam [`u, `u_1] = `u_2 := by native_decide + +/-- Decidable structural equality for the exact kernel level lists retained by +the fixtures. `Lean.Level` intentionally has no `DecidableEq` instance. -/ +def levelListStructEq06 : List Level → List Level → Bool + | [], [] => true + | u :: us, v :: vs => + Level.isStructEq u v && levelListStructEq06 us vs + | _, _ => false + +theorem levelListStructEq06_eq {us vs : List Level} + (h : levelListStructEq06 us vs) : us = vs := by + induction us generalizing vs with + | nil => cases vs <;> simp_all [levelListStructEq06] + | cons u us ih => + cases vs with + | nil => simp [levelListStructEq06] at h + | cons v vs => + simp only [levelListStructEq06, Bool.and_eq_true] at h + cases Level.isStructEq_eq h.1 + cases ih h.2 + rfl + +end Lean4Lean.InductiveReplayFixtures diff --git a/Lean4Lean/Verify/Environment/EliminationFixturesEdges.lean b/Lean4Lean/Verify/Environment/EliminationFixturesEdges.lean new file mode 100644 index 00000000..2cbdd647 --- /dev/null +++ b/Lean4Lean/Verify/Environment/EliminationFixturesEdges.lean @@ -0,0 +1,241 @@ +import Lean4Lean.Verify.Environment.EliminationFixturesCommon + +/-! Exact L4L-06C `Unit`/`PUnit` and `Empty` edge-shape fixtures. + +`Unit` is a reducible alias for `PUnit` on this Lean revision. The alias has +definition metadata but no independent inductive/constructor/recursor records, +so the real one-constructor transaction is checked under `PUnit`. `Empty` +supplies the matching zero-constructor transaction. -/ + +namespace Lean4Lean.InductiveReplayFixtures +open Lean Meta Elab Term +open Lean4Lean.InductiveFixtures + +/-- Translate the declaration-first universe order produced by `vconst` to +the fresh-first order stored by large recursor metadata. -/ +private def permC06C (constant : VConstant) (levels : List VLevel) : + VConstant := + ⟨constant.uvars, constant.type.instL levels⟩ + +/-! ## Unit is exactly the reducible PUnit alias -/ + +def unitAliasInfo06C : DefinitionVal := kernelDefVal% Unit + +/-- Pin every field of the actual `Unit` definition metadata. In particular, +there is no fabricated alias-level recursor for the edge fixture. -/ +example : + (unitAliasInfo06C.name, unitAliasInfo06C.levelParams, + unitAliasInfo06C.type, unitAliasInfo06C.value, + unitAliasInfo06C.hints, unitAliasInfo06C.safety, + unitAliasInfo06C.all) = + (``Unit, [], .sort (.succ .zero), + .const ``PUnit [.succ .zero], .abbrev, .safe, [``Unit]) := rfl + +/-! ## Complete kernel metadata shapes -/ + +def inductiveShape06C (info : ConstantInfo) : + Option (Name × List Name × Nat × Nat × List Name × List Name × Nat × + Bool × Bool × Bool) := + match info with + | .inductInfo induct => some + (induct.name, induct.levelParams, induct.numParams, induct.numIndices, + induct.all, induct.ctors, induct.numNested, induct.isRec, + induct.isUnsafe, induct.isReflexive) + | _ => none + +def constructorShape06C (info : ConstantInfo) : + Option (Name × List Name × Name × Nat × Nat × Nat × Bool) := + match info with + | .ctorInfo ctor => some + (ctor.name, ctor.levelParams, ctor.induct, ctor.cidx, ctor.numParams, + ctor.numFields, ctor.isUnsafe) + | _ => none + +def completeRecursorShape06C (info : ConstantInfo) : + Option (Name × List Name × List Name × Nat × Nat × Nat × Nat × Bool × + Bool × List (Name × Nat)) := + match info with + | .recInfo rec => some + (rec.name, rec.levelParams, rec.all, rec.numParams, rec.numIndices, + rec.numMotives, rec.numMinors, rec.k, rec.isUnsafe, + rec.rules.map fun rule => (rule.ctor, rule.nfields)) + | _ => none + +/-! ## PUnit: one constructor, one minor, one rule -/ + +def punitInfo06C : ConstantInfo := kernelInductInfo% PUnit +def punitCtorInfo06C : ConstantInfo := kernelCtorInfo% PUnit.unit +def punitRecInfo06C : ConstantInfo := kernelRecInfo% PUnit.rec +def punitRuleRhs06C : VExpr := kernelRecRuleRhs% PUnit.rec 0 + +example : inductiveShape06C punitInfo06C = some + (``PUnit, [`u], 0, 0, [``PUnit], [``PUnit.unit], 0, false, false, + false) := rfl +example : punitInfo06C.type = .sort (.param `u) := rfl +example : constructorShape06C punitCtorInfo06C = some + (``PUnit.unit, [`u], ``PUnit, 0, 0, 0, false) := rfl +example : punitCtorInfo06C.type = .const ``PUnit [.param `u] := rfl +example : completeRecursorShape06C punitRecInfo06C = some + (``PUnit.rec, [`u_1, `u], [``PUnit], 0, 0, 1, 1, false, false, + [(``PUnit.unit, 0)]) := rfl + +example : punitChecked.params = [] := rfl +example : punitChecked.indices = [] := rfl +example : punitChecked.constructors.length = 1 := rfl +example : punitChecked.constructors[0].fields = [] := rfl +example : punitChecked.constructors[0].recursive = [] := rfl +example : punitGenerationChecked.block.ctorPairs.length = 1 := rfl +example : punitGenerationChecked.minorTypes = + [.app (.bvar 0) (.const ``PUnit.unit [.param 1])] := rfl +example : punitGenerationChecked.generatedRules.length = 1 := rfl + +/-- The complete generated type agrees with the real recursor, including the +fresh-first `[u_1, u]` metadata order. -/ +example : punitGenerationChecked.recursor = + permC06C (vconst(type_of% @PUnit.rec)) [.param 1, .param 0] := rfl + +/-- Removing the three outer binders exposes motive, sole minor, then major. +The minor has no field or induction-hypothesis binders. -/ +example : VExpr.telN 3 punitGenerationChecked.recType = + [punitGenerationChecked.motiveType, + .app (.bvar 0) (.const ``PUnit.unit [.param 1]), + .const ``PUnit [.param 1]] := rfl + +example : punitRuleRhs06C = + punitGenerationChecked.generatedRules[0].rhs := rfl + +def punitKernelType06C : InductiveType where + name := punitInfo06C.name + type := punitInfo06C.type + ctors := [{ name := punitCtorInfo06C.name, type := punitCtorInfo06C.type }] + +def punitEliminationResult06C := + AddInductive.NormalizationEliminationExecution.buildExecution 0 + [punitKernelType06C] 0 false (l4l06Context [`u]) + +theorem punitEliminationResult06C_isOk : + punitEliminationResult06C.isOk = true := by + native_decide + +def punitProducedExecution06C : + { execution // punitEliminationResult06C = .ok execution } := + match h : punitEliminationResult06C with + | .ok execution => ⟨execution, rfl⟩ + | .error _ => by + have hOk := punitEliminationResult06C_isOk + rw [h] at hOk + contradiction + +def punitExecution06C := punitProducedExecution06C.val + +def punitAlignment06C : AddInductive.CheckerEliminationRun + punitGenerationChecked punitExecution06C := + (AddInductive.CheckerEliminationRun.build? punitGenerationChecked + punitExecution06C).get (by native_decide) + +def punitLargeSingleton06C := + punitExecution06C.elimination.large.singleton.get (by native_decide) + +example : punitExecution06C.normalization.stats.params.size = 0 := by + native_decide +example : punitExecution06C.normalization.stats.nindices = #[0] := by + native_decide +example : punitExecution06C.normalization.stats.isNotZero = false := by + native_decide +example : punitExecution06C.elimination.large.result = true := by + native_decide +example : punitLargeSingleton06C.trace.parameterCount = 0 := by + native_decide +example : punitLargeSingleton06C.trace.proofFieldCount = 0 := by + native_decide +example : punitLargeSingleton06C.trace.dataFieldCount = 0 := by + native_decide +example : punitExecution06C.kTarget.result = false := by native_decide +example : punitExecution06C.kTarget.singleton = none := by native_decide +example : punitExecution06C.elimination.level = .param `u_1 := + Level.isStructEq_eq (by native_decide) +example : punitExecution06C.recLevelParams = [`u_1, `u] := by + native_decide +example : punitExecution06C.recLevels = [.param `u_1, .param `u] := + levelListStructEq06_eq (by native_decide) +example : punitGenerationChecked.elimination = .large := + punitAlignment06C.large_result_iff.mp (by native_decide) +example : punitGenerationChecked.kTarget = false := + punitAlignment06C.kTarget_result_false_iff.mp (by native_decide) + +/-! ## Empty: zero constructors, zero minors, zero rules -/ + +def emptyInfo06C : ConstantInfo := kernelInductInfo% Empty +def emptyRecInfo06C : ConstantInfo := kernelRecInfo% Empty.rec + +example : inductiveShape06C emptyInfo06C = some + (``Empty, [], 0, 0, [``Empty], [], 0, false, false, false) := rfl +example : emptyInfo06C.type = .sort (.succ .zero) := rfl +example : completeRecursorShape06C emptyRecInfo06C = some + (``Empty.rec, [`u], [``Empty], 0, 0, 1, 0, false, false, []) := rfl + +example : emptyChecked.params = [] := rfl +example : emptyChecked.indices = [] := rfl +example : emptyChecked.constructors = [] := rfl +example : emptyGenerationChecked.block.ctorPairs = [] := rfl +example : emptyGenerationChecked.minorTypes = [] := rfl +example : emptyGenerationChecked.generatedRules = [] := rfl +example : emptyGenerationChecked.recursor = vconst(type_of% @Empty.rec) := rfl + +/-- Empty elimination has no synthetic constructor minor: motive is followed +immediately by the major. -/ +example : VExpr.telN 2 emptyGenerationChecked.recType = + [emptyGenerationChecked.motiveType, .const ``Empty []] := rfl + +def emptyKernelType06C : InductiveType where + name := emptyInfo06C.name + type := emptyInfo06C.type + ctors := [] + +def emptyEliminationResult06C := + AddInductive.NormalizationEliminationExecution.buildExecution 0 + [emptyKernelType06C] 0 false (l4l06Context []) + +theorem emptyEliminationResult06C_isOk : + emptyEliminationResult06C.isOk = true := by + native_decide + +def emptyProducedExecution06C : + { execution // emptyEliminationResult06C = .ok execution } := + match h : emptyEliminationResult06C with + | .ok execution => ⟨execution, rfl⟩ + | .error _ => by + have hOk := emptyEliminationResult06C_isOk + rw [h] at hOk + contradiction + +def emptyExecution06C := emptyProducedExecution06C.val + +def emptyAlignment06C : AddInductive.CheckerEliminationRun + emptyGenerationChecked emptyExecution06C := + (AddInductive.CheckerEliminationRun.build? emptyGenerationChecked + emptyExecution06C).get (by native_decide) + +example : emptyExecution06C.normalization.stats.params.size = 0 := by + native_decide +example : emptyExecution06C.normalization.stats.nindices = #[0] := by + native_decide +example : emptyExecution06C.normalization.stats.isNotZero = true := by + native_decide +example : emptyExecution06C.elimination.large.result = true := by + native_decide +example : emptyExecution06C.elimination.large.singleton = none := by + native_decide +example : emptyExecution06C.kTarget.result = false := by native_decide +example : emptyExecution06C.kTarget.singleton = none := by native_decide +example : emptyExecution06C.elimination.level = .param `u := + Level.isStructEq_eq (by native_decide) +example : emptyExecution06C.recLevelParams = [`u] := by native_decide +example : emptyExecution06C.recLevels = [.param `u] := + levelListStructEq06_eq (by native_decide) +example : emptyGenerationChecked.elimination = .large := + emptyAlignment06C.large_result_iff.mp (by native_decide) +example : emptyGenerationChecked.kTarget = false := + emptyAlignment06C.kTarget_result_false_iff.mp (by native_decide) + +end Lean4Lean.InductiveReplayFixtures diff --git a/Lean4Lean/Verify/Environment/EliminationFixturesEq.lean b/Lean4Lean/Verify/Environment/EliminationFixturesEq.lean new file mode 100644 index 00000000..b00b7912 --- /dev/null +++ b/Lean4Lean/Verify/Environment/EliminationFixturesEq.lean @@ -0,0 +1,59 @@ +import Lean4Lean.Verify.Environment.EliminationFixturesCommon + +/-! Exact L4L-06B Eq differential fixture. -/ + +namespace Lean4Lean.InductiveReplayFixtures +open Lean Meta Elab Term +open Lean4Lean.InductiveFixtures + +/-! Eq: indexed singleton large elimination and fresh-first order. -/ + +def eqKernelType06 : InductiveType where + name := eqInfo.name + type := eqInfo.type + ctors := [{ name := eqReflInfo.name, type := eqReflInfo.type }] + +def eqEliminationResult06 := + AddInductive.NormalizationEliminationExecution.buildExecution 2 + [eqKernelType06] 0 false (l4l06Context eqInfo.levelParams) + +theorem eqEliminationResult06_isOk : eqEliminationResult06.isOk = true := by + native_decide + +def eqProducedExecution06 : + { execution // eqEliminationResult06 = .ok execution } := + match h : eqEliminationResult06 with + | .ok execution => ⟨execution, rfl⟩ + | .error _ => by + have hOk := eqEliminationResult06_isOk + rw [h] at hOk + contradiction + +def eqExecution06 := eqProducedExecution06.val + +def eqAlignment06 : + AddInductive.CheckerEliminationRun eqGenerationChecked eqExecution06 := + (AddInductive.CheckerEliminationRun.build? eqGenerationChecked eqExecution06).get + (by native_decide) + +def eqKTargetSingleton06 := + eqExecution06.kTarget.singleton.get (by native_decide) + +example : eqExecution06.elimination.large.result = true := by native_decide +example : eqExecution06.kTarget.result = true := by native_decide +example : eqKTargetSingleton06.trace.parameterCount = 2 := by native_decide +example : eqKTargetSingleton06.trace.fieldCount = 0 := by native_decide +example : eqExecution06.elimination.level = .param `u := + Level.isStructEq_eq (by native_decide) +example : eqExecution06.recLevelParams = [`u, `u_1] := by native_decide +example : eqExecution06.recLevels = [.param `u, .param `u_1] := + levelListStructEq06_eq (by native_decide) +example : recursorShape06 eqRecInfo = + ([`u, `u_1], 2, 1, 1, 1, true, [(``Eq.refl, 0)]) := rfl +example : eqReflKernelRuleRhs = eqChecked.generatedRules[0].rhs := rfl +example : eqGenerationChecked.elimination = .large := + eqAlignment06.large_result_iff.mp (by native_decide) +example : eqGenerationChecked.kTarget = true := + eqAlignment06.kTarget_result_true_iff.mp (by native_decide) + +end Lean4Lean.InductiveReplayFixtures diff --git a/Lean4Lean/Verify/Environment/EliminationFixturesEqNat.lean b/Lean4Lean/Verify/Environment/EliminationFixturesEqNat.lean new file mode 100644 index 00000000..d08b37e0 --- /dev/null +++ b/Lean4Lean/Verify/Environment/EliminationFixturesEqNat.lean @@ -0,0 +1,4 @@ +import Lean4Lean.Verify.Environment.EliminationFixturesEq +import Lean4Lean.Verify.Environment.EliminationFixturesNat + +/-! Umbrella for the exact L4L-06A Eq and Nat differential fixtures. -/ diff --git a/Lean4Lean/Verify/Environment/EliminationFixturesNat.lean b/Lean4Lean/Verify/Environment/EliminationFixturesNat.lean new file mode 100644 index 00000000..d244bc73 --- /dev/null +++ b/Lean4Lean/Verify/Environment/EliminationFixturesNat.lean @@ -0,0 +1,108 @@ +import Lean4Lean.Verify.Environment.EliminationFixturesCommon + +/-! Exact L4L-06B Nat never-zero elimination and non-K fixture. -/ + +namespace Lean4Lean.InductiveReplayFixtures +open Lean Meta Elab Term +open Lean4Lean.InductiveFixtures + +/-! Nat's nonzero result universe takes the immediate large-elimination +branch. The exact singleton statistics and source levels are pinned directly +so this replay tests that branch without compiling the unrelated full +normalization trace a second time. -/ + +def natKernelType06 : InductiveType where + name := natInfo.name + type := natInfo.type + ctors := [ + { name := natZeroInfo.name, type := natZeroInfo.type }, + { name := natSuccInfo.name, type := natSuccInfo.type }] + +def natNeverZeroStats06 : AddInductive.InductiveStats := + AddInductive.singletonInductiveStats (l4l06Context []) natKernelType06 + (.succ .zero) + +def natElimLevelResult06 := + AddInductive.ElimLevelExecution.buildExecution natNeverZeroStats06 + #[natKernelType06] (l4l06Context []) + +theorem natElimLevelResult06_isOk : natElimLevelResult06.isOk = true := by + native_decide + +def natProducedElimLevel06 : + { execution // natElimLevelResult06 = .ok execution } := + match h : natElimLevelResult06 with + | .ok execution => ⟨execution, rfl⟩ + | .error _ => by + have hOk := natElimLevelResult06_isOk + rw [h] at hOk + contradiction + +def natElimLevelExecution06 := natProducedElimLevel06.val + +def natElimAlignmentResult06 := + AddInductive.CheckerElimLevelRun.build? natGenerationChecked + natElimLevelExecution06 + +theorem natElimAlignmentResult06_isSome : + natElimAlignmentResult06.isSome = true := by + native_decide + +def natElimAlignment06 : AddInductive.CheckerElimLevelRun + natGenerationChecked natElimLevelExecution06 := + natElimAlignmentResult06.get natElimAlignmentResult06_isSome + +def natKTargetResult06 := + AddInductive.KTargetExecution.buildExecution natNeverZeroStats06 + #[natKernelType06] (l4l06Context []) + +theorem natKTargetResult06_isOk : natKTargetResult06.isOk = true := by + native_decide + +def natProducedKTarget06 : + { execution // natKTargetResult06 = .ok execution } := + match h : natKTargetResult06 with + | .ok execution => ⟨execution, rfl⟩ + | .error _ => by + have hOk := natKTargetResult06_isOk + rw [h] at hOk + contradiction + +def natKTargetExecution06 := natProducedKTarget06.val + +def natKTargetAlignmentResult06 := + AddInductive.CheckerKTargetRun.build? natGenerationChecked + natKTargetExecution06 + +theorem natKTargetAlignmentResult06_isSome : + natKTargetAlignmentResult06.isSome = true := by + native_decide + +def natKTargetAlignment06 : AddInductive.CheckerKTargetRun + natGenerationChecked natKTargetExecution06 := + natKTargetAlignmentResult06.get natKTargetAlignmentResult06_isSome + +example : natNeverZeroStats06.isNotZero = true := rfl +example : natNeverZeroStats06.resultLevel = .succ .zero := rfl +example : natKernelType06.type = .sort (.succ .zero) := rfl +example : natChecked.resultLevel = .succ .zero := rfl +example : natElimLevelExecution06.large.result = true := by native_decide +example : natKTargetExecution06.result = false := by native_decide +example : natKTargetExecution06.singleton = none := by native_decide +example : natElimLevelExecution06.level = .param `u := + Level.isStructEq_eq (by native_decide) +example : AddInductive.getRecLevelParams natElimLevelExecution06.level [] = + [`u] := by native_decide +example : AddInductive.getRecLevels natElimLevelExecution06.level [] = + [.param `u] := levelListStructEq06_eq (by native_decide) +example : recursorShape06 natRecInfo = + ([`u], 0, 0, 1, 2, false, + [(``Nat.zero, 0), (``Nat.succ, 1)]) := rfl +example : natZeroKernelRuleRhs = natChecked.generatedRules[0].rhs := rfl +example : natSuccKernelRuleRhs = natChecked.generatedRules[1].rhs := rfl +example : natGenerationChecked.elimination = .large := + natElimAlignment06.large_result_iff.mp (by native_decide) +example : natGenerationChecked.kTarget = false := + natKTargetAlignment06.result_false_iff.mp (by native_decide) + +end Lean4Lean.InductiveReplayFixtures diff --git a/Lean4Lean/Verify/Environment/EliminationFixturesOrAnd.lean b/Lean4Lean/Verify/Environment/EliminationFixturesOrAnd.lean new file mode 100644 index 00000000..cc88b0c2 --- /dev/null +++ b/Lean4Lean/Verify/Environment/EliminationFixturesOrAnd.lean @@ -0,0 +1,131 @@ +import Lean4Lean.Verify.Environment.EliminationFixturesCommon + +/-! Exact L4L-06B Or/And differential fixtures. -/ + +namespace Lean4Lean.InductiveReplayFixtures +open Lean Meta Elab Term +open Lean4Lean.InductiveFixtures + +/-! ## Or: Prop-only elimination -/ + +def orInfo06 : ConstantInfo := kernelInductInfo% Or +def orInlInfo06 : ConstantInfo := kernelCtorInfo% Or.inl +def orInrInfo06 : ConstantInfo := kernelCtorInfo% Or.inr +def orRecInfo06 : ConstantInfo := kernelRecInfo% Or.rec +def orInlKernelRuleRhs06 : VExpr := kernelRecRuleRhs% Or.rec 0 +def orInrKernelRuleRhs06 : VExpr := kernelRecRuleRhs% Or.rec 1 + +def orKernelType06 : InductiveType where + name := orInfo06.name + type := orInfo06.type + ctors := [ + { name := orInlInfo06.name, type := orInlInfo06.type }, + { name := orInrInfo06.name, type := orInrInfo06.type }] + +def orEliminationResult06 := + AddInductive.NormalizationEliminationExecution.buildExecution 2 + [orKernelType06] 0 false (l4l06Context orInfo06.levelParams) + +theorem orEliminationResult06_isOk : orEliminationResult06.isOk = true := by + native_decide + +def orProducedExecution06 : + { execution // orEliminationResult06 = .ok execution } := + match h : orEliminationResult06 with + | .ok execution => ⟨execution, rfl⟩ + | .error _ => by + have hOk := orEliminationResult06_isOk + rw [h] at hOk + contradiction + +def orExecution06 := orProducedExecution06.val + +def orGeneration06 : VInductDecl.GenerationChecked orDecl := + (VInductDecl.identityGeneration? orDecl).get (by decide) + +def orAlignment06 : + AddInductive.CheckerEliminationRun orGeneration06 orExecution06 := + (AddInductive.CheckerEliminationRun.build? orGeneration06 orExecution06).get + (by native_decide) + +example : orExecution06.elimination.large.result = false := by native_decide +example : orExecution06.kTarget.result = false := by native_decide +example : orExecution06.kTarget.singleton = none := by native_decide +example : orExecution06.elimination.level = .zero := + Level.isStructEq_eq (by native_decide) +example : orExecution06.recLevelParams = [] := by native_decide +example : orExecution06.recLevels = [] := by native_decide +example : recursorShape06 orRecInfo06 = + ([], 2, 0, 1, 2, false, [(``Or.inl, 1), (``Or.inr, 1)]) := rfl +example : orInlKernelRuleRhs06 = orChecked.generatedRules[0].rhs := rfl +example : orInrKernelRuleRhs06 = orChecked.generatedRules[1].rhs := rfl +example : orGeneration06.elimination = .small := + orAlignment06.small_result_iff.mp (by native_decide) +example : orGeneration06.kTarget = false := + orAlignment06.kTarget_result_false_iff.mp (by native_decide) + +/-! ## And: singleton proof fields permit large elimination -/ + +def andInfo06 : ConstantInfo := kernelInductInfo% And +def andIntroInfo06 : ConstantInfo := kernelCtorInfo% And.intro +def andRecInfo06 : ConstantInfo := kernelRecInfo% And.rec +def andKernelRuleRhs06 : VExpr := kernelRecRuleRhs% And.rec 0 + +def andKernelType06 : InductiveType where + name := andInfo06.name + type := andInfo06.type + ctors := [{ name := andIntroInfo06.name, type := andIntroInfo06.type }] + +def andEliminationResult06 := + AddInductive.NormalizationEliminationExecution.buildExecution 2 + [andKernelType06] 0 false (l4l06Context andInfo06.levelParams) + +theorem andEliminationResult06_isOk : andEliminationResult06.isOk = true := by + native_decide + +def andProducedExecution06 : + { execution // andEliminationResult06 = .ok execution } := + match h : andEliminationResult06 with + | .ok execution => ⟨execution, rfl⟩ + | .error _ => by + have hOk := andEliminationResult06_isOk + rw [h] at hOk + contradiction + +def andExecution06 := andProducedExecution06.val + +def andGeneration06 : VInductDecl.GenerationChecked andDecl := + (VInductDecl.identityGeneration? andDecl).get (by decide) + +def andAlignment06 : + AddInductive.CheckerEliminationRun andGeneration06 andExecution06 := + (AddInductive.CheckerEliminationRun.build? andGeneration06 andExecution06).get + (by native_decide) + +def andSingletonExecution06 := + andExecution06.elimination.large.singleton.get (by native_decide) + +def andKTargetSingleton06 := + andExecution06.kTarget.singleton.get (by native_decide) + +example : andExecution06.elimination.large.result = true := by native_decide +example : andExecution06.kTarget.result = false := by native_decide +example : andKTargetSingleton06.trace.parameterCount = 2 := by native_decide +example : andKTargetSingleton06.trace.fieldCount = 1 := by native_decide +example : andExecution06.elimination.level = .param `u := + Level.isStructEq_eq (by native_decide) +example : andExecution06.recLevelParams = [`u] := by native_decide +example : andExecution06.recLevels = [.param `u] := + levelListStructEq06_eq (by native_decide) +example : recursorShape06 andRecInfo06 = + ([`u], 2, 0, 1, 1, false, [(``And.intro, 2)]) := rfl +example : andSingletonExecution06.trace.parameterCount = 2 := by native_decide +example : andSingletonExecution06.trace.proofFieldCount = 2 := by native_decide +example : andSingletonExecution06.trace.dataFieldCount = 0 := by native_decide +example : andKernelRuleRhs06 = andChecked.generatedRules[0].rhs := rfl +example : andGeneration06.elimination = .large := + andAlignment06.large_result_iff.mp (by native_decide) +example : andGeneration06.kTarget = false := + andAlignment06.kTarget_result_false_iff.mp (by native_decide) + +end Lean4Lean.InductiveReplayFixtures diff --git a/Lean4Lean/Verify/Environment/EliminationFixturesSmall.lean b/Lean4Lean/Verify/Environment/EliminationFixturesSmall.lean new file mode 100644 index 00000000..ad2307b5 --- /dev/null +++ b/Lean4Lean/Verify/Environment/EliminationFixturesSmall.lean @@ -0,0 +1,94 @@ +import Lean4Lean.Verify.Environment.EliminationFixturesCommon + +/-! Exact L4L-06B source-universe small-elimination differential fixture. -/ + +namespace Lean4Lean.InductiveReplayFixtures +open Lean Meta Elab Term +open Lean4Lean.InductiveFixtures + +def smallSourceInfo06 : ConstantInfo := kernelInductInfo% L4L06SmallSource +def smallSourceLeftInfo06 : ConstantInfo := + kernelCtorInfo% L4L06SmallSource.left +def smallSourceRightInfo06 : ConstantInfo := + kernelCtorInfo% L4L06SmallSource.right +def smallSourceRecInfo06 : ConstantInfo := + kernelRecInfo% L4L06SmallSource.rec +def smallSourceLeftRuleRhs06 : VExpr := + kernelRecRuleRhs% L4L06SmallSource.rec 0 +def smallSourceRightRuleRhs06 : VExpr := + kernelRecRuleRhs% L4L06SmallSource.rec 1 + +def smallSourceType06 : VInductiveType where + name := ``L4L06SmallSource + uvars := 1 + type := vconst(type_of% @L4L06SmallSource).type + ctors := [ + ⟨vconst(type_of% @L4L06SmallSource.left), ``L4L06SmallSource.left⟩, + ⟨vconst(type_of% @L4L06SmallSource.right), ``L4L06SmallSource.right⟩] + +def smallSourceDecl06 : VInductDecl := ⟨1, 1, [smallSourceType06]⟩ + +def smallSourceChecked06 : smallSourceDecl06.Checked := + smallSourceDecl06.checked?.get (by decide) + +def smallSourceGeneration06 : + VInductDecl.GenerationChecked smallSourceDecl06 := + (VInductDecl.identityGeneration? smallSourceDecl06).get (by decide) + +def smallSourceKernelType06 : InductiveType where + name := smallSourceInfo06.name + type := smallSourceInfo06.type + ctors := [ + { name := smallSourceLeftInfo06.name, type := smallSourceLeftInfo06.type }, + { name := smallSourceRightInfo06.name, type := smallSourceRightInfo06.type }] + +def smallSourceEliminationResult06 := + AddInductive.NormalizationEliminationExecution.buildExecution 1 + [smallSourceKernelType06] 0 false + (l4l06Context smallSourceInfo06.levelParams) + +theorem smallSourceEliminationResult06_isOk : + smallSourceEliminationResult06.isOk = true := by + native_decide + +def smallSourceProducedExecution06 : + { execution // smallSourceEliminationResult06 = .ok execution } := + match h : smallSourceEliminationResult06 with + | .ok execution => ⟨execution, rfl⟩ + | .error _ => by + have hOk := smallSourceEliminationResult06_isOk + rw [h] at hOk + contradiction + +def smallSourceExecution06 := smallSourceProducedExecution06.val + +def smallSourceAlignment06 : AddInductive.CheckerEliminationRun + smallSourceGeneration06 smallSourceExecution06 := + (AddInductive.CheckerEliminationRun.build? smallSourceGeneration06 + smallSourceExecution06).get (by native_decide) + +example : smallSourceInfo06.levelParams = [`u] := rfl +example : smallSourceExecution06.elimination.large.result = false := by + native_decide +example : smallSourceExecution06.kTarget.result = false := by native_decide +example : smallSourceExecution06.kTarget.singleton = none := by native_decide +example : smallSourceExecution06.elimination.level = .zero := + Level.isStructEq_eq (by native_decide) +example : smallSourceExecution06.recLevelParams = [`u] := by native_decide +example : smallSourceExecution06.recLevels = [.param `u] := + levelListStructEq06_eq (by native_decide) +example : recursorShape06 smallSourceRecInfo06 = + ([`u], 1, 0, 1, 2, false, + [(``L4L06SmallSource.left, 0), (``L4L06SmallSource.right, 0)]) := rfl +example : smallSourceChecked06.elimination = .small := + smallSourceAlignment06.small_result_iff.mp (by native_decide) +example : smallSourceGeneration06.kTarget = false := + smallSourceAlignment06.kTarget_result_false_iff.mp (by native_decide) +example : smallSourceGeneration06.recursor = + vconst(type_of% @L4L06SmallSource.rec) := rfl +example : smallSourceLeftRuleRhs06 = + smallSourceGeneration06.generatedRules[0].rhs := rfl +example : smallSourceRightRuleRhs06 = + smallSourceGeneration06.generatedRules[1].rhs := rfl + +end Lean4Lean.InductiveReplayFixtures diff --git a/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean b/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean index 0ec1c658..30465a28 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean @@ -19,11 +19,35 @@ private theorem indexedVecKernel_lookup_nat : change natMap.find?' ``Nat = some natInfo rw [natMap_wf.find?'_eq_find?, nat_type_map_lookup] +private theorem indexedVecKernel_lookup_zero : + indexedVecKernelEnv.find? ``Nat.zero = some natZeroInfo := by + change natMap.find?' ``Nat.zero = some natZeroInfo + rw [natMap_wf.find?'_eq_find?, natMap, + natCtorMap_wf.find?_insert, natCtorMap, + natZeroMap_wf.find?_insert, natZeroMap, + natTypeMap_wf.find?_insert] + rfl + +private theorem indexedVecKernel_lookup_succ : + indexedVecKernelEnv.find? ``Nat.succ = some natSuccInfo := by + change natMap.find?' ``Nat.succ = some natSuccInfo + rw [natMap_wf.find?'_eq_find?, nat_succ_map_lookup] + @[simp] private theorem indexedVecKernel_get_nat : indexedVecKernelEnv.get ``Nat = .ok natInfo := by simp only [Kernel.Environment.get, indexedVecKernel_lookup_nat, Pure.pure, Except.pure] +@[simp] private theorem indexedVecKernel_get_zero : + indexedVecKernelEnv.get ``Nat.zero = .ok natZeroInfo := by + simp only [Kernel.Environment.get, indexedVecKernel_lookup_zero, + Pure.pure, Except.pure] + +@[simp] private theorem indexedVecKernel_get_succ : + indexedVecKernelEnv.get ``Nat.succ = .ok natSuccInfo := by + simp only [Kernel.Environment.get, indexedVecKernel_lookup_succ, + Pure.pure, Except.pure] + private def indexedVecParamName : Name := indexedVecInfo.type.bindingName! @@ -82,7 +106,7 @@ theorem candidateIsDefEqSelfValid rw [if_pos (Expr.eqv_refl e)] rfl -private def indexedVecTypeCheckerContext +def indexedVecTypeCheckerContext (lctx : LocalContext) : Lean4Lean.TypeChecker.Context where env := indexedVecKernelEnv lctx := lctx @@ -251,6 +275,32 @@ private theorem indexedVecInferTypeFuel Level.substParams', Bind.bind, Except.bind, Pure.pure, Except.pure] +@[simp] theorem indexedVecPreFamilyInferConstantZero + (lctx : LocalContext) : + Lean4Lean.TypeChecker.Inner.inferConstant + (indexedVecTypeCheckerContext lctx) ``Nat.zero [] false = + .ok (.const ``Nat []) := by + unfold Lean4Lean.TypeChecker.Inner.inferConstant + simp [indexedVecTypeCheckerContext, indexedVecKernel_get_zero, + natZeroInfo, ConstantInfo.levelParams, ConstantInfo.isUnsafe, + ConstantInfo.instantiateTypeLevelParams, ConstantInfo.toConstantVal, + ConstantVal.instantiateTypeLevelParams, + Expr.instantiateLevelParams_eq, Expr.instantiateLevelParamsCore', + Bind.bind, Except.bind, Pure.pure, Except.pure] + +@[simp] theorem indexedVecPreFamilyInferConstantSucc + (lctx : LocalContext) : + Lean4Lean.TypeChecker.Inner.inferConstant + (indexedVecTypeCheckerContext lctx) ``Nat.succ [] false = + .ok (.forallE `n (.const ``Nat []) (.const ``Nat []) .default) := by + unfold Lean4Lean.TypeChecker.Inner.inferConstant + simp [indexedVecTypeCheckerContext, indexedVecKernel_get_succ, + natSuccInfo, ConstantInfo.levelParams, ConstantInfo.isUnsafe, + ConstantInfo.instantiateTypeLevelParams, ConstantInfo.toConstantVal, + ConstantVal.instantiateTypeLevelParams, + Expr.instantiateLevelParams_eq, Expr.instantiateLevelParamsCore', + Bind.bind, Except.bind, Pure.pure, Except.pure] + @[simp] private theorem indexedVecInferTypeNatCore (n : Nat) (lctx : LocalContext) (state : Lean4Lean.TypeChecker.State) @@ -268,6 +318,54 @@ private theorem indexedVecInferTypeFuel indexedVecInferConstantNat, Bind.bind, ReaderT.bind, StateT.bind, Except.bind] +theorem indexedVecPreFamilyInferTypeFVarCore + (n : Nat) (lctx : LocalContext) + (state : Lean4Lean.TypeChecker.State) (id : FVarId) (type : Expr) + (hcache : state.inferTypeC[(.fvar id : Expr)]? = none) + (hfind : lctx.find? id = + some (.cdecl index id name type bi kind)) : + Lean4Lean.TypeChecker.Inner.inferType' (.fvar id) false + (Lean4Lean.TypeChecker.Methods.withFuel n) + (indexedVecTypeCheckerContext lctx) state = + .ok (type, { state with inferTypeC := + state.inferTypeC.insert (.fvar id) type }) := by + unfold Lean4Lean.TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', hcache, + Lean4Lean.TypeChecker.Inner.inferFVar, + indexedVecTypeCheckerContext, hfind, LocalDecl.type, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +theorem indexedVecPreFamilyInferTypeZeroCore + (n : Nat) (lctx : LocalContext) + (state : Lean4Lean.TypeChecker.State) + (hcache : state.inferTypeC[(.const ``Nat.zero [] : Expr)]? = none) : + Lean4Lean.TypeChecker.Inner.inferType' (.const ``Nat.zero []) false + (Lean4Lean.TypeChecker.Methods.withFuel n) + (indexedVecTypeCheckerContext lctx) state = + .ok (.const ``Nat [], { state with inferTypeC := + (state.inferTypeC.insert (.const ``Nat.zero []) + (.const ``Nat [])) }) := by + unfold Lean4Lean.TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', hcache, + indexedVecPreFamilyInferConstantZero, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +theorem indexedVecPreFamilyInferTypeSuccCore + (n : Nat) (lctx : LocalContext) + (state : Lean4Lean.TypeChecker.State) + (hcache : state.inferTypeC[(.const ``Nat.succ [] : Expr)]? = none) : + Lean4Lean.TypeChecker.Inner.inferType' (.const ``Nat.succ []) false + (Lean4Lean.TypeChecker.Methods.withFuel n) + (indexedVecTypeCheckerContext lctx) state = + .ok (.forallE `n (.const ``Nat []) (.const ``Nat []) .default, + { state with inferTypeC := (state.inferTypeC.insert + (.const ``Nat.succ []) + (.forallE `n (.const ``Nat []) (.const ``Nat []) .default)) }) := by + unfold Lean4Lean.TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', hcache, + indexedVecPreFamilyInferConstantSucc, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + private def indexedVecRootSortState : Lean4Lean.TypeChecker.State := { ({} : Lean4Lean.TypeChecker.State) with inferTypeC := (({} : Lean4Lean.TypeChecker.State).inferTypeC.insert @@ -737,6 +835,216 @@ private theorem indexedVecInner_checkTypeM : simpa [indexedVecInnerKernel] using indexedVecInnerInferForall] rfl +/-! The constructor pre-family replay runs after family analysis has added its +parameter and index locals, but before `IndexedVec` itself is present in the +kernel environment. The following executions expose the family-free pieces +of the family candidate proof for an arbitrary local context. -/ + +def indexedVecPreFamilyIndexTelescope : Expr := + .forallE indexedVecIndexName (.const ``Nat []) + (.sort (.succ (.param `u))) .default + +theorem indexedVecPreFamilyIndexTelescope_eq : + indexedVecPreFamilyIndexTelescope = indexedVecInfo.type.bindingBody! := by + rfl + +theorem indexedVecPreFamilySortCheckTypeM (lctx : LocalContext) : + Lean4Lean.TypeChecker.M.run indexedVecKernelEnv .safe lctx [`u] + ({} : FuelConfig) + (Lean4Lean.TypeChecker.checkType + (.sort (.succ (.param `u)))) = + .ok (.sort (.succ (.succ (.param `u)))) := + indexedVecSort_checkTypeM lctx + +theorem indexedVecPreFamilyNatCheckTypeM (lctx : LocalContext) : + Lean4Lean.TypeChecker.M.run indexedVecKernelEnv .safe lctx [`u] + ({} : FuelConfig) + (Lean4Lean.TypeChecker.checkType (.const ``Nat [])) = + .ok (.sort (.succ .zero)) := + indexedVecNat_checkTypeM lctx + +@[simp] private theorem indexedVecInferConstantNatOnly + (lctx : LocalContext) : + Lean4Lean.TypeChecker.Inner.inferConstant + (indexedVecTypeCheckerContext lctx) ``Nat [] true = + .ok (.sort (.succ .zero)) := by + unfold Lean4Lean.TypeChecker.Inner.inferConstant + simp [indexedVecTypeCheckerContext, indexedVecKernel_get_nat, + natInfo, ConstantInfo.levelParams, ConstantInfo.isUnsafe, + ConstantInfo.instantiateTypeLevelParams, ConstantInfo.toConstantVal, + ConstantVal.instantiateTypeLevelParams, + Expr.instantiateLevelParams_eq, Expr.instantiateLevelParamsCore', + Level.substParams', Bind.bind, Except.bind, + Pure.pure, Except.pure] + +private def indexedVecPreFamilyNatInferOnlyState : + Lean4Lean.TypeChecker.State := + { ({} : Lean4Lean.TypeChecker.State) with + inferTypeI := ({} : Lean4Lean.TypeChecker.State).inferTypeI.insert + (.const ``Nat []) (.sort (.succ .zero)) } + +private theorem indexedVecPreFamilyNatInferOnly + (lctx : LocalContext) : + Lean4Lean.TypeChecker.Inner.inferType (.const ``Nat []) true + (Lean4Lean.TypeChecker.Methods.withFuel 10000) + (indexedVecTypeCheckerContext lctx) + ({} : Lean4Lean.TypeChecker.State) = + .ok (.sort (.succ .zero), + indexedVecPreFamilyNatInferOnlyState) := by + change Lean4Lean.TypeChecker.Inner.inferType' (.const ``Nat []) true + (Lean4Lean.TypeChecker.Methods.withFuel 9999) + (indexedVecTypeCheckerContext lctx) + ({} : Lean4Lean.TypeChecker.State) = _ + unfold Lean4Lean.TypeChecker.Inner.inferType' + simp [indexedVecPreFamilyNatInferOnlyState, + Expr.hasLooseBVars, Expr.looseBVarRange', + indexedVecInferConstantNatOnly, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + +theorem indexedVecPreFamilyNatEnsureTypeM (lctx : LocalContext) : + Lean4Lean.TypeChecker.M.run indexedVecKernelEnv .safe lctx [`u] + ({} : FuelConfig) + (Lean4Lean.TypeChecker.ensureType (.const ``Nat [])) = + .ok (.sort (.succ .zero)) := by + unfold Lean4Lean.TypeChecker.ensureType Lean4Lean.TypeChecker.inferType + Lean4Lean.TypeChecker.ensureSort Lean4Lean.TypeChecker.RecM.run + Lean4Lean.TypeChecker.M.run + simp only [readThe, MonadReaderOf.read, ReaderT.read, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind, + Pure.pure, StateT.pure, Except.pure, StateT.run', + Functor.map, Except.map] + rw [show Lean4Lean.TypeChecker.Inner.inferType (.const ``Nat []) true + (Lean4Lean.TypeChecker.Methods.withFuel 10000) + { env := indexedVecKernelEnv + lctx := lctx + safety := .safe + lparams := [`u] + fuel := ({} : FuelConfig) } + ({} : Lean4Lean.TypeChecker.State) = + .ok (.sort (.succ .zero), + indexedVecPreFamilyNatInferOnlyState) by + simpa [indexedVecTypeCheckerContext] using + indexedVecPreFamilyNatInferOnly lctx] + rfl + +private def indexedVecPreFamilyIndexCheckerLctx + (lctx : LocalContext) : LocalContext := + lctx.mkLocalDecl ⟨indexedVecInnerNatState.ngen.curr⟩ + indexedVecIndexName (.const ``Nat []) .default + +private theorem indexedVecPreFamilyIndexNatCore (lctx : LocalContext) : + Lean4Lean.TypeChecker.Inner.inferType' (.const ``Nat []) false + (Lean4Lean.TypeChecker.Methods.withFuel 9998) + (indexedVecTypeCheckerContext lctx) + ({} : Lean4Lean.TypeChecker.State) = + .ok (.sort (.succ .zero), indexedVecInnerNatState) := by + simpa [indexedVecInnerNatState] using + (indexedVecInferTypeNatCore 9998 lctx + ({} : Lean4Lean.TypeChecker.State) Std.HashMap.getElem?_empty) + +private theorem indexedVecPreFamilyIndexWithLocalDecl + (lctx : LocalContext) + {α} (k : Expr → Lean4Lean.TypeChecker.RecM α) + (methods : Lean4Lean.TypeChecker.Methods) : + (withLocalDecl (m := Lean4Lean.TypeChecker.RecM) + indexedVecIndexName .default (.const ``Nat []) k) + methods (indexedVecTypeCheckerContext lctx) + indexedVecInnerNatState = + k (.fvar ⟨indexedVecInnerNatState.ngen.curr⟩) methods + { indexedVecTypeCheckerContext lctx with + lctx := indexedVecPreFamilyIndexCheckerLctx lctx } + indexedVecInnerAfterIndexState := by + simpa [indexedVecPreFamilyIndexCheckerLctx, + indexedVecInnerAfterIndexState, indexedVecTypeCheckerContext] using + (indexedVecWithLocalDecl indexedVecIndexName .default + (.const ``Nat []) k methods (indexedVecTypeCheckerContext lctx) + indexedVecInnerNatState) + +private theorem indexedVecPreFamilyIndexSortCore (lctx : LocalContext) : + Lean4Lean.TypeChecker.Inner.inferType' + (.sort (.succ (.param `u))) false + (Lean4Lean.TypeChecker.Methods.withFuel 9998) + { indexedVecTypeCheckerContext lctx with + lctx := indexedVecPreFamilyIndexCheckerLctx lctx } + indexedVecInnerAfterIndexState = + .ok (.sort (.succ (.succ (.param `u))), + indexedVecInnerSortState) := by + simpa [indexedVecPreFamilyIndexCheckerLctx, + indexedVecInnerAfterIndexState, indexedVecInnerNatState, + indexedVecInnerSortState, indexedVecTypeCheckerContext] using + (indexedVecInferTypeSortCore 9998 + (indexedVecPreFamilyIndexCheckerLctx lctx) + indexedVecInnerAfterIndexState (by + simp [indexedVecInnerAfterIndexState, + indexedVecInnerNatState])) + +private theorem indexedVecPreFamilyIndexInferForall + (lctx : LocalContext) : + Lean4Lean.TypeChecker.Inner.inferForall + indexedVecPreFamilyIndexTelescope false + (Lean4Lean.TypeChecker.Methods.withFuel 9999) + (indexedVecTypeCheckerContext lctx) + ({} : Lean4Lean.TypeChecker.State) = + .ok (.sort indexedVecInnerInferredLevel, + indexedVecInnerSortState) := by + unfold indexedVecPreFamilyIndexTelescope + unfold Lean4Lean.TypeChecker.Inner.inferForall + simp only [Lean4Lean.TypeChecker.Inner.inferForall.loop] + rw [show (.const ``Nat [] : Expr).instantiateRev #[] = + .const ``Nat [] by + simp [Expr.instantiateRev_eq, Expr.instantiate_eq]] + simp only [Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rw [indexedVecInferTypeFuel 9998] + rw [indexedVecPreFamilyIndexNatCore] + simp only + rw [indexedVecEnsureSort] + simp only + rw [indexedVecPreFamilyIndexWithLocalDecl] + rw [show + (.sort (.succ (.param `u)) : Expr).instantiateRev + (#[] |>.push (.fvar ⟨indexedVecInnerNatState.ngen.curr⟩)) = + .sort (.succ (.param `u)) by + simp [Expr.instantiateRev_eq, Expr.instantiate_eq, + Expr.instantiate1']] + simp only [Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rw [indexedVecInferTypeFuel 9998] + rw [indexedVecPreFamilyIndexSortCore] + simp only + rw [indexedVecEnsureSort] + simp [indexedVecInnerInferredLevel, Expr.sortLevel!, + Pure.pure, ReaderT.pure, StateT.pure, Except.pure] + +theorem indexedVecPreFamilyIndexTelescopeCheckTypeM + (lctx : LocalContext) : + Lean4Lean.TypeChecker.M.run indexedVecKernelEnv .safe lctx [`u] + ({} : FuelConfig) + (Lean4Lean.TypeChecker.checkType + indexedVecPreFamilyIndexTelescope) = + .ok (.sort indexedVecInnerInferredLevel) := by + change Except.map + (fun x : Expr × Lean4Lean.TypeChecker.State => x.1) + (Lean4Lean.TypeChecker.Inner.inferType' + indexedVecPreFamilyIndexTelescope false + (Lean4Lean.TypeChecker.Methods.withFuel 9999) + (indexedVecTypeCheckerContext lctx) + ({} : Lean4Lean.TypeChecker.State)) = _ + unfold Lean4Lean.TypeChecker.Inner.inferType' + simp [indexedVecPreFamilyIndexTelescope, Expr.hasLooseBVars, + Expr.looseBVarRange', Bind.bind, ReaderT.bind, StateT.bind, + Except.bind] + rw [show + Lean4Lean.TypeChecker.Inner.inferForall + (.forallE indexedVecIndexName (.const ``Nat []) + (.sort (.succ (.param `u))) .default) + false (Lean4Lean.TypeChecker.Methods.withFuel 9999) + (indexedVecTypeCheckerContext lctx) + ({} : Lean4Lean.TypeChecker.State) = + .ok (.sort indexedVecInnerInferredLevel, + indexedVecInnerSortState) by + simpa [indexedVecPreFamilyIndexTelescope] using + indexedVecPreFamilyIndexInferForall lctx] + rfl + private theorem indexedVecInner_whnfM : Lean4Lean.TypeChecker.M.run indexedVecKernelEnv .safe indexedVecParamCandidateContext.lctx [`u] ({} : FuelConfig) diff --git a/Lean4Lean/Verify/Environment/IndexedVecConstructors.lean b/Lean4Lean/Verify/Environment/IndexedVecConstructors.lean index 13301e2c..aeeb3ca7 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecConstructors.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecConstructors.lean @@ -964,7 +964,7 @@ theorem nilCandidateWhnfCoreInitial (n : Nat) : rw [nilCandidateWhnfCoreFamily n ({} : TypeChecker.State)] simp [nilCandidateBodyShape, nilCandidateBodyExpr, nilCandidateFirstApp, nilCandidateReduceRecursor, - Expr.eqv_eq, Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + Expr.structuralEq, Bind.bind, ReaderT.bind, StateT.bind, Except.bind] rw [show .app (.app (.const ``IndexedVec [.param `u]) (.fvar nilCandidateAlphaId)) (.const ``Nat.zero []) = @@ -982,7 +982,7 @@ theorem nilCandidateWhnfCoreInitial (n : Nat) : .ok (none, state) := by rw [nilCandidateBodyShape] simp [TypeChecker.Inner.reduceNative, nilCandidateBodyExpr, - nilCandidateFirstApp, Expr.eqv_eq] + nilCandidateFirstApp, Expr.structuralEq] @[simp] theorem nilCandidateReduceNat (methods : TypeChecker.Methods) (state : TypeChecker.State) : @@ -992,7 +992,7 @@ theorem nilCandidateWhnfCoreInitial (n : Nat) : rw [nilCandidateBodyShape] simp [TypeChecker.Inner.reduceNat, nilCandidateBodyExpr, nilCandidateFirstApp, Expr.getAppNumArgs_eq, - Expr.getAppArgsRevList, Expr.appFn!, Expr.eqv_const] + Expr.getAppArgsRevList, Expr.appFn!, Expr.structuralEq] theorem nilCandidateIsDeltaFamily : TypeChecker.Inner.isDelta ctorEnv @@ -1759,7 +1759,7 @@ theorem ctorIndexedVecWhnfCoreInitial index).getAppFn = Expr.const ``IndexedVec [.param `u] by rfl] rw [ctorIndexedVecWhnfCoreFamily lctx n ({} : TypeChecker.State)] simp [ctorIndexedVecApp, ctorIndexedVecReduceRecursor, - Expr.eqv_eq, Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + Expr.structuralEq, Bind.bind, ReaderT.bind, StateT.bind, Except.bind] rw [show Expr.app (Expr.app (Expr.const ``IndexedVec [.param `u]) alpha) index = ctorIndexedVecApp alpha index by rfl] @@ -1775,7 +1775,7 @@ theorem ctorIndexedVecWhnfCoreInitial TypeChecker.RecM (Option Expr)) methods (tcContext lctx) state = .ok (none, state) := by cases index <;> - simp [ctorIndexedVecApp, TypeChecker.Inner.reduceNative, Expr.eqv_eq] + simp [ctorIndexedVecApp, TypeChecker.Inner.reduceNative, Expr.structuralEq] @[simp] theorem ctorIndexedVecReduceNat (lctx : LocalContext) (alpha index : Expr) @@ -1784,7 +1784,7 @@ theorem ctorIndexedVecWhnfCoreInitial methods (tcContext lctx) state = .ok (none, state) := by simp [ctorIndexedVecApp, TypeChecker.Inner.reduceNat, Expr.getAppNumArgs_eq, Expr.getAppArgsRevList, - Expr.appFn!, Expr.eqv_const] + Expr.appFn!, Expr.structuralEq] theorem ctorIndexedVecUnfoldFamily (lctx : LocalContext) (methods : TypeChecker.Methods) diff --git a/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean index 6b088357..4cd4666b 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean @@ -1220,7 +1220,7 @@ theorem indexedVecValidationTailPositivity : rfl theorem indexedVecValidationNilLoopTerminal : - AddInductive.checkConstructors.loop + AddInductive.checkConstructorType.loop indexedVecCandidateInductiveStats false 0 indexedVecKernelNil.name indexedVecValidationNilResult 1 999 indexedVecCtorValidationContext = .ok () := by @@ -1235,19 +1235,19 @@ theorem indexedVecValidationNilLoopTerminal : indexedVecValidationAlphaShape] using indexedVecValidationNilResultIsValid unfold indexedVecValidationNilResult ctorIndexedVecApp - unfold AddInductive.checkConstructors.loop + unfold AddInductive.checkConstructorType.loop simp [hvalid, ReaderT.pure, Pure.pure, Except.pure] theorem indexedVecValidationNilLoop : - AddInductive.checkConstructors.loop + AddInductive.checkConstructorType.loop indexedVecCandidateInductiveStats false 0 indexedVecKernelNil.name indexedVecKernelNil.type 0 indexedVecCtorValidationContext.fuel.inductiveFuel indexedVecCtorValidationContext = .ok () := by rw [show indexedVecCtorValidationContext.fuel.inductiveFuel = 999 + 1 by rfl] - unfold AddInductive.checkConstructors.loop + unfold AddInductive.checkConstructorType.loop simp only [indexedVecKernelNil, indexedVecNilInfo, ConstantInfo.name, ConstantInfo.type, ConstantInfo.toConstantVal] rw [show indexedVecCandidateInductiveStats.params[0]? = @@ -1287,7 +1287,7 @@ theorem indexedVecValidationNilLoop : simp [ctorIndexedVecApp, AddInductive.consumeTypeAnnotations] theorem indexedVecValidationConsLoopTerminal : - AddInductive.checkConstructors.loop + AddInductive.checkConstructorType.loop indexedVecCandidateInductiveStats false 0 indexedVecKernelCons.name indexedVecValidationConsResult 4 996 indexedVecValidationTailContext = .ok () := by @@ -1303,17 +1303,17 @@ theorem indexedVecValidationConsLoopTerminal : indexedVecValidationNExprShape] using indexedVecValidationConsResultIsValid unfold indexedVecValidationConsResult ctorIndexedVecApp replaySuccApp - unfold AddInductive.checkConstructors.loop + unfold AddInductive.checkConstructorType.loop simp [hvalid, ReaderT.pure, Pure.pure, Except.pure] theorem indexedVecValidationConsLoopTail : - AddInductive.checkConstructors.loop + AddInductive.checkConstructorType.loop indexedVecCandidateInductiveStats false 0 indexedVecKernelCons.name indexedVecValidationConsAfterHead 3 997 indexedVecValidationHeadContext = .ok () := by rw [show 997 = 996 + 1 by rfl] unfold indexedVecValidationConsAfterHead - unfold AddInductive.checkConstructors.loop + unfold AddInductive.checkConstructorType.loop simp only rw [show indexedVecCandidateInductiveStats.params[3]? = none by simp [indexedVecValidationStatsParams]] @@ -1344,13 +1344,13 @@ theorem indexedVecValidationConsLoopTail : indexedVecValidationConsLoopTerminal theorem indexedVecValidationConsLoopHead : - AddInductive.checkConstructors.loop + AddInductive.checkConstructorType.loop indexedVecCandidateInductiveStats false 0 indexedVecKernelCons.name indexedVecValidationConsAfterN 2 998 indexedVecValidationNContext = .ok () := by rw [show 998 = 997 + 1 by rfl] unfold indexedVecValidationConsAfterN - unfold AddInductive.checkConstructors.loop + unfold AddInductive.checkConstructorType.loop simp only rw [show indexedVecCandidateInductiveStats.params[2]? = none by simp [indexedVecValidationStatsParams]] @@ -1387,13 +1387,13 @@ theorem indexedVecValidationConsLoopHead : indexedVecValidationConsLoopTail theorem indexedVecValidationConsLoopN : - AddInductive.checkConstructors.loop + AddInductive.checkConstructorType.loop indexedVecCandidateInductiveStats false 0 indexedVecKernelCons.name indexedVecValidationConsAfterParam 1 999 indexedVecCtorValidationContext = .ok () := by rw [show 999 = 998 + 1 by rfl] rw [indexedVecValidationConsAfterParamExplicitShape] - unfold AddInductive.checkConstructors.loop + unfold AddInductive.checkConstructorType.loop simp only rw [show indexedVecCandidateInductiveStats.params[1]? = none by simp [indexedVecValidationStatsParams]] @@ -1433,7 +1433,7 @@ theorem indexedVecValidationConsLoopN : indexedVecValidationConsLoopHead theorem indexedVecValidationConsLoop : - AddInductive.checkConstructors.loop + AddInductive.checkConstructorType.loop indexedVecCandidateInductiveStats false 0 indexedVecKernelCons.name indexedVecKernelCons.type 0 indexedVecCtorValidationContext.fuel.inductiveFuel @@ -1443,7 +1443,7 @@ theorem indexedVecValidationConsLoop : rw [show indexedVecKernelCons.type = consCtorTypeRaw by simpa [indexedVecKernelCons] using consInfoTypeShape] unfold consCtorTypeRaw - unfold AddInductive.checkConstructors.loop + unfold AddInductive.checkConstructorType.loop simp only rw [show indexedVecCandidateInductiveStats.params[0]? = some indexedVecValidationAlpha by @@ -1459,6 +1459,174 @@ theorem indexedVecValidationConsLoop : simpa [indexedVecValidationConsAfterParam] using indexedVecValidationConsLoopN +theorem indexedVecValidationNilUniverseLoopTerminal : + AddInductive.checkConstructorUniverseSemantics.loop + indexedVecCandidateInductiveStats indexedVecValidationNilResult 1 999 + indexedVecCtorValidationContext = .ok () := by + rw [show 999 = 998 + 1 by rfl] + unfold AddInductive.checkConstructorUniverseSemantics.loop + rfl + +theorem indexedVecValidationNilUniverseLoop : + AddInductive.checkConstructorUniverseSemantics.loop + indexedVecCandidateInductiveStats indexedVecKernelNil.type 0 + indexedVecCtorValidationContext.fuel.inductiveFuel + indexedVecCtorValidationContext = .ok () := by + rw [show indexedVecCtorValidationContext.fuel.inductiveFuel = + 999 + 1 by rfl] + unfold AddInductive.checkConstructorUniverseSemantics.loop + simp only [indexedVecKernelNil, indexedVecNilInfo, + ConstantInfo.type, ConstantInfo.toConstantVal] + rw [show indexedVecCandidateInductiveStats.params[0]? = + some indexedVecValidationAlpha by + simp [indexedVecValidationStatsParams]] + simpa [indexedVecValidationNilResult, ctorIndexedVecApp, + indexedVecKernelNil, indexedVecNilInfo, ConstantInfo.toConstantVal, + Expr.instantiate1_eq, Expr.instantiate1', + Expr.liftLooseBVars_zero] using + indexedVecValidationNilUniverseLoopTerminal + +theorem indexedVecValidationConsUniverseLoopTerminal : + AddInductive.checkConstructorUniverseSemantics.loop + indexedVecCandidateInductiveStats indexedVecValidationConsResult 4 996 + indexedVecValidationTailContext = .ok () := by + rw [show 996 = 995 + 1 by rfl] + unfold AddInductive.checkConstructorUniverseSemantics.loop + rfl + +theorem indexedVecValidationConsUniverseLoopTail : + AddInductive.checkConstructorUniverseSemantics.loop + indexedVecCandidateInductiveStats indexedVecValidationConsAfterHead 3 997 + indexedVecValidationHeadContext = .ok () := by + rw [show 997 = 996 + 1 by rfl] + unfold indexedVecValidationConsAfterHead + unfold AddInductive.checkConstructorUniverseSemantics.loop + simp only + rw [show indexedVecCandidateInductiveStats.params[3]? = none by + simp [indexedVecValidationStatsParams]] + 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 [AddInductive.withLocalDecl_apply] + simpa [indexedVecValidationTailContext, + AddInductive.Context.pushLocalDecl, + AddInductive.consumeTypeAnnotations, + indexedVecValidationConsResult, ctorIndexedVecApp, + replaySuccApp, Expr.instantiate1_eq, Expr.instantiate1'] using + indexedVecValidationConsUniverseLoopTerminal + +theorem indexedVecValidationConsUniverseLoopHead : + AddInductive.checkConstructorUniverseSemantics.loop + indexedVecCandidateInductiveStats indexedVecValidationConsAfterN 2 998 + indexedVecValidationNContext = .ok () := by + rw [show 998 = 997 + 1 by rfl] + unfold indexedVecValidationConsAfterN + unfold AddInductive.checkConstructorUniverseSemantics.loop + simp only + rw [show indexedVecCandidateInductiveStats.params[2]? = none by + simp [indexedVecValidationStatsParams]] + 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 [AddInductive.withLocalDecl_apply] + simpa [indexedVecValidationHeadContext, + AddInductive.Context.pushLocalDecl, + AddInductive.consumeTypeAnnotations, + indexedVecValidationConsAfterHead, + ctorIndexedVecApp, replaySuccApp, + Expr.instantiate1_eq, Expr.instantiate1'] using + indexedVecValidationConsUniverseLoopTail + +theorem indexedVecValidationConsUniverseLoopN : + AddInductive.checkConstructorUniverseSemantics.loop + indexedVecCandidateInductiveStats indexedVecValidationConsAfterParam 1 999 + indexedVecCtorValidationContext = .ok () := by + rw [show 999 = 998 + 1 by rfl] + rw [indexedVecValidationConsAfterParamExplicitShape] + unfold AddInductive.checkConstructorUniverseSemantics.loop + simp only + rw [show indexedVecCandidateInductiveStats.params[1]? = none by + simp [indexedVecValidationStatsParams]] + 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 [AddInductive.withLocalDecl_apply] + simpa [indexedVecValidationNContext, + AddInductive.Context.pushLocalDecl, + AddInductive.consumeTypeAnnotations, + indexedVecValidationConsAfterN, + ctorIndexedVecApp, replaySuccApp, + indexedVecValidationNExpr, + AddInductive.Context.freshExpr, + Expr.instantiate1_eq, Expr.instantiate1'] using + indexedVecValidationConsUniverseLoopHead + +theorem indexedVecValidationConsUniverseLoop : + AddInductive.checkConstructorUniverseSemantics.loop + indexedVecCandidateInductiveStats indexedVecKernelCons.type 0 + indexedVecCtorValidationContext.fuel.inductiveFuel + indexedVecCtorValidationContext = .ok () := by + rw [show indexedVecCtorValidationContext.fuel.inductiveFuel = + 999 + 1 by rfl] + rw [show indexedVecKernelCons.type = consCtorTypeRaw by + simpa [indexedVecKernelCons] using consInfoTypeShape] + unfold consCtorTypeRaw + unfold AddInductive.checkConstructorUniverseSemantics.loop + simp only + rw [show indexedVecCandidateInductiveStats.params[0]? = + some indexedVecValidationAlpha by + simp [indexedVecValidationStatsParams]] + simpa [indexedVecValidationConsAfterParam] using + indexedVecValidationConsUniverseLoopN + +theorem indexedVecValidationNilUniverseRun : + AddInductive.checkConstructorUniverseSemantics + indexedVecCandidateInductiveStats indexedVecKernelNil.type + indexedVecCtorValidationContext = .ok () := by + unfold AddInductive.checkConstructorUniverseSemantics + simpa only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] using indexedVecValidationNilUniverseLoop + +theorem indexedVecValidationConsUniverseRun : + AddInductive.checkConstructorUniverseSemantics + indexedVecCandidateInductiveStats indexedVecKernelCons.type + indexedVecCtorValidationContext = .ok () := by + unfold AddInductive.checkConstructorUniverseSemantics + simpa only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] using indexedVecValidationConsUniverseLoop + +/-- Both source-ordered `IndexedVec` constructors pass the executable verified +universe gate. -/ +theorem indexedVecValidationCheckConstructorUniverseSemantics : + AddInductive.checkConstructorUniverseListSemantics + indexedVecCandidateInductiveStats indexedVecKernelType.ctors + indexedVecCtorValidationContext = .ok () := by + unfold AddInductive.checkConstructorUniverseListSemantics + simp only [indexedVecKernelType, ReaderT.bind, Bind.bind] + rw [indexedVecValidationNilUniverseRun] + simp only [Except.bind] + unfold AddInductive.checkConstructorUniverseListSemantics + simp only [ReaderT.bind, Bind.bind] + rw [indexedVecValidationConsUniverseRun] + rfl + theorem indexedVecValidationGetEnvM : TypeChecker.M.run indexedVecCtorValidationContext.env indexedVecCtorValidationContext.safety @@ -1490,6 +1658,7 @@ 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, @@ -1507,9 +1676,11 @@ theorem indexedVecValidationCheckConstructors : rw [AddInductive.withEmptyLocalContext_apply] rw [AddInductive.liftTypeChecker_apply] rw [indexedVecValidationNilRootCheckTypeM] + unfold AddInductive.checkConstructorType simp only [Except.bind, readThe, MonadReaderOf.read, ReaderT.read, - ReaderT.pure, Pure.pure, Except.pure] + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, Except.pure] rw [indexedVecValidationNilLoop] + unfold AddInductive.checkConstructorFold simp only [Except.bind, ReaderT.pure, Pure.pure, Except.pure] rw [indexedVecValidationNilSetDoesNotContainCons] simp only [Bool.false_eq_true, if_false, @@ -1521,9 +1692,11 @@ theorem indexedVecValidationCheckConstructors : rw [AddInductive.withEmptyLocalContext_apply] rw [AddInductive.liftTypeChecker_apply] rw [indexedVecValidationConsRootCheckTypeM] + unfold AddInductive.checkConstructorType simp only [Except.bind, readThe, MonadReaderOf.read, ReaderT.read, - ReaderT.pure, Pure.pure, Except.pure] + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, Except.pure] rw [indexedVecValidationConsLoop] + unfold AddInductive.checkConstructorFold rfl /-- The complete one-parameter, one-index IndexedVec request produces the diff --git a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean index cc54fa9e..b7eeac2a 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean @@ -213,32 +213,38 @@ theorem indexedVecSemanticConsSourceTr : exact hshape.to_trExprS indexedVecTypeEnv_ordered trivial ⟨.sort u, htype⟩ -def indexedVecStagedSemanticInput : - VInductDecl.StagedNormalizationCandidateSemanticInput +noncomputable def indexedVecStagedUniverseInput : + VInductDecl.StagedNormalizationCandidateUniverseInput indexedVecFamilyCandidateContext ctorContext natFinalEnv [`u] indexedVecNormalizationCandidate indexedVecDecl where - raw := indexedVecType - raw_types_eq := rfl - declaration_uvars_eq := rfl - preFamily := indexedVecPreFamilyStage - family := indexedVecFamilyStage - constructors := .cons { - name_eq := rfl - uvars_eq := rfl - type := { - context_eq := rfl - source_tr := indexedVecSemanticNilSourceTr - whnfFuel := 9999 - whnfDepth := rfl } } (.cons { - name_eq := rfl - uvars_eq := rfl - type := { - context_eq := rfl - source_tr := indexedVecSemanticConsSourceTr - whnfFuel := 9999 - whnfDepth := rfl } } .nil) - familyTypesProduced := indexedVecFamilyTypeListProduced - familiesProduced := indexedVecFamilyListProduced + staged := { + raw := indexedVecType + raw_types_eq := rfl + declaration_uvars_eq := rfl + preFamily := indexedVecPreFamilyStage + family := indexedVecFamilyStage + validation_nparams_eq := rfl + constructorValidation := + AddInductive.ConstructorValidationRun.of_run + indexedVecValidationCheckConstructors + constructors := .cons { + name_eq := rfl + uvars_eq := rfl + type := { + context_eq := rfl + source_tr := indexedVecSemanticNilSourceTr + whnfFuel := 9999 + whnfDepth := rfl } } (.cons { + name_eq := rfl + uvars_eq := rfl + type := { + context_eq := rfl + source_tr := indexedVecSemanticConsSourceTr + whnfFuel := 9999 + whnfDepth := rfl } } .nil) + familyTypesProduced := indexedVecFamilyTypeListProduced + familiesProduced := indexedVecFamilyListProduced } + universeRun := indexedVecValidationCheckConstructorUniverseSemantics /-- Generic automatic assembly joins the arbitrary-length operational list witnesses to the complete retained semantic hierarchy for the two-constructor @@ -247,7 +253,7 @@ theorem indexedVecProducedSemanticHierarchy_exists : Nonempty (VInductDecl.ProducedNormalizationCandidateSemanticRun indexedVecFamilyCandidateContext ctorContext natFinalEnv [`u] indexedVecNormalizationCandidate indexedVecDecl) := - indexedVecStagedSemanticInput.exists + indexedVecStagedUniverseInput.exists /-- The automatically assembled hierarchy retains both constructor headers in the producer's `nil`/`cons` source order. This inspects the semantic result, @@ -268,6 +274,2342 @@ theorem indexedVecProducedSemanticHierarchy_constructorHeaders : simpa only [hraw] using run.semantic.family.root.constructors.sameHeaders⟩ +/-! ## Post-family constructor alignment -/ + +private theorem indexedVecValidationSortCheckTypeM (lctx : LocalContext) : + TypeChecker.M.run ctorEnv .safe lctx [`u] ({} : FuelConfig) + (TypeChecker.checkType (.sort (.succ (.param `u)))) = + .ok (.sort (.succ (.succ (.param `u)))) := by + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' + (.sort (.succ (.param `u))) false + (TypeChecker.Methods.withFuel 9999) (tcContext lctx) + ({} : TypeChecker.State)) = _ + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + checkLevelSuccParam, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + rfl + +private def indexedVecValidationZeroState (alphaId : FVarId) : + TypeChecker.State := + replayInsert (validationFirstAppState alphaId) + (.const ``Nat.zero []) (.const ``Nat []) + +private def indexedVecValidationZeroFinalState (alphaId : FVarId) : + TypeChecker.State := + replayInsert (indexedVecValidationZeroState alphaId) + (ctorIndexedVecApp (.fvar alphaId) (.const ``Nat.zero [])) + (.sort (.succ (.param `u))) + +private theorem indexedVecValidationZeroCheckTypeM + (lctx : LocalContext) (alphaId : FVarId) + (halpha : lctx.find? alphaId = some (.cdecl alphaIndex alphaId + alphaName (.sort (.succ (.param `u))) alphaBi alphaKind)) : + TypeChecker.M.run ctorEnv .safe lctx [`u] ({} : FuelConfig) + (TypeChecker.checkType + (ctorIndexedVecApp (.fvar alphaId) (.const ``Nat.zero []))) = + .ok (.sort (.succ (.param `u))) := by + have hfirst : + TypeChecker.Inner.inferType' (replayFirstApp (.fvar alphaId)) false + (TypeChecker.Methods.withFuel 9999) (tcContext lctx) + ({} : TypeChecker.State) = + .ok (vecFamilyTail, validationFirstAppState alphaId) := by + simpa [validationFirstAppState] using + (replayInferFirstAppFVarCore 9999 lctx + ({} : TypeChecker.State) alphaId + (by simp) + (by simp [replayInsert]) + (by simp [replayFirstApp]) halpha) + have hzero : + TypeChecker.Inner.inferType' (.const ``Nat.zero []) false + (TypeChecker.Methods.withFuel 9999) (tcContext lctx) + (validationFirstAppState alphaId) = + .ok (.const ``Nat [], indexedVecValidationZeroState alphaId) := by + simpa [indexedVecValidationZeroState, replayInsert] using + (inferTypeZeroCore 9999 lctx (validationFirstAppState alphaId) + (by simp [validationFirstAppState, replayInsert, + replayFirstApp])) + have hresult : + TypeChecker.Inner.inferType' + (ctorIndexedVecApp (.fvar alphaId) (.const ``Nat.zero [])) false + (TypeChecker.Methods.withFuel 9999) (tcContext lctx) + ({} : TypeChecker.State) = + .ok (.sort (.succ (.param `u)), + indexedVecValidationZeroFinalState alphaId) := by + simpa [indexedVecValidationZeroFinalState] using + (replayInferIndexedVecAppCore 9999 lctx + ({} : TypeChecker.State) (validationFirstAppState alphaId) + (indexedVecValidationZeroState alphaId) (.fvar alphaId) + (.const ``Nat.zero []) + (by simp [ctorIndexedVecApp, Expr.hasLooseBVars, + Expr.looseBVarRange']) + (by simp [ctorIndexedVecApp]) + hfirst hzero (by rfl)) + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' + (ctorIndexedVecApp (.fvar alphaId) (.const ``Nat.zero [])) false + (TypeChecker.Methods.withFuel 9999) (tcContext lctx) + ({} : TypeChecker.State)) = _ + rw [hresult] + rfl + +private def indexedVecValidationSuccState + (alphaId nId : FVarId) : TypeChecker.State := + replayInsert + (replayInsert + (replayInsert (validationFirstAppState alphaId) + (.const ``Nat.succ []) + (.forallE `n (.const ``Nat []) (.const ``Nat []) .default)) + (.fvar nId) (.const ``Nat [])) + (replaySuccApp (.fvar nId)) (.const ``Nat []) + +private def indexedVecValidationSuccFinalState + (alphaId nId : FVarId) : TypeChecker.State := + replayInsert (indexedVecValidationSuccState alphaId nId) + (ctorIndexedVecApp (.fvar alphaId) (replaySuccApp (.fvar nId))) + (.sort (.succ (.param `u))) + +private theorem indexedVecValidationSuccCheckTypeM + (lctx : LocalContext) (alphaId nId : FVarId) + (hne : alphaId ≠ nId) + (halpha : lctx.find? alphaId = some (.cdecl alphaIndex alphaId + alphaName (.sort (.succ (.param `u))) alphaBi alphaKind)) + (hn : lctx.find? nId = some (.cdecl nIndex nId nName + (.const ``Nat []) nBi nKind)) : + TypeChecker.M.run ctorEnv .safe lctx [`u] ({} : FuelConfig) + (TypeChecker.checkType + (ctorIndexedVecApp (.fvar alphaId) + (replaySuccApp (.fvar nId)))) = + .ok (.sort (.succ (.param `u))) := by + have hfirst : + TypeChecker.Inner.inferType' (replayFirstApp (.fvar alphaId)) false + (TypeChecker.Methods.withFuel 9999) (tcContext lctx) + ({} : TypeChecker.State) = + .ok (vecFamilyTail, validationFirstAppState alphaId) := by + simpa [validationFirstAppState] using + (replayInferFirstAppFVarCore 9999 lctx + ({} : TypeChecker.State) alphaId + (by simp) + (by simp [replayInsert]) + (by simp [replayFirstApp]) halpha) + have hsucc : + TypeChecker.Inner.inferType' (replaySuccApp (.fvar nId)) false + (TypeChecker.Methods.withFuel 9999) (tcContext lctx) + (validationFirstAppState alphaId) = + .ok (.const ``Nat [], indexedVecValidationSuccState alphaId nId) := by + simpa [indexedVecValidationSuccState] using + (replayInferSuccFVarCore 9999 lctx + (validationFirstAppState alphaId) nId + (by simp [validationFirstAppState, replayInsert, + replayFirstApp]) + (by + simp only [validationFirstAppState, replayInsert, + Std.HashMap.getElem?_insert] + rw [constBeqFVar] + rw [show (replayFirstApp (.fvar alphaId) == + (.fvar nId : Expr)) = false by + simp [replayFirstApp]] + rw [show ((.fvar alphaId : Expr) == .fvar nId) = false by + change Expr.eqv (.fvar alphaId) (.fvar nId) = false + rw [Expr.eqv_eq] + simp [Expr.eqv', hne]] + rw [constBeqFVar] + simp) + (by simp [validationFirstAppState, replayInsert, + replaySuccApp]) + hn) + have hresult : + TypeChecker.Inner.inferType' + (ctorIndexedVecApp (.fvar alphaId) + (replaySuccApp (.fvar nId))) false + (TypeChecker.Methods.withFuel 9999) (tcContext lctx) + ({} : TypeChecker.State) = + .ok (.sort (.succ (.param `u)), + indexedVecValidationSuccFinalState alphaId nId) := by + simpa [indexedVecValidationSuccFinalState] using + (replayInferIndexedVecAppCore 9999 lctx + ({} : TypeChecker.State) (validationFirstAppState alphaId) + (indexedVecValidationSuccState alphaId nId) (.fvar alphaId) + (replaySuccApp (.fvar nId)) + (by simp [ctorIndexedVecApp, replaySuccApp, + Expr.hasLooseBVars, Expr.looseBVarRange']) + (by simp [ctorIndexedVecApp, replaySuccApp]) + hfirst hsucc (by rfl)) + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' + (ctorIndexedVecApp (.fvar alphaId) + (replaySuccApp (.fvar nId))) false + (TypeChecker.Methods.withFuel 9999) (tcContext lctx) + ({} : TypeChecker.State)) = _ + rw [hresult] + rfl + +private theorem indexedVecValidationHeadContextFresh : + indexedVecValidationHeadContext.lctx.find? + indexedVecValidationHeadContext.freshFVarId = none := by + have h := LocalContext.WF.find?_eq_find?_toList + (fv := indexedVecValidationHeadContext.freshFVarId) + indexedVecValidationHeadContextWF + rw [h] + simp only [indexedVecValidationHeadContext, + indexedVecValidationNContext, indexedVecCtorValidationContext, + indexedVecValidationTerminalContextShape, + indexedVecValidationFamilyContext, + indexedVecValidationParamContext, + indexedVecFamilyCandidateContext, + AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshFVarId] + rw [LocalContext.mkLocalDecl_toList, + LocalContext.mkLocalDecl_toList, + LocalContext.mkLocalDecl_toList, + LocalContext.mkLocalDecl_toList] + rw [show ({} : LocalContext).toList = [] by rfl] + simp +decide + +private theorem indexedVecValidationAlphaFindInTail : + indexedVecValidationTailContext.lctx.find? + indexedVecValidationAlphaId = + some (.cdecl 0 indexedVecValidationAlphaId + indexedVecValidationParamName + (.sort (.succ (.param `u))) .default .default) := by + have hfresh := indexedVecValidationHeadContextFresh + have hne : indexedVecValidationAlphaId ≠ + indexedVecValidationTailId := by + change indexedVecValidationAlphaId ≠ + indexedVecValidationHeadContext.freshFVarId + intro heq + rw [← heq] at hfresh + rw [indexedVecValidationAlphaFindInHead] at hfresh + contradiction + have h := localContextFindOld + (lctx := indexedVecValidationHeadContext.lctx) + (oldId := indexedVecValidationAlphaId) + (newId := indexedVecValidationTailId) + (newName := consTailName) + (newType := ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) + (newBi := .default) (newKind := .default) + (oldDecl := .cdecl 0 indexedVecValidationAlphaId + indexedVecValidationParamName (.sort (.succ (.param `u))) + .default .default) + indexedVecValidationHeadContextWF + hfresh hne + indexedVecValidationAlphaFindInHead + simpa [indexedVecValidationTailContext, + indexedVecValidationTailId, + AddInductive.Context.pushLocalDecl] using h + +private theorem indexedVecValidationNFindInTail : + indexedVecValidationTailContext.lctx.find? + indexedVecValidationNId = + some (.cdecl 2 indexedVecValidationNId consNName + (.const ``Nat []) .implicit .default) := by + have hfresh := indexedVecValidationHeadContextFresh + have hne : indexedVecValidationNId ≠ + indexedVecValidationTailId := by + change indexedVecValidationNId ≠ + indexedVecValidationHeadContext.freshFVarId + intro heq + rw [← heq] at hfresh + rw [indexedVecValidationNFindInHead] at hfresh + contradiction + have h := localContextFindOld + (lctx := indexedVecValidationHeadContext.lctx) + (oldId := indexedVecValidationNId) + (newId := indexedVecValidationTailId) + (newName := consTailName) + (newType := ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) + (newBi := .default) (newKind := .default) + (oldDecl := .cdecl 2 indexedVecValidationNId consNName + (.const ``Nat []) .implicit .default) + indexedVecValidationHeadContextWF + hfresh hne + indexedVecValidationNFindInHead + simpa [indexedVecValidationTailContext, + indexedVecValidationTailId, + AddInductive.Context.pushLocalDecl] using h + +private theorem indexedVecValidationSortCheckValid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨indexedVecCtorValidationContext, + .sort (.succ (.param `u)), + .sort (.succ (.succ (.param `u)))⟩ := by + change TypeChecker.M.run ctorEnv .safe + indexedVecCtorValidationContext.lctx [`u] ({} : FuelConfig) + (TypeChecker.checkType (.sort (.succ (.param `u)))) = _ + exact indexedVecValidationSortCheckTypeM + indexedVecCtorValidationContext.lctx + +private theorem indexedVecValidationNatCheckValid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨indexedVecCtorValidationContext, .const ``Nat [], + .sort (.succ .zero)⟩ := by + change TypeChecker.M.run ctorEnv .safe + indexedVecCtorValidationContext.lctx [`u] ({} : FuelConfig) + (TypeChecker.checkType (.const ``Nat [])) = _ + exact ctorNatCheckTypeM indexedVecCtorValidationContext.lctx + +private theorem indexedVecValidationAlphaCheckValid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨indexedVecValidationNContext, indexedVecValidationAlpha, + .sort (.succ (.param `u))⟩ := by + change TypeChecker.M.run ctorEnv .safe + indexedVecValidationNContext.lctx [`u] ({} : FuelConfig) + (TypeChecker.checkType (.fvar indexedVecValidationAlphaId)) = _ + exact ctorFVarCheckTypeM indexedVecValidationNContext.lctx + indexedVecValidationAlphaId (.sort (.succ (.param `u))) + indexedVecValidationAlphaFindInN + +private theorem indexedVecValidationTailCheckValid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨indexedVecValidationHeadContext, + ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr, + .sort (.succ (.param `u))⟩ := by + change TypeChecker.M.run ctorEnv .safe + indexedVecValidationHeadContext.lctx [`u] ({} : FuelConfig) + (TypeChecker.checkType + (ctorIndexedVecApp (.fvar indexedVecValidationAlphaId) + (.fvar indexedVecValidationNId))) = _ + exact ctorIndexedVecFVarCheckTypeM + indexedVecValidationHeadContext.lctx + indexedVecValidationAlphaId indexedVecValidationNId + indexedVecValidationAlphaNeN indexedVecValidationAlphaFindInHead + indexedVecValidationNFindInHead + +private theorem indexedVecValidationNilResultCheckValid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨indexedVecCtorValidationContext, indexedVecValidationNilResult, + .sort (.succ (.param `u))⟩ := by + change TypeChecker.M.run ctorEnv .safe + indexedVecCtorValidationContext.lctx [`u] ({} : FuelConfig) + (TypeChecker.checkType + (ctorIndexedVecApp (.fvar indexedVecValidationAlphaId) + (.const ``Nat.zero []))) = _ + exact indexedVecValidationZeroCheckTypeM + indexedVecCtorValidationContext.lctx indexedVecValidationAlphaId + indexedVecValidationAlphaFind + +private theorem indexedVecValidationConsResultCheckValid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨indexedVecValidationTailContext, indexedVecValidationConsResult, + .sort (.succ (.param `u))⟩ := by + change TypeChecker.M.run ctorEnv .safe + indexedVecValidationTailContext.lctx [`u] ({} : FuelConfig) + (TypeChecker.checkType + (ctorIndexedVecApp (.fvar indexedVecValidationAlphaId) + (replaySuccApp (.fvar indexedVecValidationNId)))) = _ + exact indexedVecValidationSuccCheckTypeM + indexedVecValidationTailContext.lctx + indexedVecValidationAlphaId indexedVecValidationNId + indexedVecValidationAlphaNeN + indexedVecValidationAlphaFindInTail + indexedVecValidationNFindInTail + +private def indexedVecCheckedOfValid + (context : AddInductive.Context) (source inferred : Expr) + (fvars : source.FVarsIn + (fun fv => (context.lctx.find? fv).isSome = true)) + (valid : AddInductive.CandidateCheckTypeStep.Valid + ⟨context, source, inferred⟩) : + AddInductive.ConstructorCheckedExpr context source := + .ofRun fvars valid + +private def indexedVecValidationSortChecked : + AddInductive.ConstructorCheckedExpr indexedVecCtorValidationContext + (.sort (.succ (.param `u))) := + indexedVecCheckedOfValid _ _ _ (by + simp [FVarsIn, Level.hasMVar']) + indexedVecValidationSortCheckValid + +private def indexedVecValidationNatChecked : + AddInductive.ConstructorCheckedExpr indexedVecCtorValidationContext + (.const ``Nat []) := + indexedVecCheckedOfValid _ _ _ (by simp [FVarsIn]) + indexedVecValidationNatCheckValid + +private def indexedVecValidationAlphaChecked : + AddInductive.ConstructorCheckedExpr indexedVecValidationNContext + indexedVecValidationAlpha := + indexedVecCheckedOfValid _ _ _ (by + change (indexedVecValidationNContext.lctx.find? + indexedVecValidationAlphaId).isSome = true + rw [indexedVecValidationAlphaFindInN] + rfl) + indexedVecValidationAlphaCheckValid + +private def indexedVecValidationTailChecked : + AddInductive.ConstructorCheckedExpr indexedVecValidationHeadContext + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) := + indexedVecCheckedOfValid _ _ _ (by + simp [ctorIndexedVecApp, indexedVecValidationAlpha, + indexedVecValidationNExpr, AddInductive.Context.freshExpr, + FVarsIn, Level.hasMVar'] + constructor + · change (indexedVecValidationHeadContext.lctx.find? + indexedVecValidationAlphaId).isSome = true + rw [indexedVecValidationAlphaFindInHead] + rfl + · change (indexedVecValidationHeadContext.lctx.find? + indexedVecValidationNId).isSome = true + rw [indexedVecValidationNFindInHead] + rfl) + indexedVecValidationTailCheckValid + +private def indexedVecValidationNilResultChecked : + AddInductive.ConstructorCheckedExpr indexedVecCtorValidationContext + indexedVecValidationNilResult := + indexedVecCheckedOfValid _ _ _ (by + simp [indexedVecValidationNilResult, ctorIndexedVecApp, + indexedVecValidationAlpha, + AddInductive.Context.freshExpr, FVarsIn, Level.hasMVar'] + change (indexedVecCtorValidationContext.lctx.find? + indexedVecValidationAlphaId).isSome = true + rw [indexedVecValidationAlphaFind] + rfl) + indexedVecValidationNilResultCheckValid + +private def indexedVecValidationConsResultChecked : + AddInductive.ConstructorCheckedExpr indexedVecValidationTailContext + indexedVecValidationConsResult := + indexedVecCheckedOfValid _ _ _ (by + simp [indexedVecValidationConsResult, ctorIndexedVecApp, + replaySuccApp, indexedVecValidationAlpha, + indexedVecValidationNExpr, AddInductive.Context.freshExpr, + FVarsIn, Level.hasMVar'] + constructor + · change (indexedVecValidationTailContext.lctx.find? + indexedVecValidationAlphaId).isSome = true + rw [indexedVecValidationAlphaFindInTail] + rfl + · change (indexedVecValidationTailContext.lctx.find? + indexedVecValidationNId).isSome = true + rw [indexedVecValidationNFindInTail] + rfl) + indexedVecValidationConsResultCheckValid + +private theorem indexedVecStagedStats_eq : + indexedVecStagedUniverseInput.staged.family.validation.stats = + indexedVecCandidateInductiveStats := rfl + +private theorem indexedVecValidationPostContext_eq : + { indexedVecNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with + env := ctorContext.env } = indexedVecCtorValidationContext := rfl + +private def indexedVecTransportValidationTrace + {context context' : AddInductive.Context} + (context_eq : context = context') + {source source' : Expr} (source_eq : source = source') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) : + AddInductive.ConstructorTypeValidationTrace stats isUnsafe familyIdx ctor + context' source' argIdx fuel := by + subst context' + subst source' + exact trace + +private def indexedVecTransportViewAlignment + {context context' : AddInductive.Context} + (context_eq : context = context') + {source source' view view' : Expr} + (source_eq : source = source') (view_eq : view = view') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) + (alignment : AddInductive.ConstructorViewAlignmentTrace + (indexedVecTransportValidationTrace context_eq source_eq trace) + view') : + AddInductive.ConstructorViewAlignmentTrace trace view := by + subst context' + subst source' + subst view' + exact alignment + +@[simp] private theorem indexedVecTransportValidationTrace_spineLength + {context context' : AddInductive.Context} + (context_eq : context = context') + {source source' : Expr} (source_eq : source = source') + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) : + (indexedVecTransportValidationTrace context_eq source_eq trace).spineLength = + trace.spineLength := by + subst context' + subst source' + rfl + +private theorem indexedVecValidationNatWhnfSelf : + AddInductive.CandidateWhnfStep.Valid + ⟨indexedVecCtorValidationContext, .const ``Nat [], + .const ``Nat []⟩ := by + change TypeChecker.M.run ctorEnv .safe + indexedVecCtorValidationContext.lctx [`u] ({} : FuelConfig) + (TypeChecker.whnf (.const ``Nat [])) = .ok (.const ``Nat []) + exact ctorNatWhnfM indexedVecCtorValidationContext.lctx + +private theorem indexedVecValidationAlphaWhnfSelf : + AddInductive.CandidateWhnfStep.Valid + ⟨indexedVecValidationNContext, indexedVecValidationAlpha, + indexedVecValidationAlpha⟩ := by + change TypeChecker.M.run ctorEnv .safe + indexedVecValidationNContext.lctx [`u] ({} : FuelConfig) + (TypeChecker.whnf (.fvar indexedVecValidationAlphaId)) = + .ok (.fvar indexedVecValidationAlphaId) + exact ctorFVarWhnfM indexedVecValidationNContext.lctx + indexedVecValidationAlphaId indexedVecValidationAlphaFindInN + +private theorem indexedVecValidationTailWhnfSelf : + AddInductive.CandidateWhnfStep.Valid + ⟨indexedVecValidationHeadContext, + ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr, + ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr⟩ := by + change TypeChecker.M.run ctorEnv .safe + indexedVecValidationHeadContext.lctx [`u] ({} : FuelConfig) + (TypeChecker.whnf + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr)) = + .ok (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) + exact ctorIndexedVecWhnfM indexedVecValidationHeadContext.lctx + indexedVecValidationAlpha indexedVecValidationNExpr + +private theorem indexedVecCandidateWhnfResult_eq + (self : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, source⟩) + (other : AddInductive.CandidateWhnfStep.Valid + ⟨context, source, result⟩) : + result = source := by + unfold AddInductive.CandidateWhnfStep.Valid at self other + rw [self] at other + exact (Except.ok.inj other).symm + +private noncomputable def indexedVecValidationNatPositivityAlignment + (trace : AddInductive.ConstructorPositivityModeTrace + indexedVecStagedUniverseInput.staged.family.validation.stats false + indexedVecKernelCons.name 1 indexedVecCtorValidationContext + (.const ``Nat [])) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := by + cases trace with + | skipped unsafeEq => contradiction + | safe unsafeEq positivityTrace => + apply AddInductive.ConstructorPositivityModeAlignmentTrace.safe + cases positivityTrace with + | absent context source result fuel whnf occurs => + have result_eq := indexedVecCandidateWhnfResult_eq + indexedVecValidationNatWhnfSelf whnf + subst result + exact .absent indexedVecValidationNatChecked + | forallE context source fuel name domain body binderInfo whnf occurs + domainFree tail => + have result_eq := indexedVecCandidateWhnfResult_eq + indexedVecValidationNatWhnfSelf whnf + have impossible := congrArg Expr.isForall result_eq + simp [Expr.isForall] at impossible + | target context source result fuel targetIdx whnf occurs terminal valid => + have result_eq := indexedVecCandidateWhnfResult_eq + indexedVecValidationNatWhnfSelf whnf + subst result + rw [indexedVecStagedStats_eq, + indexedVecValidationNatHasNoIndOcc] at occurs + contradiction + +private noncomputable def indexedVecValidationAlphaPositivityAlignment + (trace : AddInductive.ConstructorPositivityModeTrace + indexedVecStagedUniverseInput.staged.family.validation.stats false + indexedVecKernelCons.name 2 indexedVecValidationNContext + indexedVecValidationAlpha) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := by + cases trace with + | skipped unsafeEq => contradiction + | safe unsafeEq positivityTrace => + apply AddInductive.ConstructorPositivityModeAlignmentTrace.safe + cases positivityTrace with + | absent context source result fuel whnf occurs => + have result_eq := indexedVecCandidateWhnfResult_eq + indexedVecValidationAlphaWhnfSelf whnf + subst result + exact .absent indexedVecValidationAlphaChecked + | forallE context source fuel name domain body binderInfo whnf occurs + domainFree tail => + have result_eq := indexedVecCandidateWhnfResult_eq + indexedVecValidationAlphaWhnfSelf whnf + have impossible := congrArg Expr.isForall result_eq + simp [indexedVecValidationAlphaShape, Expr.isForall] at impossible + | target context source result fuel targetIdx whnf occurs terminal valid => + have result_eq := indexedVecCandidateWhnfResult_eq + indexedVecValidationAlphaWhnfSelf whnf + subst result + rw [indexedVecStagedStats_eq] at occurs + change AddInductive.hasIndOcc + indexedVecCandidateInductiveStats.indConsts + indexedVecValidationAlpha = true at occurs + rw [indexedVecValidationAlphaHasNoIndOcc] at occurs + contradiction + +private noncomputable def indexedVecValidationTailPositivityAlignment + (trace : AddInductive.ConstructorPositivityModeTrace + indexedVecStagedUniverseInput.staged.family.validation.stats false + indexedVecKernelCons.name 3 indexedVecValidationHeadContext + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr)) : + AddInductive.ConstructorPositivityModeAlignmentTrace trace := by + cases trace with + | skipped unsafeEq => contradiction + | safe unsafeEq positivityTrace => + apply AddInductive.ConstructorPositivityModeAlignmentTrace.safe + cases positivityTrace with + | absent context source result fuel whnf occurs => + have result_eq := indexedVecCandidateWhnfResult_eq + indexedVecValidationTailWhnfSelf whnf + subst result + rw [indexedVecStagedStats_eq] at occurs + change AddInductive.hasIndOcc + indexedVecCandidateInductiveStats.indConsts + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) = false at occurs + rw [indexedVecValidationTailHasIndOcc] at occurs + contradiction + | forallE context source fuel name domain body binderInfo whnf occurs + domainFree tail => + have result_eq := indexedVecCandidateWhnfResult_eq + indexedVecValidationTailWhnfSelf whnf + have impossible := congrArg Expr.isForall result_eq + simp [ctorIndexedVecApp, Expr.isForall] at impossible + | target context source result fuel targetIdx whnf occurs terminal valid => + have result_eq := indexedVecCandidateWhnfResult_eq + indexedVecValidationTailWhnfSelf whnf + subst result + exact .target indexedVecValidationTailChecked + +private def indexedVecValidationNatAnnotations : + AddInductive.CandidateIsDefEqObservation + indexedVecCtorValidationContext (.const ``Nat []) + (.const ``Nat []) := + ⟨AddInductive.candidateIsDefEqRefl indexedVecCtorValidationContext + (.const ``Nat [])⟩ + +private def indexedVecValidationAlphaAnnotations : + AddInductive.CandidateIsDefEqObservation + indexedVecValidationNContext indexedVecValidationAlpha + indexedVecValidationAlpha := + ⟨AddInductive.candidateIsDefEqRefl indexedVecValidationNContext + indexedVecValidationAlpha⟩ + +private def indexedVecValidationTailAnnotations : + AddInductive.CandidateIsDefEqObservation + indexedVecValidationHeadContext + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) := + ⟨AddInductive.candidateIsDefEqRefl indexedVecValidationHeadContext + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr)⟩ + +/-- The validator and analyzer intentionally allocate the retained `n` field +under different fresh-FVar histories. D2 alignment must therefore be +positional rather than identifier-based. -/ +theorem indexedVecValidationCandidateFieldFVars_ne : + indexedVecValidationNId ≠ consNId := by + simp [indexedVecValidationNId, indexedVecCtorValidationContext, + indexedVecValidationTerminalContextShape, + indexedVecValidationFamilyContext, + indexedVecValidationParamContext, indexedVecFamilyCandidateContext, + consNId, consAlphaContext, consRootContext, ctorContext, + AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshFVarId, + NameGenerator.next, NameGenerator.curr] + +/-- 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 : + VInductDecl.StagedNormalizationCandidatePostFamilyInput + indexedVecFamilyCandidateContext ctorContext natFinalEnv [`u] + indexedVecNormalizationCandidate indexedVecDecl where + universeInput := indexedVecStagedUniverseInput + alignment := by + change AddInductive.ConstructorCandidateAlignmentTrace + indexedVecStagedUniverseInput.staged.family.validation.stats false 0 + indexedVecCtorValidationContext + indexedVecStagedUniverseInput.staged.constructorValidation.trace + (.cons indexedVecNilConstructorCandidate + (.cons indexedVecConsConstructorCandidate .nil)) + generalize htrace : + indexedVecStagedUniverseInput.staged.constructorValidation.trace = trace + cases trace with + | cons seen head constructors fresh closed rootCheck typeTrace tailTrace => + clear htrace + cases hnilRoot : typeTrace with + | parameter context fuel argIdx name domain body binderInfo param + parameterType parameterAt parameterTypeRun parameterDefEq + nilTypeTail => + rw [indexedVecStagedStats_eq, + indexedVecValidationStatsParams] at parameterAt + simp at parameterAt + subst param + change AddInductive.getType indexedVecValidationAlpha + indexedVecCtorValidationContext = .ok parameterType at parameterTypeRun + rw [indexedVecValidationGetTypeAlpha] at parameterTypeRun + injection parameterTypeRun with parameterType_eq + subst parameterType + let nilNormalized := indexedVecTransportValidationTrace + indexedVecValidationPostContext_eq + indexedVecValidationNilResultShape nilTypeTail + let nilNormalizedTrace := nilNormalized + have nilSpine : nilTypeTail.spineLength = + nilNormalizedTrace.spineLength := by + exact (indexedVecTransportValidationTrace_spineLength + indexedVecValidationPostContext_eq + indexedVecValidationNilResultShape nilTypeTail).symm + cases hnilNormalized : nilNormalizedTrace with + | terminal context source fuel argIdx nilTerminal nilValid => + simp [hnilNormalized, + AddInductive.ConstructorTypeValidationTrace.spineLength] at nilSpine + have nilNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + nilNormalizedTrace indexedVecValidationNilResult := by + rw [hnilNormalized] + exact .terminal indexedVecValidationNilResultChecked + indexedVecValidationNilResultChecked nilTerminal nilValid + have nilTailAlignment := indexedVecTransportViewAlignment + indexedVecValidationPostContext_eq + indexedVecValidationNilResultShape + indexedVecValidationNilResultShape nilTypeTail + nilNormalizedAlignment + have nilHeadAlignment : + AddInductive.ConstructorViewAlignmentTrace + (.parameter + { indexedVecNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with + env := ctorContext.env } + 999 0 `α (.sort (.succ (.param `u))) + nilCtorBodyRaw .implicit indexedVecValidationAlpha + (.sort (.succ (.param `u))) parameterAt + parameterTypeRun parameterDefEq nilTypeTail) + indexedVecNilConstructorCandidate.type.view := by + change AddInductive.ConstructorViewAlignmentTrace + _ nilCandidate.view + rw [nilCandidate_view_eq] + exact .parameter indexedVecValidationSortChecked + indexedVecValidationSortChecked + indexedVecValidationSortChecked rfl + (by simp [indexedVecValidationAlphaFind]) + nilTypeTail nilTailAlignment + cases tailTrace with + | cons seen head constructors consFresh consClosed + consRootCheck consTypeTrace finalTrace => + cases hconsRoot : consTypeTrace with + | parameter context fuel argIdx name domain body binderInfo + param parameterType parameterAt parameterTypeRun + parameterDefEq consAfterParamTrace => + rw [indexedVecStagedStats_eq, + indexedVecValidationStatsParams] at parameterAt + simp at parameterAt + subst param + change AddInductive.getType indexedVecValidationAlpha + indexedVecCtorValidationContext = .ok parameterType at parameterTypeRun + rw [indexedVecValidationGetTypeAlpha] at parameterTypeRun + injection parameterTypeRun with parameterType_eq + subst parameterType + let buildConsHeadAlignment + (tailAlignment : + AddInductive.ConstructorViewAlignmentTrace + consAfterParamTrace + (consNTypeRaw.instantiate1 + indexedVecValidationAlpha)) : + AddInductive.ConstructorViewAlignmentTrace + (.parameter + { indexedVecNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with + env := ctorContext.env } + 999 0 consAlphaName + (.sort (.succ (.param `u))) consNTypeRaw + .implicit indexedVecValidationAlpha + (.sort (.succ (.param `u))) parameterAt + parameterTypeRun parameterDefEq + consAfterParamTrace) + indexedVecConsConstructorCandidate.type.view := by + change AddInductive.ConstructorViewAlignmentTrace + _ consCandidate.view + rw [consCandidate_view_eq] + exact .parameter indexedVecValidationSortChecked + indexedVecValidationSortChecked + indexedVecValidationSortChecked rfl + (by simp [indexedVecValidationAlphaFind]) + consAfterParamTrace tailAlignment + have consAfterParamSource_eq : + indexedVecConsInfo.type.bindingBody!.instantiate1 + indexedVecValidationAlpha = + indexedVecValidationConsAfterParam := + indexedVecValidationConsAfterParamShape + have consAfterParamExplicit_eq : + indexedVecConsInfo.type.bindingBody!.instantiate1 + indexedVecValidationAlpha = + .forallE consNName (.const ``Nat []) + (.forallE consHeadName + indexedVecValidationAlpha + (.forallE consTailName + (ctorIndexedVecApp + indexedVecValidationAlpha (.bvar 1)) + (ctorIndexedVecApp + indexedVecValidationAlpha + (replaySuccApp (.bvar 2))) .default) + .default) + .implicit := + consAfterParamSource_eq.trans + indexedVecValidationConsAfterParamExplicitShape + let consAfterParamNormalized := + indexedVecTransportValidationTrace + indexedVecValidationPostContext_eq + consAfterParamExplicit_eq consAfterParamTrace + let consAfterParamNormalizedTrace := + consAfterParamNormalized + have consAfterParamSpine : + consAfterParamTrace.spineLength = + consAfterParamNormalizedTrace.spineLength := by + exact (indexedVecTransportValidationTrace_spineLength + indexedVecValidationPostContext_eq + consAfterParamExplicit_eq + consAfterParamTrace).symm + cases hconsAfterParamNormalized : + consAfterParamNormalizedTrace with + | parameter context fuel argIdx name domain body + binderInfo param parameterType parameterAt + parameterTypeRun parameterDefEq tail => + rw [indexedVecStagedStats_eq, + indexedVecValidationStatsParams] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body + binderInfo sortResult noParameter ensureType + universeTrace natPositivity consAfterNTrace => + simp [hconsAfterParamNormalized, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at consAfterParamSpine + have natPositivityAlignment := + indexedVecValidationNatPositivityAlignment + natPositivity + have afterParamBody_eq : + indexedVecValidationConsAfterParam.bindingBody! = + .forallE consHeadName + indexedVecValidationAlpha + (.forallE consTailName + (ctorIndexedVecApp + indexedVecValidationAlpha (.bvar 1)) + (ctorIndexedVecApp + indexedVecValidationAlpha + (replaySuccApp (.bvar 2))) .default) + .default := by + exact congrArg Expr.bindingBody! + indexedVecValidationConsAfterParamExplicitShape + have afterNSource_eq : + ((Expr.forallE consHeadName + indexedVecValidationAlpha + (Expr.forallE consTailName + (ctorIndexedVecApp + indexedVecValidationAlpha (.bvar 1)) + (ctorIndexedVecApp + indexedVecValidationAlpha + (replaySuccApp (.bvar 2))) .default) + .default).instantiate1 + indexedVecCtorValidationContext.freshExpr) = + indexedVecValidationConsAfterN := by + change + ((Expr.forallE consHeadName + indexedVecValidationAlpha + (Expr.forallE consTailName + (ctorIndexedVecApp + indexedVecValidationAlpha (.bvar 1)) + (ctorIndexedVecApp + indexedVecValidationAlpha + (replaySuccApp (.bvar 2))) .default) + .default).instantiate1 + indexedVecValidationNExpr) = + indexedVecValidationConsAfterN + rw [← afterParamBody_eq] + exact indexedVecValidationConsAfterNShape + have nContext_eq : + indexedVecCtorValidationContext.pushLocalDecl + consNName .implicit + (AddInductive.consumeTypeAnnotations + (.const ``Nat [])) = + indexedVecValidationNContext := by + simp [indexedVecValidationNContext] + let consAfterNNormalized := + indexedVecTransportValidationTrace nContext_eq + afterNSource_eq consAfterNTrace + let consAfterNNormalizedTrace := consAfterNNormalized + have consAfterNSpine : + consAfterNTrace.spineLength = + consAfterNNormalizedTrace.spineLength := by + exact + (indexedVecTransportValidationTrace_spineLength + nContext_eq afterNSource_eq + consAfterNTrace).symm + cases hconsAfterNNormalized : + consAfterNNormalizedTrace with + | parameter context fuel argIdx name domain body + binderInfo param parameterType parameterAt + parameterTypeRun parameterDefEq tail => + rw [indexedVecStagedStats_eq, + indexedVecValidationStatsParams] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body + binderInfo sortResult noParameter ensureType + universeTrace alphaPositivity + consAfterHeadTrace => + simp [hconsAfterNNormalized, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at consAfterNSpine + have alphaPositivityAlignment := + indexedVecValidationAlphaPositivityAlignment + alphaPositivity + have headContext_eq : + indexedVecValidationNContext.pushLocalDecl + consHeadName .default + (AddInductive.consumeTypeAnnotations + indexedVecValidationAlpha) = + indexedVecValidationHeadContext := by + rw [indexedVecValidationConsumeAlpha] + rfl + let consAfterHeadNormalized := + indexedVecTransportValidationTrace + headContext_eq + indexedVecValidationConsAfterHeadShape + consAfterHeadTrace + let consAfterHeadNormalizedTrace := + consAfterHeadNormalized + have consAfterHeadSpine : + consAfterHeadTrace.spineLength = + consAfterHeadNormalizedTrace.spineLength := by + exact + (indexedVecTransportValidationTrace_spineLength + headContext_eq + indexedVecValidationConsAfterHeadShape + consAfterHeadTrace).symm + cases hconsAfterHeadNormalized : + consAfterHeadNormalizedTrace with + | parameter context fuel argIdx name domain body + binderInfo param parameterType parameterAt + parameterTypeRun parameterDefEq tail => + rw [indexedVecStagedStats_eq, + indexedVecValidationStatsParams] at parameterAt + simp at parameterAt + | ordinary context fuel argIdx name domain body + binderInfo sortResult noParameter ensureType + universeTrace tailPositivity + consResultTrace => + simp [hconsAfterHeadNormalized, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at consAfterHeadSpine + have tailPositivityAlignment := + indexedVecValidationTailPositivityAlignment + tailPositivity + have tailContext_eq : + indexedVecValidationHeadContext.pushLocalDecl + consTailName .default + (AddInductive.consumeTypeAnnotations + (ctorIndexedVecApp + indexedVecValidationAlpha + indexedVecValidationNExpr)) = + indexedVecValidationTailContext := by + rw [indexedVecValidationConsumeTail] + rfl + let consResultNormalized := + indexedVecTransportValidationTrace + tailContext_eq + indexedVecValidationConsResultShape + consResultTrace + let consResultNormalizedTrace := + consResultNormalized + have consResultSpine : + consResultTrace.spineLength = + consResultNormalizedTrace.spineLength := by + exact + (indexedVecTransportValidationTrace_spineLength + tailContext_eq + indexedVecValidationConsResultShape + consResultTrace).symm + cases hconsResultNormalized : + consResultNormalizedTrace with + | terminal context source fuel argIdx + resultTerminal resultValid => + simp [hconsResultNormalized, + AddInductive.ConstructorTypeValidationTrace.spineLength] + at consResultSpine + have consResultNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + consResultNormalizedTrace + indexedVecValidationConsResult := by + rw [hconsResultNormalized] + exact .terminal + indexedVecValidationConsResultChecked + indexedVecValidationConsResultChecked + resultTerminal resultValid + have consResultAlignment := + indexedVecTransportViewAlignment + tailContext_eq + indexedVecValidationConsResultShape + indexedVecValidationConsResultShape + consResultTrace + consResultNormalizedAlignment + have consAfterHeadNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + consAfterHeadNormalizedTrace + indexedVecValidationConsAfterHead := by + rw [hconsAfterHeadNormalized] + exact .ordinary + indexedVecValidationTailChecked + indexedVecValidationTailChecked + (by simpa only + [indexedVecValidationConsumeTail] + using + indexedVecValidationTailAnnotations) + (by simpa only + [indexedVecValidationConsumeTail] + using indexedVecValidationTailChecked) + tailPositivity + tailPositivityAlignment + indexedVecValidationHeadContextFresh + (by simpa only + [indexedVecValidationConsumeTail] + using + indexedVecValidationTailAnnotations) + consResultTrace consResultAlignment + have consAfterHeadAlignment := + indexedVecTransportViewAlignment + headContext_eq + indexedVecValidationConsAfterHeadShape + indexedVecValidationConsAfterHeadShape + consAfterHeadTrace + consAfterHeadNormalizedAlignment + have consAfterNNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + consAfterNNormalizedTrace + indexedVecValidationConsAfterN := by + rw [hconsAfterNNormalized] + exact .ordinary + indexedVecValidationAlphaChecked + indexedVecValidationAlphaChecked + (by simpa only + [indexedVecValidationConsumeAlpha] + using + indexedVecValidationAlphaAnnotations) + (by simpa only + [indexedVecValidationConsumeAlpha] + using indexedVecValidationAlphaChecked) + alphaPositivity + alphaPositivityAlignment + indexedVecValidationNContextFresh + (by simpa only + [indexedVecValidationConsumeAlpha] + using + indexedVecValidationAlphaAnnotations) + consAfterHeadTrace + consAfterHeadAlignment + have consAfterNAlignment := + indexedVecTransportViewAlignment + nContext_eq afterNSource_eq + afterNSource_eq consAfterNTrace + consAfterNNormalizedAlignment + have consAfterParamNormalizedAlignment : + AddInductive.ConstructorViewAlignmentTrace + consAfterParamNormalizedTrace + (.forallE consNName + (.const ``Nat []) + (.forallE consHeadName + indexedVecValidationAlpha + (.forallE consTailName + (ctorIndexedVecApp + indexedVecValidationAlpha + (.bvar 1)) + (ctorIndexedVecApp + indexedVecValidationAlpha + (replaySuccApp (.bvar 2))) + .default) + .default) + .implicit) := by + rw [hconsAfterParamNormalized] + exact .ordinary + indexedVecValidationNatChecked + indexedVecValidationNatChecked + (by simpa only + [indexedVecValidationConsumeNat] + using + indexedVecValidationNatAnnotations) + (by simpa only + [indexedVecValidationConsumeNat] + using indexedVecValidationNatChecked) + natPositivity natPositivityAlignment + indexedVecCtorValidationContextFresh + (by simpa only + [indexedVecValidationConsumeNat] + using + indexedVecValidationNatAnnotations) + consAfterNTrace consAfterNAlignment + have consAfterParamAlignment := + indexedVecTransportViewAlignment + indexedVecValidationPostContext_eq + consAfterParamExplicit_eq + consAfterParamExplicit_eq + consAfterParamTrace + consAfterParamNormalizedAlignment + have consHeadAlignment := + buildConsHeadAlignment + consAfterParamAlignment + change + AddInductive.CandidateCheckTypeObservation + indexedVecCtorValidationContext.withEmptyLocalContext + indexedVecKernelNil.type at rootCheck + change + AddInductive.CandidateCheckTypeObservation + indexedVecCtorValidationContext.withEmptyLocalContext + indexedVecKernelCons.type at consRootCheck + let nilRootScope : + AddInductive.ConstructorCheckedExpr + indexedVecCtorValidationContext.withEmptyLocalContext + indexedVecKernelNil.type := + AddInductive.ConstructorCheckedExpr.ofClosedRoot + closed rootCheck + let consRootScope : + AddInductive.ConstructorCheckedExpr + indexedVecCtorValidationContext.withEmptyLocalContext + indexedVecKernelCons.type := + AddInductive.ConstructorCheckedExpr.ofClosedRoot + consClosed consRootCheck + cases finalTrace with + | nil finalSeen => + exact + AddInductive.ConstructorCandidateAlignmentTrace.cons + nilRootScope + (by + change nilCandidate.trace.storedSpine = true + exact nilCandidate_identity.storedSpine) + (by + change 1 = + nilTypeTail.spineLength + 1 + omega) + (by rfl) nilHeadAlignment <| + AddInductive.ConstructorCandidateAlignmentTrace.cons + consRootScope + (by + change consCandidate.trace.storedSpine = true + exact consCandidate_identity.storedSpine) + (by + change 4 = + consAfterParamTrace.spineLength + 1 + omega) + (by rfl) consHeadAlignment <| + AddInductive.ConstructorCandidateAlignmentTrace.nil + ((∅ : NameSet).insert + indexedVecKernelNil.name |>.insert + indexedVecKernelCons.name) + | terminal context source fuel argIdx terminal + valid => + simp [indexedVecValidationConsAfterHead, + Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [indexedVecValidationConsAfterN, + Expr.isForall] at terminal + | terminal context source fuel argIdx terminal valid => + simp [Expr.isForall] at terminal + | ordinary context fuel argIdx name domain body binderInfo + sortResult noParameter ensureType universeTrace positivity + tail => + rw [indexedVecStagedStats_eq, + indexedVecValidationStatsParams] at noParameter + simp at noParameter + | terminal context source fuel argIdx terminal valid => + have consType_eq : indexedVecKernelCons.type = + consCtorTypeRaw := by + simpa [indexedVecKernelCons] using consInfoTypeShape + rw [consType_eq] at terminal + simp [consCtorTypeRaw, Expr.isForall] at terminal + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity nilTypeTail => + rw [indexedVecStagedStats_eq, + indexedVecValidationStatsParams] at noParameter + simp at noParameter + | terminal context source fuel argIdx terminal valid => + simp [indexedVecKernelNil, indexedVecNilInfo, + ConstantInfo.type, ConstantInfo.toConstantVal, + Expr.isForall] at terminal + +/-- The retained `nil`/`cons` validator telescopes, exact analyzer views, field +checks, positivity target, and terminal family applications all admit the D2 +post-family Theory interpretation despite their distinct fresh identifiers. -/ +theorem indexedVecProducedPostFamilySemantic_exists : + Nonempty (VInductDecl.ProducedNormalizationCandidatePostFamilySemanticRun + indexedVecStagedPostFamilyInput) := + indexedVecStagedPostFamilyInput.exists + +/-! ## Pre-family constructor safety + +The D3 replay uses the terminal family-analysis context, whose environment is +still exactly `natMap`. Ordinary constructor fields extend that context; +recursive fields advance only the fresh-name generator so their locals cannot +be used by later fields or the result. -/ + +private def indexedVecPreFamilyContext : AddInductive.Context := + indexedVecFamilyCandidate.trace.terminalContext + +private def indexedVecPreFamilyNContext : AddInductive.Context := + indexedVecPreFamilyContext.pushLocalDecl + consNName .implicit (.const ``Nat []) + +private def indexedVecPreFamilyHeadContext : AddInductive.Context := + indexedVecPreFamilyNContext.pushLocalDecl + consHeadName .default indexedVecValidationAlpha + +private def indexedVecPreFamilyResultContext : AddInductive.Context := + indexedVecPreFamilyHeadContext.advanceFresh + +private theorem indexedVecPreFamilyContext_eq : + indexedVecPreFamilyContext = indexedVecValidationFamilyContext := rfl + +private theorem indexedVecPreFamilyNContext_eq : + indexedVecPreFamilyNContext = + { indexedVecValidationNContext with env := indexedVecKernelEnv } := rfl + +private theorem indexedVecPreFamilyHeadContext_eq : + indexedVecPreFamilyHeadContext = + { indexedVecValidationHeadContext with env := indexedVecKernelEnv } := rfl + +private theorem indexedVecPreFamilySortCheckValid + (context : AddInductive.Context) + (contextEnv : context.env = indexedVecKernelEnv) + (contextSafety : context.safety = .safe) + (contextLparams : context.lparams = [`u]) + (contextFuel : context.fuel = ({} : FuelConfig)) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, .sort (.succ (.param `u)), + .sort (.succ (.succ (.param `u)))⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + rw [contextEnv, contextSafety, contextLparams, contextFuel] + exact indexedVecPreFamilySortCheckTypeM context.lctx + +private theorem indexedVecPreFamilyNatCheckValid + (context : AddInductive.Context) + (contextEnv : context.env = indexedVecKernelEnv) + (contextSafety : context.safety = .safe) + (contextLparams : context.lparams = [`u]) + (contextFuel : context.fuel = ({} : FuelConfig)) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, .const ``Nat [], .sort (.succ .zero)⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + rw [contextEnv, contextSafety, contextLparams, contextFuel] + exact indexedVecPreFamilyNatCheckTypeM context.lctx + +private theorem indexedVecPreFamilyNatEnsureValid + (context : AddInductive.Context) + (contextEnv : context.env = indexedVecKernelEnv) + (contextSafety : context.safety = .safe) + (contextLparams : context.lparams = [`u]) + (contextFuel : context.fuel = ({} : FuelConfig)) : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨context, .const ``Nat [], .sort (.succ .zero)⟩ := by + unfold AddInductive.ConstructorEnsureTypeStep.Valid + rw [contextEnv, contextSafety, contextLparams, contextFuel] + exact indexedVecPreFamilyNatEnsureTypeM context.lctx + +private theorem indexedVecPreFamilyTelescopeCheckValid + (context : AddInductive.Context) + (contextEnv : context.env = indexedVecKernelEnv) + (contextSafety : context.safety = .safe) + (contextLparams : context.lparams = [`u]) + (contextFuel : context.fuel = ({} : FuelConfig)) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, indexedVecPreFamilyIndexTelescope, + .sort (mkLevelIMax' (.succ .zero) + (.succ (.succ (.param `u))))⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + rw [contextEnv, contextSafety, contextLparams, contextFuel] + exact indexedVecPreFamilyIndexTelescopeCheckTypeM context.lctx + +private theorem indexedVecPreFamilyFVarCheckTypeM + (lctx : LocalContext) (id : FVarId) (type : Expr) + (find : lctx.find? id = + some (.cdecl index id name type bi kind)) : + TypeChecker.M.run indexedVecKernelEnv .safe lctx [`u] + ({} : FuelConfig) (TypeChecker.checkType (.fvar id)) = + .ok type := by + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' (.fvar id) false + (TypeChecker.Methods.withFuel 9999) + (indexedVecTypeCheckerContext lctx) + ({} : TypeChecker.State)) = _ + rw [indexedVecPreFamilyInferTypeFVarCore 9999 lctx + ({} : TypeChecker.State) id type Std.HashMap.getElem?_empty find] + rfl + +private def indexedVecPreFamilyFVarInferOnlyState + (id : FVarId) (type : Expr) : TypeChecker.State := + { ({} : TypeChecker.State) with + inferTypeI := ({} : TypeChecker.State).inferTypeI.insert + (.fvar id) type } + +private theorem indexedVecPreFamilyFVarInferOnly + (lctx : LocalContext) (id : FVarId) (type : Expr) + (find : lctx.find? id = + some (.cdecl index id name type bi kind)) : + TypeChecker.Inner.inferType (.fvar id) true + (TypeChecker.Methods.withFuel 10000) + (indexedVecTypeCheckerContext lctx) + ({} : TypeChecker.State) = + .ok (type, indexedVecPreFamilyFVarInferOnlyState id type) := by + change TypeChecker.Inner.inferType' (.fvar id) true + (TypeChecker.Methods.withFuel 9999) + (indexedVecTypeCheckerContext lctx) + ({} : TypeChecker.State) = _ + unfold TypeChecker.Inner.inferType' + simp [indexedVecPreFamilyFVarInferOnlyState, + Expr.hasLooseBVars, Expr.looseBVarRange', + TypeChecker.Inner.inferFVar, indexedVecTypeCheckerContext, + find, LocalDecl.type, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + +private theorem indexedVecPreFamilyFVarEnsureTypeM + (lctx : LocalContext) (id : FVarId) (level : Level) + (find : lctx.find? id = + some (.cdecl index id name (.sort level) bi kind)) : + TypeChecker.M.run indexedVecKernelEnv .safe lctx [`u] + ({} : FuelConfig) (TypeChecker.ensureType (.fvar id)) = + .ok (.sort level) := by + unfold TypeChecker.ensureType TypeChecker.inferType + TypeChecker.ensureSort TypeChecker.RecM.run TypeChecker.M.run + simp only [readThe, MonadReaderOf.read, ReaderT.read, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind, + Pure.pure, StateT.pure, Except.pure, StateT.run', + Functor.map, Except.map] + rw [show TypeChecker.Inner.inferType (.fvar id) true + (TypeChecker.Methods.withFuel 10000) + { env := indexedVecKernelEnv, lctx := lctx, safety := .safe, + lparams := [`u], fuel := ({} : FuelConfig) } + ({} : TypeChecker.State) = + .ok (.sort level, + indexedVecPreFamilyFVarInferOnlyState id (.sort level)) by + simpa [indexedVecTypeCheckerContext] using + indexedVecPreFamilyFVarInferOnly lctx id (.sort level) find] + rfl + +private theorem indexedVecPreFamilyZeroCheckTypeM + (lctx : LocalContext) : + TypeChecker.M.run indexedVecKernelEnv .safe lctx [`u] + ({} : FuelConfig) (TypeChecker.checkType (.const ``Nat.zero [])) = + .ok (.const ``Nat []) := by + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' (.const ``Nat.zero []) false + (TypeChecker.Methods.withFuel 9999) + (indexedVecTypeCheckerContext lctx) + ({} : TypeChecker.State)) = _ + rw [indexedVecPreFamilyInferTypeZeroCore 9999 lctx + ({} : TypeChecker.State) Std.HashMap.getElem?_empty] + rfl + +private theorem indexedVecPreFamilySuccFVarCheckTypeM + (lctx : LocalContext) (id : FVarId) + (find : lctx.find? id = + some (.cdecl index id name (.const ``Nat []) bi kind)) : + TypeChecker.M.run indexedVecKernelEnv .safe lctx [`u] + ({} : FuelConfig) + (TypeChecker.checkType (replaySuccApp (.fvar id))) = + .ok (.const ``Nat []) := by + let succState := replayInsert ({} : TypeChecker.State) + (.const ``Nat.succ []) + (.forallE `n (.const ``Nat []) (.const ``Nat []) .default) + let argumentState := replayInsert succState (.fvar id) (.const ``Nat []) + have succRun : TypeChecker.Inner.inferType' (.const ``Nat.succ []) false + (TypeChecker.Methods.withFuel 9999) + (indexedVecTypeCheckerContext lctx) ({} : TypeChecker.State) = + .ok (.forallE `n (.const ``Nat []) (.const ``Nat []) .default, + succState) := by + simpa [succState, replayInsert] using + (indexedVecPreFamilyInferTypeSuccCore 9999 lctx + ({} : TypeChecker.State) Std.HashMap.getElem?_empty) + have argumentRun : TypeChecker.Inner.inferType' (.fvar id) false + (TypeChecker.Methods.withFuel 9999) + (indexedVecTypeCheckerContext lctx) succState = + .ok (.const ``Nat [], argumentState) := by + apply indexedVecPreFamilyInferTypeFVarCore + · simp [succState, replayInsert] + · exact find + have appRun := inferAppCoreOf 9999 + (indexedVecTypeCheckerContext lctx) + ({} : TypeChecker.State) succState argumentState + (.const ``Nat.succ []) (.fvar id) (.const ``Nat []) + (.const ``Nat []) `n .default + (by simp [Expr.hasLooseBVars, Expr.looseBVarRange']) + (by simp [replaySuccApp]) succRun argumentRun (by rfl) + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' (replaySuccApp (.fvar id)) false + (TypeChecker.Methods.withFuel 9999) + (indexedVecTypeCheckerContext lctx) + ({} : TypeChecker.State)) = _ + rw [show TypeChecker.Inner.inferType' + (replaySuccApp (.fvar id)) false + (TypeChecker.Methods.withFuel 9999) + (indexedVecTypeCheckerContext lctx) + ({} : TypeChecker.State) = + .ok (.const ``Nat [], + { argumentState with inferTypeC := + (argumentState.inferTypeC.insert + (replaySuccApp (.fvar id)) (.const ``Nat [])) }) by + simpa [replaySuccApp, Expr.instantiate1_eq, + Expr.instantiate1'] using appRun] + rfl + +private theorem indexedVecPreFamilyFVarCheckValid + (context : AddInductive.Context) (id : FVarId) (type : Expr) + (find : context.lctx.find? id = + some (.cdecl index id name type bi kind)) + (contextEnv : context.env = indexedVecKernelEnv) + (contextSafety : context.safety = .safe) + (contextLparams : context.lparams = [`u]) + (contextFuel : context.fuel = ({} : FuelConfig)) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, .fvar id, type⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + rw [contextEnv, contextSafety, contextLparams, contextFuel] + exact indexedVecPreFamilyFVarCheckTypeM context.lctx id type find + +private theorem indexedVecPreFamilyFVarEnsureValid + (context : AddInductive.Context) (id : FVarId) (level : Level) + (find : context.lctx.find? id = + some (.cdecl index id name (.sort level) bi kind)) + (contextEnv : context.env = indexedVecKernelEnv) + (contextSafety : context.safety = .safe) + (contextLparams : context.lparams = [`u]) + (contextFuel : context.fuel = ({} : FuelConfig)) : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨context, .fvar id, .sort level⟩ := by + unfold AddInductive.ConstructorEnsureTypeStep.Valid + rw [contextEnv, contextSafety, contextLparams, contextFuel] + exact indexedVecPreFamilyFVarEnsureTypeM context.lctx id level find + +private theorem indexedVecPreFamilyZeroCheckValid + (context : AddInductive.Context) + (contextEnv : context.env = indexedVecKernelEnv) + (contextSafety : context.safety = .safe) + (contextLparams : context.lparams = [`u]) + (contextFuel : context.fuel = ({} : FuelConfig)) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, .const ``Nat.zero [], .const ``Nat []⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + rw [contextEnv, contextSafety, contextLparams, contextFuel] + exact indexedVecPreFamilyZeroCheckTypeM context.lctx + +private theorem indexedVecPreFamilySuccCheckValid + (context : AddInductive.Context) (id : FVarId) + (find : context.lctx.find? id = + some (.cdecl index id name (.const ``Nat []) bi kind)) + (contextEnv : context.env = indexedVecKernelEnv) + (contextSafety : context.safety = .safe) + (contextLparams : context.lparams = [`u]) + (contextFuel : context.fuel = ({} : FuelConfig)) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, replaySuccApp (.fvar id), .const ``Nat []⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + rw [contextEnv, contextSafety, contextLparams, contextFuel] + exact indexedVecPreFamilySuccFVarCheckTypeM context.lctx id find + +private theorem indexedVecNormalizationFamilyView_eq : + indexedVecNormalizationCandidate.families.singleton.familyType.type.view = + indexedVecInfo.type := by + change indexedVecFamilyCandidate.view = indexedVecInfo.type + exact indexedVecFamilyCandidate_view_eq + +private theorem indexedVecNormalizationConstructors_eq : + indexedVecNormalizationCandidate.families.singleton.constructors = + .cons indexedVecNilConstructorCandidate + (.cons indexedVecConsConstructorCandidate .nil) := rfl + +private theorem indexedVecNormalizationPreFamilyContext_eq : + indexedVecNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext = + indexedVecPreFamilyContext := rfl + +private theorem indexedVecPreFamilySafetyRun : + AddInductive.checkConstructorPreFamilySafety + indexedVecStagedUniverseInput.staged.family.validation.stats + indexedVecNormalizationCandidate.families.singleton.familyType.type.view + indexedVecNormalizationCandidate.families.singleton.constructors + indexedVecNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext = + .ok () := by + rw [indexedVecStagedStats_eq] + rw [indexedVecNormalizationFamilyView_eq, + indexedVecNormalizationConstructors_eq, + indexedVecNormalizationPreFamilyContext_eq] + change AddInductive.checkConstructorPreFamilySafety + indexedVecCandidateInductiveStats indexedVecInfo.type + (.cons indexedVecNilConstructorCandidate + (.cons indexedVecConsConstructorCandidate .nil)) + indexedVecPreFamilyContext = .ok () + have alphaFind : indexedVecPreFamilyContext.lctx.find? + indexedVecValidationAlphaId = + some (.cdecl 0 indexedVecValidationAlphaId + indexedVecValidationParamName + (.sort (.succ (.param `u))) .default .default) := by + change indexedVecCtorValidationContext.lctx.find? + indexedVecValidationAlphaId = _ + exact indexedVecValidationAlphaFind + have alphaFindN : indexedVecPreFamilyNContext.lctx.find? + indexedVecValidationAlphaId = + some (.cdecl 0 indexedVecValidationAlphaId + indexedVecValidationParamName + (.sort (.succ (.param `u))) .default .default) := by + change indexedVecValidationNContext.lctx.find? + indexedVecValidationAlphaId = _ + exact indexedVecValidationAlphaFindInN + have alphaFindHead : indexedVecPreFamilyHeadContext.lctx.find? + indexedVecValidationAlphaId = + some (.cdecl 0 indexedVecValidationAlphaId + indexedVecValidationParamName + (.sort (.succ (.param `u))) .default .default) := by + change indexedVecValidationHeadContext.lctx.find? + indexedVecValidationAlphaId = _ + exact indexedVecValidationAlphaFindInHead + have nFindHead : indexedVecPreFamilyHeadContext.lctx.find? + indexedVecValidationNId = + some (.cdecl 2 indexedVecValidationNId consNName + (.const ``Nat []) .implicit .default) := by + change indexedVecValidationHeadContext.lctx.find? + indexedVecValidationNId = _ + exact indexedVecValidationNFindInHead + have nFindResult : indexedVecPreFamilyResultContext.lctx.find? + indexedVecValidationNId = + some (.cdecl 2 indexedVecValidationNId consNName + (.const ``Nat []) .implicit .default) := by + simpa [indexedVecPreFamilyResultContext, + AddInductive.Context.advanceFresh] using nFindHead + have baseFresh : indexedVecPreFamilyContext.lctx.find? + indexedVecPreFamilyContext.freshFVarId = none := by + change indexedVecCtorValidationContext.lctx.find? + indexedVecCtorValidationContext.freshFVarId = none + exact indexedVecCtorValidationContextFresh + have nFresh : indexedVecPreFamilyNContext.lctx.find? + indexedVecPreFamilyNContext.freshFVarId = none := by + change indexedVecValidationNContext.lctx.find? + indexedVecValidationNContext.freshFVarId = none + exact indexedVecValidationNContextFresh + have headFresh : indexedVecPreFamilyHeadContext.lctx.find? + indexedVecPreFamilyHeadContext.freshFVarId = none := by + change indexedVecValidationHeadContext.lctx.find? + indexedVecValidationHeadContext.freshFVarId = none + exact indexedVecValidationHeadContextFresh + let baseTelescope : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyContext indexedVecPreFamilyIndexTelescope := + .ofRun (by + simp [indexedVecPreFamilyIndexTelescope, FVarsIn, + Level.hasMVar']) + (indexedVecPreFamilyTelescopeCheckValid + indexedVecPreFamilyContext rfl rfl rfl rfl) + let headTelescope : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyHeadContext indexedVecPreFamilyIndexTelescope := + .ofRun (by + simp [indexedVecPreFamilyIndexTelescope, FVarsIn, + Level.hasMVar']) + (indexedVecPreFamilyTelescopeCheckValid + indexedVecPreFamilyHeadContext rfl rfl rfl rfl) + let resultTelescope : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyResultContext indexedVecPreFamilyIndexTelescope := + .ofRun (by + simp [indexedVecPreFamilyIndexTelescope, FVarsIn, + Level.hasMVar']) + (indexedVecPreFamilyTelescopeCheckValid + indexedVecPreFamilyResultContext rfl rfl rfl rfl) + let baseSort : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyContext (.sort (.succ (.param `u))) := + .ofRun (by simp [FVarsIn, Level.hasMVar']) + (indexedVecPreFamilySortCheckValid + indexedVecPreFamilyContext rfl rfl rfl rfl) + let headSort : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyHeadContext (.sort (.succ (.param `u))) := + .ofRun (by simp [FVarsIn, Level.hasMVar']) + (indexedVecPreFamilySortCheckValid + indexedVecPreFamilyHeadContext rfl rfl rfl rfl) + let resultSort : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyResultContext (.sort (.succ (.param `u))) := + .ofRun (by simp [FVarsIn, Level.hasMVar']) + (indexedVecPreFamilySortCheckValid + indexedVecPreFamilyResultContext rfl rfl rfl rfl) + let baseNat : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyContext (.const ``Nat []) := + .ofRun (by simp [FVarsIn]) + (indexedVecPreFamilyNatCheckValid + indexedVecPreFamilyContext rfl rfl rfl rfl) + let headNat : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyHeadContext (.const ``Nat []) := + .ofRun (by simp [FVarsIn]) + (indexedVecPreFamilyNatCheckValid + indexedVecPreFamilyHeadContext rfl rfl rfl rfl) + let resultNat : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyResultContext (.const ``Nat []) := + .ofRun (by simp [FVarsIn]) + (indexedVecPreFamilyNatCheckValid + indexedVecPreFamilyResultContext rfl rfl rfl rfl) + let zeroChecked : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyContext (.const ``Nat.zero []) := + .ofRun (by simp [FVarsIn]) + (indexedVecPreFamilyZeroCheckValid + indexedVecPreFamilyContext rfl rfl rfl rfl) + let nChecked : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyHeadContext indexedVecValidationNExpr := by + rw [indexedVecValidationNExprShape] + exact .ofRun (by + change (indexedVecPreFamilyHeadContext.lctx.find? + indexedVecValidationNId).isSome = true + rw [nFindHead] + rfl) (indexedVecPreFamilyFVarCheckValid + indexedVecPreFamilyHeadContext indexedVecValidationNId + (.const ``Nat []) nFindHead rfl rfl rfl rfl) + let succChecked : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyResultContext + (replaySuccApp indexedVecValidationNExpr) := by + rw [indexedVecValidationNExprShape] + exact .ofRun (by + simp [replaySuccApp, FVarsIn] + change (indexedVecPreFamilyResultContext.lctx.find? + indexedVecValidationNId).isSome = true + rw [nFindResult] + rfl) (indexedVecPreFamilySuccCheckValid + indexedVecPreFamilyResultContext indexedVecValidationNId + nFindResult rfl rfl rfl rfl) + let zeroComparison : AddInductive.CandidateIsDefEqObservation + indexedVecPreFamilyContext (.const ``Nat []) (.const ``Nat []) := + ⟨candidateIsDefEqSelfValid indexedVecPreFamilyContext + (.const ``Nat []) 9999 rfl⟩ + let nComparison : AddInductive.CandidateIsDefEqObservation + indexedVecPreFamilyHeadContext (.const ``Nat []) (.const ``Nat []) := + ⟨candidateIsDefEqSelfValid indexedVecPreFamilyHeadContext + (.const ``Nat []) 9999 rfl⟩ + let succComparison : AddInductive.CandidateIsDefEqObservation + indexedVecPreFamilyResultContext (.const ``Nat []) (.const ``Nat []) := + ⟨candidateIsDefEqSelfValid indexedVecPreFamilyResultContext + (.const ``Nat []) 9999 rfl⟩ + let nilSpine : AddInductive.ConstructorPreFamilyIndexSpineTrace + indexedVecPreFamilyContext indexedVecPreFamilyIndexTelescope + [.const ``Nat.zero []] := by + unfold indexedVecPreFamilyIndexTelescope + exact .cons indexedVecPreFamilyContext + indexedVecInfo.type.bindingBody!.bindingName! + (.const ``Nat []) (.sort (.succ (.param `u))) .default + (.const ``Nat.zero []) [] baseTelescope + ⟨zeroChecked, baseNat, zeroComparison⟩ + (by + simpa [Expr.instantiate1_eq, Expr.instantiate1'] using + (AddInductive.ConstructorPreFamilyIndexSpineTrace.nil + indexedVecPreFamilyContext + (.sort (.succ (.param `u))) baseSort rfl)) + let recursiveSpine : AddInductive.ConstructorPreFamilyIndexSpineTrace + indexedVecPreFamilyHeadContext indexedVecPreFamilyIndexTelescope + [indexedVecValidationNExpr] := by + unfold indexedVecPreFamilyIndexTelescope + exact .cons indexedVecPreFamilyHeadContext + indexedVecInfo.type.bindingBody!.bindingName! + (.const ``Nat []) (.sort (.succ (.param `u))) .default + indexedVecValidationNExpr [] headTelescope + ⟨nChecked, headNat, nComparison⟩ + (by + simpa [Expr.instantiate1_eq, Expr.instantiate1'] using + (AddInductive.ConstructorPreFamilyIndexSpineTrace.nil + indexedVecPreFamilyHeadContext + (.sort (.succ (.param `u))) headSort rfl)) + let resultSpine : AddInductive.ConstructorPreFamilyIndexSpineTrace + indexedVecPreFamilyResultContext indexedVecPreFamilyIndexTelescope + [replaySuccApp indexedVecValidationNExpr] := by + unfold indexedVecPreFamilyIndexTelescope + exact .cons indexedVecPreFamilyResultContext + indexedVecInfo.type.bindingBody!.bindingName! + (.const ``Nat []) (.sort (.succ (.param `u))) .default + (replaySuccApp indexedVecValidationNExpr) [] resultTelescope + ⟨succChecked, resultNat, succComparison⟩ + (by + simpa [Expr.instantiate1_eq, Expr.instantiate1'] using + (AddInductive.ConstructorPreFamilyIndexSpineTrace.nil + indexedVecPreFamilyResultContext + (.sort (.succ (.param `u))) resultSort rfl)) + have nilArgs : indexedVecValidationNilResult.getAppArgs.toList.drop + indexedVecCandidateInductiveStats.params.size = + [.const ``Nat.zero []] := by + simp [indexedVecValidationNilResult, + indexedVecValidationStatsParams, ctorIndexedVecAppGetAppArgs] + obtain ⟨nilTargetSpine, nilTargetSpineRun⟩ : + ∃ nilTargetSpine : AddInductive.ConstructorPreFamilyIndexSpineTrace + indexedVecPreFamilyContext indexedVecPreFamilyIndexTelescope + (indexedVecValidationNilResult.getAppArgs.toList.drop + indexedVecCandidateInductiveStats.params.size), + AddInductive.ConstructorPreFamilyIndexSpineTrace.build + indexedVecPreFamilyContext indexedVecPreFamilyIndexTelescope + (indexedVecValidationNilResult.getAppArgs.toList.drop + indexedVecCandidateInductiveStats.params.size) = + .ok nilTargetSpine := by + rw [nilArgs] + exact ⟨nilSpine, nilSpine.build_eq⟩ + have nilIndependent : AddInductive.constructorIndependentOf + indexedVecValidationNilResult [] = true := by + simp [AddInductive.constructorIndependentOf] + let nilTerminalTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecValidationNilResult 1 [] false := + .terminal indexedVecPreFamilyContext indexedVecValidationNilResult + 1 [] false indexedVecValidationNilResultIsValid nilIndependent + nilTargetSpine + have nilTerminalRun : + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecValidationNilResult 1 [] false 999 = + .ok nilTerminalTrace := by + exact AddInductive.ConstructorPreFamilyViewTrace.terminal_build_eq + (fuel := 998) rfl indexedVecValidationNilResultIsValid nilIndependent + nilTargetSpine + obtain ⟨nilTailTrace, nilTailRun⟩ : + ∃ nilTailTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + (nilCtorBodyRaw.instantiate1 indexedVecValidationAlpha) + 1 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + (nilCtorBodyRaw.instantiate1 indexedVecValidationAlpha) + 1 [] false 999 = + .ok nilTailTrace := by + rw [show nilCtorBodyRaw.instantiate1 indexedVecValidationAlpha = + indexedVecValidationNilResult by + simpa [nilInfoTypeShape, nilCtorTypeRaw] using + indexedVecValidationNilResultShape] + exact ⟨nilTerminalTrace, nilTerminalRun⟩ + have parameterAtZero : indexedVecCandidateInductiveStats.params[0]? = + some indexedVecValidationAlpha := by + rw [indexedVecValidationStatsParams] + rfl + obtain ⟨nilRawViewTrace, nilRawViewRun⟩ : + ∃ nilRawViewTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + nilCtorTypeRaw 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + nilCtorTypeRaw 0 [] false 1000 = .ok nilRawViewTrace := by + simp only [nilCtorTypeRaw, + AddInductive.ConstructorPreFamilyViewTrace.build] + split + · rename_i parameter parameterAt + rw [parameterAtZero] at parameterAt + cases parameterAt + rw [nilTailRun] + exact ⟨_, rfl⟩ + · rename_i noParameter + rw [parameterAtZero] at noParameter + contradiction + obtain ⟨nilViewTrace, nilViewRun⟩ : + ∃ nilViewTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecNilInfo.type 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecNilInfo.type 0 [] false 1000 = + .ok nilViewTrace := by + rw [nilInfoTypeShape] + exact ⟨nilRawViewTrace, nilRawViewRun⟩ + obtain ⟨nilHeadTrace, nilHeadRun⟩ : + ∃ nilHeadTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecNilConstructorCandidate.type.view 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecNilConstructorCandidate.type.view 0 [] false 1000 = + .ok nilHeadTrace := by + change ∃ nilHeadTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + nilCandidate.view 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + nilCandidate.view 0 [] false 1000 = .ok nilHeadTrace + rw [nilCandidate_view_eq] + exact ⟨nilViewTrace, nilViewRun⟩ + let baseNatEnsure : AddInductive.ConstructorEnsureTypeObservation + indexedVecPreFamilyContext (.const ``Nat []) := + ⟨.sort (.succ .zero), indexedVecPreFamilyNatEnsureValid + indexedVecPreFamilyContext rfl rfl rfl rfl⟩ + let baseNatConsumed : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyContext + (AddInductive.consumeTypeAnnotations (.const ``Nat [])) := by + rw [indexedVecValidationConsumeNat] + exact baseNat + let baseNatAnnotations : AddInductive.CandidateIsDefEqObservation + indexedVecPreFamilyContext (.const ``Nat []) + (AddInductive.consumeTypeAnnotations (.const ``Nat [])) := by + rw [indexedVecValidationConsumeNat] + exact ⟨candidateIsDefEqSelfValid indexedVecPreFamilyContext + (.const ``Nat []) 9999 rfl⟩ + let alphaChecked : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyNContext indexedVecValidationAlpha := by + rw [indexedVecValidationAlphaShape] + exact .ofRun (by + change (indexedVecPreFamilyNContext.lctx.find? + indexedVecValidationAlphaId).isSome = true + rw [alphaFindN] + rfl) (indexedVecPreFamilyFVarCheckValid + indexedVecPreFamilyNContext indexedVecValidationAlphaId + (.sort (.succ (.param `u))) alphaFindN rfl rfl rfl rfl) + let alphaEnsure : AddInductive.ConstructorEnsureTypeObservation + indexedVecPreFamilyNContext indexedVecValidationAlpha := by + rw [indexedVecValidationAlphaShape] + exact ⟨.sort (.succ (.param `u)), + indexedVecPreFamilyFVarEnsureValid indexedVecPreFamilyNContext + indexedVecValidationAlphaId (.succ (.param `u)) alphaFindN + rfl rfl rfl rfl⟩ + let alphaConsumed : AddInductive.ConstructorCheckedExpr + indexedVecPreFamilyNContext + (AddInductive.consumeTypeAnnotations indexedVecValidationAlpha) := by + rw [indexedVecValidationConsumeAlpha] + exact alphaChecked + let alphaAnnotations : AddInductive.CandidateIsDefEqObservation + indexedVecPreFamilyNContext indexedVecValidationAlpha + (AddInductive.consumeTypeAnnotations indexedVecValidationAlpha) := by + rw [indexedVecValidationConsumeAlpha] + exact ⟨candidateIsDefEqSelfValid indexedVecPreFamilyNContext + indexedVecValidationAlpha 9999 rfl⟩ + have alphaNeRemoved : indexedVecValidationAlphaId ≠ + indexedVecPreFamilyHeadContext.freshFVarId := by + intro equality + have fresh := headFresh + rw [← equality, alphaFindHead] at fresh + contradiction + have nNeRemoved : indexedVecValidationNId ≠ + indexedVecPreFamilyHeadContext.freshFVarId := by + intro equality + have fresh := headFresh + rw [← equality, nFindHead] at fresh + contradiction + have recursiveArgs : + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr).getAppArgs.toList.drop + indexedVecCandidateInductiveStats.params.size = + [indexedVecValidationNExpr] := by + simp [indexedVecValidationStatsParams, ctorIndexedVecAppGetAppArgs] + obtain ⟨recursiveTargetSpine, recursiveTargetSpineRun⟩ : + ∃ recursiveTargetSpine : + AddInductive.ConstructorPreFamilyIndexSpineTrace + indexedVecPreFamilyHeadContext + indexedVecPreFamilyIndexTelescope + ((ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr).getAppArgs.toList.drop + indexedVecCandidateInductiveStats.params.size), + AddInductive.ConstructorPreFamilyIndexSpineTrace.build + indexedVecPreFamilyHeadContext + indexedVecPreFamilyIndexTelescope + ((ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr).getAppArgs.toList.drop + indexedVecCandidateInductiveStats.params.size) = + .ok recursiveTargetSpine := by + rw [recursiveArgs] + exact ⟨recursiveSpine, recursiveSpine.build_eq⟩ + have recursiveTargetValid : AddInductive.isValidIndAppIdx + indexedVecCandidateInductiveStats + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) 0 = true := + indexedVecValidationAppIsValidIdx indexedVecValidationNExpr + indexedVecValidationNHasNoIndOcc + let recursiveFieldTrace : AddInductive.ConstructorPreFamilyRecursiveTrace + indexedVecCandidateInductiveStats 0 indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyHeadContext + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) + indexedVecPreFamilyHeadContext.fuel.inductiveFuel := + .target indexedVecPreFamilyHeadContext + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) + recursiveTargetValid recursiveTargetSpine + have recursiveFieldRun : AddInductive.ConstructorPreFamilyRecursiveTrace.build + indexedVecCandidateInductiveStats 0 indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyHeadContext + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) + indexedVecPreFamilyHeadContext.fuel.inductiveFuel = + .ok recursiveFieldTrace := by + exact AddInductive.ConstructorPreFamilyRecursiveTrace.target_build_eq + (fuel := 999) rfl recursiveTargetValid recursiveTargetSpine + have recursiveIndependent : AddInductive.constructorIndependentOf + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) [] = true := by + simp [AddInductive.constructorIndependentOf] + have resultArgs : indexedVecValidationConsResult.getAppArgs.toList.drop + indexedVecCandidateInductiveStats.params.size = + [replaySuccApp indexedVecValidationNExpr] := by + simp [indexedVecValidationConsResult, + indexedVecValidationStatsParams, ctorIndexedVecAppGetAppArgs] + obtain ⟨resultTargetSpine, resultTargetSpineRun⟩ : + ∃ resultTargetSpine : + AddInductive.ConstructorPreFamilyIndexSpineTrace + indexedVecPreFamilyResultContext + indexedVecPreFamilyIndexTelescope + (indexedVecValidationConsResult.getAppArgs.toList.drop + indexedVecCandidateInductiveStats.params.size), + AddInductive.ConstructorPreFamilyIndexSpineTrace.build + indexedVecPreFamilyResultContext + indexedVecPreFamilyIndexTelescope + (indexedVecValidationConsResult.getAppArgs.toList.drop + indexedVecCandidateInductiveStats.params.size) = + .ok resultTargetSpine := by + rw [resultArgs] + exact ⟨resultSpine, resultSpine.build_eq⟩ + have resultIndependent : AddInductive.constructorIndependentOf + indexedVecValidationConsResult + [indexedVecPreFamilyHeadContext.freshFVarId] = true := by + simp [AddInductive.constructorIndependentOf, + indexedVecValidationConsResult, ctorIndexedVecApp, replaySuccApp, + Expr.fvarsList, + indexedVecValidationAlphaShape, indexedVecValidationNExprShape, + alphaNeRemoved, nNeRemoved] + let resultTerminalTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyResultContext indexedVecValidationConsResult 4 + [indexedVecPreFamilyHeadContext.freshFVarId] true := + .terminal indexedVecPreFamilyResultContext + indexedVecValidationConsResult 4 + [indexedVecPreFamilyHeadContext.freshFVarId] true + indexedVecValidationConsResultIsValid resultIndependent + resultTargetSpine + have resultTerminalRun : AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyResultContext indexedVecValidationConsResult 4 + [indexedVecPreFamilyHeadContext.freshFVarId] true 996 = + .ok resultTerminalTrace := by + exact AddInductive.ConstructorPreFamilyViewTrace.terminal_build_eq + (fuel := 995) rfl indexedVecValidationConsResultIsValid + resultIndependent resultTargetSpine + obtain ⟨consResultTailTrace, consResultTailRun⟩ : + ∃ consResultTailTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyHeadContext.advanceFresh + (indexedVecValidationConsAfterHead.bindingBody!.instantiate1 + indexedVecPreFamilyHeadContext.freshExpr) + 4 [indexedVecPreFamilyHeadContext.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyHeadContext.advanceFresh + (indexedVecValidationConsAfterHead.bindingBody!.instantiate1 + indexedVecPreFamilyHeadContext.freshExpr) + 4 [indexedVecPreFamilyHeadContext.freshFVarId] true 996 = + .ok consResultTailTrace := by + rw [show indexedVecValidationConsAfterHead.bindingBody!.instantiate1 + indexedVecPreFamilyHeadContext.freshExpr = + indexedVecValidationConsResult by + change indexedVecValidationConsAfterHead.bindingBody!.instantiate1 + indexedVecValidationHeadContext.freshExpr = _ + exact indexedVecValidationConsResultShape] + exact ⟨resultTerminalTrace, resultTerminalRun⟩ + obtain ⟨explicitResultTailTrace, explicitResultTailRun⟩ : + ∃ explicitResultTailTrace : + AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyHeadContext.advanceFresh + ((ctorIndexedVecApp indexedVecValidationAlpha + (replaySuccApp indexedVecValidationNExpr)).instantiate1 + indexedVecPreFamilyHeadContext.freshExpr) + 4 [indexedVecPreFamilyHeadContext.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyHeadContext.advanceFresh + ((ctorIndexedVecApp indexedVecValidationAlpha + (replaySuccApp indexedVecValidationNExpr)).instantiate1 + indexedVecPreFamilyHeadContext.freshExpr) + 4 [indexedVecPreFamilyHeadContext.freshFVarId] true 996 = + .ok explicitResultTailTrace := by + change ∃ explicitResultTailTrace : + AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyHeadContext.advanceFresh + (indexedVecValidationConsAfterHead.bindingBody!.instantiate1 + indexedVecPreFamilyHeadContext.freshExpr) + 4 [indexedVecPreFamilyHeadContext.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyHeadContext.advanceFresh + (indexedVecValidationConsAfterHead.bindingBody!.instantiate1 + indexedVecPreFamilyHeadContext.freshExpr) + 4 [indexedVecPreFamilyHeadContext.freshFVarId] true 996 = + .ok explicitResultTailTrace + exact ⟨consResultTailTrace, consResultTailRun⟩ + have noParameterThree : indexedVecCandidateInductiveStats.params[3]? = + none := by + rw [indexedVecValidationStatsParams] + rfl + obtain ⟨consAfterHeadTrace, consAfterHeadRun⟩ : + ∃ consAfterHeadTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyHeadContext + indexedVecValidationConsAfterHead 3 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyHeadContext + indexedVecValidationConsAfterHead 3 [] false 997 = + .ok consAfterHeadTrace := by + simp only [indexedVecValidationConsAfterHead, + AddInductive.ConstructorPreFamilyViewTrace.build] + split + · rename_i parameter parameterAt + rw [noParameterThree] at parameterAt + contradiction + · split + · rename_i nonrecursive + rw [indexedVecValidationTailHasIndOcc] at nonrecursive + contradiction + · rw [dif_pos recursiveIndependent, recursiveFieldRun] + simp only [Bind.bind, Except.bind] + rw [dif_pos headFresh] + rw [explicitResultTailRun] + exact ⟨_, rfl⟩ + obtain ⟨consHeadTailTrace, consHeadTailRun⟩ : + ∃ consHeadTailTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyHeadContext + (indexedVecValidationConsAfterN.bindingBody!.instantiate1 + indexedVecPreFamilyNContext.freshExpr) + 3 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyHeadContext + (indexedVecValidationConsAfterN.bindingBody!.instantiate1 + indexedVecPreFamilyNContext.freshExpr) + 3 [] false 997 = .ok consHeadTailTrace := by + rw [show indexedVecValidationConsAfterN.bindingBody!.instantiate1 + indexedVecPreFamilyNContext.freshExpr = + indexedVecValidationConsAfterHead by + change indexedVecValidationConsAfterN.bindingBody!.instantiate1 + indexedVecValidationNContext.freshExpr = _ + exact indexedVecValidationConsAfterHeadShape] + exact ⟨consAfterHeadTrace, consAfterHeadRun⟩ + obtain ⟨explicitHeadTailTrace, explicitHeadTailRun⟩ : + ∃ explicitHeadTailTrace : + AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope + (indexedVecPreFamilyNContext.pushLocalDecl consHeadName .default + (AddInductive.consumeTypeAnnotations + indexedVecValidationAlpha)) + ((Expr.forallE consTailName + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) + (ctorIndexedVecApp indexedVecValidationAlpha + (replaySuccApp indexedVecValidationNExpr)) + .default).instantiate1 indexedVecPreFamilyNContext.freshExpr) + 3 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope + (indexedVecPreFamilyNContext.pushLocalDecl consHeadName .default + (AddInductive.consumeTypeAnnotations + indexedVecValidationAlpha)) + ((Expr.forallE consTailName + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) + (ctorIndexedVecApp indexedVecValidationAlpha + (replaySuccApp indexedVecValidationNExpr)) + .default).instantiate1 indexedVecPreFamilyNContext.freshExpr) + 3 [] false 997 = .ok explicitHeadTailTrace := by + rw [indexedVecValidationConsumeAlpha] + rw [show Expr.forallE consTailName + (ctorIndexedVecApp indexedVecValidationAlpha + indexedVecValidationNExpr) + (ctorIndexedVecApp indexedVecValidationAlpha + (replaySuccApp indexedVecValidationNExpr)) .default = + indexedVecValidationConsAfterN.bindingBody! by rfl] + exact ⟨consHeadTailTrace, consHeadTailRun⟩ + have noParameterTwo : indexedVecCandidateInductiveStats.params[2]? = + none := by + rw [indexedVecValidationStatsParams] + rfl + obtain ⟨consAfterNTrace, consAfterNRun⟩ : + ∃ consAfterNTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyNContext + indexedVecValidationConsAfterN 2 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyNContext + indexedVecValidationConsAfterN 2 [] false 998 = + .ok consAfterNTrace := by + simp only [indexedVecValidationConsAfterN, + AddInductive.ConstructorPreFamilyViewTrace.build] + split + · rename_i parameter parameterAt + rw [noParameterTwo] at parameterAt + contradiction + · split + · rw [alphaChecked.check_eq, alphaEnsure.observe_eq, + alphaConsumed.check_eq] + rw [dif_pos (by + simp [AddInductive.constructorIndependentOf])] + simp only [Bind.bind, Except.bind] + rw [alphaAnnotations.observe_eq] + simp only [Bind.bind, Except.bind] + rw [dif_pos nFresh] + rw [explicitHeadTailRun] + exact ⟨_, rfl⟩ + · rename_i recursive + rw [indexedVecValidationAlphaHasNoIndOcc] at recursive + contradiction + obtain ⟨consNTailTrace, consNTailRun⟩ : + ∃ consNTailTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyNContext + (indexedVecValidationConsAfterParam.bindingBody!.instantiate1 + indexedVecPreFamilyContext.freshExpr) + 2 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyNContext + (indexedVecValidationConsAfterParam.bindingBody!.instantiate1 + indexedVecPreFamilyContext.freshExpr) + 2 [] false 998 = .ok consNTailTrace := by + rw [show indexedVecValidationConsAfterParam.bindingBody!.instantiate1 + indexedVecPreFamilyContext.freshExpr = + indexedVecValidationConsAfterN by + change indexedVecValidationConsAfterParam.bindingBody!.instantiate1 + indexedVecValidationNExpr = _ + exact indexedVecValidationConsAfterNShape] + exact ⟨consAfterNTrace, consAfterNRun⟩ + obtain ⟨explicitNTailTrace, explicitNTailRun⟩ : + ∃ explicitNTailTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope + (indexedVecPreFamilyContext.pushLocalDecl consNName .implicit + (AddInductive.consumeTypeAnnotations (.const ``Nat []))) + ((Expr.forallE consHeadName indexedVecValidationAlpha + (Expr.forallE consTailName + (ctorIndexedVecApp indexedVecValidationAlpha (.bvar 1)) + (ctorIndexedVecApp indexedVecValidationAlpha + (replaySuccApp (.bvar 2))) .default) + .default).instantiate1 indexedVecPreFamilyContext.freshExpr) + 2 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope + (indexedVecPreFamilyContext.pushLocalDecl consNName .implicit + (AddInductive.consumeTypeAnnotations (.const ``Nat []))) + ((Expr.forallE consHeadName indexedVecValidationAlpha + (Expr.forallE consTailName + (ctorIndexedVecApp indexedVecValidationAlpha (.bvar 1)) + (ctorIndexedVecApp indexedVecValidationAlpha + (replaySuccApp (.bvar 2))) .default) + .default).instantiate1 indexedVecPreFamilyContext.freshExpr) + 2 [] false 998 = .ok explicitNTailTrace := by + rw [indexedVecValidationConsumeNat] + rw [show Expr.forallE consHeadName indexedVecValidationAlpha + (Expr.forallE consTailName + (ctorIndexedVecApp indexedVecValidationAlpha (.bvar 1)) + (ctorIndexedVecApp indexedVecValidationAlpha + (replaySuccApp (.bvar 2))) .default) .default = + indexedVecValidationConsAfterParam.bindingBody! by + rw [indexedVecValidationConsAfterParamExplicitShape] + rfl] + exact ⟨consNTailTrace, consNTailRun⟩ + have noParameterOne : indexedVecCandidateInductiveStats.params[1]? = + none := by + rw [indexedVecValidationStatsParams] + rfl + obtain ⟨consAfterParamTrace, consAfterParamRun⟩ : + ∃ consAfterParamTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecValidationConsAfterParam 1 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecValidationConsAfterParam 1 [] false 999 = + .ok consAfterParamTrace := by + rw [indexedVecValidationConsAfterParamExplicitShape] + simp only [AddInductive.ConstructorPreFamilyViewTrace.build] + split + · rename_i parameter parameterAt + rw [noParameterOne] at parameterAt + contradiction + · split + · rw [baseNat.check_eq, baseNatEnsure.observe_eq, + baseNatConsumed.check_eq] + rw [dif_pos (by + simp [AddInductive.constructorIndependentOf])] + simp only [Bind.bind, Except.bind] + rw [baseNatAnnotations.observe_eq] + simp only [Bind.bind, Except.bind] + rw [dif_pos baseFresh] + rw [explicitNTailRun] + exact ⟨_, rfl⟩ + · rename_i recursive + rw [indexedVecValidationNatHasNoIndOcc] at recursive + contradiction + obtain ⟨consParameterTailTrace, consParameterTailRun⟩ : + ∃ consParameterTailTrace : + AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + (consNTypeRaw.instantiate1 indexedVecValidationAlpha) + 1 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + (consNTypeRaw.instantiate1 indexedVecValidationAlpha) + 1 [] false 999 = .ok consParameterTailTrace := by + change ∃ consParameterTailTrace : + AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecValidationConsAfterParam 1 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecValidationConsAfterParam 1 [] false 999 = + .ok consParameterTailTrace + exact ⟨consAfterParamTrace, consAfterParamRun⟩ + obtain ⟨consRawViewTrace, consRawViewRun⟩ : + ∃ consRawViewTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + consCtorTypeRaw 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + consCtorTypeRaw 0 [] false 1000 = .ok consRawViewTrace := by + simp only [consCtorTypeRaw, + AddInductive.ConstructorPreFamilyViewTrace.build] + split + · rename_i parameter parameterAt + rw [parameterAtZero] at parameterAt + cases parameterAt + rw [consParameterTailRun] + exact ⟨_, rfl⟩ + · rename_i noParameter + rw [parameterAtZero] at noParameter + contradiction + obtain ⟨consViewTrace, consViewRun⟩ : + ∃ consViewTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecConsInfo.type 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecConsInfo.type 0 [] false 1000 = .ok consViewTrace := by + rw [consInfoTypeShape] + exact ⟨consRawViewTrace, consRawViewRun⟩ + obtain ⟨consHeadTrace, consHeadRun⟩ : + ∃ consHeadTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecConsConstructorCandidate.type.view 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + indexedVecConsConstructorCandidate.type.view 0 [] false 1000 = + .ok consHeadTrace := by + change ∃ consHeadTrace : AddInductive.ConstructorPreFamilyViewTrace + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + consCandidate.view 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + consCandidate.view 0 [] false 1000 = .ok consHeadTrace + rw [consCandidate_view_eq] + exact ⟨consViewTrace, consViewRun⟩ + let consListTrace : AddInductive.ConstructorPreFamilyListTrace + indexedVecCandidateInductiveStats 0 indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyContext + (.cons indexedVecConsConstructorCandidate .nil) := + .cons consHeadTrace .nil + have consListRun : AddInductive.ConstructorPreFamilyListTrace.build + indexedVecCandidateInductiveStats 0 indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyContext + (.cons indexedVecConsConstructorCandidate .nil) = + .ok consListTrace := by + exact AddInductive.ConstructorPreFamilyListTrace.cons_build_eq + consHeadTrace consHeadRun .nil rfl + let constructorListTrace : AddInductive.ConstructorPreFamilyListTrace + indexedVecCandidateInductiveStats 0 indexedVecPreFamilyIndexTelescope + indexedVecPreFamilyContext + (.cons indexedVecNilConstructorCandidate + (.cons indexedVecConsConstructorCandidate .nil)) := + .cons nilHeadTrace consListTrace + have constructorListRun : + AddInductive.ConstructorPreFamilyListTrace.build + indexedVecCandidateInductiveStats 0 + indexedVecPreFamilyIndexTelescope indexedVecPreFamilyContext + (.cons indexedVecNilConstructorCandidate + (.cons indexedVecConsConstructorCandidate .nil)) = + .ok constructorListTrace := by + exact AddInductive.ConstructorPreFamilyListTrace.cons_build_eq + nilHeadTrace nilHeadRun consListTrace consListRun + have parametersRun : AddInductive.instantiateFamilyParameters + indexedVecInfo.type indexedVecCandidateInductiveStats.params.toList = + .ok indexedVecPreFamilyIndexTelescope := by + rw [indexedVecPreFamilyIndexTelescope_eq] + rw [indexedVecValidationStatsParams] + rw [indexedVecInfoTypeShape] + simp [AddInductive.instantiateFamilyParameters, vecFamilyTail, + vecIndexName, + indexedVecPreFamilyIndexTelescope, Expr.instantiate1_eq, + Expr.instantiate1', Pure.pure, Except.pure] + unfold AddInductive.checkConstructorPreFamilySafety + have translationUnique : + (AddInductive.theoryTranslationUnique indexedVecInfo.type && + (AddInductive.CandidateList.cons indexedVecNilConstructorCandidate + (AddInductive.CandidateList.cons indexedVecConsConstructorCandidate + (AddInductive.CandidateList.nil : AddInductive.CandidateList + AddInductive.CandidateConstructor []))).viewTranslationUnique) = + true := by + change (AddInductive.theoryTranslationUnique indexedVecInfo.type && + (nilCandidateTrace.viewTranslationUnique && + (consCandidateTrace.viewTranslationUnique && true))) = true + rw [nilCandidateTrace.viewTranslationUnique_eq, + consCandidateTrace.viewTranslationUnique_eq] + change (AddInductive.theoryTranslationUnique indexedVecInfo.type && + (AddInductive.theoryTranslationUnique nilCandidate.view && + (AddInductive.theoryTranslationUnique consCandidate.view && true))) = + true + rw [nilCandidate_view_eq, consCandidate_view_eq, + indexedVecInfoTypeShape, nilInfoTypeShape, consInfoTypeShape] + simp [AddInductive.theoryTranslationUnique, vecFamilyTail, + nilCtorTypeRaw, nilCtorBodyRaw, consCtorTypeRaw, consNTypeRaw, + consHeadTypeRaw, consTailTypeRaw, consTerminalRaw] + rw [if_pos translationUnique] + rw [parametersRun] + simp only [Bind.bind, Except.bind] + rw [constructorListRun] + rfl + +private noncomputable def indexedVecStagedPreFamilyInput : + VInductDecl.StagedNormalizationCandidatePreFamilyInput + indexedVecFamilyCandidateContext ctorContext natFinalEnv [`u] + indexedVecNormalizationCandidate indexedVecDecl := + VInductDecl.StagedNormalizationCandidatePreFamilyInput.ofRun + indexedVecStagedPostFamilyInput indexedVecPreFamilySafetyRun + +/-- IndexedVec's ordinary fields are retained, its recursive tail is omitted, +and both constructor-result index spines admit the exact pre-family semantic +replay. -/ +theorem indexedVecProducedPreFamilySemantic_exists : + Nonempty (VInductDecl.ProducedNormalizationCandidatePreFamilySemanticRun + indexedVecStagedPreFamilyInput) := + indexedVecStagedPreFamilyInput.exists + private def indexedVecReorderedViewType : VInductiveType := { indexedVecType with ctors := [indexedVecType.ctors[1], indexedVecType.ctors[0]] } @@ -409,21 +2751,13 @@ def indexedVecSemanticFamilyRun : indexedVecFamilyListCandidate indexedVecType := indexedVecSemanticFamilySemanticRun.root -/-- Temporary L4L-01A compatibility witness. The two-stage owner proves a -semantic run exists without choosing this concrete identity value; L4L-01E -removes the explicit downstream witness. -/ -def indexedVecSemanticNormalizationCandidateSemanticRun : - VInductDecl.NormalizationCandidateSemanticRun natFinalEnv [`u] +def indexedVecSemanticNormalizationCandidateRun : + VInductDecl.NormalizationCandidateRun natFinalEnv [`u] indexedVecNormalizationCandidate indexedVecDecl where raw := indexedVecType raw_types_eq := rfl uvars_eq := rfl - family := indexedVecSemanticFamilySemanticRun - -def indexedVecSemanticNormalizationCandidateRun : - VInductDecl.NormalizationCandidateRun natFinalEnv [`u] - indexedVecNormalizationCandidate indexedVecDecl := - indexedVecSemanticNormalizationCandidateSemanticRun.root + family := indexedVecSemanticFamilyRun /-- Reconstructing every family and constructor payload leaves the identity IndexedVec declaration unchanged. -/ @@ -459,8 +2793,8 @@ def indexedVecSemanticConsSpineRun : consCandidate_identity.storedSpine theorem indexedVecSemanticCandidate_generationShape : - indexedVecSemanticNormalizationCandidateSemanticRun.generationShape = - true := by + VInductDecl.normalizationCandidateGenerationShape indexedVecDecl + indexedVecType indexedVecNormalizationCandidate = true := by change ((indexedVecFamilyCandidate.trace.storedSpine && true) && ((nilCandidate.trace.storedSpine && true) && ((consCandidate.trace.storedSpine && true) && true))) = true @@ -481,13 +2815,6 @@ theorem indexedVecSemanticCandidate_extraRawShape_rejected : .nil [indexedVecType.ctors[0]] = false := rfl -/-- Temporary L4L-01A view-WF compatibility premise. L4L-01D derives this -from retained validation and L4L-01E removes it from package construction. -/ -theorem indexedVecSemanticCandidate_viewDecl_wf : - indexedVecSemanticNormalizationCandidateRun.viewDecl.WF natFinalEnv := by - change indexedVecDecl.WF natFinalEnv - exact indexedVecDecl_wf - def indexedVecSemanticProducedGenerationShapeCandidate : VInductDecl.ProducedGenerationShapeCandidate indexedVecDecl indexedVecType indexedVecKernelType 0 false indexedVecFamilyCandidateContext where @@ -511,36 +2838,63 @@ theorem indexedVecSemanticGenerationShapeCandidate_produced : (source := indexedVecDecl) (raw := indexedVecType) produced indexedVecSemanticCandidate_generationShape -def indexedVecSemanticGenerationCandidateSemanticRun : - VInductDecl.GenerationCandidateSemanticRun - indexedVecSemanticNormalizationCandidateSemanticRun +private theorem indexedVecSemanticCandidate_analysis + (normalization : VInductDecl.NormalizationCandidateSemanticRun + natFinalEnv [`u] indexedVecNormalizationCandidate indexedVecDecl) : + normalization.root.normalization.generation? = + some indexedVecChecked.identityGeneration := by + let reference : VInductDecl.NormalizationCandidateSemanticRun natFinalEnv + [`u] indexedVecNormalizationCandidate indexedVecDecl := { + raw := indexedVecType + raw_types_eq := rfl + uvars_eq := rfl + family := indexedVecSemanticFamilySemanticRun } + rw [indexedVecStagedPreFamilyInput.normalization_eq normalization reference] + rfl + +/-- The parameter/index and two-constructor fixture closes through the same +generic staged-owner theorem without supplying its semantic hierarchy. -/ +theorem indexedVecSemanticExactProducedGenerationCandidatePackage_exists : + Nonempty (VInductDecl.ExactProducedGenerationCandidatePackage + natFinalEnv [`u] indexedVecSemanticProducedGenerationShapeCandidate + indexedVecChecked.identityGeneration) := + indexedVecSemanticProducedGenerationShapeCandidate + |>.exactProducedPackage_nonempty indexedVecStagedPreFamilyInput rfl + indexedVecChecked.identityGeneration indexedVecSemanticCandidate_analysis + +private noncomputable def + indexedVecSemanticExactProducedGenerationCandidatePackage : + VInductDecl.ExactProducedGenerationCandidatePackage natFinalEnv [`u] + indexedVecSemanticProducedGenerationShapeCandidate + indexedVecChecked.identityGeneration := + Classical.choice + indexedVecSemanticExactProducedGenerationCandidatePackage_exists + +noncomputable def indexedVecSemanticGenerationCandidateSemanticRun : + VInductDecl.GenerationCandidateSemanticRun + indexedVecSemanticExactProducedGenerationCandidatePackage.normalization indexedVecChecked.identityGeneration := - VInductDecl.GenerationCandidateSemanticRun.ofGenerationShape - indexedVecSemanticNormalizationCandidateSemanticRun - indexedVecChecked.identityGeneration rfl - indexedVecSemanticCandidate_viewDecl_wf - indexedVecSemanticCandidate_generationShape + indexedVecSemanticExactProducedGenerationCandidatePackage.semantic -def indexedVecSemanticGenerationCandidateRun : +noncomputable def indexedVecSemanticGenerationCandidateRun : VInductDecl.GenerationCandidateRun - indexedVecSemanticNormalizationCandidateRun + indexedVecSemanticExactProducedGenerationCandidatePackage.normalization.root indexedVecChecked.identityGeneration := indexedVecSemanticGenerationCandidateSemanticRun.run -def indexedVecSemanticGenerationCandidatePackage : +noncomputable def indexedVecSemanticGenerationCandidatePackage : VInductDecl.GenerationCandidatePackage natFinalEnv [`u] := indexedVecSemanticGenerationCandidateSemanticRun.package -def indexedVecSemanticProducedGenerationCandidatePackage : +noncomputable def indexedVecSemanticProducedGenerationCandidatePackage : VInductDecl.ProducedGenerationCandidatePackage natFinalEnv [`u] := - indexedVecSemanticProducedGenerationShapeCandidate.producedPackage - indexedVecSemanticNormalizationCandidateSemanticRun rfl - indexedVecChecked.identityGeneration rfl - indexedVecSemanticCandidate_viewDecl_wf + indexedVecSemanticExactProducedGenerationCandidatePackage.package def indexedVecSemanticGenerationCertificate : - indexedVecDecl.GenerationCertificate natFinalEnv := - indexedVecSemanticProducedGenerationCandidatePackage.package.certificate + indexedVecDecl.GenerationCertificate natFinalEnv where + generation := indexedVecChecked.identityGeneration + wf := + indexedVecSemanticExactProducedGenerationCandidatePackage.semantic.run.wf theorem indexedVecSemantic_addInductCertified : natFinalEnv.addInductCertified indexedVecSemanticGenerationCertificate = @@ -557,12 +2911,12 @@ theorem indexedVecSemanticCertified_ordered : VEnv.addInductCertified_WF nat_env_wf.ordered indexedVecSemantic_addInductCertified -def indexedVecSemanticAddInductTraceChecked : +noncomputable def indexedVecSemanticAddInductTraceChecked : AddInductTrace natMap natFinalEnv indexedVecDecl indexedVecMap indexedVecFinalEnv := by refine indexedVecSemanticProducedGenerationCandidatePackage.package.addInductTrace indexedVecTypeMap indexedVecTypeEnv indexedVecCtorMap - indexedVecCtorEnv indexedVecRecEnv ?_ ?_ ?_ ⟨rfl⟩ + indexedVecCtorEnv indexedVecRecEnv ?_ ?_ ?_ ?_ ⟨rfl⟩ · exact { info := indexedVecInfo kind_eq := by simp [indexedVecInfo, InductConstantKind.Matches] @@ -603,6 +2957,7 @@ def indexedVecSemanticAddInductTraceChecked : exact indexedVecRec_fresh env_add := rfl map_add := rfl } + · decide theorem indexedVecSemantic_addInduct_checked : AddInduct natMap natFinalEnv indexedVecDecl indexedVecMap @@ -658,6 +3013,72 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecProducedSemanticHierarchy_exi #guard_msgs in #print axioms indexedVecProducedSemanticHierarchy_exists +/-- +info: 'Lean4Lean.InductiveReplayFixtures.indexedVecProducedPostFamilySemantic_exists' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms indexedVecProducedPostFamilySemantic_exists + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.indexedVecProducedPreFamilySemantic_exists' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms indexedVecProducedPreFamilySemantic_exists + /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecProducedSemanticHierarchy_constructorHeaders' depends on axioms: [propext, sorryAx, @@ -731,6 +3152,32 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticCandidate_extraRawSha /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticGenerationShapeCandidate_produced' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + Expr.eqv_eq, + Expr.instantiate1_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms indexedVecSemanticGenerationShapeCandidate_produced + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticExactProducedGenerationCandidatePackage_exists' depends on axioms: [propext, sorryAx, Classical.choice, ptrEqConstantInfo_eq, @@ -760,7 +3207,7 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticGenerationShapeCandid PersistentHashMap.WF.toList'_insert] -/ #guard_msgs in -#print axioms indexedVecSemanticGenerationShapeCandidate_produced +#print axioms indexedVecSemanticExactProducedGenerationCandidatePackage_exists /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticGenerationCandidateSemanticRun' depends on axioms: [propext, diff --git a/Lean4Lean/Verify/Environment/InductiveFixtures.lean b/Lean4Lean/Verify/Environment/InductiveFixtures.lean index 29245f7b..330016e2 100644 --- a/Lean4Lean/Verify/Environment/InductiveFixtures.lean +++ b/Lean4Lean/Verify/Environment/InductiveFixtures.lean @@ -1,5 +1,5 @@ import Lean4Lean.Verify.Environment.Lemmas -import Lean4Lean.Verify.Environment.Normalization +import Lean4Lean.Verify.Environment.ConstructorValidation import Lean4Lean.Inductive.Add import Lean4Lean.Theory.Meta import Lean4Lean.Theory.InductiveFixtures @@ -84,6 +84,7 @@ macro_rules | apply TrTypeExpr.const <;> (first | assumption | rfl | (dsimp; simp [VLevel.params'])) | apply TrTypeExpr.app <;> tr_type_expr_tac + | apply TrTypeExpr.mdata; tr_type_expr_tac | apply TrTypeExpr.forallE <;> tr_type_expr_tac) local instance : Inhabited VEnv := ⟨.empty⟩ @@ -323,6 +324,7 @@ theorem nat_addInduct : exact natRec_fresh env_add := rfl map_add := rfl } + recK := by decide addRules := ⟨rfl⟩ }⟩ exact .cons { info := natZeroInfo @@ -350,6 +352,19 @@ 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. -/ +theorem natFinalEnv_ordered : natFinalEnv.Ordered := + VEnv.addInductGeneration_WF .empty + ((natChecked.wf_of_decl natDecl_wf).identityGeneration .empty) rfl + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.natFinalEnv_ordered' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms natFinalEnv_ordered + theorem nat_env_wf : natFinalEnv.WF := nat_trEnv'.wf theorem nat_aligned : Aligned .safe natMap natFinalEnv := nat_trEnv'.aligned @@ -583,6 +598,7 @@ theorem seedNat_addInduct : exact seedNatRec_fresh env_add := rfl map_add := rfl } + recK := by decide addRules := ⟨rfl⟩ }⟩ exact .cons { info := natZeroInfo @@ -836,6 +852,7 @@ theorem eq_addInduct : exact eqRec_fresh env_add := rfl map_add := rfl } + recK := by decide addRules := ⟨rfl⟩ }⟩ exact .cons { info := eqReflInfo @@ -1327,6 +1344,7 @@ theorem indexedVec_addInduct : exact indexedVecRec_fresh env_add := rfl map_add := rfl } + recK := by decide addRules := ⟨rfl⟩ }⟩ exact .cons { info := indexedVecNilInfo @@ -1636,6 +1654,7 @@ theorem acc_addInduct : exact accRec_fresh env_add := rfl map_add := rfl } + recK := by decide addRules := ⟨rfl⟩ }⟩ exact .cons { info := accIntroInfo @@ -1954,6 +1973,7 @@ private def aliasFormerAddInductTraceWith exact aliasFormerRec_fresh env_add := rfl map_add := rfl } + recK := by decide addRules := ⟨rfl⟩ } exact .cons { info := aliasFormerMkInfo @@ -2257,6 +2277,7 @@ private def aliasRecAddInductTraceWith exact aliasRecRec_fresh env_add := rfl map_add := rfl } + recK := by decide addRules := ⟨rfl⟩ } exact .cons { info := aliasRecMkInfo @@ -2552,6 +2573,182 @@ private theorem outParamVEnvs_wf : outParamVEnvs.WF outParamKernelEnv where safePrimitives := outParam_safePrimitives mono := fun _ => .rfl +/-! ## Definitionally equal constructor parameters -/ + +def annotatedParamInfo : ConstantInfo := kernelInductInfo% AnnotatedParam +def annotatedParamMkInfo : ConstantInfo := kernelCtorInfo% AnnotatedParam.mk +def annotatedParamRecInfo : ConstantInfo := kernelRecInfo% AnnotatedParam.rec +def annotatedParamKernelRuleRhs : VExpr := + kernelRecRuleRhs% AnnotatedParam.rec 0 + +example : annotatedParamKernelRuleRhs = + annotatedParamGenerationChecked.generatedRules[0].rhs := rfl + +private def annotatedParamKernelCtor : Constructor where + name := annotatedParamMkInfo.name + type := annotatedParamMkInfo.type + +private def annotatedParamKernelType : InductiveType where + name := annotatedParamInfo.name + type := annotatedParamInfo.type + ctors := [annotatedParamKernelCtor] + +private def annotatedParamCandidateContext : AddInductive.Context where + env := outParamKernelEnv + lparams := [] + safety := .safe + allowPrimitive := false + +private def annotatedParamExpectedFamilyView : Expr := + .forallE `alpha (.sort (.succ .zero)) + (.sort (.succ .zero)) .default + +private def annotatedParamExpectedCtorView : Expr := + .forallE `alpha (.sort (.succ .zero)) + (.app (.const ``AnnotatedParam []) (.bvar 0)) .implicit + +/- The successful whole metadata pass reaches `checkConstructors`, compares +the stored `outParam Type` constructor prefix with the checked `Type` family +local by ordinary definitional equality, and retains the checked surface in +both candidate views. -/ +#guard match AddInductive.buildNormalizationCandidate 1 + [annotatedParamKernelType] 0 false annotatedParamCandidateContext with + | .ok candidate => + candidate.families.singleton.familyType.type.view.equal + annotatedParamExpectedFamilyView && + match candidate.families.singleton.constructors with + | .cons constructor .nil => + constructor.type.view.equal annotatedParamExpectedCtorView + | .error _ => false + +/- Keep the constructor type closed and independently well typed while making +its declared parameter domain genuinely different. The fixed result avoids a +premature application-type failure, so rejection is specifically the same +constructor-parameter check exercised by the positive. -/ +private def annotatedParamNonDefEqCtor : Constructor where + name := annotatedParamMkInfo.name + type := .forallE `alpha (.sort .zero) + (.app (.const ``AnnotatedParam []) (.sort .zero)) .implicit + +private def annotatedParamNonDefEqType : InductiveType := + { annotatedParamKernelType with ctors := [annotatedParamNonDefEqCtor] } + +#guard match AddInductive.buildNormalizationCandidate 1 + [annotatedParamNonDefEqType] 0 false annotatedParamCandidateContext with + | .error (.other message) => + message == + "arg #1 of 'Lean4Lean.InductiveFixtures.AnnotatedParam.mk' does not match inductive datatype parameters" + | _ => false + +private theorem annotatedParamRawType_wf : + annotatedParamRawType.toVConstant.WF outParamEnv := by + refine ⟨.imax (.succ (.succ .zero)) (.succ (.succ .zero)), ?_⟩ + change outParamEnv.HasType 0 [] + (.forallE + (.app (.const ``outParam [.succ (.succ .zero)]) + (.sort (.succ .zero))) + (.sort (.succ .zero))) + (.sort (.imax (.succ (.succ .zero)) (.succ (.succ .zero)))) + apply VEnv.HasType.forallE + · apply VEnv.HasType.app + (A := .sort (.succ (.succ .zero))) + (B := .sort (.succ (.succ .zero))) + · simpa [VExpr.instL, VLevel.inst] using VEnv.HasType.const + (env := outParamEnv) (U := 0) (c := ``outParam) + (ci := vconst(type_of% @outParam)) + (ls := [.succ (.succ .zero)]) rfl + (by simp; decide) rfl + · exact VEnv.HasType.sort (by decide) + · exact VEnv.HasType.sort (by decide) + +private theorem annotatedParamInfo_tr : + TrConstVal .safe outParamEnv annotatedParamInfo + annotatedParamRawType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr outParamEnv annotatedParamInfo.levelParams [] + annotatedParamInfo.type annotatedParamRawType.type := by + tr_type_expr_tac + obtain ⟨u, htype⟩ := annotatedParamRawType_wf + exact hshape.to_trExprS outParamEnv_ordered trivial ⟨.sort u, htype⟩ + +private def annotatedParamTypeEnv : VEnv := + (outParamEnv.addConst annotatedParamRawType.name + annotatedParamRawType.toVConstant).get! + +private def annotatedParamTypeMap : ConstMap := + outParamMap.insert ``AnnotatedParam annotatedParamInfo + +private theorem annotatedParamType_fresh : + outParamMap.find? ``AnnotatedParam = none := by + rw [outParamMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +private theorem annotatedParamTypeMap_wf : annotatedParamTypeMap.WF := + outParamMap_wf.insert _ _ annotatedParamType_fresh + +private def annotatedParamAddType : + AddInductConstant .induct outParamMap outParamEnv + annotatedParamRawType.toVConstVal annotatedParamTypeMap + annotatedParamTypeEnv where + info := annotatedParamInfo + kind_eq := by simp [annotatedParamInfo, InductConstantKind.Matches] + tr := annotatedParamInfo_tr + map_fresh := by simpa [annotatedParamRawType] using + annotatedParamType_fresh + env_add := rfl + map_add := rfl + +private def annotatedParamTypeKernelEnv : Kernel.Environment := + Kernel.Environment.ofConstants `_annotatedParamCandidate + annotatedParamTypeMap + +private theorem annotatedParamTypeEnv_ordered : + annotatedParamTypeEnv.Ordered := + .const (n := annotatedParamRawType.name) + (ci := annotatedParamRawType.toVConstant) + outParamEnv_ordered annotatedParamRawType_wf rfl + +private def annotatedParamCtorCandidateContext : AddInductive.Context where + env := annotatedParamTypeKernelEnv + lparams := [] + safety := .safe + allowPrimitive := false + +private theorem annotatedParamType_lookup_outParam : + annotatedParamTypeKernelEnv.find? ``outParam = + some annotationOutParamInfo := by + change annotatedParamTypeMap.find?' ``outParam = + some annotationOutParamInfo + rw [annotatedParamTypeMap_wf.find?'_eq_find?, annotatedParamTypeMap, + outParamMap_wf.find?_insert] + rw [outParamMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + rfl + +private theorem annotatedParamType_lookup_family : + annotatedParamTypeKernelEnv.find? ``AnnotatedParam = + some annotatedParamInfo := by + change annotatedParamTypeMap.find?' ``AnnotatedParam = + some annotatedParamInfo + rw [annotatedParamTypeMap_wf.find?'_eq_find?, annotatedParamTypeMap, + outParamMap_wf.find?_insert] + rfl + +@[simp] private theorem annotatedParamType_get_outParam : + annotatedParamTypeKernelEnv.get ``outParam = + .ok annotationOutParamInfo := by + unfold Kernel.Environment.get + rw [annotatedParamType_lookup_outParam] + rfl + +@[simp] private theorem annotatedParamType_get_family : + annotatedParamTypeKernelEnv.get ``AnnotatedParam = + .ok annotatedParamInfo := by + unfold Kernel.Environment.get + rw [annotatedParamType_lookup_family] + rfl + def annotatedPiInfo : ConstantInfo := kernelInductInfo% AnnotatedPi def annotatedPiMkInfo : ConstantInfo := kernelCtorInfo% AnnotatedPi.mk def annotatedPiRecInfo : ConstantInfo := kernelRecInfo% AnnotatedPi.rec @@ -4161,7 +4358,7 @@ private theorem annotatedPiWhnfCoreDomainInitial (n) : .const ``outParam [.succ .zero] by rfl] rw [annotatedPiWhnfCoreOutParamConst n ({} : TypeChecker.State)] simp [annotatedPiRawDomainKernel, annotatedPiReduceRecursorDomain, - Expr.eqv_eq, + Expr.structuralEq, Bind.bind, ReaderT.bind, StateT.bind, Except.bind] rw [show .app (.const ``outParam [.succ .zero]) (.sort .zero) = @@ -4298,7 +4495,7 @@ private theorem annotatedPiWhnfCoreDomainBeta (n) : methods annotatedPiCtorCandidateContext.toTypeChecker state = .ok (none, state) simp [TypeChecker.Inner.reduceNat, Expr.getAppNumArgs_eq, - Expr.getAppArgsRevList, Expr.appFn!, Expr.eqv_const] + Expr.getAppArgsRevList, Expr.appFn!, Expr.structuralEq] private theorem annotatedPiWhnfLoopDomain : TypeChecker.Inner.whnf'.loop annotatedPiRawDomainKernel 100000 @@ -4447,50 +4644,61 @@ private theorem annotatedPiEmptyEqv_isEquivDomainSort : private theorem annotatedPiQuickIsDefEqDomainInitial (methods : TypeChecker.Methods) - (context : TypeChecker.Context) : - ∃ m : EquivManager, + (context : TypeChecker.Context) (initial : EquivManager) : + ∃ (r : LBool) (m : EquivManager), TypeChecker.Inner.quickIsDefEq annotatedPiRawDomainKernel (.sort .zero) true - methods context ({} : TypeChecker.State) = - .ok (.undef, - annotatedPiWithEqvManager ({} : TypeChecker.State) m) := by - obtain ⟨m, hm⟩ := annotatedPiEmptyEqv_isEquivDomainSort - refine ⟨m, ?_⟩ - rw [show annotatedPiRawDomainKernel = - .app (.const ``outParam [.succ .zero]) (.sort .zero) by rfl] - at hm ⊢ - unfold TypeChecker.Inner.quickIsDefEq - simp [modifyGet, MonadStateOf.modifyGet, monadLift, - MonadLift.monadLift, StateT.modifyGet, pure, ReaderT.pure, - StateT.pure, Except.pure, hm, annotatedPiWithEqvManager, - Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + methods context ({ eqvManager := initial } : TypeChecker.State) = + .ok (r, ({ eqvManager := m } : TypeChecker.State)) ∧ + (r = .true ∨ r = .undef) := by + let q := EquivManager.isEquiv true + annotatedPiRawDomainKernel (.sort .zero) initial + rcases hq : q with ⟨b, m⟩ + have hq' : EquivManager.isEquiv true + annotatedPiRawDomainKernel (.sort .zero) initial = (b, m) := by + simpa [q] using hq + cases b + · refine ⟨.undef, m, ?_, Or.inr rfl⟩ + simp [TypeChecker.Inner.quickIsDefEq, modifyGet, + MonadStateOf.modifyGet, monadLift, MonadLift.monadLift, + StateT.modifyGet, pure, ReaderT.pure, StateT.pure, + Except.pure, hq', Bind.bind, ReaderT.bind, StateT.bind, + Except.bind] + rfl + · refine ⟨.true, m, ?_, Or.inl rfl⟩ + simp [TypeChecker.Inner.quickIsDefEq, modifyGet, + MonadStateOf.modifyGet, monadLift, MonadLift.monadLift, + StateT.modifyGet, pure, ReaderT.pure, StateT.pure, + Except.pure, hq', Bind.bind, ReaderT.bind, StateT.bind, + Except.bind] @[simp] private theorem annotatedPiWhnfCoreOutParamConstCheap - (m : EquivManager) : + (fuel : Nat) (m : EquivManager) : TypeChecker.Inner.whnfCore (.const ``outParam [.succ .zero]) false true - (TypeChecker.Methods.withFuel 9998) + (TypeChecker.Methods.withFuel (fuel + 2)) annotatedPiCtorCandidateContext.toTypeChecker ({ eqvManager := m } : TypeChecker.State) = .ok (.const ``outParam [.succ .zero], ({ eqvManager := m } : TypeChecker.State)) := by rfl -private theorem annotatedPiWhnfCoreDomainCheap (m : EquivManager) : +private theorem annotatedPiWhnfCoreDomainCheap + (fuel : Nat) (m : EquivManager) : TypeChecker.Inner.whnfCore annotatedPiRawDomainKernel false true - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker - (annotatedPiWithEqvManager ({} : TypeChecker.State) m) = + ({ eqvManager := m } : TypeChecker.State) = .ok (annotatedPiRawDomainKernel, - annotatedPiWithEqvManager ({} : TypeChecker.State) m) := by + ({ eqvManager := m } : TypeChecker.State)) := by change TypeChecker.Inner.whnfCore' (.app (.const ``outParam [.succ .zero]) (.sort .zero)) - false true (TypeChecker.Methods.withFuel 9998) + false true (TypeChecker.Methods.withFuel (fuel + 2)) annotatedPiCtorCandidateContext.toTypeChecker - (annotatedPiWithEqvManager ({} : TypeChecker.State) m) = + ({ eqvManager := m } : TypeChecker.State) = .ok (.app (.const ``outParam [.succ .zero]) (.sort .zero), - annotatedPiWithEqvManager ({} : TypeChecker.State) m) + ({ eqvManager := m } : TypeChecker.State)) unfold TypeChecker.Inner.whnfCore' simp only [normalizationRecMPure, normalizationRecMBind, normalizationRecMGet, annotatedPiWithEqvManager, @@ -4501,9 +4709,9 @@ private theorem annotatedPiWhnfCoreDomainCheap (m : EquivManager) : (Expr.app (.const ``outParam [.succ .zero]) (.sort .zero)).getAppFn = .const ``outParam [.succ .zero] by rfl] - rw [annotatedPiWhnfCoreOutParamConstCheap] + rw [annotatedPiWhnfCoreOutParamConstCheap fuel] simp [annotatedPiRawDomainKernel, annotatedPiReduceRecursorDomain, - annotatedPiWithEqvManager, Expr.eqv_eq, + annotatedPiWithEqvManager, Expr.structuralEq, Bind.bind, ReaderT.bind, StateT.bind, Except.bind] rw [show .app (.const ``outParam [.succ .zero]) (.sort .zero) = @@ -4537,10 +4745,11 @@ private def annotatedPiOutParamInferOnlyState (.const ``outParam [.succ .zero]) annotatedPiOutParamFnType, eqvManager := m } -private theorem annotatedPiInferTypeOutParamOnly (m : EquivManager) : +private theorem annotatedPiInferTypeOutParamOnly + (fuel : Nat) (m : EquivManager) : TypeChecker.Inner.inferType (.const ``outParam [.succ .zero]) true - (TypeChecker.Methods.withFuel 9998) + (TypeChecker.Methods.withFuel (fuel + 2)) annotatedPiCtorCandidateContext.toTypeChecker ({ eqvManager := m } : TypeChecker.State) = .ok (annotatedPiOutParamFnType, @@ -4548,7 +4757,7 @@ private theorem annotatedPiInferTypeOutParamOnly (m : EquivManager) : change TypeChecker.Inner.inferType' (.const ``outParam [.succ .zero]) true - (TypeChecker.Methods.withFuel 9997) + (TypeChecker.Methods.withFuel (fuel + 1)) annotatedPiCtorCandidateContext.toTypeChecker ({ eqvManager := m } : TypeChecker.State) = .ok (annotatedPiOutParamFnType, @@ -4558,9 +4767,10 @@ private theorem annotatedPiInferTypeOutParamOnly (m : EquivManager) : Expr.hasLooseBVars, Expr.looseBVarRange', Bind.bind, ReaderT.bind, StateT.bind, Except.bind] -private theorem annotatedPiInferAppDomainOnly (m : EquivManager) : +private theorem annotatedPiInferAppDomainOnly + (fuel : Nat) (m : EquivManager) : TypeChecker.Inner.inferApp annotatedPiRawDomainKernel - (TypeChecker.Methods.withFuel 9998) + (TypeChecker.Methods.withFuel (fuel + 2)) annotatedPiCtorCandidateContext.toTypeChecker ({ eqvManager := m } : TypeChecker.State) = .ok (.sort (.succ .zero), @@ -4571,7 +4781,7 @@ private theorem annotatedPiInferAppDomainOnly (m : EquivManager) : rw [show annotatedPiRawDomainKernel.getAppArgs = #[.sort .zero] by rfl] simp only [normalizationRecMBind] - rw [annotatedPiInferTypeOutParamOnly] + rw [annotatedPiInferTypeOutParamOnly fuel] simp [TypeChecker.Inner.inferApp.loop, annotatedPiOutParamFnType, Expr.instantiateRevRange, Bind.bind, ReaderT.bind, StateT.bind, Except.bind] @@ -4584,15 +4794,16 @@ private def annotatedPiDomainInferOnlyState annotatedPiRawDomainKernel (.sort (.succ .zero)), eqvManager := m } -private theorem annotatedPiInferTypeDomainOnlyAny (m : EquivManager) : +private theorem annotatedPiInferTypeDomainOnlyAny + (fuel : Nat) (m : EquivManager) : TypeChecker.Inner.inferType annotatedPiRawDomainKernel true - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker ({ eqvManager := m } : TypeChecker.State) = .ok (.sort (.succ .zero), annotatedPiDomainInferOnlyState m) := by change TypeChecker.Inner.inferType' annotatedPiRawDomainKernel true - (TypeChecker.Methods.withFuel 9998) + (TypeChecker.Methods.withFuel (fuel + 2)) annotatedPiCtorCandidateContext.toTypeChecker ({ eqvManager := m } : TypeChecker.State) = .ok (.sort (.succ .zero), annotatedPiDomainInferOnlyState m) @@ -4605,7 +4816,33 @@ private theorem annotatedPiInferTypeDomainOnlyAny (m : EquivManager) : rw [show .app (.const ``outParam [.succ .zero]) (.sort .zero) = annotatedPiRawDomainKernel by rfl] - rw [annotatedPiInferAppDomainOnly] + rw [annotatedPiInferAppDomainOnly fuel] + simp [annotatedPiDomainInferOnlyState, + annotatedPiOutParamInferOnlyState, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + +private theorem annotatedPiInferTypeDomainOnly998 + (m : EquivManager) : + TypeChecker.Inner.inferType' + (.app (.const ``outParam [.succ .zero]) (.sort .zero)) true + (TypeChecker.Methods.withFuel 9998) + annotatedPiCtorCandidateContext.toTypeChecker + ({ eqvManager := m } : TypeChecker.State) = + .ok (.sort (.succ .zero), annotatedPiDomainInferOnlyState m) := by + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + annotatedPiDomainInferOnlyState, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + rw [show + .app (.const ``outParam [.succ .zero]) (.sort .zero) = + annotatedPiRawDomainKernel by rfl] + rw [show TypeChecker.Inner.inferApp annotatedPiRawDomainKernel + (TypeChecker.Methods.withFuel 9998) + annotatedPiCtorCandidateContext.toTypeChecker + ({ eqvManager := m } : TypeChecker.State) = + .ok (.sort (.succ .zero), annotatedPiOutParamInferOnlyState m) by + simpa only [Nat.reduceAdd] using + annotatedPiInferAppDomainOnly 9996 m] simp [annotatedPiDomainInferOnlyState, annotatedPiOutParamInferOnlyState, Bind.bind, ReaderT.bind, StateT.bind, Except.bind] @@ -4623,16 +4860,17 @@ private def annotatedPiSortOneInferOnlyState simp [annotatedPiDomainInferOnlyState, annotatedPiRawDomainKernel, annotatedPiOutParamFnType, Expr.eqv_eq] -private theorem annotatedPiInferTypeSortOneOnly (m : EquivManager) : +private theorem annotatedPiInferTypeSortOneOnly + (fuel : Nat) (m : EquivManager) : TypeChecker.Inner.inferType (.sort (.succ .zero)) true - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker (annotatedPiDomainInferOnlyState m) = .ok (.sort (.succ (.succ .zero)), annotatedPiSortOneInferOnlyState m) := by change TypeChecker.Inner.inferType' (.sort (.succ .zero)) true - (TypeChecker.Methods.withFuel 9998) + (TypeChecker.Methods.withFuel (fuel + 2)) annotatedPiCtorCandidateContext.toTypeChecker (annotatedPiDomainInferOnlyState m) = .ok (.sort (.succ (.succ .zero)), @@ -4644,37 +4882,38 @@ private theorem annotatedPiInferTypeSortOneOnly (m : EquivManager) : Except.bind] @[simp] private theorem annotatedPiWhnfSortTwo - (state : TypeChecker.State) : + (fuel : Nat) (state : TypeChecker.State) : TypeChecker.Inner.whnf (.sort (.succ (.succ .zero))) - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker state = .ok (.sort (.succ (.succ .zero)), state) := by rfl -private theorem annotatedPiIsPropSortOneFalse (m : EquivManager) : +private theorem annotatedPiIsPropSortOneFalse + (fuel : Nat) (m : EquivManager) : TypeChecker.Inner.isProp (.sort (.succ .zero)) - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker (annotatedPiDomainInferOnlyState m) = .ok (false, annotatedPiSortOneInferOnlyState m) := by unfold TypeChecker.Inner.isProp TypeChecker.Inner.getSortLevel simp only [normalizationRecMBind] - rw [annotatedPiInferTypeSortOneOnly] + rw [annotatedPiInferTypeSortOneOnly fuel] rfl private theorem annotatedPiIsDefEqProofIrrelDomain - (m : EquivManager) : + (fuel : Nat) (m : EquivManager) : TypeChecker.Inner.isDefEqProofIrrel annotatedPiRawDomainKernel (.sort .zero) - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker ({ eqvManager := m } : TypeChecker.State) = .ok (.undef, annotatedPiSortOneInferOnlyState m) := by unfold TypeChecker.Inner.isDefEqProofIrrel simp only [normalizationRecMBind] - rw [annotatedPiInferTypeDomainOnlyAny] + rw [annotatedPiInferTypeDomainOnlyAny fuel] simp only [normalizationRecMBind] - rw [annotatedPiIsPropSortOneFalse] + rw [annotatedPiIsPropSortOneFalse fuel] rfl private theorem annotatedPiUnfoldOutParamCoreOfMiss @@ -4731,26 +4970,28 @@ private theorem annotatedPiUnfoldDomainOfMiss (by simp) (by rfl) (by rfl)] rfl -@[simp] private theorem annotatedPiWhnfCoreIdentityCheap (state) : +@[simp] private theorem annotatedPiWhnfCoreIdentityCheap + (fuel : Nat) (state) : TypeChecker.Inner.whnfCore (.lam `α (.sort (.succ .zero)) (.bvar 0) .default) - false true (TypeChecker.Methods.withFuel 9998) + false true (TypeChecker.Methods.withFuel (fuel + 2)) annotatedPiCtorCandidateContext.toTypeChecker state = .ok (.lam `α (.sort (.succ .zero)) (.bvar 0) .default, state) := by rfl -@[simp] private theorem annotatedPiWhnfCoreSortZeroCheap998 (state) : +@[simp] private theorem annotatedPiWhnfCoreSortZeroCheap + (fuel : Nat) (state) : TypeChecker.Inner.whnfCore (.sort .zero) false true - (TypeChecker.Methods.withFuel 9998) + (TypeChecker.Methods.withFuel (fuel + 2)) annotatedPiCtorCandidateContext.toTypeChecker state = .ok (.sort .zero, state) := by rfl private theorem annotatedPiWhnfCoreDomainBetaCheap - (m : EquivManager) : + (fuel : Nat) (m : EquivManager) : TypeChecker.Inner.whnfCore annotatedPiDomainBetaKernel false true - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker (annotatedPiOutParamUnfoldState (annotatedPiSortOneInferOnlyState m)) = @@ -4759,7 +5000,7 @@ private theorem annotatedPiWhnfCoreDomainBetaCheap (annotatedPiSortOneInferOnlyState m)) := by change TypeChecker.Inner.whnfCore' annotatedPiDomainBetaKernel false true - (TypeChecker.Methods.withFuel 9998) + (TypeChecker.Methods.withFuel (fuel + 2)) annotatedPiCtorCandidateContext.toTypeChecker (annotatedPiOutParamUnfoldState (annotatedPiSortOneInferOnlyState m)) = @@ -4780,7 +5021,7 @@ private theorem annotatedPiWhnfCoreDomainBetaCheap (.lam `α (.sort (.succ .zero)) (.bvar 0) .default) (.sort .zero)).getAppFn = .lam `α (.sort (.succ .zero)) (.bvar 0) .default by rfl] - rw [annotatedPiWhnfCoreIdentityCheap] + rw [annotatedPiWhnfCoreIdentityCheap fuel] rw [show (Expr.app (.lam `α (.sort (.succ .zero)) (.bvar 0) .default) @@ -4817,7 +5058,7 @@ private theorem annotatedPiQuickIsDefEqSortZeroAny MonadStateOf.modifyGet, monadLift, MonadLift.monadLift, StateT.modifyGet, pure, ReaderT.pure, StateT.pure, Except.pure, hr', annotatedPiWithEqvManager, - Level.isEquiv, Level.isEquiv', + Level.isEquiv, Level.isEquiv', Level.isStructEq, Bind.bind, ReaderT.bind, StateT.bind, Except.bind] @@ -4846,10 +5087,10 @@ private theorem annotatedPiIsDeltaDomain : rfl private theorem annotatedPiDeltaDomain - (m : EquivManager) : + (fuel : Nat) (m : EquivManager) : (TypeChecker.Inner.unfoldDefinition annotatedPiRawDomainKernel >>= fun e => TypeChecker.Inner.whnfCore e.get! false true) - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker (annotatedPiSortOneInferOnlyState m) = .ok (.sort .zero, @@ -4857,21 +5098,21 @@ private theorem annotatedPiDeltaDomain (annotatedPiSortOneInferOnlyState m)) := by simp only [normalizationRecMBind] rw [annotatedPiUnfoldDomainOfMiss - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) (annotatedPiSortOneInferOnlyState m) (by simp [annotatedPiSortOneInferOnlyState, annotatedPiDomainInferOnlyState])] simp only rw [show (some annotatedPiDomainBetaKernel).get! = annotatedPiDomainBetaKernel by rfl] - rw [annotatedPiWhnfCoreDomainBetaCheap] + rw [annotatedPiWhnfCoreDomainBetaCheap fuel] private theorem annotatedPiLazyDeltaStepDomain - (m : EquivManager) : + (fuel : Nat) (m : EquivManager) : ∃ m' : EquivManager, TypeChecker.Inner.lazyDeltaReductionStep annotatedPiRawDomainKernel (.sort .zero) - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker (annotatedPiSortOneInferOnlyState m) = .ok (.bool true, @@ -4879,7 +5120,7 @@ private theorem annotatedPiLazyDeltaStepDomain (annotatedPiOutParamUnfoldState (annotatedPiSortOneInferOnlyState m)) m') := by obtain ⟨m', hquick⟩ := annotatedPiQuickIsDefEqSortZeroAny - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker (annotatedPiOutParamUnfoldState (annotatedPiSortOneInferOnlyState m)) @@ -4896,17 +5137,17 @@ private theorem annotatedPiLazyDeltaStepDomain rw [annotatedPiTryUnfoldProjAppSortZero] simp only rw [normalizationRecMBind] - rw [annotatedPiDeltaDomain] + rw [annotatedPiDeltaDomain fuel] simp only rw [normalizationRecMBind] rw [hquick] rfl @[simp] private theorem annotatedPiIsDefEqOffsetDomain - (m : EquivManager) : + (fuel : Nat) (m : EquivManager) : TypeChecker.Inner.isDefEqOffset annotatedPiRawDomainKernel (.sort .zero) - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker (annotatedPiSortOneInferOnlyState m) = .ok (.undef, annotatedPiSortOneInferOnlyState m) := by @@ -4922,23 +5163,23 @@ private theorem annotatedPiLazyDeltaStepDomain rfl private theorem annotatedPiLazyDeltaLoopDomain - (m : EquivManager) : + (fuel : Nat) (m : EquivManager) : ∃ m' : EquivManager, TypeChecker.Inner.lazyDeltaReduction.loop annotatedPiRawDomainKernel (.sort .zero) 1000 - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker (annotatedPiSortOneInferOnlyState m) = .ok (.bool true, annotatedPiWithEqvManager (annotatedPiOutParamUnfoldState (annotatedPiSortOneInferOnlyState m)) m') := by - obtain ⟨m', hstep⟩ := annotatedPiLazyDeltaStepDomain m + obtain ⟨m', hstep⟩ := annotatedPiLazyDeltaStepDomain fuel m refine ⟨m', ?_⟩ rw [show 1000 = 999 + 1 by rfl] unfold TypeChecker.Inner.lazyDeltaReduction.loop rw [normalizationRecMBind] - rw [annotatedPiIsDefEqOffsetDomain] + rw [annotatedPiIsDefEqOffsetDomain fuel] simp only rw [show (LBool.undef != LBool.undef) = false by rfl] simp only [Bool.false_eq_true, if_false] @@ -4982,18 +5223,18 @@ private theorem annotatedPiLazyDeltaLoopDomain rfl private theorem annotatedPiLazyDeltaDomain - (m : EquivManager) : + (fuel : Nat) (m : EquivManager) : ∃ m' : EquivManager, TypeChecker.Inner.lazyDeltaReduction annotatedPiRawDomainKernel (.sort .zero) - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker (annotatedPiSortOneInferOnlyState m) = .ok (.bool true, annotatedPiWithEqvManager (annotatedPiOutParamUnfoldState (annotatedPiSortOneInferOnlyState m)) m') := by - obtain ⟨m', hloop⟩ := annotatedPiLazyDeltaLoopDomain m + obtain ⟨m', hloop⟩ := annotatedPiLazyDeltaLoopDomain fuel m refine ⟨m', ?_⟩ unfold TypeChecker.Inner.lazyDeltaReduction rw [normalizationRecMBind] @@ -5002,17 +5243,17 @@ private theorem annotatedPiLazyDeltaDomain change TypeChecker.Inner.lazyDeltaReduction.loop annotatedPiRawDomainKernel (.sort .zero) 1000 - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker (annotatedPiSortOneInferOnlyState m) = _ exact hloop private theorem annotatedPiQuickIsDefEqDomainAny - (m : EquivManager) : + (fuel : Nat) (m : EquivManager) : ∃ (r : LBool) (m' : EquivManager), TypeChecker.Inner.quickIsDefEq annotatedPiRawDomainKernel (.sort .zero) false - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker ({ eqvManager := m } : TypeChecker.State) = .ok (r, ({ eqvManager := m' } : TypeChecker.State)) ∧ @@ -5039,93 +5280,64 @@ private theorem annotatedPiQuickIsDefEqDomainAny Except.bind] @[simp] private theorem annotatedPiWhnfCoreSortCheap - (state : TypeChecker.State) : + (fuel : Nat) (state : TypeChecker.State) : TypeChecker.Inner.whnfCore (.sort .zero) false true - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker state = .ok (.sort .zero, state) := by rfl -private theorem annotatedPiIsDefEqCoreDomain : +private theorem annotatedPiIsDefEqCoreDomain + (fuel : Nat) (initial : EquivManager := {}) : ∃ state : TypeChecker.State, TypeChecker.Inner.isDefEqCore' annotatedPiRawDomainKernel (.sort .zero) - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker - ({} : TypeChecker.State) = + ({ eqvManager := initial } : TypeChecker.State) = .ok (true, state) := by - obtain ⟨m, hquick⟩ := annotatedPiQuickIsDefEqDomainInitial - (TypeChecker.Methods.withFuel 9999) - annotatedPiCtorCandidateContext.toTypeChecker + obtain ⟨r, m, hquick, hr⟩ := annotatedPiQuickIsDefEqDomainInitial + (TypeChecker.Methods.withFuel (fuel + 3)) + annotatedPiCtorCandidateContext.toTypeChecker initial unfold TypeChecker.Inner.isDefEqCore' rw [normalizationRecMBind] rw [hquick] - 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] - 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] - simp only - rw [normalizationRecMBind] - rw [annotatedPiWhnfCoreSortCheap] - simp only - cases hptr : - (!(ptrEqExpr annotatedPiRawDomainKernel annotatedPiRawDomainKernel && - ptrEqExpr (.sort .zero) (.sort .zero))) - · simp only [Bool.false_eq_true, if_false] + rcases hr with htrue | hundef + · subst r + simp only + rw [show (LBool.true != LBool.undef) = true by rfl] + simp only [if_true] + exact ⟨({ eqvManager := m } : TypeChecker.State), rfl⟩ + · subst r + 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] - rw [show annotatedPiWithEqvManager ({} : TypeChecker.State) m = - ({ eqvManager := m } : TypeChecker.State) by rfl] - rw [annotatedPiIsDefEqProofIrrelDomain] + rw [normalizationRecMReadContext] simp only - rw [show (LBool.undef != LBool.undef) = false by rfl] - simp only [Bool.false_eq_true, if_false] + 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] - obtain ⟨m'', hlazy⟩ := annotatedPiLazyDeltaDomain m - rw [hlazy] - refine ⟨annotatedPiWithEqvManager - (annotatedPiOutParamUnfoldState - (annotatedPiSortOneInferOnlyState m)) m'', ?_⟩ - rfl - · simp only [if_true] - obtain ⟨r, m', hquick', hr⟩ := - annotatedPiQuickIsDefEqDomainAny m + rw [annotatedPiWhnfCoreDomainCheap fuel] + simp only rw [normalizationRecMBind] - rw [show annotatedPiWithEqvManager ({} : TypeChecker.State) m = - ({ eqvManager := m } : TypeChecker.State) by rfl] - rw [hquick'] + rw [annotatedPiWhnfCoreSortCheap fuel] simp only - rcases hr with htrue | hundef - · subst r - rw [show (LBool.true != LBool.undef) = true by rfl] - simp only [if_true] - refine ⟨({ eqvManager := m' } : TypeChecker.State), ?_⟩ - rfl - · subst r - rw [show (LBool.undef != LBool.undef) = false by rfl] - simp only [Bool.false_eq_true, if_false] + cases hptr : + (!(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] + rw [annotatedPiIsDefEqProofIrrelDomain fuel] simp only rw [show (LBool.undef != LBool.undef) = false by rfl] simp only [Bool.false_eq_true, if_false] @@ -5133,37 +5345,88 @@ private theorem annotatedPiIsDefEqCoreDomain : rw [normalizationRecMPure] simp only rw [normalizationRecMBind] - obtain ⟨m'', hlazy⟩ := annotatedPiLazyDeltaDomain m' + obtain ⟨m'', hlazy⟩ := annotatedPiLazyDeltaDomain fuel m rw [hlazy] refine ⟨annotatedPiWithEqvManager (annotatedPiOutParamUnfoldState - (annotatedPiSortOneInferOnlyState m')) m'', ?_⟩ + (annotatedPiSortOneInferOnlyState m)) m'', ?_⟩ rfl - -private theorem annotatedPiDomain_isDefEqM : - TypeChecker.M.run annotatedPiCtorCandidateContext.env - annotatedPiCtorCandidateContext.safety - annotatedPiCtorCandidateContext.lctx - annotatedPiCtorCandidateContext.lparams - annotatedPiCtorCandidateContext.fuel - (TypeChecker.isDefEq annotatedPiRawDomainKernel (.sort .zero)) = - .ok true := by - obtain ⟨state, hcore⟩ := annotatedPiIsDefEqCoreDomain + · simp only [if_true] + obtain ⟨r, m', hquick', hr⟩ := + annotatedPiQuickIsDefEqDomainAny fuel m + rw [normalizationRecMBind] + rw [hquick'] + simp only + rcases hr with htrue | hundef + · subst r + rw [show (LBool.true != LBool.undef) = true by rfl] + simp only [if_true] + refine ⟨({ eqvManager := m' } : TypeChecker.State), ?_⟩ + rfl + · subst r + 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 + (annotatedPiOutParamUnfoldState + (annotatedPiSortOneInferOnlyState m')) m'', ?_⟩ + rfl + +private theorem annotatedPiDomain_isDefEqInner + (fuel : Nat) (initial : EquivManager := {}) : + ∃ state : TypeChecker.State, + TypeChecker.Inner.isDefEq annotatedPiRawDomainKernel (.sort .zero) + (TypeChecker.Methods.withFuel (fuel + 4)) + annotatedPiCtorCandidateContext.toTypeChecker + ({ eqvManager := initial } : TypeChecker.State) = + .ok (true, state) := by + obtain ⟨state, hcore⟩ := annotatedPiIsDefEqCoreDomain fuel initial have hcore' : TypeChecker.Inner.isDefEqCore annotatedPiRawDomainKernel (.sort .zero) - (TypeChecker.Methods.withFuel 10000) + (TypeChecker.Methods.withFuel (fuel + 4)) annotatedPiCtorCandidateContext.toTypeChecker - ({} : TypeChecker.State) = + ({ eqvManager := initial } : TypeChecker.State) = .ok (true, state) := by change TypeChecker.Inner.isDefEqCore' annotatedPiRawDomainKernel (.sort .zero) - (TypeChecker.Methods.withFuel 9999) + (TypeChecker.Methods.withFuel (fuel + 3)) annotatedPiCtorCandidateContext.toTypeChecker - ({} : TypeChecker.State) = + ({ eqvManager := initial } : TypeChecker.State) = .ok (true, state) exact hcore + unfold TypeChecker.Inner.isDefEq + rw [show + (annotatedPiRawDomainKernel == (.sort .zero : Expr)) = false by + exact annotatedPiApp_beq_sort _ _ _] + simp only [Bool.false_eq_true, if_false, pure_bind, + normalizationRecMBind] + rw [hcore'] + exact ⟨_, rfl⟩ + +private theorem annotatedPiDomain_isDefEqM : + TypeChecker.M.run annotatedPiCtorCandidateContext.env + annotatedPiCtorCandidateContext.safety + annotatedPiCtorCandidateContext.lctx + annotatedPiCtorCandidateContext.lparams + annotatedPiCtorCandidateContext.fuel + (TypeChecker.isDefEq annotatedPiRawDomainKernel (.sort .zero)) = + .ok true := by + obtain ⟨state, hrun⟩ := annotatedPiDomain_isDefEqInner 9996 change Except.map (fun x : Bool × TypeChecker.State => x.1) (TypeChecker.Inner.isDefEq @@ -5172,13 +5435,12 @@ private theorem annotatedPiDomain_isDefEqM : annotatedPiCtorCandidateContext.toTypeChecker ({} : TypeChecker.State)) = .ok true - unfold TypeChecker.Inner.isDefEq - rw [show - (annotatedPiRawDomainKernel == (.sort .zero : Expr)) = false by - exact annotatedPiApp_beq_sort _ _ _] - simp only [Bool.false_eq_true, if_false, pure_bind, - normalizationRecMBind] - rw [hcore'] + rw [show TypeChecker.Inner.isDefEq + annotatedPiRawDomainKernel (.sort .zero) + (TypeChecker.Methods.withFuel 10000) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State) = .ok (true, state) by + simpa only [Nat.reduceAdd] using hrun] rfl private theorem annotatedPiInner_checkTypeM : @@ -5835,6 +6097,7 @@ private def annotatedPiInnerInferOnlyFinalState : TypeChecker.State := inferTypeI := annotatedPiFamilyInferOnlyState.inferTypeI.insert annotatedPiInnerKernel (.sort (.succ .zero)) } +set_option maxRecDepth 10000 in private theorem annotatedPiInner_inferTypeInner : TypeChecker.Inner.inferType annotatedPiInnerKernel true (TypeChecker.Methods.withFuel 10000) @@ -5852,14 +6115,7 @@ private theorem annotatedPiInner_inferTypeInner : Expr.hasLooseBVars, Expr.looseBVarRange', TypeChecker.Inner.inferForall, TypeChecker.Inner.inferForall.loop, Bind.bind, ReaderT.bind, StateT.bind, Except.bind] - rw [show TypeChecker.Inner.inferType' - (.app (.const ``outParam [.succ .zero]) (.sort .zero)) true - (TypeChecker.Methods.withFuel 9998) - annotatedPiCtorCandidateContext.toTypeChecker - ({} : TypeChecker.State) = - .ok (.sort (.succ .zero), - annotatedPiDomainInferOnlyState {}) by - exact annotatedPiInferTypeDomainOnlyAny {}] + rw [annotatedPiInferTypeDomainOnly998] simp only [TypeChecker.Inner.ensureSortCore, Expr.isSort, if_true, annotatedPiWithLocalDecl, Expr.instantiate1', annotatedPiRecMPure, Bind.bind, ReaderT.bind, @@ -6040,16 +6296,16 @@ private theorem annotatedPi_checkPositivity_expanded : annotatedPiRawDomainKernel] using annotatedPi_checkPositivity private theorem annotatedPi_checkConstructors_terminal : - AddInductive.checkConstructors.loop annotatedPiInductiveStats false 0 + AddInductive.checkConstructorType.loop annotatedPiInductiveStats false 0 ``AnnotatedPi.mk (.const ``AnnotatedPi []) 1 999 annotatedPiOuterBodyCandidateContext = .ok () := by rw [show 999 = 998 + 1 by rfl] - unfold AddInductive.checkConstructors.loop + unfold AddInductive.checkConstructorType.loop simp [annotatedPiConst_isValidIndAppIdx, ReaderT.pure, Pure.pure, Except.pure] private theorem annotatedPi_checkConstructors_terminal_expanded : - AddInductive.checkConstructors.loop annotatedPiInductiveStats false 0 + AddInductive.checkConstructorType.loop annotatedPiInductiveStats false 0 ``AnnotatedPi.mk (.const ``AnnotatedPi []) 1 999 ({ env := annotatedPiTypeKernelEnv lctx := ({} : LocalContext).mkLocalDecl @@ -6171,6 +6427,7 @@ private theorem annotatedPi_checkConstructors : rw [AddInductive.liftTypeChecker_apply] rw [annotatedPiCtor_getEnvM] simp only [Except.bind] + unfold AddInductive.checkConstructorFold simp +decide [annotatedPiKernelType, annotatedPiKernelCtor, annotatedPiMkInfo, ConstantInfo.name, ConstantInfo.type, ConstantInfo.toConstantVal, NameSet.contains] @@ -6182,6 +6439,7 @@ private theorem annotatedPi_checkConstructors : simp only rw [annotatedPiCtor_checkTypeM_empty] simp only [Except.bind] + unfold AddInductive.checkConstructorType simp +decide [ConstantInfo.type, ConstantInfo.toConstantVal, AddInductive.liftTypeChecker_apply, readThe, MonadReaderOf.read, ReaderT.read, @@ -6189,7 +6447,7 @@ private theorem annotatedPi_checkConstructors : Except.bind, Except.pure] rw [show annotatedPiCtorCandidateContext.fuel.inductiveFuel = 999 + 1 by rfl] - unfold AddInductive.checkConstructors.loop + unfold AddInductive.checkConstructorType.loop simp only rw [show annotatedPiInductiveStats.params[0]? = none by rfl] simp only @@ -6215,8 +6473,42 @@ 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] +private theorem annotatedPi_checkConstructorUniverseSemantics : + AddInductive.checkConstructorUniverseListSemantics + annotatedPiInductiveStats annotatedPiKernelType.ctors + annotatedPiCtorCandidateContext = .ok () := by + unfold AddInductive.checkConstructorUniverseListSemantics + simp only [annotatedPiKernelType, annotatedPiKernelCtor, + annotatedPiMkInfo, ConstantInfo.type, ConstantInfo.toConstantVal, + ReaderT.bind, Bind.bind] + unfold AddInductive.checkConstructorUniverseSemantics + simp only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] + rw [show annotatedPiCtorCandidateContext.fuel.inductiveFuel = + 999 + 1 by rfl] + unfold AddInductive.checkConstructorUniverseSemantics.loop + simp only + rw [show annotatedPiInductiveStats.params[0]? = none by rfl] + simp only [ReaderT.bind, Bind.bind, AddInductive.liftTypeChecker_apply] + rw [annotatedPiInner_ensureTypeM_expanded] + simp only [Except.bind] + simp [Expr.sortLevel!, AddInductive.constructorUniverseSemanticGe, + AddInductive.levelStructGe, AddInductive.levelStructEq, Pure.pure] + simp only [AddInductive.withLocalDecl_apply, + annotatedPiConst_instantiate1, annotatedPiConst_instantiate1', + annotatedPiOuterBodyCandidateContext, + AddInductive.Context.pushLocalDecl, + AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, + AddInductive.consumeTypeAnnotations, annotatedPiInnerAnnotations, + annotatedPiInnerKernel, annotatedPiRawDomainKernel, + annotatedPiCtorCandidateContext] + unfold AddInductive.checkConstructorUniverseSemantics.loop + rfl + private theorem annotatedPiSortAnnotationTrace_build : AddInductive.CandidateTypeAnnotationTrace.build (.sort .zero) = ⟨.sort .zero, .identity _⟩ := by @@ -6724,6 +7016,7 @@ private theorem aliasFormer_checkConstructors : rw [AddInductive.liftTypeChecker_apply] rw [aliasFormerCtor_getEnvM] simp only [Except.bind] + unfold AddInductive.checkConstructorFold simp +decide [aliasFormerKernelType, aliasFormerKernelCtor, aliasFormerMkInfo, ConstantInfo.name, NameSet.contains] simp +decide [ConstantInfo.type, @@ -6738,11 +7031,32 @@ private theorem aliasFormer_checkConstructors : { root := PersistentArrayNode.node #[], tail := #[] } } : LocalContext) rfl] simp only [Except.bind] + unfold AddInductive.checkConstructorType + simp only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] rw [show aliasFormerCtorCandidateContext.fuel.inductiveFuel = 999 + 1 by rfl] - unfold AddInductive.checkConstructors.loop + unfold AddInductive.checkConstructorType.loop simp [aliasFormerCtor_isValidIndAppIdx, ReaderT.pure, Pure.pure, - Except.pure] + Except.pure, AddInductive.checkConstructorFold] + +private theorem aliasFormer_checkConstructorUniverseSemantics : + AddInductive.checkConstructorUniverseListSemantics + aliasFormerInductiveStats aliasFormerKernelType.ctors + aliasFormerCtorCandidateContext = .ok () := by + unfold AddInductive.checkConstructorUniverseListSemantics + simp only [aliasFormerKernelType, aliasFormerKernelCtor, + aliasFormerMkInfo, ConstantInfo.type, ConstantInfo.toConstantVal, + ReaderT.bind, Bind.bind] + unfold AddInductive.checkConstructorUniverseSemantics + simp only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] + rw [show aliasFormerCtorCandidateContext.fuel.inductiveFuel = 999 + 1 by + rfl] + unfold AddInductive.checkConstructorUniverseSemantics.loop + rfl /-- The generic candidate traversal retains the exact context, input, and result of the actual AliasFormer family WHNF observation. -/ @@ -7022,7 +7336,7 @@ private def aliasFormerFamilyCandidateNodeRun : (by have hs : TrExprS typeFamilyAliasEnv [] [] (.sort (.succ .zero)) (.sort (.succ .zero)) := .sort rfl - exact ⟨_, hs, ⟨_, VEnv.HasType.sort (by decide)⟩⟩) + exact hs) 10000 9999 (by rfl) (by rfl) /-- Verified family-result normalization leaf for AliasFormer. -/ @@ -7198,8 +7512,7 @@ private def aliasFormerCtorCandidateNodeRun : aliasFormerCtorCandidateContextRun.context_eq rfl rfl rfl aliasFormerCtorCandidateContextRun.state_wf aliasFormerCtorCheckTypeRun.expr_tr (.const rfl rfl rfl) - ⟨_, aliasFormerCtorCheckTypeRun.expr_tr, - ⟨_, aliasFormerCtorCheckTypeRun.hasType⟩⟩ + aliasFormerCtorCheckTypeRun.expr_tr 10000 9999 (by rfl) (by rfl) private def aliasFormerCtorCandidateRun : @@ -7278,10 +7591,7 @@ def recAliasWhnfRun : exact .lam ⟨_, VEnv.HasType.sort (by decide)⟩ (.sort rfl) (.bvar rfl) - exact ⟨_, hs, ⟨_, - VEnv.HasType.lam - (VEnv.HasType.sort (by decide)) - (VEnv.HasType.bvar .zero)⟩⟩ + exact hs recursionFuel := 9999 run_eq := by simpa [aliasRecNormalizationContext, TypeChecker.VContext.mk', @@ -7393,51 +7703,272 @@ private def aliasFormerCandidateFamilyRun : aliasFormerFamilyListCandidate aliasFormerRawType := aliasFormerCandidateFamilySemanticRun.root -/-- Temporary L4L-01A compatibility witness used by downstream generation. -The staged owner above independently proves existence without choosing this -value; L4L-01E removes the explicit witness. -/ -private def aliasFormerNormalizationCandidateSemanticRun : - VInductDecl.NormalizationCandidateSemanticRun typeFamilyAliasEnv [] - aliasFormerNormalizationCandidate aliasFormerRawDecl where - raw := aliasFormerRawType - raw_types_eq := rfl - uvars_eq := rfl - family := aliasFormerCandidateFamilySemanticRun - -private def aliasFormerStagedSemanticInput : - VInductDecl.StagedNormalizationCandidateSemanticInput +private noncomputable def aliasFormerStagedUniverseInput : + VInductDecl.StagedNormalizationCandidateUniverseInput aliasFormerCandidateContext aliasFormerCtorCandidateContext typeFamilyAliasEnv [] aliasFormerNormalizationCandidate aliasFormerRawDecl where - raw := aliasFormerRawType - raw_types_eq := rfl - declaration_uvars_eq := rfl - preFamily := aliasFormerPreFamilyStage - family := aliasFormerFamilyStage - constructors := .cons { - name_eq := rfl - uvars_eq := rfl - type := { - context_eq := rfl - source_tr := aliasFormerCtorCheckTypeRun.expr_tr - whnfFuel := 9999 - whnfDepth := rfl } } .nil - familyTypesProduced := aliasFormerFamilyTypeListProduced - familiesProduced := aliasFormerFamilyListProduced - -/-- The exact family/constructor producer traversals and verified translations -automatically determine a complete retained AliasFormer hierarchy. -/ -theorem aliasFormerProducedSemanticHierarchy_exists : + staged := { + raw := aliasFormerRawType + raw_types_eq := rfl + declaration_uvars_eq := rfl + preFamily := aliasFormerPreFamilyStage + family := aliasFormerFamilyStage + validation_nparams_eq := rfl + constructorValidation := + AddInductive.ConstructorValidationRun.of_run aliasFormer_checkConstructors + constructors := .cons { + name_eq := rfl + uvars_eq := rfl + type := { + context_eq := rfl + source_tr := aliasFormerCtorCheckTypeRun.expr_tr + whnfFuel := 9999 + whnfDepth := rfl } } .nil + familyTypesProduced := aliasFormerFamilyTypeListProduced + familiesProduced := aliasFormerFamilyListProduced } + universeRun := aliasFormer_checkConstructorUniverseSemantics + +private theorem aliasFormerConstructorValidationContext_eq : + { aliasFormerNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with + env := aliasFormerCtorCandidateContext.env } = + aliasFormerCtorCandidateContext := rfl + +private theorem aliasFormerCtorCandidateContext_empty : + aliasFormerCtorCandidateContext.withEmptyLocalContext = + aliasFormerCtorCandidateContext := rfl + +private 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 : + VInductDecl.StagedNormalizationCandidatePostFamilyInput + aliasFormerCandidateContext aliasFormerCtorCandidateContext + typeFamilyAliasEnv [] aliasFormerNormalizationCandidate + aliasFormerRawDecl := + VInductDecl.StagedNormalizationCandidatePostFamilyInput.ofRun + aliasFormerStagedUniverseInput aliasFormerAlignmentRun + +private theorem aliasFormerPreFamilySafetyRun : + AddInductive.checkConstructorPreFamilySafety + aliasFormerStagedUniverseInput.staged.family.validation.stats + aliasFormerNormalizationCandidate.families.singleton.familyType.type.view + aliasFormerNormalizationCandidate.families.singleton.constructors + aliasFormerNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext = + .ok () := by + change AddInductive.checkConstructorPreFamilySafety + aliasFormerInductiveStats (.sort (.succ .zero)) + (.cons aliasFormerConstructorCandidate .nil) + aliasFormerCandidateContext = .ok () + let sortStep : AddInductive.CandidateCheckTypeStep := + ⟨aliasFormerCandidateContext, .sort (.succ .zero), + .sort (.succ (.succ .zero))⟩ + have sortRun : sortStep.Valid := by + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' (.sort (.succ .zero)) false + (TypeChecker.Methods.withFuel 9999) + aliasFormerCandidateContext.toTypeChecker + ({} : TypeChecker.State)) = _ + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + annotatedPi_checkLevelSuccZero, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + rfl + have sortHasMVar : (Expr.sort (.succ .zero)).hasMVar = false := by + simp [Expr.hasMVar, annotatedPiSortOne_data_hasExprMVar_false, + annotatedPiSortOne_data_hasLevelMVar_false] + obtain ⟨sortChecked, sortCheckedRun⟩ := + AddInductive.checkConstructorAlignedExpr.exists_of_run + (context := aliasFormerCandidateContext) + (source := .sort (.succ .zero)) + (inferred := .sort (.succ (.succ .zero))) rfl sortHasMVar sortRun + have aliasArgs : + (Expr.const ``AliasFormer []).getAppArgs.toList.drop 0 = [] := by + rfl + have paramsSize : aliasFormerInductiveStats.params.size = 0 := rfl + have targetArgs : + (Expr.const ``AliasFormer []).getAppArgs.toList.drop + aliasFormerInductiveStats.params.size = [] := by + rw [paramsSize] + exact aliasArgs + have inductiveFuel : + aliasFormerCandidateContext.fuel.inductiveFuel = 1000 := rfl + unfold AddInductive.checkConstructorPreFamilySafety + have parametersRun : + AddInductive.instantiateFamilyParameters (.sort (.succ .zero)) + aliasFormerInductiveStats.params.toList = .ok (.sort (.succ .zero)) := by + rfl + have sortTerminal : (Expr.sort (.succ .zero)).isForall = false := rfl + let spineTrace : AddInductive.ConstructorPreFamilyIndexSpineTrace + aliasFormerCandidateContext (.sort (.succ .zero)) [] := + .nil aliasFormerCandidateContext (.sort (.succ .zero)) sortChecked + sortTerminal + have spineRun : + AddInductive.ConstructorPreFamilyIndexSpineTrace.build + aliasFormerCandidateContext (.sort (.succ .zero)) [] = + .ok spineTrace := by + unfold AddInductive.ConstructorPreFamilyIndexSpineTrace.build + rw [dif_pos sortTerminal, sortCheckedRun] + rfl + obtain ⟨targetSpineTrace, targetSpineRun⟩ : + ∃ targetSpineTrace : AddInductive.ConstructorPreFamilyIndexSpineTrace + aliasFormerCandidateContext (.sort (.succ .zero)) + ((Expr.const ``AliasFormer []).getAppArgs.toList.drop + aliasFormerInductiveStats.params.size), + AddInductive.ConstructorPreFamilyIndexSpineTrace.build + aliasFormerCandidateContext (.sort (.succ .zero)) + ((Expr.const ``AliasFormer []).getAppArgs.toList.drop + aliasFormerInductiveStats.params.size) = + .ok targetSpineTrace := by + rw [targetArgs] + exact ⟨spineTrace, spineRun⟩ + have valid : AddInductive.isValidIndAppIdx aliasFormerInductiveStats + (.const ``AliasFormer []) 0 = true := + aliasFormerCtor_isValidIndAppIdx + have independent : AddInductive.constructorIndependentOf + (.const ``AliasFormer []) [] = true := by + rfl + obtain ⟨viewTrace, viewRun⟩ : ∃ viewTrace, + AddInductive.ConstructorPreFamilyViewTrace.build + aliasFormerInductiveStats 0 (.sort (.succ .zero)) + aliasFormerCandidateContext (.const ``AliasFormer []) 0 [] false + aliasFormerCandidateContext.fuel.inductiveFuel = .ok viewTrace := by + rw [inductiveFuel] + rw [show 1000 = 999 + 1 by rfl] + simp only [AddInductive.ConstructorPreFamilyViewTrace.build] + rw [dif_pos valid, dif_pos independent] + rw [targetSpineRun] + exact ⟨_, rfl⟩ + obtain ⟨listTrace, listRun⟩ : ∃ listTrace, + AddInductive.ConstructorPreFamilyListTrace.build + aliasFormerInductiveStats 0 (.sort (.succ .zero)) + aliasFormerCandidateContext + (.cons aliasFormerConstructorCandidate .nil) = .ok listTrace := by + refine ⟨.cons viewTrace .nil, ?_⟩ + simp [AddInductive.ConstructorPreFamilyListTrace.build, + aliasFormerConstructorCandidate, aliasFormerCtorCandidate, + AddInductive.CandidateExpr.view, AddInductive.CandidateExprTrace.view, + viewRun, Bind.bind, Except.bind, Except.pure, Pure.pure] + have translationUnique : + (AddInductive.theoryTranslationUnique (.sort (.succ .zero)) && + (AddInductive.CandidateList.cons aliasFormerConstructorCandidate + (AddInductive.CandidateList.nil : AddInductive.CandidateList + AddInductive.CandidateConstructor [])).viewTranslationUnique) = + true := by + rfl + rw [if_pos translationUnique] + simp [parametersRun, listRun, Bind.bind, Except.bind, + Except.pure, Pure.pure] + +private noncomputable def aliasFormerStagedPreFamilyInput : + VInductDecl.StagedNormalizationCandidatePreFamilyInput + aliasFormerCandidateContext aliasFormerCtorCandidateContext + typeFamilyAliasEnv [] aliasFormerNormalizationCandidate + aliasFormerRawDecl := + VInductDecl.StagedNormalizationCandidatePreFamilyInput.ofRun + aliasFormerStagedPostFamilyInput aliasFormerPreFamilySafetyRun + +/-- The exact family/constructor producer traversals and verified translations +automatically determine a complete retained AliasFormer hierarchy. -/ +theorem aliasFormerProducedSemanticHierarchy_exists : Nonempty (VInductDecl.ProducedNormalizationCandidateSemanticRun aliasFormerCandidateContext aliasFormerCtorCandidateContext typeFamilyAliasEnv [] aliasFormerNormalizationCandidate aliasFormerRawDecl) := - aliasFormerStagedSemanticInput.exists + aliasFormerStagedUniverseInput.exists + +/-- The retained validator telescope and independently produced candidate +telescope align positionally and admit the complete post-family semantic +interpretation for `AliasFormer`. -/ +theorem aliasFormerProducedPostFamilySemantic_exists : + Nonempty (VInductDecl.ProducedNormalizationCandidatePostFamilySemanticRun + aliasFormerStagedPostFamilyInput) := + aliasFormerStagedPostFamilyInput.exists + +/-- AliasFormer's analyzer-owned constructor candidate passes the executable +pre-family suffix/dependency gate and admits the exact family-free replay. -/ +theorem aliasFormerProducedPreFamilySemantic_exists : + Nonempty (VInductDecl.ProducedNormalizationCandidatePreFamilySemanticRun + aliasFormerStagedPreFamilyInput) := + aliasFormerStagedPreFamilyInput.exists def aliasFormerNormalizationCandidateRun : VInductDecl.NormalizationCandidateRun typeFamilyAliasEnv [] - aliasFormerNormalizationCandidate aliasFormerRawDecl := - aliasFormerNormalizationCandidateSemanticRun.root + aliasFormerNormalizationCandidate aliasFormerRawDecl where + raw := aliasFormerRawType + raw_types_eq := rfl + uvars_eq := rfl + family := aliasFormerCandidateFamilyRun example : aliasFormerNormalizationCandidateRun.viewDecl = aliasFormerViewDecl := rfl @@ -7528,17 +8059,10 @@ theorem aliasFormerCtor_isType_checked : ⟨.succ .zero, aliasFormerCtor_hasSort_checked⟩ private theorem aliasFormerCandidate_generationShape : - aliasFormerNormalizationCandidateSemanticRun.generationShape = true := + VInductDecl.normalizationCandidateGenerationShape aliasFormerRawDecl + aliasFormerRawType aliasFormerNormalizationCandidate = true := rfl -/-- Temporary L4L-01A view-WF compatibility premise. L4L-01D derives this -from retained validation and L4L-01E removes it from package construction. -/ -private theorem aliasFormerCandidate_viewDecl_wf : - aliasFormerNormalizationCandidateRun.viewDecl.WF - typeFamilyAliasEnv := by - change aliasFormerViewDecl.WF typeFamilyAliasEnv - exact aliasFormerViewDecl_wf - private def aliasFormerProducedGenerationShapeCandidate : VInductDecl.ProducedGenerationShapeCandidate aliasFormerRawDecl aliasFormerRawType aliasFormerKernelType 0 false @@ -7564,44 +8088,72 @@ theorem aliasFormerGenerationShapeCandidate_produced : (source := aliasFormerRawDecl) (raw := aliasFormerRawType) produced aliasFormerCandidate_generationShape +private theorem aliasFormerCandidate_analysis + (normalization : VInductDecl.NormalizationCandidateSemanticRun + typeFamilyAliasEnv [] aliasFormerNormalizationCandidate + aliasFormerRawDecl) : + normalization.root.normalization.generation? = + some aliasFormerGenerationChecked := by + let reference : VInductDecl.NormalizationCandidateSemanticRun + typeFamilyAliasEnv [] aliasFormerNormalizationCandidate + aliasFormerRawDecl := { + raw := aliasFormerRawType + raw_types_eq := rfl + uvars_eq := rfl + family := aliasFormerCandidateFamilySemanticRun } + rw [aliasFormerStagedPreFamilyInput.normalization_eq normalization reference] + rfl + +/-- The staged owner, exact dependent analysis, and strengthened producer +close AliasFormer without exposing a caller-selected semantic hierarchy. -/ +theorem aliasFormerExactProducedGenerationCandidatePackage_exists : + Nonempty (VInductDecl.ExactProducedGenerationCandidatePackage + typeFamilyAliasEnv [] aliasFormerProducedGenerationShapeCandidate + aliasFormerGenerationChecked) := + aliasFormerProducedGenerationShapeCandidate.exactProducedPackage_nonempty + aliasFormerStagedPreFamilyInput rfl aliasFormerGenerationChecked + aliasFormerCandidate_analysis + +private noncomputable def + aliasFormerExactProducedGenerationCandidatePackage : + VInductDecl.ExactProducedGenerationCandidatePackage typeFamilyAliasEnv [] + aliasFormerProducedGenerationShapeCandidate aliasFormerGenerationChecked := + Classical.choice aliasFormerExactProducedGenerationCandidatePackage_exists + /-- Complete source-indexed candidate certificate for the non-identity AliasFormer generation transaction. -/ -def aliasFormerGenerationCandidateSemanticRun : - VInductDecl.GenerationCandidateSemanticRun - aliasFormerNormalizationCandidateSemanticRun +noncomputable def aliasFormerGenerationCandidateSemanticRun : + VInductDecl.GenerationCandidateSemanticRun + aliasFormerExactProducedGenerationCandidatePackage.normalization aliasFormerGenerationChecked := - VInductDecl.GenerationCandidateSemanticRun.ofGenerationShape - aliasFormerNormalizationCandidateSemanticRun - aliasFormerGenerationChecked rfl aliasFormerCandidate_viewDecl_wf - aliasFormerCandidate_generationShape + aliasFormerExactProducedGenerationCandidatePackage.semantic -def aliasFormerGenerationCandidateRun : +noncomputable def aliasFormerGenerationCandidateRun : VInductDecl.GenerationCandidateRun - aliasFormerNormalizationCandidateRun + aliasFormerExactProducedGenerationCandidatePackage.normalization.root aliasFormerGenerationChecked := aliasFormerGenerationCandidateSemanticRun.run /-- The generic dependent package retains the exact AliasFormer kernel source, candidate trace, reconstructed normalization, successful dependent analysis, and semantic generation run in one value. -/ -def aliasFormerGenerationCandidatePackage : +noncomputable 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. -/ -def aliasFormerProducedGenerationCandidatePackage : +noncomputable def aliasFormerProducedGenerationCandidatePackage : VInductDecl.ProducedGenerationCandidatePackage typeFamilyAliasEnv [] := - aliasFormerProducedGenerationShapeCandidate.producedPackage - aliasFormerNormalizationCandidateSemanticRun rfl - aliasFormerGenerationChecked rfl aliasFormerCandidate_viewDecl_wf + aliasFormerExactProducedGenerationCandidatePackage.package /-- Theory-only erasure of the AliasFormer producer package. This is the consumer-facing value accepted by the public non-identity transaction. -/ def aliasFormerGenerationCertificate : - aliasFormerRawDecl.GenerationCertificate typeFamilyAliasEnv := - aliasFormerProducedGenerationCandidatePackage.package.certificate + aliasFormerRawDecl.GenerationCertificate typeFamilyAliasEnv where + generation := aliasFormerGenerationChecked + wf := aliasFormerExactProducedGenerationCandidatePackage.semantic.run.wf /-- The public proof-carrying path exposes AliasFormer's candidate-derived non-identity generation without exposing its checker package. -/ @@ -7623,7 +8175,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. -/ -def aliasFormerGenerationRun : +noncomputable def aliasFormerGenerationRun : VInductDecl.GenerationRun aliasFormerGenerationChecked typeFamilyAliasEnv := aliasFormerProducedGenerationCandidatePackage.package.run.generationRun @@ -7907,8 +8459,7 @@ private def annotatedPiFamilyCandidateNodeRun : annotatedPiFamilyCandidateContextRun.context_eq rfl rfl rfl annotatedPiFamilyCandidateContextRun.state_wf (.sort rfl) (.sort rfl) - ⟨_, TrExprS.sort rfl, - ⟨_, VEnv.HasType.sort (by decide)⟩⟩ + (TrExprS.sort rfl) 10000 9999 rfl rfl private def annotatedPiFamilyCandidateRun : @@ -7960,7 +8511,7 @@ private def annotatedPiCtorCandidateNodeRun : annotatedPiCtorCandidateContextRun.context_eq rfl rfl rfl annotatedPiCtorCandidateContextRun.state_wf annotatedPiCtorSource_tr (.sort rfl) - ⟨_, annotatedPiCtorSource_tr, ⟨_, annotatedPiRawCtor_hasType⟩⟩ + annotatedPiCtorSource_tr 10000 9999 rfl rfl private def annotatedPiInnerCandidateNodeRun : @@ -7977,8 +8528,7 @@ private def annotatedPiInnerCandidateNodeRun : annotatedPiCtorCandidateContextRun.context_eq rfl rfl rfl annotatedPiCtorCandidateContextRun.state_wf annotatedPiInnerSource_tr (.sort rfl) - ⟨_, annotatedPiInnerSource_tr, - ⟨_, annotatedPiRawInner_hasType []⟩⟩ + annotatedPiInnerSource_tr 10000 9999 rfl rfl private def annotatedPiDomainCandidateNodeRun : @@ -7995,8 +8545,7 @@ private def annotatedPiDomainCandidateNodeRun : annotatedPiCtorCandidateContextRun.context_eq rfl rfl rfl annotatedPiCtorCandidateContextRun.state_wf annotatedPiDomainSource_tr (.sort rfl) - ⟨_, TrExprS.sort rfl, - ⟨_, VEnv.HasType.sort (by decide)⟩⟩ + (TrExprS.sort rfl) 10000 9999 rfl rfl private def annotatedPiInnerBodyCandidateNodeRun : @@ -8025,10 +8574,8 @@ private def annotatedPiInnerBodyCandidateNodeRun : (annotatedPiInstConstSource_tr annotatedPiInnerBodyCandidateContextRun.context.vlctx) (.sort rfl) - ⟨_, annotatedPiConstSource_tr - annotatedPiInnerBodyCandidateContextRun.context.vlctx, - ⟨_, annotatedPiFamilyConst_hasType - annotatedPiInnerBodyCandidateContextRun.context.vlctx.toCtx⟩⟩ + (annotatedPiConstSource_tr + annotatedPiInnerBodyCandidateContextRun.context.vlctx) 10000 9999 rfl rfl private def annotatedPiOuterBodyCandidateNodeRun : @@ -8057,10 +8604,8 @@ private def annotatedPiOuterBodyCandidateNodeRun : (annotatedPiInstConstSource_tr annotatedPiOuterBodyCandidateContextRun.context.vlctx) (.sort rfl) - ⟨_, annotatedPiConstSource_tr - annotatedPiOuterBodyCandidateContextRun.context.vlctx, - ⟨_, annotatedPiFamilyConst_hasType - annotatedPiOuterBodyCandidateContextRun.context.vlctx.toCtx⟩⟩ + (annotatedPiConstSource_tr + annotatedPiOuterBodyCandidateContextRun.context.vlctx) 10000 9999 rfl rfl private def annotatedPiDomainAnnotationsRun : @@ -8175,7 +8720,7 @@ private theorem annotatedPiCtorCandidate_storedSpine : (.const ``AnnotatedPi []) .default := rfl simp only [annotatedPiCtorCandidate, annotatedPiCtorCandidateTrace, AddInductive.CandidateExprTrace.storedSpine, hsource, - beq_self_eq_true, Bool.true_and] + Expr.structuralEq_refl, Bool.true_and] rfl private def annotatedPiCtorSpineRun : @@ -8224,37 +8769,1353 @@ private def annotatedPiCandidateFamilyRun : annotatedPiFamilyListCandidate annotatedPiRawType := annotatedPiCandidateFamilySemanticRun.root -/-- Temporary L4L-01A compatibility witness for the annotation-bearing -recursive Pi fixture. The staged owner proves existence without choosing it; -L4L-01E removes this explicit downstream value. -/ -private def annotatedPiNormalizationCandidateSemanticRun : - VInductDecl.NormalizationCandidateSemanticRun outParamEnv [] - annotatedPiNormalizationCandidate annotatedPiRawDecl where - raw := annotatedPiRawType - raw_types_eq := rfl - uvars_eq := rfl - family := annotatedPiCandidateFamilySemanticRun +private noncomputable def annotatedPiStagedUniverseInput : + VInductDecl.StagedNormalizationCandidateUniverseInput + annotatedPiFamilyCandidateContext annotatedPiCtorCandidateContext + outParamEnv [] annotatedPiNormalizationCandidate + annotatedPiRawDecl where + staged := { + raw := annotatedPiRawType + raw_types_eq := rfl + declaration_uvars_eq := rfl + preFamily := annotatedPiPreFamilyStage + family := annotatedPiFamilyStage + validation_nparams_eq := rfl + constructorValidation := + AddInductive.ConstructorValidationRun.of_run annotatedPi_checkConstructors + constructors := .cons { + name_eq := rfl + uvars_eq := rfl + type := { + context_eq := rfl + source_tr := annotatedPiCtorCandidateRun.source_tr + whnfFuel := 9999 + whnfDepth := rfl } } .nil + familyTypesProduced := annotatedPiFamilyTypeListProduced + familiesProduced := annotatedPiFamilyListProduced } + universeRun := annotatedPi_checkConstructorUniverseSemantics + +private def annotatedPiConstructorValidationContext : AddInductive.Context := + { env := annotatedPiCtorCandidateContext.env + lctx := annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.lctx + lparams := annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.lparams + ngen := annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.ngen + safety := annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.safety + allowPrimitive := annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.allowPrimitive + fuel := annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.fuel } + +private theorem annotatedPiConstructorValidationContext_eq : + { annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with + env := annotatedPiCtorCandidateContext.env } = + annotatedPiCtorCandidateContext := rfl + +private theorem annotatedPiConstructorValidationContext_def_eq : + annotatedPiConstructorValidationContext = + annotatedPiCtorCandidateContext := rfl + +private theorem annotatedPiConstructorValidationContextLiteral_eq : + ({ env := annotatedPiCtorCandidateContext.env + lctx := annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.lctx + lparams := annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.lparams + ngen := annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.ngen + safety := annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.safety + allowPrimitive := annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.allowPrimitive + fuel := annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.fuel } : + AddInductive.Context) = annotatedPiCtorCandidateContext := rfl + +private theorem annotatedPiStagedStats_eq : + annotatedPiStagedUniverseInput.staged.family.validation.stats = + annotatedPiInductiveStats := rfl + +private theorem annotatedPiStagedParams_zero : + annotatedPiStagedUniverseInput.staged.family.validation.stats.params[0]? = + none := by + rw [annotatedPiStagedStats_eq] + rfl + +private theorem annotatedPiKernelCtor_isForall : + annotatedPiKernelCtor.type.isForall = true := rfl + +private theorem annotatedPiKernelType_ctors_eq : + annotatedPiKernelType.ctors = [annotatedPiKernelCtor] := rfl + +private theorem annotatedPiKernelCtor_type_eq : + annotatedPiKernelCtor.type = + .forallE annotatedPiOuterName annotatedPiInnerKernel + (.const ``AnnotatedPi []) .default := rfl + +private theorem annotatedPiConstructorValidationFuel_eq : + annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext.fuel.inductiveFuel = + 1000 := rfl + +private theorem annotatedPiCtorCandidateContext_empty : + annotatedPiCtorCandidateContext.withEmptyLocalContext = + annotatedPiCtorCandidateContext := rfl + +private def annotatedPiViewInnerKernel : Expr := + .forallE `p (.sort .zero) (.const ``AnnotatedPi []) .default + +private def annotatedPiViewCtorKernel : Expr := + .forallE annotatedPiOuterName annotatedPiViewInnerKernel + (.const ``AnnotatedPi []) .default + +private def annotatedPiAlignedViewInnerKernel : Expr := + .forallE `p (.sort .zero) + ((Expr.const ``AnnotatedPi []).abstract + #[annotatedPiCtorCandidateContext.freshExpr]) .default + +private def annotatedPiAlignedViewCtorKernel : Expr := + .forallE annotatedPiOuterName annotatedPiAlignedViewInnerKernel + ((Expr.const ``AnnotatedPi []).abstract + #[annotatedPiCtorCandidateContext.freshExpr]) .default + +@[simp] private theorem annotatedPiConst_abstract_singleton + (context : AddInductive.Context) : + (Expr.const ``AnnotatedPi []).abstract #[context.freshExpr] = + .const ``AnnotatedPi [] := by + rw [show #[context.freshExpr] = + ⟨[context.freshFVarId].map Expr.fvar⟩ by rfl] + simp only [Expr.abstract_eq, Expr.abstractList, Expr.abstract1] + +private theorem annotatedPiAlignedViewInnerKernel_eq : + annotatedPiAlignedViewInnerKernel = annotatedPiViewInnerKernel := by + simp [annotatedPiAlignedViewInnerKernel, annotatedPiViewInnerKernel] + +private theorem annotatedPiAlignedViewCtorKernel_eq : + annotatedPiAlignedViewCtorKernel = annotatedPiViewCtorKernel := by + simp [annotatedPiAlignedViewCtorKernel, annotatedPiViewCtorKernel, + annotatedPiAlignedViewInnerKernel, annotatedPiViewInnerKernel] + +set_option maxRecDepth 10000 in +private theorem annotatedPiDomain_isDefEqInner9999 + (initial : EquivManager) : + ∃ state : TypeChecker.State, + TypeChecker.Inner.isDefEq annotatedPiRawDomainKernel (.sort .zero) + (TypeChecker.Methods.withFuel 9999) + annotatedPiCtorCandidateContext.toTypeChecker + ({ eqvManager := initial } : TypeChecker.State) = + .ok (true, state) := by + simpa only [Nat.reduceAdd] using + annotatedPiDomain_isDefEqInner 9995 initial + +private theorem annotatedPiInnerView_isDefEqForall + (initial : EquivManager) : + ∃ state : TypeChecker.State, + TypeChecker.Inner.isDefEqForall + annotatedPiInnerKernel annotatedPiViewInnerKernel #[] + (TypeChecker.Methods.withFuel 9999) + annotatedPiCtorCandidateContext.toTypeChecker + ({ eqvManager := initial } : TypeChecker.State) = + .ok (true, state) := by + obtain ⟨state, domainRun⟩ := + annotatedPiDomain_isDefEqInner9999 initial + have domainRun' : TypeChecker.Inner.isDefEq + (annotatedPiRawDomainKernel.instantiateRev #[]) + ((.sort .zero : Expr).instantiateRev #[]) + (TypeChecker.Methods.withFuel 9999) + annotatedPiCtorCandidateContext.toTypeChecker + ({ eqvManager := initial } : TypeChecker.State) = + .ok (true, state) := by + simpa [Expr.instantiateRev] using domainRun + refine ⟨state, ?_⟩ + unfold annotatedPiInnerKernel annotatedPiViewInnerKernel + TypeChecker.Inner.isDefEqForall + rw [show + (annotatedPiRawDomainKernel == (.sort .zero : Expr)) = false by + exact annotatedPiApp_beq_sort _ _ _] + simp only [Bool.false_eq_true, if_false, pure_bind, + normalizationRecMBind] + rw [domainRun'] + simp [TypeChecker.Inner.isDefEqForall, TypeChecker.Inner.isDefEq, + Expr.hasLooseBVars, Expr.looseBVarRange', Expr.instantiateRev, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +private theorem annotatedPiInnerView_quickIsDefEq + (initial : EquivManager) : + ∃ state : TypeChecker.State, + TypeChecker.Inner.quickIsDefEq + annotatedPiInnerKernel annotatedPiViewInnerKernel true + (TypeChecker.Methods.withFuel 9999) + annotatedPiCtorCandidateContext.toTypeChecker + ({ eqvManager := initial } : TypeChecker.State) = + .ok (.true, state) := by + let q := EquivManager.isEquiv true annotatedPiInnerKernel + annotatedPiViewInnerKernel initial + rcases hq : q with ⟨equal, manager⟩ + have hq' : EquivManager.isEquiv true annotatedPiInnerKernel + annotatedPiViewInnerKernel initial = (equal, manager) := by + simpa [q] using hq + cases equal + · obtain ⟨state, forallRun⟩ := + annotatedPiInnerView_isDefEqForall manager + refine ⟨state, ?_⟩ + unfold annotatedPiInnerKernel annotatedPiViewInnerKernel at hq' forallRun ⊢ + unfold TypeChecker.Inner.quickIsDefEq + simp [modifyGet, MonadStateOf.modifyGet, monadLift, + MonadLift.monadLift, StateT.modifyGet, pure, ReaderT.pure, + StateT.pure, Except.pure, hq', forallRun, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + unfold toLBoolM + rw [normalizationRecMBind, forallRun] + rfl + · refine ⟨({ eqvManager := manager } : TypeChecker.State), ?_⟩ + unfold TypeChecker.Inner.quickIsDefEq + simp [modifyGet, MonadStateOf.modifyGet, monadLift, + MonadLift.monadLift, StateT.modifyGet, pure, ReaderT.pure, + StateT.pure, Except.pure, hq', + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + +private theorem annotatedPiInnerView_isDefEqInner : + ∃ state : TypeChecker.State, + TypeChecker.Inner.isDefEq + annotatedPiInnerKernel annotatedPiViewInnerKernel + (TypeChecker.Methods.withFuel 10000) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State) = + .ok (true, state) := by + obtain ⟨quickState, quickRun⟩ := + annotatedPiInnerView_quickIsDefEq {} + have coreRun : TypeChecker.Inner.isDefEqCore + annotatedPiInnerKernel annotatedPiViewInnerKernel + (TypeChecker.Methods.withFuel 10000) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State) = .ok (true, quickState) := by + change TypeChecker.Inner.isDefEqCore' + annotatedPiInnerKernel annotatedPiViewInnerKernel + (TypeChecker.Methods.withFuel 9999) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State) = .ok (true, quickState) + unfold TypeChecker.Inner.isDefEqCore' + rw [normalizationRecMBind, quickRun] + rfl + unfold TypeChecker.Inner.isDefEq + rw [show + (annotatedPiInnerKernel == annotatedPiViewInnerKernel) = false by + change Expr.eqv + (.forallE `p annotatedPiRawDomainKernel + (.const ``AnnotatedPi []) .default) + (.forallE `p (.sort .zero) + (.const ``AnnotatedPi []) .default) = false + rw [Expr.eqv_eq] + rfl] + simp only [Bool.false_eq_true, if_false, pure_bind, + normalizationRecMBind] + rw [coreRun] + exact ⟨_, rfl⟩ + +private theorem annotatedPiInnerView_isDefEq : + AddInductive.CandidateIsDefEqStep.Valid + ⟨annotatedPiConstructorValidationContext, + annotatedPiInnerKernel, annotatedPiAlignedViewInnerKernel⟩ := by + unfold AddInductive.CandidateIsDefEqStep.Valid + rw [annotatedPiConstructorValidationContext_def_eq, + annotatedPiAlignedViewInnerKernel_eq] + obtain ⟨state, run⟩ := annotatedPiInnerView_isDefEqInner + change Except.map (fun x : Bool × TypeChecker.State => x.1) + (TypeChecker.Inner.isDefEq annotatedPiInnerKernel + annotatedPiViewInnerKernel + (TypeChecker.Methods.withFuel 10000) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State)) = .ok true + rw [run] + rfl + +private theorem annotatedPiValidationAlignedCheck_exists + {source candidateSource : Expr} + (source_eq : source = candidateSource) + {checked : AddInductive.ConstructorCheckedExpr + annotatedPiCtorCandidateContext candidateSource} + (run : AddInductive.checkConstructorAlignedExpr + annotatedPiCtorCandidateContext candidateSource = .ok checked) : + ∃ aligned : AddInductive.ConstructorCheckedExpr + annotatedPiConstructorValidationContext source, + AddInductive.checkConstructorAlignedExpr + annotatedPiConstructorValidationContext source = .ok aligned := by + subst candidateSource + rw [annotatedPiConstructorValidationContext_def_eq] + exact ⟨checked, run⟩ + +private def annotatedPiAlignChecked + {context candidateContext : AddInductive.Context} + {source candidateSource : Expr} + (context_eq : context = candidateContext) + (source_eq : source = candidateSource) + (checked : AddInductive.ConstructorCheckedExpr + candidateContext candidateSource) : + AddInductive.ConstructorCheckedExpr context source := by + subst candidateContext + subst candidateSource + exact checked + +private def annotatedPiAlignIsDefEq + {context candidateContext : AddInductive.Context} + {lhs rhs candidateLhs candidateRhs : Expr} + (context_eq : context = candidateContext) + (lhs_eq : lhs = candidateLhs) + (rhs_eq : rhs = candidateRhs) + (observation : AddInductive.CandidateIsDefEqObservation + candidateContext candidateLhs candidateRhs) : + AddInductive.CandidateIsDefEqObservation context lhs rhs := by + subst candidateContext + subst candidateLhs + subst candidateRhs + exact observation + +private theorem annotatedPiViewInnerCheckTypeStep_valid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨annotatedPiCtorCandidateContext, annotatedPiViewInnerKernel, + .sort (.succ .zero)⟩ := by + change TypeChecker.M.run annotatedPiCtorCandidateContext.env + annotatedPiCtorCandidateContext.safety + annotatedPiCtorCandidateContext.lctx + annotatedPiCtorCandidateContext.lparams + annotatedPiCtorCandidateContext.fuel + (TypeChecker.checkType annotatedPiViewInnerKernel) = + .ok (.sort (.succ .zero)) + change + Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType annotatedPiViewInnerKernel false + (TypeChecker.Methods.withFuel 10000) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State)) = + .ok (.sort (.succ .zero)) + change + Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' annotatedPiViewInnerKernel false + (TypeChecker.Methods.withFuel 9999) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State)) = + .ok (.sort (.succ .zero)) + unfold annotatedPiViewInnerKernel TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + TypeChecker.Inner.inferType', + TypeChecker.Inner.inferForall, TypeChecker.Inner.inferForall.loop, + Expr.instantiate1_eq, Expr.instantiate1', + annotatedPiWithLocalDecl, annotatedPiCtorCandidateContext, + AddInductive.Context.toTypeChecker, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + simp [Expr.sortLevel!, annotatedPi_mkLevelIMaxSuccZero] + rfl + +private def annotatedPiViewInnerFinalState : TypeChecker.State := + { ({} : TypeChecker.State) with + ngen := ({} : TypeChecker.State).ngen.next + inferTypeC := + ((({} : TypeChecker.State).inferTypeC.insert + (.sort .zero) (.sort (.succ .zero))).insert + (.const ``AnnotatedPi []) (.sort (.succ .zero))).insert + annotatedPiViewInnerKernel (.sort (.succ .zero)) } + +private theorem annotatedPiViewInnerInferType_exists (n : Nat) : + ∃ state : TypeChecker.State, + TypeChecker.Inner.inferType' annotatedPiViewInnerKernel false + (TypeChecker.Methods.withFuel (n + 1)) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State) = + .ok (.sort (.succ .zero), state) ∧ + state.inferTypeC[(.const ``AnnotatedPi [] : Expr)]? = + some (.sort (.succ .zero)) := by + refine ⟨annotatedPiViewInnerFinalState, ?_, ?_⟩ + · unfold annotatedPiViewInnerKernel TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + TypeChecker.Inner.inferType', + TypeChecker.Inner.inferForall, TypeChecker.Inner.inferForall.loop, + Expr.instantiate1_eq, Expr.instantiate1', + annotatedPiWithLocalDecl, annotatedPiCtorCandidateContext, + AddInductive.Context.toTypeChecker, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + simp [Expr.sortLevel!, annotatedPi_mkLevelIMaxSuccZero] + rfl + · simpa [annotatedPiViewInnerFinalState, + annotatedPiViewInnerKernel] using + annotatedPiFamilyCacheAfterForall + (({} : TypeChecker.State).inferTypeC.insert + (.sort .zero) (.sort (.succ .zero))) + `p (.sort .zero) (.const ``AnnotatedPi []) + (.sort (.succ .zero)) .default + +private theorem annotatedPiViewCtorCheckTypeStep_valid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨annotatedPiCtorCandidateContext, annotatedPiViewCtorKernel, + .sort (.succ .zero)⟩ := by + change TypeChecker.M.run annotatedPiCtorCandidateContext.env + annotatedPiCtorCandidateContext.safety + annotatedPiCtorCandidateContext.lctx + annotatedPiCtorCandidateContext.lparams + annotatedPiCtorCandidateContext.fuel + (TypeChecker.checkType annotatedPiViewCtorKernel) = + .ok (.sort (.succ .zero)) + change + Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType annotatedPiViewCtorKernel false + (TypeChecker.Methods.withFuel 10000) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State)) = + .ok (.sort (.succ .zero)) + change + Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' annotatedPiViewCtorKernel false + (TypeChecker.Methods.withFuel 9999) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State)) = + .ok (.sort (.succ .zero)) + obtain ⟨innerState, hinner, hinnerCache⟩ := + annotatedPiViewInnerInferType_exists 9997 + change TypeChecker.Inner.inferType' annotatedPiViewInnerKernel false + (TypeChecker.Methods.withFuel 9998) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State) = + .ok (.sort (.succ .zero), innerState) at hinner + unfold annotatedPiViewInnerKernel at hinner + let outerState : TypeChecker.State := + { innerState with ngen := innerState.ngen.next } + have houterCache : + outerState.inferTypeC[(.const ``AnnotatedPi [] : Expr)]? = + some (.sort (.succ .zero)) := by + exact hinnerCache + have hfamily : + TypeChecker.Inner.inferType' (.const ``AnnotatedPi []) false + (TypeChecker.Methods.withFuel 9998) + ({ env := annotatedPiCtorCandidateContext.toTypeChecker.env + lctx := annotatedPiCtorCandidateContext.toTypeChecker.lctx.mkLocalDecl + ⟨innerState.ngen.curr⟩ annotatedPiOuterName + annotatedPiViewInnerKernel .default + safety := annotatedPiCtorCandidateContext.toTypeChecker.safety + eagerReduce := annotatedPiCtorCandidateContext.toTypeChecker.eagerReduce + lparams := annotatedPiCtorCandidateContext.toTypeChecker.lparams + fuel := annotatedPiCtorCandidateContext.toTypeChecker.fuel } : + TypeChecker.Context) + outerState = + .ok (.sort (.succ .zero), outerState) := by + simpa [annotatedPiCtorCandidateContext, + AddInductive.Context.toTypeChecker] using + annotatedPiInferTypeFamilyCached 9998 + (annotatedPiCtorCandidateContext.toTypeChecker.lctx.mkLocalDecl + ⟨innerState.ngen.curr⟩ annotatedPiOuterName + annotatedPiViewInnerKernel .default) + outerState houterCache + unfold annotatedPiViewInnerKernel at hfamily + unfold annotatedPiViewCtorKernel TypeChecker.Inner.inferType' + simp [annotatedPiViewInnerKernel, + Expr.hasLooseBVars, Expr.looseBVarRange', + TypeChecker.Inner.inferForall, TypeChecker.Inner.inferForall.loop, + Expr.instantiate1_eq, Expr.instantiate1', + annotatedPiWithLocalDecl, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rw [hinner] + simp only [TypeChecker.Inner.ensureSortCore, Expr.isSort, if_true, + annotatedPiWithLocalDecl, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + rw [hfamily] + simp [TypeChecker.Inner.ensureSortCore, + Expr.sortLevel!, annotatedPi_mkLevelIMaxSuccZero, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind, + ReaderT.pure, StateT.pure, Except.pure, Pure.pure] + rfl + +private theorem annotatedPiSortZeroCheckTypeStep_valid : + AddInductive.CandidateCheckTypeStep.Valid + ⟨annotatedPiCtorCandidateContext, .sort .zero, + .sort (.succ .zero)⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + change + Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType (.sort .zero) false + (TypeChecker.Methods.withFuel 10000) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State)) = + .ok (.sort (.succ .zero)) + change + Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' (.sort .zero) false + (TypeChecker.Methods.withFuel 9999) + annotatedPiCtorCandidateContext.toTypeChecker + ({} : TypeChecker.State)) = + .ok (.sort (.succ .zero)) + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + annotatedPiCtorCandidateContext, + AddInductive.Context.toTypeChecker, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind] + rfl + +private theorem annotatedPiConsumeRawDomain : + AddInductive.consumeTypeAnnotations annotatedPiRawDomainKernel = + .sort .zero := by + simp [AddInductive.consumeTypeAnnotations, annotatedPiRawDomainKernel] + +private theorem annotatedPiConsumeInner : + AddInductive.consumeTypeAnnotations annotatedPiInnerKernel = + annotatedPiInnerKernel := by + simp [AddInductive.consumeTypeAnnotations, annotatedPiInnerKernel] + +private theorem annotatedPiValidationInnerBodyContext_eq : + annotatedPiConstructorValidationContext.pushLocalDecl + `p .default + (AddInductive.consumeTypeAnnotations annotatedPiRawDomainKernel) = + annotatedPiInnerBodyCandidateContext := by + rw [annotatedPiConstructorValidationContext_def_eq, + annotatedPiConsumeRawDomain] + rfl + +private theorem annotatedPiValidationOuterBodyContext_eq : + annotatedPiConstructorValidationContext.pushLocalDecl + annotatedPiOuterName .default + (AddInductive.consumeTypeAnnotations annotatedPiInnerKernel) = + annotatedPiOuterBodyCandidateContext := by + rw [annotatedPiConstructorValidationContext_def_eq, + annotatedPiConsumeInner] + rfl -private def annotatedPiStagedSemanticInput : - VInductDecl.StagedNormalizationCandidateSemanticInput +private theorem annotatedPiValidationInnerBody_whnf_eq + {result : Expr} + (run : AddInductive.CandidateWhnfStep.Valid + ⟨({ annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with + env := annotatedPiCtorCandidateContext.env }).pushLocalDecl + `p .default (AddInductive.consumeTypeAnnotations + annotatedPiRawDomainKernel), + .const ``AnnotatedPi [], result⟩) : + result = .const ``AnnotatedPi [] := by + rw [annotatedPiConstructorValidationContext_eq, + annotatedPiConsumeRawDomain] at run + change TypeChecker.M.run annotatedPiInnerBodyCandidateContext.env + annotatedPiInnerBodyCandidateContext.safety + annotatedPiInnerBodyCandidateContext.lctx + annotatedPiInnerBodyCandidateContext.lparams + annotatedPiInnerBodyCandidateContext.fuel + (TypeChecker.whnf (.const ``AnnotatedPi [])) = .ok result at run + have known := annotatedPiInnerBodyCandidateStep_valid + change TypeChecker.M.run annotatedPiInnerBodyCandidateContext.env + annotatedPiInnerBodyCandidateContext.safety + annotatedPiInnerBodyCandidateContext.lctx + annotatedPiInnerBodyCandidateContext.lparams + annotatedPiInnerBodyCandidateContext.fuel + (TypeChecker.whnf (.const ``AnnotatedPi [])) = + .ok (.const ``AnnotatedPi []) at known + rw [known] at run + exact (Except.ok.inj run).symm + +private theorem constructorTypeValidationTrace_spineLength_zero + {stats : AddInductive.InductiveStats} {isUnsafe : Bool} + {familyIdx : Nat} {ctor : Name} {context : AddInductive.Context} + {source : Expr} {argIdx fuel : Nat} + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx fuel) + (terminal : source.isForall = false) : + trace.spineLength = 0 := by + cases trace <;> + simp_all [AddInductive.ConstructorTypeValidationTrace.spineLength, + Expr.isForall] + +private theorem constructorTypeValidationTrace_eq_terminal + {stats : AddInductive.InductiveStats} {isUnsafe : Bool} + {familyIdx : Nat} {ctor : Name} {context : AddInductive.Context} + {source : Expr} {argIdx fuel : Nat} + (trace : AddInductive.ConstructorTypeValidationTrace stats isUnsafe + familyIdx ctor context source argIdx (fuel + 1)) + (terminal : source.isForall = false) + (valid : AddInductive.isValidIndAppIdx stats source familyIdx = true) : + trace = .terminal context source fuel argIdx terminal valid := by + cases trace with + | parameter context fuel argIdx name domain body binderInfo param + parameterType parameterAt parameterTypeRun defeq tail => + have impossible : + (Expr.forallE name domain body binderInfo).isForall = true := rfl + rw [impossible] at terminal + contradiction + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity tail => + have impossible : + (Expr.forallE name domain body binderInfo).isForall = true := rfl + rw [impossible] at terminal + contradiction + | terminal => rfl + +set_option maxHeartbeats 10000000 in +private noncomputable def annotatedPiStagedPostFamilyInput : + VInductDecl.StagedNormalizationCandidatePostFamilyInput annotatedPiFamilyCandidateContext annotatedPiCtorCandidateContext outParamEnv [] annotatedPiNormalizationCandidate annotatedPiRawDecl where - raw := annotatedPiRawType - raw_types_eq := rfl - declaration_uvars_eq := rfl - preFamily := annotatedPiPreFamilyStage - family := annotatedPiFamilyStage - constructors := .cons { - name_eq := rfl - uvars_eq := rfl - type := { - context_eq := rfl - source_tr := annotatedPiCtorCandidateRun.source_tr - whnfFuel := 9999 - whnfDepth := rfl } } .nil - familyTypesProduced := annotatedPiFamilyTypeListProduced - familiesProduced := annotatedPiFamilyListProduced + universeInput := annotatedPiStagedUniverseInput + alignment := by + change AddInductive.ConstructorCandidateAlignmentTrace + annotatedPiStagedUniverseInput.staged.family.validation.stats false 0 + annotatedPiConstructorValidationContext + annotatedPiStagedUniverseInput.staged.constructorValidation.trace + (.cons annotatedPiConstructorCandidate .nil) + generalize htrace : + annotatedPiStagedUniverseInput.staged.constructorValidation.trace = trace + cases trace with + | cons seen head constructors constructorFresh constructorClosed + constructorRootCheck typeTrace listTailTrace => + cases typeTrace with + | parameter context fuel argIdx name domain body binderInfo param + parameterType parameterAt parameterTypeRun defeq tail => + rw [annotatedPiStagedParams_zero] at parameterAt + contradiction + | terminal context source fuel argIdx terminal valid => + rw [annotatedPiKernelCtor_isForall] at terminal + contradiction + | ordinary context fuel argIdx name domain body binderInfo sortResult + noParameter ensureType universeTrace positivity tail => + cases listTailTrace + cases positivity with + | skipped isUnsafe_eq => contradiction + | safe isUnsafe_eq positivityTrace => + cases positivityTrace with + | absent context source result fuel whnf occurs => + change AddInductive.CandidateWhnfStep.Valid + ⟨{ annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with + env := annotatedPiCtorCandidateContext.env }, + annotatedPiInnerKernel, result⟩ at whnf + rw [annotatedPiConstructorValidationContext_eq] at whnf + change TypeChecker.M.run annotatedPiCtorCandidateContext.env + annotatedPiCtorCandidateContext.safety + annotatedPiCtorCandidateContext.lctx + annotatedPiCtorCandidateContext.lparams + annotatedPiCtorCandidateContext.fuel + (TypeChecker.whnf annotatedPiInnerKernel) = + .ok result at whnf + rw [annotatedPiInner_whnfM] at whnf + cases whnf + rw [annotatedPiStagedStats_eq, + annotatedPiInner_stats_hasIndOcc] at occurs + contradiction + | target context source result fuel targetIdx whnf occurs + terminal valid => + change AddInductive.CandidateWhnfStep.Valid + ⟨{ annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with + env := annotatedPiCtorCandidateContext.env }, + annotatedPiInnerKernel, result⟩ at whnf + rw [annotatedPiConstructorValidationContext_eq] at whnf + change TypeChecker.M.run annotatedPiCtorCandidateContext.env + annotatedPiCtorCandidateContext.safety + annotatedPiCtorCandidateContext.lctx + annotatedPiCtorCandidateContext.lparams + annotatedPiCtorCandidateContext.fuel + (TypeChecker.whnf annotatedPiInnerKernel) = + .ok result at whnf + rw [annotatedPiInner_whnfM] at whnf + cases whnf + simp [annotatedPiInnerKernel, Expr.isForall] at terminal + | forallE positivityContext positivitySource positivityFuel + positivityName positivityDomain positivityBody + positivityBinderInfo positivityWhnf positivityOccurs + positivityDomainFree positivityTail => + change AddInductive.CandidateWhnfStep.Valid + ⟨{ annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with + env := annotatedPiCtorCandidateContext.env }, + annotatedPiInnerKernel, + .forallE positivityName positivityDomain positivityBody + positivityBinderInfo⟩ at positivityWhnf + rw [annotatedPiConstructorValidationContext_eq] at positivityWhnf + change TypeChecker.M.run annotatedPiCtorCandidateContext.env + annotatedPiCtorCandidateContext.safety + annotatedPiCtorCandidateContext.lctx + annotatedPiCtorCandidateContext.lparams + annotatedPiCtorCandidateContext.fuel + (TypeChecker.whnf annotatedPiInnerKernel) = + .ok (.forallE positivityName positivityDomain + positivityBody positivityBinderInfo) at positivityWhnf + rw [annotatedPiInner_whnfM] at positivityWhnf + cases positivityWhnf + have hTailSpine : tail.spineLength = 0 := + constructorTypeValidationTrace_spineLength_zero tail (by + simp only [annotatedPiConst_instantiate1, + Expr.isForall]) + cases positivityTail with + | absent context source result fuel whnf occurs => + have whnf' : AddInductive.CandidateWhnfStep.Valid + ⟨({ annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with + env := annotatedPiCtorCandidateContext.env }).pushLocalDecl + `p .default (AddInductive.consumeTypeAnnotations + annotatedPiRawDomainKernel), + .const ``AnnotatedPi [], result⟩ := by + simpa only [annotatedPiConst_instantiate1] using whnf + have hresult := + annotatedPiValidationInnerBody_whnf_eq whnf' + subst result + rw [annotatedPiStagedStats_eq, + annotatedPiConst_hasIndOcc] at occurs + contradiction + | forallE context source fuel name domain body binderInfo + whnf occurs domainFree positivityTail => + have whnf' : AddInductive.CandidateWhnfStep.Valid + ⟨({ annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with + env := annotatedPiCtorCandidateContext.env }).pushLocalDecl + `p .default (AddInductive.consumeTypeAnnotations + annotatedPiRawDomainKernel), + .const ``AnnotatedPi [], + .forallE name domain body binderInfo⟩ := by + simpa only [annotatedPiConst_instantiate1] using whnf + have hresult := + annotatedPiValidationInnerBody_whnf_eq whnf' + contradiction + | target targetContext targetSource targetResult targetFuel + targetIdx targetWhnf targetOccurs targetTerminal + targetValid => + have targetWhnfNormalized : + AddInductive.CandidateWhnfStep.Valid + ⟨({ annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext with + env := annotatedPiCtorCandidateContext.env }).pushLocalDecl + `p .default (AddInductive.consumeTypeAnnotations + annotatedPiRawDomainKernel), + .const ``AnnotatedPi [], targetResult⟩ := by + simpa only [annotatedPiConst_instantiate1] using + targetWhnf + have hresult := + annotatedPiValidationInnerBody_whnf_eq + targetWhnfNormalized + subst targetResult + simp only [annotatedPiConst_instantiate1] at tail ⊢ + cases tail + change AddInductive.CandidateCheckTypeObservation + annotatedPiConstructorValidationContext.withEmptyLocalContext + annotatedPiKernelCtor.type at constructorRootCheck + let rootChecked := + AddInductive.ConstructorCheckedExpr.ofClosedRoot + constructorClosed constructorRootCheck + let innerChecked : AddInductive.ConstructorCheckedExpr + annotatedPiCtorCandidateContext + annotatedPiInnerKernel := + .ofRun (by + simp [annotatedPiInnerKernel, + annotatedPiRawDomainKernel, FVarsIn, + Level.hasMVar']) + annotatedPiInnerCheckTypeStep_valid + let viewInnerChecked : AddInductive.ConstructorCheckedExpr + annotatedPiCtorCandidateContext + annotatedPiViewInnerKernel := + .ofRun (by + simp [annotatedPiViewInnerKernel, FVarsIn, + Level.hasMVar']) + annotatedPiViewInnerCheckTypeStep_valid + let domainChecked : AddInductive.ConstructorCheckedExpr + annotatedPiCtorCandidateContext + annotatedPiRawDomainKernel := + .ofRun (by + simp [annotatedPiRawDomainKernel, FVarsIn, + Level.hasMVar']) + annotatedPiDomainCheckTypeStep_valid + let sortChecked : AddInductive.ConstructorCheckedExpr + annotatedPiCtorCandidateContext (.sort .zero) := + .ofRun (by simp [FVarsIn, Level.hasMVar']) + annotatedPiSortZeroCheckTypeStep_valid + let innerBodyChecked : + AddInductive.ConstructorCheckedExpr + annotatedPiInnerBodyCandidateContext + (.const ``AnnotatedPi []) := + .ofRun (by simp [FVarsIn]) + annotatedPiInnerBodyCheckTypeStep_valid + let outerBodyChecked : + AddInductive.ConstructorCheckedExpr + annotatedPiOuterBodyCandidateContext + (.const ``AnnotatedPi []) := + .ofRun (by simp [FVarsIn]) + annotatedPiOuterBodyCheckTypeStep_valid + let innerChecked' := annotatedPiAlignChecked + annotatedPiConstructorValidationContext_def_eq rfl + innerChecked + let viewInnerChecked' := annotatedPiAlignChecked + annotatedPiConstructorValidationContext_def_eq + annotatedPiAlignedViewInnerKernel_eq viewInnerChecked + let consumedInnerChecked := annotatedPiAlignChecked + annotatedPiConstructorValidationContext_def_eq + annotatedPiConsumeInner innerChecked + let domainChecked' := annotatedPiAlignChecked + annotatedPiConstructorValidationContext_def_eq rfl + domainChecked + let sortChecked' := annotatedPiAlignChecked + annotatedPiConstructorValidationContext_def_eq + annotatedPiConsumeRawDomain sortChecked + let innerBodyChecked' := annotatedPiAlignChecked + annotatedPiValidationInnerBodyContext_eq rfl + innerBodyChecked + let innerBodyPositivityChecked := + annotatedPiAlignChecked + annotatedPiValidationInnerBodyContext_eq + (annotatedPiConst_instantiate1 + annotatedPiConstructorValidationContext.freshExpr) + innerBodyChecked + let outerBodyChecked' := annotatedPiAlignChecked + annotatedPiValidationOuterBodyContext_eq rfl + outerBodyChecked + let outerBodySourceChecked := annotatedPiAlignChecked + annotatedPiValidationOuterBodyContext_eq + (annotatedPiConst_instantiate1 + annotatedPiConstructorValidationContext.freshExpr) + outerBodyChecked + have outerTailView_eq : + ((Expr.const ``AnnotatedPi []).abstract + #[annotatedPiCtorCandidateContext.freshExpr] + |>.instantiate1 + annotatedPiConstructorValidationContext.freshExpr) = + .const ``AnnotatedPi [] := by + simp [annotatedPiConst_abstract_singleton] + let outerBodyViewChecked := annotatedPiAlignChecked + annotatedPiValidationOuterBodyContext_eq + outerTailView_eq outerBodyChecked + let innerAnnotations : + AddInductive.CandidateIsDefEqObservation + annotatedPiCtorCandidateContext + annotatedPiInnerKernel annotatedPiInnerKernel := + ⟨AddInductive.candidateIsDefEqRefl + annotatedPiCtorCandidateContext + annotatedPiInnerKernel⟩ + let innerAnnotations' := annotatedPiAlignIsDefEq + annotatedPiConstructorValidationContext_def_eq rfl + annotatedPiConsumeInner innerAnnotations + let domainAnnotations : + AddInductive.CandidateIsDefEqObservation + annotatedPiCtorCandidateContext + annotatedPiRawDomainKernel (.sort .zero) := + ⟨annotatedPiDomainAnnotationsEq⟩ + let domainAnnotations' := annotatedPiAlignIsDefEq + annotatedPiConstructorValidationContext_def_eq rfl + annotatedPiConsumeRawDomain domainAnnotations + have sortCheckedInferred : + sortChecked'.observation.inferred = + .sort (.succ .zero) := by + apply sortChecked'.inferred_eq_of_run + rw [annotatedPiConstructorValidationContext_def_eq, + annotatedPiConsumeRawDomain] + exact annotatedPiSortZeroCheckTypeStep_valid + have rootStoredSpine : + annotatedPiConstructorCandidate.type.trace.storedSpine = + true := by + change annotatedPiCtorCandidate.trace.storedSpine = true + exact annotatedPiCtorCandidate_storedSpine + have rootDepth : + annotatedPiConstructorCandidate.type.context.fuel.recDepth = + annotatedPiConstructorValidationContext.fuel.recDepth := by + rfl + let constructorTailTrace := + AddInductive.ConstructorTypeValidationTrace.terminal + (stats := annotatedPiStagedUniverseInput.staged.family.validation.stats) + (isUnsafe := false) (familyIdx := 0) + (ctor := annotatedPiKernelCtor.name) + (annotatedPiConstructorValidationContext.pushLocalDecl + annotatedPiOuterName .default + (AddInductive.consumeTypeAnnotations + annotatedPiInnerKernel)) + ((Expr.const ``AnnotatedPi []).instantiate1 + annotatedPiConstructorValidationContext.freshExpr) + 998 1 + (by + simp only [annotatedPiConst_instantiate1, + Expr.isForall]) + (by + simp only [annotatedPiConst_instantiate1] + assumption) + have tail_eq : tail = constructorTailTrace := by + unfold constructorTailTrace + apply constructorTypeValidationTrace_eq_terminal + let positivityTargetTrace := + AddInductive.ConstructorPositivityTrace.target + (stats := annotatedPiStagedUniverseInput.staged.family.validation.stats) + (ctor := annotatedPiKernelCtor.name) + (argIdx := 0) + (annotatedPiConstructorValidationContext.pushLocalDecl + `p .default + (AddInductive.consumeTypeAnnotations + annotatedPiRawDomainKernel)) + ((Expr.const ``AnnotatedPi []).instantiate1 + annotatedPiConstructorValidationContext.freshExpr) + (.const ``AnnotatedPi []) 998 targetIdx + targetWhnf targetOccurs targetTerminal targetValid + let nestedPositivityTrace := + AddInductive.ConstructorPositivityTrace.forallE + (stats := annotatedPiStagedUniverseInput.staged.family.validation.stats) + (ctor := annotatedPiKernelCtor.name) + (argIdx := 0) + annotatedPiConstructorValidationContext + annotatedPiInnerKernel 999 `p + annotatedPiRawDomainKernel + (.const ``AnnotatedPi []) .default positivityWhnf + positivityOccurs positivityDomainFree + positivityTargetTrace + let positivityModeTrace := + AddInductive.ConstructorPositivityModeTrace.safe + isUnsafe_eq nestedPositivityTrace + let headValidationTrace := + AddInductive.ConstructorTypeValidationTrace.ordinary + annotatedPiConstructorValidationContext 999 0 + annotatedPiOuterName annotatedPiInnerKernel + (.const ``AnnotatedPi []) .default sortResult + noParameter ensureType universeTrace + positivityModeTrace constructorTailTrace + have rootSpineLength' : + annotatedPiConstructorCandidate.type.trace.spineLength = + headValidationTrace.spineLength := by + rfl + have positivityTargetAlignment : + AddInductive.ConstructorPositivityAlignmentTrace + positivityTargetTrace := + .target innerBodyPositivityChecked + have positivityAlignment : + AddInductive.ConstructorPositivityModeAlignmentTrace + positivityModeTrace := + .safe <| .forallE innerChecked' domainChecked' + sortChecked' (.succ .zero) + sortCheckedInferred (by + rw [annotatedPiConstructorValidationContext_def_eq] + exact annotatedPiCtorCandidateFresh) + domainAnnotations' positivityTargetTrace + positivityTargetAlignment + have outerTailAlignment : + AddInductive.ConstructorViewAlignmentTrace + constructorTailTrace + ((Expr.const ``AnnotatedPi []).abstract + #[annotatedPiCtorCandidateContext.freshExpr] + |>.instantiate1 + annotatedPiConstructorValidationContext.freshExpr) := by + simp only [annotatedPiConst_abstract_singleton, + annotatedPiConst_instantiate1] + exact .terminal outerBodySourceChecked + outerBodyChecked' + (by simp [Expr.isForall]) (by assumption) + have headAlignment : + AddInductive.ConstructorViewAlignmentTrace + headValidationTrace + annotatedPiConstructorCandidate.type.view := by + change AddInductive.ConstructorViewAlignmentTrace + headValidationTrace + annotatedPiAlignedViewCtorKernel + exact AddInductive.ConstructorViewAlignmentTrace.ordinary + innerChecked' viewInnerChecked' + ⟨annotatedPiInnerView_isDefEq⟩ + consumedInnerChecked + positivityModeTrace + positivityAlignment (by + rw [annotatedPiConstructorValidationContext_def_eq] + exact annotatedPiCtorCandidateFresh) + innerAnnotations' constructorTailTrace + outerTailAlignment + rw [tail_eq] + exact + AddInductive.ConstructorCandidateAlignmentTrace.cons + (seen := ∅) (fresh := constructorFresh) + (closed := constructorClosed) + (rootCheck := constructorRootCheck) + (typeTrace := headValidationTrace) + (tailTrace := + AddInductive.ConstructorListValidationTrace.nil + ((∅ : NameSet).insert + annotatedPiKernelCtor.name)) + (candidate := annotatedPiConstructorCandidate) + (candidates := AddInductive.CandidateList.nil) + rootChecked rootStoredSpine rootSpineLength' + rootDepth headAlignment + (AddInductive.ConstructorCandidateAlignmentTrace.nil + (stats := annotatedPiStagedUniverseInput.staged.family.validation.stats) + (isUnsafe := false) (familyIdx := 0) + (context := annotatedPiConstructorValidationContext) + ((∅ : NameSet).insert + annotatedPiKernelCtor.name)) + +private theorem annotatedPiPreFamilySortZeroCheckTypeStep_valid + (context : AddInductive.Context) + (depth : context.fuel.recDepth = 10000) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, .sort .zero, .sort (.succ .zero)⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType (.sort .zero) false + (TypeChecker.Methods.withFuel context.fuel.recDepth) + context.toTypeChecker ({} : TypeChecker.State)) = _ + rw [depth] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' (.sort .zero) false + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State)) = _ + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + annotatedPi_checkLevelZero, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + rfl + +private theorem annotatedPiPreFamilySortOneCheckTypeStep_valid + (context : AddInductive.Context) + (depth : context.fuel.recDepth = 10000) : + AddInductive.CandidateCheckTypeStep.Valid + ⟨context, .sort (.succ .zero), + .sort (.succ (.succ .zero))⟩ := by + unfold AddInductive.CandidateCheckTypeStep.Valid + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType (.sort (.succ .zero)) false + (TypeChecker.Methods.withFuel context.fuel.recDepth) + context.toTypeChecker ({} : TypeChecker.State)) = _ + rw [depth] + change Except.map (fun x : Expr × TypeChecker.State => x.1) + (TypeChecker.Inner.inferType' (.sort (.succ .zero)) false + (TypeChecker.Methods.withFuel 9999) + context.toTypeChecker ({} : TypeChecker.State)) = _ + unfold TypeChecker.Inner.inferType' + simp [Expr.hasLooseBVars, Expr.looseBVarRange', + annotatedPi_checkLevelSuccZero, Bind.bind, ReaderT.bind, + StateT.bind, Except.bind] + rfl + +private def annotatedPiPreFamilySortZeroInferState : TypeChecker.State := + { ({} : TypeChecker.State) with + inferTypeI := ({} : TypeChecker.State).inferTypeI.insert + (.sort .zero) (.sort (.succ .zero)) } + +private theorem annotatedPiPreFamilySortZeroInferTypeInner + (context : AddInductive.Context) + (depth : context.fuel.recDepth = 10000) : + TypeChecker.Inner.inferType (.sort .zero) true + (TypeChecker.Methods.withFuel context.fuel.recDepth) + context.toTypeChecker ({} : TypeChecker.State) = + .ok (.sort (.succ .zero), + annotatedPiPreFamilySortZeroInferState) := by + rw [depth] + change TypeChecker.Inner.inferType' (.sort .zero) true + (TypeChecker.Methods.withFuel 9999) context.toTypeChecker + ({} : TypeChecker.State) = _ + unfold TypeChecker.Inner.inferType' + simp [annotatedPiPreFamilySortZeroInferState, + Expr.hasLooseBVars, Expr.looseBVarRange', Bind.bind, + ReaderT.bind, StateT.bind, Except.bind] + +private theorem annotatedPiPreFamilySortZeroEnsureTypeStep_valid + (context : AddInductive.Context) + (depth : context.fuel.recDepth = 10000) : + AddInductive.ConstructorEnsureTypeStep.Valid + ⟨context, .sort .zero, .sort (.succ .zero)⟩ := by + unfold AddInductive.ConstructorEnsureTypeStep.Valid + TypeChecker.ensureType TypeChecker.inferType TypeChecker.ensureSort + TypeChecker.RecM.run TypeChecker.M.run + simp only [readThe, MonadReaderOf.read, ReaderT.read, + Bind.bind, ReaderT.bind, StateT.bind, Except.bind, + Pure.pure, StateT.pure, Except.pure, StateT.run', + Functor.map, Except.map] + rw [show TypeChecker.Inner.inferType (.sort .zero) true + (TypeChecker.Methods.withFuel context.fuel.recDepth) + { env := context.env + lctx := context.lctx + safety := context.safety + lparams := context.lparams + fuel := context.fuel } + ({} : TypeChecker.State) = + .ok (.sort (.succ .zero), + annotatedPiPreFamilySortZeroInferState) by + simpa [AddInductive.Context.toTypeChecker] using + annotatedPiPreFamilySortZeroInferTypeInner context depth] + rfl + +private theorem annotatedPiPreFamilySafetyRun : + AddInductive.checkConstructorPreFamilySafety + annotatedPiStagedUniverseInput.staged.family.validation.stats + annotatedPiNormalizationCandidate.families.singleton.familyType.type.view + annotatedPiNormalizationCandidate.families.singleton.constructors + annotatedPiNormalizationCandidate.families.singleton.familyType.type.trace.terminalContext = + .ok () := by + change AddInductive.checkConstructorPreFamilySafety + annotatedPiInductiveStats (.sort (.succ .zero)) + (.cons annotatedPiConstructorCandidate .nil) + annotatedPiFamilyCandidateContext = .ok () + have consumeSortZero : AddInductive.consumeTypeAnnotations + (.sort .zero) = .sort .zero := by + simp [AddInductive.consumeTypeAnnotations] + let nestedContext := annotatedPiFamilyCandidateContext.pushLocalDecl + `p .default (AddInductive.consumeTypeAnnotations (.sort .zero)) + let resultContext := annotatedPiFamilyCandidateContext.advanceFresh + let rootSortZero : AddInductive.ConstructorCheckedExpr + annotatedPiFamilyCandidateContext (.sort .zero) := + .ofRun (by simp [FVarsIn, Level.hasMVar']) + (annotatedPiPreFamilySortZeroCheckTypeStep_valid + annotatedPiFamilyCandidateContext rfl) + let rootSortOne : AddInductive.ConstructorCheckedExpr + annotatedPiFamilyCandidateContext (.sort (.succ .zero)) := + .ofRun (by simp [FVarsIn, Level.hasMVar']) + (annotatedPiPreFamilySortOneCheckTypeStep_valid + annotatedPiFamilyCandidateContext rfl) + let nestedSortOne : AddInductive.ConstructorCheckedExpr + nestedContext (.sort (.succ .zero)) := + .ofRun (by simp [FVarsIn, Level.hasMVar']) + (annotatedPiPreFamilySortOneCheckTypeStep_valid nestedContext rfl) + let resultSortOne : AddInductive.ConstructorCheckedExpr + resultContext (.sort (.succ .zero)) := + .ofRun (by simp [FVarsIn, Level.hasMVar']) + (annotatedPiPreFamilySortOneCheckTypeStep_valid resultContext rfl) + let rootEnsure : AddInductive.ConstructorEnsureTypeObservation + annotatedPiFamilyCandidateContext (.sort .zero) := + ⟨.sort (.succ .zero), + annotatedPiPreFamilySortZeroEnsureTypeStep_valid + annotatedPiFamilyCandidateContext rfl⟩ + let consumedSortZero : AddInductive.ConstructorCheckedExpr + annotatedPiFamilyCandidateContext + (AddInductive.consumeTypeAnnotations (.sort .zero)) := by + rw [consumeSortZero] + exact rootSortZero + let annotations : AddInductive.CandidateIsDefEqObservation + annotatedPiFamilyCandidateContext (.sort .zero) + (AddInductive.consumeTypeAnnotations (.sort .zero)) := + ⟨by + rw [consumeSortZero] + exact AddInductive.candidateIsDefEqRefl + annotatedPiFamilyCandidateContext (.sort .zero)⟩ + have rootFresh : annotatedPiFamilyCandidateContext.lctx.find? + annotatedPiFamilyCandidateContext.freshFVarId = none := by + have h := LocalContext.WF.find?_eq_find?_toList + (fv := annotatedPiFamilyCandidateContext.freshFVarId) + LocalContext.WF.nil + change + ({ fvarIdToDecl := PersistentHashMap.empty + decls := PersistentArray.empty + auxDeclToFullName := Std.TreeMap.empty } : LocalContext).find? + annotatedPiFamilyCandidateContext.freshFVarId = none + rw [h] + simp [LocalContext.toList] + let rootSpine : AddInductive.ConstructorPreFamilyIndexSpineTrace + annotatedPiFamilyCandidateContext (.sort (.succ .zero)) [] := + .nil annotatedPiFamilyCandidateContext (.sort (.succ .zero)) + rootSortOne rfl + let nestedSpine : AddInductive.ConstructorPreFamilyIndexSpineTrace + nestedContext (.sort (.succ .zero)) [] := + .nil nestedContext (.sort (.succ .zero)) nestedSortOne rfl + let resultSpine : AddInductive.ConstructorPreFamilyIndexSpineTrace + resultContext (.sort (.succ .zero)) [] := + .nil resultContext (.sort (.succ .zero)) resultSortOne rfl + have valid : AddInductive.isValidIndAppIdx annotatedPiInductiveStats + (.const ``AnnotatedPi []) 0 = true := + annotatedPiConst_isValidIndAppIdx + have targetArgs : + (Expr.const ``AnnotatedPi []).getAppArgs.toList.drop + annotatedPiInductiveStats.params.size = [] := by + rfl + obtain ⟨nestedTargetSpine, nestedTargetSpineRun⟩ : + ∃ nestedTargetSpine : + AddInductive.ConstructorPreFamilyIndexSpineTrace nestedContext + (.sort (.succ .zero)) + ((Expr.const ``AnnotatedPi []).getAppArgs.toList.drop + annotatedPiInductiveStats.params.size), + AddInductive.ConstructorPreFamilyIndexSpineTrace.build nestedContext + (.sort (.succ .zero)) + ((Expr.const ``AnnotatedPi []).getAppArgs.toList.drop + annotatedPiInductiveStats.params.size) = + .ok nestedTargetSpine := by + rw [targetArgs] + exact ⟨nestedSpine, nestedSpine.build_eq⟩ + let targetTrace : AddInductive.ConstructorPreFamilyRecursiveTrace + annotatedPiInductiveStats 0 (.sort (.succ .zero)) nestedContext + (.const ``AnnotatedPi []) 999 := + .target nestedContext (.const ``AnnotatedPi []) valid nestedTargetSpine + have targetRun : + AddInductive.ConstructorPreFamilyRecursiveTrace.build + annotatedPiInductiveStats 0 (.sort (.succ .zero)) nestedContext + (.const ``AnnotatedPi []) 999 = .ok targetTrace := by + simp only [AddInductive.ConstructorPreFamilyRecursiveTrace.build] + rw [dif_pos valid, nestedTargetSpineRun] + rfl + obtain ⟨recursiveTailTrace, recursiveTailRun⟩ : + ∃ recursiveTailTrace : + AddInductive.ConstructorPreFamilyRecursiveTrace + annotatedPiInductiveStats 0 (.sort (.succ .zero)) nestedContext + ((Expr.const ``AnnotatedPi []).instantiate1 + annotatedPiFamilyCandidateContext.freshExpr) 999, + AddInductive.ConstructorPreFamilyRecursiveTrace.build + annotatedPiInductiveStats 0 (.sort (.succ .zero)) nestedContext + ((Expr.const ``AnnotatedPi []).instantiate1 + annotatedPiFamilyCandidateContext.freshExpr) 999 = + .ok recursiveTailTrace := by + rw [annotatedPiConst_instantiate1] + exact ⟨targetTrace, targetRun⟩ + let recursiveTrace : AddInductive.ConstructorPreFamilyRecursiveTrace + annotatedPiInductiveStats 0 (.sort (.succ .zero)) + annotatedPiFamilyCandidateContext annotatedPiViewInnerKernel + annotatedPiFamilyCandidateContext.fuel.inductiveFuel := + .forallE annotatedPiFamilyCandidateContext `p (.sort .zero) + (.const ``AnnotatedPi []) .default rootSortZero rootEnsure + consumedSortZero annotations rootFresh (by + simpa only [nestedContext] using recursiveTailTrace) + have recursiveRun : + AddInductive.ConstructorPreFamilyRecursiveTrace.build + annotatedPiInductiveStats 0 (.sort (.succ .zero)) + annotatedPiFamilyCandidateContext annotatedPiViewInnerKernel + annotatedPiFamilyCandidateContext.fuel.inductiveFuel = + .ok recursiveTrace := by + change AddInductive.ConstructorPreFamilyRecursiveTrace.build + annotatedPiInductiveStats 0 (.sort (.succ .zero)) + annotatedPiFamilyCandidateContext annotatedPiViewInnerKernel 1000 = + .ok recursiveTrace + simp only [annotatedPiViewInnerKernel, + AddInductive.ConstructorPreFamilyRecursiveTrace.build] + rw [rootSortZero.check_eq, rootEnsure.observe_eq, + consumedSortZero.check_eq] + simp only [Bind.bind, Except.bind] + rw [annotations.observe_eq] + simp only [Bind.bind, Except.bind] + rw [dif_pos rootFresh] + rw [recursiveTailRun] + rfl + have resultIndependent : AddInductive.constructorIndependentOf + (.const ``AnnotatedPi []) + [annotatedPiFamilyCandidateContext.freshFVarId] = true := by + rfl + obtain ⟨resultTargetSpine, resultTargetSpineRun⟩ : + ∃ resultTargetSpine : + AddInductive.ConstructorPreFamilyIndexSpineTrace resultContext + (.sort (.succ .zero)) + ((Expr.const ``AnnotatedPi []).getAppArgs.toList.drop + annotatedPiInductiveStats.params.size), + AddInductive.ConstructorPreFamilyIndexSpineTrace.build resultContext + (.sort (.succ .zero)) + ((Expr.const ``AnnotatedPi []).getAppArgs.toList.drop + annotatedPiInductiveStats.params.size) = + .ok resultTargetSpine := by + rw [targetArgs] + exact ⟨resultSpine, resultSpine.build_eq⟩ + let terminalTrace : AddInductive.ConstructorPreFamilyViewTrace + annotatedPiInductiveStats 0 (.sort (.succ .zero)) resultContext + (.const ``AnnotatedPi []) 1 + [annotatedPiFamilyCandidateContext.freshFVarId] true := + .terminal resultContext (.const ``AnnotatedPi []) 1 + [annotatedPiFamilyCandidateContext.freshFVarId] true valid + resultIndependent resultTargetSpine + have terminalRun : + AddInductive.ConstructorPreFamilyViewTrace.build + annotatedPiInductiveStats 0 (.sort (.succ .zero)) resultContext + (.const ``AnnotatedPi []) 1 + [annotatedPiFamilyCandidateContext.freshFVarId] true 999 = + .ok terminalTrace := by + simp only [AddInductive.ConstructorPreFamilyViewTrace.build] + rw [dif_pos valid, dif_pos resultIndependent, resultTargetSpineRun] + rfl + obtain ⟨viewTailTrace, viewTailRun⟩ : + ∃ viewTailTrace : AddInductive.ConstructorPreFamilyViewTrace + annotatedPiInductiveStats 0 (.sort (.succ .zero)) resultContext + ((Expr.const ``AnnotatedPi []).instantiate1 + annotatedPiFamilyCandidateContext.freshExpr) + 1 [annotatedPiFamilyCandidateContext.freshFVarId] true, + AddInductive.ConstructorPreFamilyViewTrace.build + annotatedPiInductiveStats 0 (.sort (.succ .zero)) resultContext + ((Expr.const ``AnnotatedPi []).instantiate1 + annotatedPiFamilyCandidateContext.freshExpr) + 1 [annotatedPiFamilyCandidateContext.freshFVarId] true 999 = + .ok viewTailTrace := by + rw [annotatedPiConst_instantiate1] + exact ⟨terminalTrace, terminalRun⟩ + have noParameter : annotatedPiInductiveStats.params[0]? = none := rfl + have recursive : AddInductive.hasIndOcc annotatedPiInductiveStats.indConsts + annotatedPiViewInnerKernel = true := by + simp [AddInductive.hasIndOcc, annotatedPiInductiveStats, + annotatedPiViewInnerKernel, Expr.constName!] + have fieldIndependent : AddInductive.constructorIndependentOf + annotatedPiViewInnerKernel [] = true := by + simp [AddInductive.constructorIndependentOf, + annotatedPiViewInnerKernel] + let viewTrace : AddInductive.ConstructorPreFamilyViewTrace + annotatedPiInductiveStats 0 (.sort (.succ .zero)) + annotatedPiFamilyCandidateContext annotatedPiViewCtorKernel 0 [] false := + .recursive annotatedPiFamilyCandidateContext 0 [] false + annotatedPiOuterName annotatedPiViewInnerKernel + (.const ``AnnotatedPi []) .default noParameter recursive + fieldIndependent recursiveTrace rootFresh (by + simpa only [resultContext] using viewTailTrace) + have viewRun : + AddInductive.ConstructorPreFamilyViewTrace.build + annotatedPiInductiveStats 0 (.sort (.succ .zero)) + annotatedPiFamilyCandidateContext annotatedPiViewCtorKernel 0 [] + false 1000 = .ok viewTrace := by + simp only [annotatedPiViewCtorKernel, + AddInductive.ConstructorPreFamilyViewTrace.build] + split + · rename_i parameter parameterAt + rw [noParameter] at parameterAt + contradiction + · split + · rename_i nonrecursive + rw [recursive] at nonrecursive + contradiction + · rw [dif_pos fieldIndependent] + rw [recursiveRun] + simp only [Bind.bind, Except.bind] + rw [dif_pos rootFresh] + rw [viewTailRun] + rfl + have candidateViewEq : annotatedPiConstructorCandidate.type.view = + annotatedPiViewCtorKernel := by + change annotatedPiCtorCandidate.trace.view = annotatedPiViewCtorKernel + change annotatedPiAlignedViewCtorKernel = annotatedPiViewCtorKernel + exact annotatedPiAlignedViewCtorKernel_eq + obtain ⟨headTrace, headRun⟩ : + ∃ headTrace : AddInductive.ConstructorPreFamilyViewTrace + annotatedPiInductiveStats 0 (.sort (.succ .zero)) + annotatedPiFamilyCandidateContext + annotatedPiConstructorCandidate.type.view 0 [] false, + AddInductive.ConstructorPreFamilyViewTrace.build + annotatedPiInductiveStats 0 (.sort (.succ .zero)) + annotatedPiFamilyCandidateContext + annotatedPiConstructorCandidate.type.view 0 [] false 1000 = + .ok headTrace := by + rw [candidateViewEq] + exact ⟨viewTrace, viewRun⟩ + let listTrace : AddInductive.ConstructorPreFamilyListTrace + annotatedPiInductiveStats 0 (.sort (.succ .zero)) + annotatedPiFamilyCandidateContext + (.cons annotatedPiConstructorCandidate .nil) := + .cons headTrace .nil + have listRun : + AddInductive.ConstructorPreFamilyListTrace.build + annotatedPiInductiveStats 0 (.sort (.succ .zero)) + annotatedPiFamilyCandidateContext + (.cons annotatedPiConstructorCandidate .nil) = .ok listTrace := by + simp only [AddInductive.ConstructorPreFamilyListTrace.build] + rw [show annotatedPiFamilyCandidateContext.fuel.inductiveFuel = 1000 by + rfl, headRun] + rfl + have parametersRun : AddInductive.instantiateFamilyParameters + (.sort (.succ .zero)) annotatedPiInductiveStats.params.toList = + .ok (.sort (.succ .zero)) := by + rfl + unfold AddInductive.checkConstructorPreFamilySafety + have translationUnique : + (AddInductive.theoryTranslationUnique (.sort (.succ .zero)) && + (AddInductive.CandidateList.cons annotatedPiConstructorCandidate + (AddInductive.CandidateList.nil : AddInductive.CandidateList + AddInductive.CandidateConstructor [])).viewTranslationUnique) = + true := by + simp [AddInductive.theoryTranslationUnique, + AddInductive.CandidateList.viewTranslationUnique, + AddInductive.CandidateExprTrace.viewTranslationUnique, + AddInductive.CandidateExprTrace.view, + annotatedPiConstructorCandidate, annotatedPiCtorCandidate, + annotatedPiCtorCandidateTrace, annotatedPiInnerCandidateTrace, + annotatedPiDomainCandidateTrace, annotatedPiInnerBodyCandidateTrace, + annotatedPiOuterBodyCandidateTrace, + annotatedPiConst_abstract_singleton] + rw [if_pos translationUnique] + rw [parametersRun] + simp only [Bind.bind, Except.bind] + rw [listRun] + rfl + +private noncomputable def annotatedPiStagedPreFamilyInput : + VInductDecl.StagedNormalizationCandidatePreFamilyInput + annotatedPiFamilyCandidateContext annotatedPiCtorCandidateContext + outParamEnv [] annotatedPiNormalizationCandidate annotatedPiRawDecl := + VInductDecl.StagedNormalizationCandidatePreFamilyInput.ofRun + annotatedPiStagedPostFamilyInput annotatedPiPreFamilySafetyRun + +/-- AnnotatedPi's retained validator telescope and candidate telescope admit +the complete post-family semantic interpretation, including the nested +annotation-bearing recursive field. -/ +theorem annotatedPiProducedPostFamilySemantic_exists : + Nonempty (VInductDecl.ProducedNormalizationCandidatePostFamilySemanticRun + annotatedPiStagedPostFamilyInput) := + annotatedPiStagedPostFamilyInput.exists + +/-- AnnotatedPi's recursive outer field is omitted from the pre-family local +context while its nested Pi binder and both family-index spines receive the +exact verified family-free interpretation. -/ +theorem annotatedPiProducedPreFamilySemantic_exists : + Nonempty (VInductDecl.ProducedNormalizationCandidatePreFamilySemanticRun + annotatedPiStagedPreFamilyInput) := + annotatedPiStagedPreFamilyInput.exists /-- The exact family/constructor producer traversals and verified translations automatically determine the complete retained AnnotatedPi hierarchy, including @@ -8264,12 +10125,15 @@ theorem annotatedPiProducedSemanticHierarchy_exists : annotatedPiFamilyCandidateContext annotatedPiCtorCandidateContext outParamEnv [] annotatedPiNormalizationCandidate annotatedPiRawDecl) := - annotatedPiStagedSemanticInput.exists + annotatedPiStagedUniverseInput.exists def annotatedPiNormalizationCandidateRun : VInductDecl.NormalizationCandidateRun outParamEnv [] - annotatedPiNormalizationCandidate annotatedPiRawDecl := - annotatedPiNormalizationCandidateSemanticRun.root + annotatedPiNormalizationCandidate annotatedPiRawDecl where + raw := annotatedPiRawType + raw_types_eq := rfl + uvars_eq := rfl + family := annotatedPiCandidateFamilyRun example : annotatedPiNormalizationCandidateRun.viewDecl = annotatedPiViewDecl := rfl @@ -8293,22 +10157,13 @@ theorem annotatedPiBlock_wf_checked : exact annotatedPiViewChecked_wf private theorem annotatedPiCandidate_generationShape : - annotatedPiNormalizationCandidateSemanticRun.generationShape = true := by + VInductDecl.normalizationCandidateGenerationShape annotatedPiRawDecl + annotatedPiRawType annotatedPiNormalizationCandidate = true := by change ((true && true) && (annotatedPiCtorCandidate.trace.storedSpine && true && true)) = true rw [annotatedPiCtorCandidate_storedSpine] rfl -/-- Temporary L4L-01A view-WF compatibility premise. L4L-01D derives this -from retained validation and L4L-01E removes it from package construction. -/ -private theorem annotatedPiCandidate_viewDecl_wf : - annotatedPiNormalizationCandidateRun.viewDecl.WF outParamEnv := by - change annotatedPiViewDecl.WF outParamEnv - apply annotatedPiViewDecl_wf.mono - exact (VEnv.addConst_le (by rfl : - VEnv.empty.addConst ``outParam (vconst(type_of% @outParam)) = - some outParamConstEnv)).trans VEnv.addDefEq_le - private def annotatedPiProducedGenerationShapeCandidate : VInductDecl.ProducedGenerationShapeCandidate annotatedPiRawDecl annotatedPiRawType annotatedPiKernelType 0 false @@ -8334,45 +10189,72 @@ theorem annotatedPiGenerationShapeCandidate_produced : (source := annotatedPiRawDecl) (raw := annotatedPiRawType) produced annotatedPiCandidate_generationShape +private theorem annotatedPiCandidate_analysis + (normalization : VInductDecl.NormalizationCandidateSemanticRun + outParamEnv [] annotatedPiNormalizationCandidate + annotatedPiRawDecl) : + normalization.root.normalization.generation? = + some annotatedPiGenerationChecked := by + let reference : VInductDecl.NormalizationCandidateSemanticRun outParamEnv [] + annotatedPiNormalizationCandidate annotatedPiRawDecl := { + raw := annotatedPiRawType + raw_types_eq := rfl + uvars_eq := rfl + family := annotatedPiCandidateFamilySemanticRun } + rw [annotatedPiStagedPreFamilyInput.normalization_eq normalization reference] + rfl + +/-- AnnotatedPi's nested annotation-normalizing candidate closes through the +same generic staged-owner boundary as the ordinary singleton fixture. -/ +theorem annotatedPiExactProducedGenerationCandidatePackage_exists : + Nonempty (VInductDecl.ExactProducedGenerationCandidatePackage + outParamEnv [] annotatedPiProducedGenerationShapeCandidate + annotatedPiGenerationChecked) := + annotatedPiProducedGenerationShapeCandidate.exactProducedPackage_nonempty + annotatedPiStagedPreFamilyInput rfl annotatedPiGenerationChecked + annotatedPiCandidate_analysis + +private noncomputable def + annotatedPiExactProducedGenerationCandidatePackage : + VInductDecl.ExactProducedGenerationCandidatePackage outParamEnv [] + annotatedPiProducedGenerationShapeCandidate annotatedPiGenerationChecked := + Classical.choice annotatedPiExactProducedGenerationCandidatePackage_exists + /-- 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. -/ -def annotatedPiGenerationCandidateSemanticRun : - VInductDecl.GenerationCandidateSemanticRun - annotatedPiNormalizationCandidateSemanticRun +noncomputable def annotatedPiGenerationCandidateSemanticRun : + VInductDecl.GenerationCandidateSemanticRun + annotatedPiExactProducedGenerationCandidatePackage.normalization annotatedPiGenerationChecked := - VInductDecl.GenerationCandidateSemanticRun.ofGenerationShape - annotatedPiNormalizationCandidateSemanticRun - annotatedPiGenerationChecked rfl annotatedPiCandidate_viewDecl_wf - annotatedPiCandidate_generationShape + annotatedPiExactProducedGenerationCandidatePackage.semantic -def annotatedPiGenerationCandidateRun : +noncomputable def annotatedPiGenerationCandidateRun : VInductDecl.GenerationCandidateRun - annotatedPiNormalizationCandidateRun + annotatedPiExactProducedGenerationCandidatePackage.normalization.root annotatedPiGenerationChecked := annotatedPiGenerationCandidateSemanticRun.run /-- Complete dependent producer package for the annotation-bearing recursive Π candidate. -/ -def annotatedPiGenerationCandidatePackage : +noncomputable 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. -/ -def annotatedPiProducedGenerationCandidatePackage : +noncomputable def annotatedPiProducedGenerationCandidatePackage : VInductDecl.ProducedGenerationCandidatePackage outParamEnv [] := - annotatedPiProducedGenerationShapeCandidate.producedPackage - annotatedPiNormalizationCandidateSemanticRun rfl - annotatedPiGenerationChecked rfl annotatedPiCandidate_viewDecl_wf + annotatedPiExactProducedGenerationCandidatePackage.package /-- Theory-only erasure consumed by the public certified transaction. -/ def annotatedPiGenerationCertificate : - annotatedPiRawDecl.GenerationCertificate outParamEnv := - annotatedPiProducedGenerationCandidatePackage.package.certificate + annotatedPiRawDecl.GenerationCertificate outParamEnv where + generation := annotatedPiGenerationChecked + wf := annotatedPiExactProducedGenerationCandidatePackage.semantic.run.wf -def annotatedPiGenerationRun : +noncomputable def annotatedPiGenerationRun : VInductDecl.GenerationRun annotatedPiGenerationChecked outParamEnv := annotatedPiProducedGenerationCandidatePackage.package.run.generationRun @@ -8490,12 +10372,12 @@ private theorem annotatedPiRec_fresh : /-- Complete kernel-metadata replay transaction for `AnnotatedPi`, driven by the checker-produced non-identity normalization certificate. -/ -def annotatedPiAddInductTraceChecked : +noncomputable def annotatedPiAddInductTraceChecked : AddInductTrace outParamMap outParamEnv annotatedPiRawDecl annotatedPiMap annotatedPiFinalEnv := by refine annotatedPiProducedGenerationCandidatePackage.package.addInductTrace annotatedPiTypeMap annotatedPiTypeEnv annotatedPiCtorMap - annotatedPiCtorEnv annotatedPiRecEnv annotatedPiAddType ?_ ?_ ⟨rfl⟩ + annotatedPiCtorEnv annotatedPiRecEnv annotatedPiAddType ?_ ?_ ?_ ⟨rfl⟩ · exact .cons { info := annotatedPiMkInfo kind_eq := by simp [annotatedPiMkInfo, InductConstantKind.Matches] @@ -8516,6 +10398,7 @@ def annotatedPiAddInductTraceChecked : exact annotatedPiRec_fresh env_add := rfl map_add := rfl } + · decide theorem annotatedPi_addInduct_checked : AddInduct outParamMap outParamEnv annotatedPiRawDecl @@ -8559,80 +10442,352 @@ theorem annotatedPiFinalEnv_ctor_lookup : rcases annotatedPiFinalEnv_trace with ⟨trace⟩ exact trace.ctor_lookup (.head _) -theorem annotatedPiFinalEnv_rec_lookup : - annotatedPiFinalEnv.constants ``AnnotatedPi.rec = - some annotatedPiGenerationChecked.recursor := by - rcases annotatedPiFinalEnv_trace with ⟨trace⟩ - exact trace.rec_lookup +theorem annotatedPiFinalEnv_rec_lookup : + annotatedPiFinalEnv.constants ``AnnotatedPi.rec = + some annotatedPiGenerationChecked.recursor := by + rcases annotatedPiFinalEnv_trace with ⟨trace⟩ + exact trace.rec_lookup + +theorem annotatedPiFinalEnv_rule_mem : + ∀ df ∈ annotatedPiGenerationChecked.generatedRules, + annotatedPiFinalEnv.defeqs df := by + intro df hdf + rcases annotatedPiFinalEnv_trace with ⟨trace⟩ + exact trace.rule_mem hdf + +theorem annotatedPiFinalEnv_iota_mem : + annotatedPiFinalEnv.defeqs + annotatedPiGenerationChecked.generatedRules[0] := by + apply annotatedPiFinalEnv_rule_mem + exact .head _ + +theorem annotatedPi_iota_rhs_matches_kernel : + annotatedPiKernelRuleRhs = + annotatedPiGenerationChecked.generatedRules[0].rhs := rfl + +theorem annotatedPi_type_map_lookup : + annotatedPiMap.find? ``AnnotatedPi = some annotatedPiInfo := by + rw [annotatedPiMap, annotatedPiCtorMap_wf.find?_insert, + annotatedPiCtorMap, annotatedPiTypeMap_wf.find?_insert] + simp +decide + rw [annotatedPiTypeMap, outParamMap_wf.find?_insert] + simp +decide + +theorem annotatedPi_mk_map_lookup : + annotatedPiMap.find? ``AnnotatedPi.mk = some annotatedPiMkInfo := by + rw [annotatedPiMap, annotatedPiCtorMap_wf.find?_insert, + annotatedPiCtorMap, annotatedPiTypeMap_wf.find?_insert] + rfl + +theorem annotatedPi_rec_map_lookup : + annotatedPiMap.find? ``AnnotatedPi.rec = some annotatedPiRecInfo := by + rw [annotatedPiMap, annotatedPiCtorMap_wf.find?_insert] + rfl + +theorem annotatedPi_type_lookup_unique : + annotatedPiInfo.name = ``AnnotatedPi ∧ + TrConstant .safe annotatedPiFinalEnv annotatedPiInfo + annotatedPiRawType.toVConstant := + annotatedPi_aligned_checked.find?_uniq annotatedPi_type_map_lookup + annotatedPiFinalEnv_family_lookup + +theorem annotatedPi_mk_lookup_unique : + annotatedPiMkInfo.name = ``AnnotatedPi.mk ∧ + TrConstant .safe annotatedPiFinalEnv annotatedPiMkInfo + annotatedPiRawType.ctors[0].toVConstant := + annotatedPi_aligned_checked.find?_uniq annotatedPi_mk_map_lookup + annotatedPiFinalEnv_ctor_lookup + +theorem annotatedPi_rec_lookup_unique : + annotatedPiRecInfo.name = ``AnnotatedPi.rec ∧ + TrConstant .safe annotatedPiFinalEnv annotatedPiRecInfo + annotatedPiGenerationChecked.recursor := + annotatedPi_aligned_checked.find?_uniq annotatedPi_rec_map_lookup + annotatedPiFinalEnv_rec_lookup + +/-! ## Definitionally equal parameter transaction replay -/ + +/-- Consumer-facing certificate for the exact mixed generation value whose +stored parameter is `outParam Type` and whose emitted recursor parameter is +the definitionally equal checked `Type`. -/ +def annotatedParamGenerationCertificate : + annotatedParamRawDecl.GenerationCertificate outParamEnv where + generation := annotatedParamGenerationChecked + wf := annotatedParamGenerationChecked_wf + +def annotatedParamCtorEnv : VEnv := + (annotatedParamTypeEnv.addConst annotatedParamRawType.ctors[0].name + annotatedParamRawType.ctors[0].toVConstant).get! + +def annotatedParamRecEnv : VEnv := + (annotatedParamCtorEnv.addConst ``AnnotatedParam.rec + annotatedParamGenerationChecked.recursor).get! + +def annotatedParamFinalEnv : VEnv := + (outParamEnv.addInductGeneration + annotatedParamGenerationChecked).get (by decide) + +theorem annotatedParam_addInductGeneration : + outParamEnv.addInductGeneration annotatedParamGenerationChecked = + some annotatedParamFinalEnv := rfl + +/-- The public proof-carrying transaction accepts the raw/checked parameter +normalization and computes the same environment as the underlying generation +transaction. -/ +theorem annotatedParam_addInductCertified : + outParamEnv.addInductCertified annotatedParamGenerationCertificate = + some annotatedParamFinalEnv := + annotatedParam_addInductGeneration + +theorem annotatedParamCertified_ordered : + annotatedParamFinalEnv.Ordered := + VEnv.addInductCertified_WF outParamEnv_ordered + annotatedParam_addInductCertified + +private theorem annotatedParamRawCtor_wf : + annotatedParamRawType.ctors[0].toVConstant.WF + annotatedParamTypeEnv := by + change annotatedParamTypeEnv.IsType 0 [] + annotatedParamRawType.ctors[0].type + let ctor : VInductDecl.NormalizedCtor := + ⟨annotatedParamRawType.ctors[0], + annotatedParamViewChecked.constructors[0]⟩ + have hctor : ctor ∈ + annotatedParamGenerationChecked.block.ctorPairs := by + change ctor ∈ [⟨annotatedParamRawType.ctors[0], + annotatedParamViewChecked.constructors[0]⟩] + exact .head _ + simpa [ctor, annotatedParamRawDecl] using + annotatedParamGenerationChecked_wf.rawCtor_isType + (envT := annotatedParamTypeEnv) rfl hctor + +private theorem annotatedParamCtorEnv_ordered : + annotatedParamCtorEnv.Ordered := + .const (n := annotatedParamRawType.ctors[0].name) + (ci := annotatedParamRawType.ctors[0].toVConstant) + annotatedParamTypeEnv_ordered annotatedParamRawCtor_wf rfl + +private theorem annotatedParamGenerationEnv : + VInductDecl.GenerationEnv annotatedParamGenerationChecked + annotatedParamCtorEnv := by + apply annotatedParamGenerationChecked_wf.toGenerationEnv + (envT := annotatedParamTypeEnv) + · rfl + · exact (VEnv.addConst_le (show + outParamEnv.addConst annotatedParamRawType.name + annotatedParamRawType.toVConstant = + some annotatedParamTypeEnv from rfl)).trans + (VEnv.addConst_le (show + annotatedParamTypeEnv.addConst + annotatedParamRawType.ctors[0].name + annotatedParamRawType.ctors[0].toVConstant = + some annotatedParamCtorEnv from rfl)) + · exact VEnv.addConst_le (show + annotatedParamTypeEnv.addConst + annotatedParamRawType.ctors[0].name + annotatedParamRawType.ctors[0].toVConstant = + some annotatedParamCtorEnv from rfl) + · exact annotatedParamCtorEnv_ordered + · rfl + · intro ctor hctor + change ctor ∈ [⟨annotatedParamRawType.ctors[0], + annotatedParamViewChecked.constructors[0]⟩] at hctor + obtain rfl := List.mem_singleton.1 hctor + rfl + +private theorem annotatedParamMkInfo_tr : + TrConstVal .safe annotatedParamTypeEnv annotatedParamMkInfo + annotatedParamRawType.ctors[0] := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr annotatedParamTypeEnv + annotatedParamMkInfo.levelParams [] annotatedParamMkInfo.type + annotatedParamRawType.ctors[0].type := by + tr_type_expr_tac + obtain ⟨u, htype⟩ := annotatedParamRawCtor_wf + exact hshape.to_trExprS annotatedParamTypeEnv_ordered trivial + ⟨.sort u, htype⟩ + +private theorem annotatedParamRecInfo_tr : + TrConstVal .safe annotatedParamCtorEnv annotatedParamRecInfo + (inductGenerationRecVal annotatedParamGenerationChecked) := by + have hfamily : annotatedParamCtorEnv.constants ``AnnotatedParam = + some annotatedParamRawType.toVConstant := rfl + have hmk : annotatedParamCtorEnv.constants ``AnnotatedParam.mk = + some annotatedParamRawType.ctors[0].toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr annotatedParamCtorEnv + annotatedParamRecInfo.levelParams [] annotatedParamRecInfo.type + (inductGenerationRecVal annotatedParamGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨u, hrec⟩ := annotatedParamGenerationEnv.recursor_wf + exact hshape.to_trExprS annotatedParamCtorEnv_ordered trivial + ⟨.sort u, hrec⟩ + +private def annotatedParamCtorMap : ConstMap := + annotatedParamTypeMap.insert ``AnnotatedParam.mk annotatedParamMkInfo + +private def annotatedParamMap : ConstMap := + annotatedParamCtorMap.insert ``AnnotatedParam.rec annotatedParamRecInfo + +private theorem annotatedParamMk_fresh : + annotatedParamTypeMap.find? ``AnnotatedParam.mk = none := by + rw [annotatedParamTypeMap, outParamMap_wf.find?_insert, + outParamMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +private theorem annotatedParamCtorMap_wf : annotatedParamCtorMap.WF := + annotatedParamTypeMap_wf.insert _ _ annotatedParamMk_fresh + +private theorem annotatedParamRec_fresh : + annotatedParamCtorMap.find? ``AnnotatedParam.rec = none := by + rw [annotatedParamCtorMap, annotatedParamTypeMap_wf.find?_insert, + annotatedParamTypeMap, outParamMap_wf.find?_insert, outParamMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +/-- Real `ConstantInfo` replay for the definitionally equal parameter case. +The generation certificate and the emitted recursor/rule payload are the same +values checked against kernel metadata above. -/ +def annotatedParamAddInductTraceChecked : + AddInductTrace outParamMap outParamEnv annotatedParamRawDecl + annotatedParamMap annotatedParamFinalEnv := by + refine { + generation := annotatedParamGenerationChecked + generation_wf := annotatedParamGenerationChecked_wf + typeMap := annotatedParamTypeMap + typeEnv := annotatedParamTypeEnv + ctorMap := annotatedParamCtorMap + ctorEnv := annotatedParamCtorEnv + recEnv := annotatedParamRecEnv + addType := annotatedParamAddType + addCtors := ?_ + addRec := { + info := annotatedParamRecInfo + kind_eq := by + simp [annotatedParamRecInfo, InductConstantKind.Matches] + tr := annotatedParamRecInfo_tr + map_fresh := by + rw [show + (inductGenerationRecVal annotatedParamGenerationChecked).name = + ``AnnotatedParam.rec by rfl] + exact annotatedParamRec_fresh + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ } + exact .cons { + info := annotatedParamMkInfo + kind_eq := by + simp [annotatedParamMkInfo, InductConstantKind.Matches] + tr := annotatedParamMkInfo_tr + map_fresh := by + simpa [annotatedParamRawType] using annotatedParamMk_fresh + env_add := rfl + map_add := rfl } .nil + +theorem annotatedParam_addInduct_checked : + AddInduct outParamMap outParamEnv annotatedParamRawDecl + annotatedParamMap annotatedParamFinalEnv := + ⟨annotatedParamAddInductTraceChecked⟩ + +theorem annotatedParam_trEnv'_checked : + TrEnv' .safe annotatedParamMap false annotatedParamFinalEnv := + .induct annotatedParam_addInduct_checked outParam_trEnv' + +theorem annotatedParam_env_wf_checked : annotatedParamFinalEnv.WF := + annotatedParam_trEnv'_checked.wf + +theorem annotatedParam_aligned_checked : + Aligned .safe annotatedParamMap annotatedParamFinalEnv := + annotatedParam_trEnv'_checked.aligned + +theorem annotatedParamCertified_trace : + Nonempty (VEnv.AddInductGenerationTrace outParamEnv + annotatedParamFinalEnv annotatedParamGenerationChecked) := + VEnv.addInductCertified_trace annotatedParam_addInductCertified -theorem annotatedPiFinalEnv_rule_mem : - ∀ df ∈ annotatedPiGenerationChecked.generatedRules, - annotatedPiFinalEnv.defeqs df := by - intro df hdf - rcases annotatedPiFinalEnv_trace with ⟨trace⟩ - exact trace.rule_mem hdf +theorem annotatedParamFinalEnv_family_lookup : + annotatedParamFinalEnv.constants ``AnnotatedParam = + some annotatedParamRawType.toVConstant := by + rcases annotatedParamCertified_trace with ⟨trace⟩ + exact trace.family_lookup -theorem annotatedPiFinalEnv_iota_mem : - annotatedPiFinalEnv.defeqs - annotatedPiGenerationChecked.generatedRules[0] := by - apply annotatedPiFinalEnv_rule_mem - exact .head _ +theorem annotatedParamFinalEnv_ctor_lookup : + annotatedParamFinalEnv.constants ``AnnotatedParam.mk = + some annotatedParamRawType.ctors[0].toVConstant := by + rcases annotatedParamCertified_trace with ⟨trace⟩ + exact trace.ctor_lookup (.head _) -theorem annotatedPi_iota_rhs_matches_kernel : - annotatedPiKernelRuleRhs = - annotatedPiGenerationChecked.generatedRules[0].rhs := rfl +theorem annotatedParamFinalEnv_rec_lookup : + annotatedParamFinalEnv.constants ``AnnotatedParam.rec = + some annotatedParamGenerationChecked.recursor := by + rcases annotatedParamCertified_trace with ⟨trace⟩ + exact trace.rec_lookup -theorem annotatedPi_type_map_lookup : - annotatedPiMap.find? ``AnnotatedPi = some annotatedPiInfo := by - rw [annotatedPiMap, annotatedPiCtorMap_wf.find?_insert, - annotatedPiCtorMap, annotatedPiTypeMap_wf.find?_insert] - simp +decide - rw [annotatedPiTypeMap, outParamMap_wf.find?_insert] +theorem annotatedParamFinalEnv_iota_mem : + annotatedParamFinalEnv.defeqs + annotatedParamGenerationChecked.generatedRules[0] := by + rcases annotatedParamCertified_trace with ⟨trace⟩ + exact trace.rule_mem (.head _) + +theorem annotatedParam_iota_rhs_matches_kernel : + annotatedParamKernelRuleRhs = + annotatedParamGenerationChecked.generatedRules[0].rhs := rfl + +theorem annotatedParam_type_map_lookup : + annotatedParamMap.find? ``AnnotatedParam = + some annotatedParamInfo := by + rw [annotatedParamMap, annotatedParamCtorMap_wf.find?_insert, + annotatedParamCtorMap, annotatedParamTypeMap_wf.find?_insert, + annotatedParamTypeMap, outParamMap_wf.find?_insert] simp +decide -theorem annotatedPi_mk_map_lookup : - annotatedPiMap.find? ``AnnotatedPi.mk = some annotatedPiMkInfo := by - rw [annotatedPiMap, annotatedPiCtorMap_wf.find?_insert, - annotatedPiCtorMap, annotatedPiTypeMap_wf.find?_insert] +theorem annotatedParam_mk_map_lookup : + annotatedParamMap.find? ``AnnotatedParam.mk = + some annotatedParamMkInfo := by + rw [annotatedParamMap, annotatedParamCtorMap_wf.find?_insert, + annotatedParamCtorMap, annotatedParamTypeMap_wf.find?_insert] rfl -theorem annotatedPi_rec_map_lookup : - annotatedPiMap.find? ``AnnotatedPi.rec = some annotatedPiRecInfo := by - rw [annotatedPiMap, annotatedPiCtorMap_wf.find?_insert] +theorem annotatedParam_rec_map_lookup : + annotatedParamMap.find? ``AnnotatedParam.rec = + some annotatedParamRecInfo := by + rw [annotatedParamMap, annotatedParamCtorMap_wf.find?_insert] rfl -theorem annotatedPi_type_lookup_unique : - annotatedPiInfo.name = ``AnnotatedPi ∧ - TrConstant .safe annotatedPiFinalEnv annotatedPiInfo - annotatedPiRawType.toVConstant := - annotatedPi_aligned_checked.find?_uniq annotatedPi_type_map_lookup - annotatedPiFinalEnv_family_lookup - -theorem annotatedPi_mk_lookup_unique : - annotatedPiMkInfo.name = ``AnnotatedPi.mk ∧ - TrConstant .safe annotatedPiFinalEnv annotatedPiMkInfo - annotatedPiRawType.ctors[0].toVConstant := - annotatedPi_aligned_checked.find?_uniq annotatedPi_mk_map_lookup - annotatedPiFinalEnv_ctor_lookup - -theorem annotatedPi_rec_lookup_unique : - annotatedPiRecInfo.name = ``AnnotatedPi.rec ∧ - TrConstant .safe annotatedPiFinalEnv annotatedPiRecInfo - annotatedPiGenerationChecked.recursor := - annotatedPi_aligned_checked.find?_uniq annotatedPi_rec_map_lookup - annotatedPiFinalEnv_rec_lookup +theorem annotatedParam_type_lookup_unique : + annotatedParamInfo.name = ``AnnotatedParam ∧ + TrConstant .safe annotatedParamFinalEnv annotatedParamInfo + annotatedParamRawType.toVConstant := + annotatedParam_aligned_checked.find?_uniq annotatedParam_type_map_lookup + annotatedParamFinalEnv_family_lookup + +theorem annotatedParam_mk_lookup_unique : + annotatedParamMkInfo.name = ``AnnotatedParam.mk ∧ + TrConstant .safe annotatedParamFinalEnv annotatedParamMkInfo + annotatedParamRawType.ctors[0].toVConstant := + annotatedParam_aligned_checked.find?_uniq annotatedParam_mk_map_lookup + annotatedParamFinalEnv_ctor_lookup + +theorem annotatedParam_rec_lookup_unique : + annotatedParamRecInfo.name = ``AnnotatedParam.rec ∧ + TrConstant .safe annotatedParamFinalEnv annotatedParamRecInfo + annotatedParamGenerationChecked.recursor := + annotatedParam_aligned_checked.find?_uniq annotatedParam_rec_map_lookup + annotatedParamFinalEnv_rec_lookup /-- 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. -/ -def aliasFormerAddInductTraceChecked : +noncomputable def aliasFormerAddInductTraceChecked : AddInductTrace typeFamilyAliasMap typeFamilyAliasEnv aliasFormerRawDecl aliasFormerMap aliasFormerFinalEnv := let replay := aliasFormerAddInductTraceWith aliasFormerGenerationCertificate.wf aliasFormerProducedGenerationCandidatePackage.package.addInductTrace replay.typeMap replay.typeEnv replay.ctorMap replay.ctorEnv replay.recEnv - replay.addType replay.addCtors replay.addRec replay.addRules + replay.addType replay.addCtors replay.addRec replay.recK replay.addRules theorem aliasFormer_addInduct_checked : AddInduct typeFamilyAliasMap typeFamilyAliasEnv @@ -9213,6 +11368,72 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerProducedSemanticHierarchy_ex #guard_msgs in #print axioms aliasFormerProducedSemanticHierarchy_exists +/-- +info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerProducedPostFamilySemantic_exists' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms aliasFormerProducedPostFamilySemantic_exists + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerProducedPreFamilySemantic_exists' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms aliasFormerProducedPreFamilySemantic_exists + /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationCandidateSemanticRun' depends on axioms: [propext, sorryAx, @@ -9332,6 +11553,24 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerNormalizationCandidate_produ /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationShapeCandidate_produced' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + Expr.eqv_eq, + Expr.looseBVarRange_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Level.instLawfulBEqLevel, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms aliasFormerGenerationShapeCandidate_produced + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerExactProducedGenerationCandidatePackage_exists' depends on axioms: [propext, sorryAx, Classical.choice, ptrEqConstantInfo_eq, @@ -9361,7 +11600,7 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationShapeCandidate_pro PersistentHashMap.WF.toList'_insert] -/ #guard_msgs in -#print axioms aliasFormerGenerationShapeCandidate_produced +#print axioms aliasFormerExactProducedGenerationCandidatePackage_exists /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerProducedGenerationCandidatePackage' depends on axioms: [propext, @@ -9769,6 +12008,72 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiProducedSemanticHierarchy_ex #guard_msgs in #print axioms annotatedPiProducedSemanticHierarchy_exists +/-- +info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiProducedPostFamilySemantic_exists' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms annotatedPiProducedPostFamilySemantic_exists + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiProducedPreFamilySemantic_exists' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms annotatedPiProducedPreFamilySemantic_exists + /-- info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiNormalizationCandidateRun' depends on axioms: [propext, sorryAx, @@ -9905,7 +12210,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationCandidatePackage' info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiCtor_candidateTrace' depends on axioms: [propext, sorryAx, Classical.choice, - ptrEqExpr_eq, Quot.sound, Expr.eqv_eq, Expr.instantiate1_eq, @@ -9945,7 +12249,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiFamily_candidateTrace' depen info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiNormalizationCandidate_produced' depends on axioms: [propext, sorryAx, Classical.choice, - ptrEqExpr_eq, Quot.sound, Expr.eqv_eq, Expr.instantiate1_eq, @@ -9971,6 +12274,33 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiNormalizationCandidate_produ /-- info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationShapeCandidate_produced' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + Expr.eqv_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms annotatedPiGenerationShapeCandidate_produced + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiExactProducedGenerationCandidatePackage_exists' depends on axioms: [propext, sorryAx, Classical.choice, ptrEqConstantInfo_eq, @@ -10000,7 +12330,7 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationShapeCandidate_pro PersistentHashMap.WF.toList'_insert] -/ #guard_msgs in -#print axioms annotatedPiGenerationShapeCandidate_produced +#print axioms annotatedPiExactProducedGenerationCandidatePackage_exists /-- info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiProducedGenerationCandidatePackage' depends on axioms: [propext, @@ -10173,4 +12503,45 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiFinalEnv_iota_mem' depends o #guard_msgs in #print axioms annotatedPiFinalEnv_iota_mem +/-! The parameter-parity fixture deliberately keeps its operational checker +outcome guard separate from the Theory certificate. These pins make the exact +trust split visible: the semantic transaction stays Theory-small, while real +`ConstantInfo` replay inherits only the already classified Verify frontier. -/ + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.annotatedParam_addInductCertified' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms annotatedParam_addInductCertified + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.annotatedParamAddInductTraceChecked' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms annotatedParamAddInductTraceChecked + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.annotatedParam_trEnv'_checked' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms annotatedParam_trEnv'_checked + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.annotatedParamFinalEnv_iota_mem' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms annotatedParamFinalEnv_iota_mem + end Lean4Lean.InductiveReplayFixtures diff --git a/Lean4Lean/Verify/Environment/Lemmas.lean b/Lean4Lean/Verify/Environment/Lemmas.lean index 97029fed..0af803b9 100644 --- a/Lean4Lean/Verify/Environment/Lemmas.lean +++ b/Lean4Lean/Verify/Environment/Lemmas.lean @@ -33,6 +33,8 @@ theorem TrEnv'.sf_mono (hsf : safety ≤ safety') : .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) theorem TrConstant.mono {env env' : VEnv} (henv : env ≤ env') (H : TrConstant safety env ci ci') : TrConstant safety env' ci ci' := @@ -138,6 +140,24 @@ theorem AddInduct.old_of_value (H : AddInduct C₁ env₁ decl C₂ env₂) exact H.addType.old_of_value wf (H.addCtors.old_of_value wfType (H.addRec.old_of_value wfCtors hout hv) hv) hv +theorem AddInductBlock.map_wf + (H : AddInductBlock 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 AddInductBlock.old_of_value + (H : AddInductBlock 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 @@ -166,12 +186,28 @@ theorem Aligned.addInduct (H : AddInduct C₁ env₁ decl C₂ env₂) have wfRec := wfCtors.addInductConstant H.addRec exact wfRec.addDefEqFold _ +theorem Aligned.addInductBlock + (H : AddInductBlock 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] -/ #guard_msgs in #print axioms Aligned.addInduct +/-- +info: 'Lean4Lean.Aligned.addInductBlock' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms Aligned.addInductBlock + theorem TrEnv'.aligned (H : TrEnv' safety C Q venv) : Aligned safety C venv := by induction H with | empty => exact .empty @@ -181,6 +217,7 @@ theorem TrEnv'.aligned (H : TrEnv' safety C Q venv) : Aligned safety C venv := b | 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 /-- info: 'Lean4Lean.TrEnv'.aligned' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] @@ -286,6 +323,8 @@ 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 | induct h1 H ih => 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 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 new file mode 100644 index 00000000..32f09cb3 --- /dev/null +++ b/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean @@ -0,0 +1,3218 @@ +import Lean4Lean.Verify.Environment.InductiveFixtures +import Lean4Lean.Theory.MutualInductiveFixtures + +/-! +# Mutual generation, preservation, and environment replay + +The real `Tree`/`TreeList` and indexed mutual fixtures instantiate the +arbitrary-block validator traces, generate one recursor per family with one +globally flattened minor/rule inventory, and compare every kernel metadata +record. Their Theory transactions stage all families before constructors, +all constructors before recursors, and all recursors before rules, then replay +the same phases through `TrEnv'.inductBlock` into aligned Verify environments. +-/ + +namespace Lean4Lean.MutualInductiveReplayFixtures + +open Lean Meta Elab Term +open Kernel +open AddInductive +open VInductDecl +open Lean4Lean.MutualInductiveFixtures +open Lean4Lean.InductiveReplayFixtures + +local instance : Inhabited VEnv := ⟨.empty⟩ + +/-- Quote a kernel recursor type using the recursor metadata's own universe +parameter order. -/ +syntax "kernelRecConstant08C%" ident : term +syntax "kernelConstVType08C%" ident : term + +elab_rules : term + | `(kernelRecConstant08C% $n:ident) => do + let name ← realizeGlobalConstNoOverloadWithInfo n + let .recInfo info ← getConstInfo name + | throwError "expected recursor metadata for {name}" + let type ← Lean4Lean.Meta.expandExpr info.type + let type ← Lean4Lean.Meta.ofExpr info.levelParams {} type + return toExpr ({ uvars := info.levelParams.length, type } : VConstant) + +/-- Quote a stored kernel metadata type in that record's own universe order. +Together with the explicit record-field checks below, this observes universe +permutations as well as the translated type expression. -/ +elab_rules : term + | `(kernelConstVType08C% $n:ident) => do + let name ← realizeGlobalConstNoOverloadWithInfo n + let info ← getConstInfo name + let type ← Lean4Lean.Meta.expandExpr info.type + let type ← Lean4Lean.Meta.ofExpr info.levelParams {} type + return toExpr type + +/-! ## Complete block metadata parity -/ + +/-- One block-wide comparison between the retained Theory generation and all +kernel inductive metadata. The nested lists preserve family/constructor +ownership and split each recursor's local rules out of the globally flattened +Theory rule list. -/ +structure MutualKernelBlockRow where + source : VInductDecl + generation : BlockGenerationChecked source + inductInfos : List ConstantInfo + ctorInfos : List (List ConstantInfo) + recInfos : List ConstantInfo + familyTypes : List VExpr + ctorTypes : List (List VExpr) + recTypes : List VExpr + ruleRhs : List (List VExpr) + +namespace MutualKernelBlockRow + +def ctorMatches (row : MutualKernelBlockRow) + (family : NormalizedFamily) (cidx : Nat) (info : ConstantInfo) + (constructor : NormalizedCtor) (storedType : VExpr) : Bool := + match info with + | .ctorInfo ctor => + ctor.name == constructor.raw.name && + ctor.levelParams.length == row.source.uvars && + ctor.induct == family.raw.name && + ctor.cidx == cidx && + ctor.numParams == row.source.nparams && + ctor.numFields == constructor.view.fields.length && + !ctor.isUnsafe && storedType == constructor.raw.type + | _ => false + +def ctorsMatch (row : MutualKernelBlockRow) + (family : NormalizedFamily) : + List ConstantInfo → List NormalizedCtor → List VExpr → Nat → Bool + | [], [], [], _ => true + | info :: infos, constructor :: constructors, storedType :: storedTypes, + cidx => + row.ctorMatches family cidx info constructor storedType && + row.ctorsMatch family infos constructors storedTypes (cidx + 1) + | _, _, _, _ => false + +def recursorMatches (row : MutualKernelBlockRow) + (family : NormalizedFamily) (offset : Nat) + (info : ConstantInfo) (storedType : VExpr) + (rhs : List VExpr) : Bool := + match info with + | .recInfo rec => + rec.name == .str family.raw.name "rec" && + rec.levelParams.length == row.generation.recUvars && + rec.all == row.source.types.map (·.name) && + rec.numParams == row.source.nparams && + rec.numIndices == family.view.indices.length && + rec.numMotives == row.generation.familyCount && + rec.numMinors == row.generation.minorCount && + rec.k == row.generation.kTarget && + !rec.isUnsafe && + rec.rules.map (fun rule => (rule.ctor, rule.nfields)) == + family.ctorPairs.map (fun constructor => + (constructor.raw.name, constructor.view.fields.length)) && + storedType == (row.generation.recursor family).type && + rhs == ((row.generation.generatedRules.drop offset).take + family.ctorPairs.length |>.map (·.rhs)) + | _ => false + +def familiesMatch (row : MutualKernelBlockRow) : + List NormalizedFamily → List ConstantInfo → List (List ConstantInfo) → + List ConstantInfo → List VExpr → List (List VExpr) → List VExpr → + List (List VExpr) → Nat → Bool + | [], [], [], [], [], [], [], [], _ => true + | family :: families, inductInfo :: inductInfos, + ctorInfos :: ctorInfosTail, recInfo :: recInfos, + familyType :: familyTypes, ctorTypes :: ctorTypesTail, + recType :: recTypes, ruleRhs :: ruleRhsTail, offset => + (match inductInfo with + | .inductInfo induct => + induct.name == family.raw.name && + induct.levelParams.length == row.source.uvars && + induct.numParams == row.source.nparams && + induct.numIndices == family.view.indices.length && + induct.all == row.source.types.map (·.name) && + induct.ctors == family.raw.ctors.map (·.name) && + induct.numNested == 0 && + induct.isRec == row.generation.isRec && + induct.isReflexive == row.generation.isReflexive && + !induct.isUnsafe && + familyType == family.raw.type + | _ => false) && + row.ctorsMatch family ctorInfos family.ctorPairs ctorTypes 0 && + row.recursorMatches family offset recInfo recType ruleRhs && + row.familiesMatch families inductInfos ctorInfosTail recInfos + familyTypes ctorTypesTail recTypes ruleRhsTail + (offset + family.ctorPairs.length) + | _, _, _, _, _, _, _, _, _ => false + +/-- Every list must agree position-for-position; no truncated family, +constructor, recursor, or rule inventory can satisfy the comparison. -/ +def agrees (row : MutualKernelBlockRow) : Bool := + row.familiesMatch row.generation.families row.inductInfos row.ctorInfos + row.recInfos row.familyTypes row.ctorTypes row.recTypes row.ruleRhs 0 + +end MutualKernelBlockRow + +/-! ## Executable kernel validation -/ + +def treeKernelInfo : ConstantInfo := kernelInductInfo% Tree +def treeListKernelInfo : ConstantInfo := kernelInductInfo% TreeList +def treeLeafKernelInfo : ConstantInfo := kernelCtorInfo% Tree.leaf +def treeNodeKernelInfo : ConstantInfo := kernelCtorInfo% Tree.node +def treeBranchKernelInfo : ConstantInfo := kernelCtorInfo% Tree.branch +def treeListNilKernelInfo : ConstantInfo := kernelCtorInfo% TreeList.nil +def treeListConsKernelInfo : ConstantInfo := kernelCtorInfo% TreeList.cons +def treeRecKernelInfo : ConstantInfo := kernelRecInfo% Tree.rec +def treeListRecKernelInfo : ConstantInfo := kernelRecInfo% TreeList.rec +def treeRecKernelConstant : VConstant := kernelRecConstant08C% Tree.rec +def treeListRecKernelConstant : VConstant := + kernelRecConstant08C% TreeList.rec +def treeLeafKernelRuleRhs : VExpr := kernelRecRuleRhs% Tree.rec 0 +def treeNodeKernelRuleRhs : VExpr := kernelRecRuleRhs% Tree.rec 1 +def treeBranchKernelRuleRhs : VExpr := kernelRecRuleRhs% Tree.rec 2 +def treeListNilKernelRuleRhs : VExpr := kernelRecRuleRhs% TreeList.rec 0 +def treeListConsKernelRuleRhs : VExpr := kernelRecRuleRhs% TreeList.rec 1 + +example : treeRecKernelConstant = + treeGeneration.recursors[0].toVConstant := rfl +example : treeListRecKernelConstant = + treeGeneration.recursors[1].toVConstant := rfl +example : treeLeafKernelRuleRhs = treeGeneration.generatedRules[0].rhs := rfl +example : treeNodeKernelRuleRhs = treeGeneration.generatedRules[1].rhs := rfl +example : treeBranchKernelRuleRhs = treeGeneration.generatedRules[2].rhs := rfl +example : treeListNilKernelRuleRhs = treeGeneration.generatedRules[3].rhs := rfl +example : treeListConsKernelRuleRhs = treeGeneration.generatedRules[4].rhs := rfl + +def treeKernelType : InductiveType where + name := treeKernelInfo.name + type := treeKernelInfo.type + ctors := [ + ⟨treeLeafKernelInfo.name, treeLeafKernelInfo.type⟩, + ⟨treeNodeKernelInfo.name, treeNodeKernelInfo.type⟩, + ⟨treeBranchKernelInfo.name, treeBranchKernelInfo.type⟩] + +def treeListKernelType : InductiveType where + name := treeListKernelInfo.name + type := treeListKernelInfo.type + ctors := [ + ⟨treeListNilKernelInfo.name, treeListNilKernelInfo.type⟩, + ⟨treeListConsKernelInfo.name, treeListConsKernelInfo.type⟩] + +def treeKernelTypes : List InductiveType := + [treeKernelType, treeListKernelType] + +def treeKernelContext : AddInductive.Context where + env := Kernel.Environment.ofConstants `_mutualTree ({} : ConstMap) + lparams := [`u] + safety := .safe + allowPrimitive := false + +def treeExecutionResult := + AddInductive.buildNormalizationCandidateExecution 1 treeKernelTypes 0 false + treeKernelContext + +theorem treeExecutionResult_isOk : treeExecutionResult.isOk = true := by + native_decide + +def treeProducedExecution : + { execution // treeExecutionResult = .ok execution } := + match h : treeExecutionResult with + | .ok execution => ⟨execution, rfl⟩ + | .error _ => by + have hOk := treeExecutionResult_isOk + rw [h] at hOk + contradiction + +def treeExecution := treeProducedExecution.val + +def treeFamilyValidationResult := + FamilyValidationBlockRun.buildExecution 1 treeKernelTypes treeKernelContext + +theorem treeFamilyValidationResult_isOk : + treeFamilyValidationResult.isOk = true := by + native_decide + +def treeProducedFamilyValidation : + { run // treeFamilyValidationResult = .ok run } := + match h : treeFamilyValidationResult with + | .ok run => ⟨run, rfl⟩ + | .error _ => by + have hOk := treeFamilyValidationResult_isOk + rw [h] at hOk + contradiction + +def treeFamilyValidation := treeProducedFamilyValidation.val + +def treeConstructorContext : AddInductive.Context := + { treeExecution.validationContext with env := treeExecution.familyEnv } + +def treeConstructorValidationResult := + ConstructorBlockValidationRun.buildExecution treeKernelTypes + treeExecution.stats false treeConstructorContext + +theorem treeConstructorValidationResult_isOk : + treeConstructorValidationResult.isOk = true := by + native_decide + +def treeProducedConstructorValidation : + { run // treeConstructorValidationResult = .ok run } := + match h : treeConstructorValidationResult with + | .ok run => ⟨run, rfl⟩ + | .error _ => by + have hOk := treeConstructorValidationResult_isOk + rw [h] at hOk + contradiction + +def treeConstructorValidation := treeProducedConstructorValidation.val + +/-- The real positivity traversal selects both sibling targets and records the +one Pi binder above `Tree.branch`'s recursive occurrence. -/ +theorem treeConstructorTargets_exact : + treeConstructorValidation.traces.targets = + [ + [[none], + [some { familyIdx := 1, binderDepth := 0 }], + [some { familyIdx := 1, binderDepth := 1 }]], + [[], + [some { familyIdx := 0, binderDepth := 0 }, + some { familyIdx := 1, binderDepth := 0 }]] + ] := by + native_decide + +example : treeFamilyValidation.parameters.size = 1 := + treeFamilyValidation.params_size + +example : treeFamilyValidation.result.stats.nindices = #[0, 0] := by + native_decide + +#guard AddInductive.levelStructEq treeFamilyValidation.resultLevel + (.succ (.param `u)) + +#guard AddInductive.levelStructEq treeExecution.stats.resultLevel + (.succ (.param `u)) + +def indexedTreeKernelInfo : ConstantInfo := kernelInductInfo% IndexedTree +def indexedTreeListKernelInfo : ConstantInfo := + kernelInductInfo% IndexedTreeList +def indexedTreeLeafKernelInfo : ConstantInfo := + kernelCtorInfo% IndexedTree.leaf +def indexedTreeNodeKernelInfo : ConstantInfo := + kernelCtorInfo% IndexedTree.node +def indexedTreeListNilKernelInfo : ConstantInfo := + kernelCtorInfo% IndexedTreeList.nil +def indexedTreeListConsKernelInfo : ConstantInfo := + kernelCtorInfo% IndexedTreeList.cons +def indexedTreeRecKernelInfo : ConstantInfo := + kernelRecInfo% IndexedTree.rec +def indexedTreeListRecKernelInfo : ConstantInfo := + kernelRecInfo% IndexedTreeList.rec +def indexedTreeRecKernelConstant : VConstant := + kernelRecConstant08C% IndexedTree.rec +def indexedTreeListRecKernelConstant : VConstant := + kernelRecConstant08C% IndexedTreeList.rec +def indexedTreeLeafKernelRuleRhs : VExpr := + kernelRecRuleRhs% IndexedTree.rec 0 +def indexedTreeNodeKernelRuleRhs : VExpr := + kernelRecRuleRhs% IndexedTree.rec 1 +def indexedTreeListNilKernelRuleRhs : VExpr := + kernelRecRuleRhs% IndexedTreeList.rec 0 +def indexedTreeListConsKernelRuleRhs : VExpr := + kernelRecRuleRhs% IndexedTreeList.rec 1 + +example : indexedTreeRecKernelConstant = + indexedTreeGeneration.recursors[0].toVConstant := rfl +example : indexedTreeListRecKernelConstant = + indexedTreeGeneration.recursors[1].toVConstant := rfl +example : indexedTreeLeafKernelRuleRhs = + indexedTreeGeneration.generatedRules[0].rhs := rfl +example : indexedTreeNodeKernelRuleRhs = + indexedTreeGeneration.generatedRules[1].rhs := rfl +example : indexedTreeListNilKernelRuleRhs = + indexedTreeGeneration.generatedRules[2].rhs := rfl +example : indexedTreeListConsKernelRuleRhs = + indexedTreeGeneration.generatedRules[3].rhs := rfl + +/-- Complete kernel/Theory metadata row for the unindexed mutual block. -/ +def treeKernelBlockRow : MutualKernelBlockRow where + source := treeDecl + generation := treeGeneration + inductInfos := [treeKernelInfo, treeListKernelInfo] + ctorInfos := [ + [treeLeafKernelInfo, treeNodeKernelInfo, treeBranchKernelInfo], + [treeListNilKernelInfo, treeListConsKernelInfo]] + recInfos := [treeRecKernelInfo, treeListRecKernelInfo] + familyTypes := [kernelConstVType08C% Tree, + kernelConstVType08C% TreeList] + ctorTypes := [ + [kernelConstVType08C% Tree.leaf, kernelConstVType08C% Tree.node, + kernelConstVType08C% Tree.branch], + [kernelConstVType08C% TreeList.nil, + kernelConstVType08C% TreeList.cons]] + recTypes := [kernelConstVType08C% Tree.rec, + kernelConstVType08C% TreeList.rec] + ruleRhs := [ + [treeLeafKernelRuleRhs, treeNodeKernelRuleRhs, + treeBranchKernelRuleRhs], + [treeListNilKernelRuleRhs, treeListConsKernelRuleRhs]] + +#guard treeKernelBlockRow.agrees + +/-- Complete kernel/Theory metadata row for the indexed mutual block. -/ +def indexedTreeKernelBlockRow : MutualKernelBlockRow where + source := indexedTreeDecl + generation := indexedTreeGeneration + inductInfos := [indexedTreeKernelInfo, indexedTreeListKernelInfo] + ctorInfos := [ + [indexedTreeLeafKernelInfo, indexedTreeNodeKernelInfo], + [indexedTreeListNilKernelInfo, indexedTreeListConsKernelInfo]] + recInfos := [indexedTreeRecKernelInfo, indexedTreeListRecKernelInfo] + familyTypes := [kernelConstVType08C% IndexedTree, + kernelConstVType08C% IndexedTreeList] + ctorTypes := [ + [kernelConstVType08C% IndexedTree.leaf, + kernelConstVType08C% IndexedTree.node], + [kernelConstVType08C% IndexedTreeList.nil, + kernelConstVType08C% IndexedTreeList.cons]] + recTypes := [kernelConstVType08C% IndexedTree.rec, + kernelConstVType08C% IndexedTreeList.rec] + ruleRhs := [ + [indexedTreeLeafKernelRuleRhs, indexedTreeNodeKernelRuleRhs], + [indexedTreeListNilKernelRuleRhs, indexedTreeListConsKernelRuleRhs]] + +#guard indexedTreeKernelBlockRow.agrees + +def indexedTreeKernelType : InductiveType where + name := indexedTreeKernelInfo.name + type := indexedTreeKernelInfo.type + ctors := [ + ⟨indexedTreeLeafKernelInfo.name, indexedTreeLeafKernelInfo.type⟩, + ⟨indexedTreeNodeKernelInfo.name, indexedTreeNodeKernelInfo.type⟩] + +def indexedTreeListKernelType : InductiveType where + name := indexedTreeListKernelInfo.name + type := indexedTreeListKernelInfo.type + ctors := [ + ⟨indexedTreeListNilKernelInfo.name, indexedTreeListNilKernelInfo.type⟩, + ⟨indexedTreeListConsKernelInfo.name, indexedTreeListConsKernelInfo.type⟩] + +def indexedTreeKernelTypes : List InductiveType := + [indexedTreeKernelType, indexedTreeListKernelType] + +def indexedTreeKernelContext : AddInductive.Context where + env := Kernel.Environment.ofConstants `_mutualIndexedTree natMap + lparams := [`u] + safety := .safe + allowPrimitive := false + +def indexedTreeExecutionResult := + AddInductive.buildNormalizationCandidateExecution 1 indexedTreeKernelTypes + 0 false indexedTreeKernelContext + +theorem indexedTreeExecutionResult_isOk : + indexedTreeExecutionResult.isOk = true := by + native_decide + +def indexedTreeProducedExecution : + { execution // indexedTreeExecutionResult = .ok execution } := + match h : indexedTreeExecutionResult with + | .ok execution => ⟨execution, rfl⟩ + | .error _ => by + have hOk := indexedTreeExecutionResult_isOk + rw [h] at hOk + contradiction + +def indexedTreeExecution := indexedTreeProducedExecution.val + +def indexedTreeFamilyValidationResult := + FamilyValidationBlockRun.buildExecution 1 indexedTreeKernelTypes + indexedTreeKernelContext + +theorem indexedTreeFamilyValidationResult_isOk : + indexedTreeFamilyValidationResult.isOk = true := by + native_decide + +def indexedTreeProducedFamilyValidation : + { run // indexedTreeFamilyValidationResult = .ok run } := + match h : indexedTreeFamilyValidationResult with + | .ok run => ⟨run, rfl⟩ + | .error _ => by + have hOk := indexedTreeFamilyValidationResult_isOk + rw [h] at hOk + contradiction + +def indexedTreeFamilyValidation := indexedTreeProducedFamilyValidation.val + +def indexedTreeConstructorContext : AddInductive.Context := + { indexedTreeExecution.validationContext with + env := indexedTreeExecution.familyEnv } + +def indexedTreeConstructorValidationResult := + ConstructorBlockValidationRun.buildExecution indexedTreeKernelTypes + indexedTreeExecution.stats false indexedTreeConstructorContext + +theorem indexedTreeConstructorValidationResult_isOk : + indexedTreeConstructorValidationResult.isOk = true := by + native_decide + +def indexedTreeProducedConstructorValidation : + { run // indexedTreeConstructorValidationResult = .ok run } := + match h : indexedTreeConstructorValidationResult with + | .ok run => ⟨run, rfl⟩ + | .error _ => by + have hOk := indexedTreeConstructorValidationResult_isOk + rw [h] at hOk + contradiction + +def indexedTreeConstructorValidation := + indexedTreeProducedConstructorValidation.val + +/-- Indexed recursive fields retain sibling ordinals after the ordinary Nat +binder, while nonrecursive fields occupy explicit `none` slots. -/ +theorem indexedTreeConstructorTargets_exact : + indexedTreeConstructorValidation.traces.targets = + [ + [[none], + [none, some { familyIdx := 1, binderDepth := 0 }]], + [[], + [none, + some { familyIdx := 0, binderDepth := 0 }, + some { familyIdx := 1, binderDepth := 0 }]] + ] := by + native_decide + +example : indexedTreeFamilyValidation.parameters.size = 1 := + indexedTreeFamilyValidation.params_size + +example : indexedTreeFamilyValidation.result.stats.nindices = #[1, 1] := by + native_decide + +#guard AddInductive.levelStructEq indexedTreeFamilyValidation.resultLevel + (.succ (.param `u)) + +/-! ## Phase-specific failures -/ + +def treeParameterMismatchType : InductiveType := + { treeListKernelType with + type := .forallE `α (.sort .zero) (.sort (.succ (.param `u))) .default } + +#guard match observeFamilyValidationBlock 1 + [treeKernelType, treeParameterMismatchType] treeKernelContext with + | .error (.other message) => + message == "parameters of all inductive datatypes must match" + | _ => false + +def treeResultUniverseMismatchType : InductiveType := + { treeListKernelType with + type := .forallE `α (.sort (.succ (.param `u))) (.sort .zero) .default } + +#guard match observeFamilyValidationBlock 1 + [treeKernelType, treeResultUniverseMismatchType] treeKernelContext with + | .error (.other message) => + message == "mutually inductive types must live in the same universe" + | _ => false + +/-- Reusing the original family statistics after swapping source owners +reaches constructor validation and fails at the first now-misowned return. -/ +def treeReorderedConstructorResult := + checkConstructors #[treeListKernelType, treeKernelType] + treeExecution.stats false treeConstructorContext + +#guard match treeReorderedConstructorResult with + | .error (.other message) => + message == + "invalid return type for 'Lean4Lean.MutualInductiveFixtures.TreeList.nil'" + | _ => false + +def treeReorderedView : VInductDecl := + { treeDecl with types := [treeListType, treeType] } + +/- Raw/view normalization rejects family reordering before semantic evidence +can be attached to the dependent candidate list. -/ +#guard (normalization? treeDecl treeReorderedView).isNone + +/-! The host elaborator diagnostics independently pin the corresponding +family-validation phases in Lean itself. -/ + +namespace KernelPhases + +universe v + +/-- +error: Invalid mutually inductive types: Parameter `α` has type + Prop +of sort `Type` but is expected to have type + Type v +of sort `Type (v + 1)` +-/ +#guard_msgs in +mutual +inductive ParamA (α : Type v) : Type v +inductive ParamB (α : Prop) : Type v +end + +/-- +error: Invalid mutually inductive types: The resulting type of this declaration + Prop +differs from a preceding one + Type v + +Note: All inductive types declared in the same `mutual` block must belong to the same type universe +-/ +#guard_msgs in +mutual +inductive UniverseA (α : Type v) : Type v +inductive UniverseB (α : Type v) : Prop +end + +end KernelPhases + +/-! ## Tree/TreeList Theory semantics -/ + +def treeBlockEnv : VEnv := + (VEnv.empty.stageInductiveTypes treeDecl.types).get! + +theorem treeStage : + VEnv.empty.stageInductiveTypes treeDecl.types = some treeBlockEnv := by + rfl + +theorem treeFamilyTypeWF (type : VInductiveType) + (h : type = treeType ∨ type = treeListType) : + type.type.WF VEnv.empty type.uvars [] := by + rcases h with rfl | rfl <;> + refine ⟨.sort (.imax (.succ (.succ (.param 0))) + (.succ (.succ (.param 0)))), VEnv.HasType.forallE ?_ ?_⟩ <;> + exact VEnv.HasType.sort (by decide) + +theorem treeCtorWF (ctor : VConstVal) + (h : ctor ∈ treeType.ctors ∨ ctor ∈ treeListType.ctors) : + ctor.type.WF treeBlockEnv 1 [] := by + have hTree : treeBlockEnv.constants ``Tree = + some treeType.toVConstant := by rfl + have hTreeList : treeBlockEnv.constants ``TreeList = + some treeListType.toVConstant := by rfl + rcases h with h | h + · simp [treeType] at h + rcases h with (rfl | rfl | rfl) + · exact ⟨_, by type_tac⟩ + · exact ⟨_, by type_tac⟩ + · exact ⟨_, by type_tac⟩ + · simp [treeListType] at h + rcases h with (rfl | rfl) + · exact ⟨_, by type_tac⟩ + · exact ⟨_, by type_tac⟩ + +theorem treeNormalizationBlockWF : + (Normalization.identity treeDecl).BlockWF VEnv.empty treeBlockEnv := by + refine ⟨treeStage, ?_⟩ + change List.Forall₂ _ [treeType, treeListType] [treeType, treeListType] + apply List.Forall₂.cons + · refine ⟨?_, ?_⟩ + · exact VEnv.IsDefEqU.refl (treeFamilyTypeWF treeType (.inl rfl)) + · apply List.Forall₂.rfl + intro ctor h + exact VEnv.IsDefEqU.refl (treeCtorWF ctor (.inl h)) + · apply List.Forall₂.cons + · refine ⟨?_, ?_⟩ + · exact VEnv.IsDefEqU.refl (treeFamilyTypeWF treeListType (.inr rfl)) + · apply List.Forall₂.rfl + intro ctor h + exact VEnv.IsDefEqU.refl (treeCtorWF ctor (.inr h)) + · exact .nil + +theorem treeLeafSemantic : + let constructor := CheckedCtor.ofBlock treeDecl treeType.ctors[0] + checkedBlockFieldsWF VEnv.empty 1 (.succ (.param 0)) [[], []] + constructor.fields constructor.recursiveAt + [.sort (.succ (.param 0))] 0 ∧ + VEnv.empty.SpineWF 1 + (constructor.fields.reverse ++ [.sort (.succ (.param 0))]) + (VExpr.forallN (VExpr.liftTelN constructor.fields.length [] 0) + (.sort (.succ (.param 0)))) + constructor.resultIndices (.sort (.succ (.param 0))) := by + dsimp only + rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[0]).fields = + [.bvar 0] by rfl] + rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[0]).recursiveAt = + [none] by rfl] + rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[0]).resultIndices = + [] by rfl] + exact ⟨⟨⟨.succ (.param 0), .bvar .zero, + .inr (VLevel.le_refl _)⟩, trivial⟩, rfl⟩ + +theorem treeNodeSemantic : + let constructor := CheckedCtor.ofBlock treeDecl treeType.ctors[1] + checkedBlockFieldsWF VEnv.empty 1 (.succ (.param 0)) [[], []] + constructor.fields constructor.recursiveAt + [.sort (.succ (.param 0))] 0 ∧ + VEnv.empty.SpineWF 1 + (constructor.fields.reverse ++ [.sort (.succ (.param 0))]) + (VExpr.forallN (VExpr.liftTelN constructor.fields.length [] 0) + (.sort (.succ (.param 0)))) + constructor.resultIndices (.sort (.succ (.param 0))) := by + dsimp only + rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[1]).fields = + [.app (.const ``TreeList [.param 0]) (.bvar 0)] by rfl] + rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[1]).recursiveAt = + [some ({ + fieldIndex := 0 + binders := [] + targetType := 1 + indices := [] } : RecArg)] by rfl] + rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[1]).resultIndices = + [] by rfl] + exact ⟨⟨⟨rfl, trivial, rfl⟩, trivial⟩, rfl⟩ + +theorem treeBranchSemantic : + let constructor := CheckedCtor.ofBlock treeDecl treeType.ctors[2] + checkedBlockFieldsWF VEnv.empty 1 (.succ (.param 0)) [[], []] + constructor.fields constructor.recursiveAt + [.sort (.succ (.param 0))] 0 ∧ + VEnv.empty.SpineWF 1 + (constructor.fields.reverse ++ [.sort (.succ (.param 0))]) + (VExpr.forallN (VExpr.liftTelN constructor.fields.length [] 0) + (.sort (.succ (.param 0)))) + constructor.resultIndices (.sort (.succ (.param 0))) := by + dsimp only + rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[2]).fields = + [.forallE (.bvar 0) + (.app (.const ``TreeList [.param 0]) (.bvar 1))] by rfl] + rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[2]).recursiveAt = + [some ({ + fieldIndex := 0 + binders := [.bvar 0] + targetType := 1 + indices := [] } : RecArg)] by rfl] + rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[2]).resultIndices = + [] by rfl] + exact ⟨ + ⟨⟨rfl, ⟨⟨⟨.succ (.param 0), .bvar .zero⟩, trivial⟩, rfl⟩⟩, + trivial⟩, + rfl⟩ + +theorem treeListNilSemantic : + let constructor := CheckedCtor.ofBlock treeDecl treeListType.ctors[0] + checkedBlockFieldsWF VEnv.empty 1 (.succ (.param 0)) [[], []] + constructor.fields constructor.recursiveAt + [.sort (.succ (.param 0))] 0 ∧ + VEnv.empty.SpineWF 1 + (constructor.fields.reverse ++ [.sort (.succ (.param 0))]) + (VExpr.forallN (VExpr.liftTelN constructor.fields.length [] 0) + (.sort (.succ (.param 0)))) + constructor.resultIndices (.sort (.succ (.param 0))) := by + dsimp only + rw [show (CheckedCtor.ofBlock treeDecl treeListType.ctors[0]).fields = + [] by rfl] + rw [show (CheckedCtor.ofBlock treeDecl treeListType.ctors[0]).recursiveAt = + [] by rfl] + rw [show (CheckedCtor.ofBlock treeDecl treeListType.ctors[0]).resultIndices = + [] by rfl] + exact ⟨trivial, rfl⟩ + +theorem treeListConsSemantic : + let constructor := CheckedCtor.ofBlock treeDecl treeListType.ctors[1] + checkedBlockFieldsWF VEnv.empty 1 (.succ (.param 0)) [[], []] + constructor.fields constructor.recursiveAt + [.sort (.succ (.param 0))] 0 ∧ + VEnv.empty.SpineWF 1 + (constructor.fields.reverse ++ [.sort (.succ (.param 0))]) + (VExpr.forallN (VExpr.liftTelN constructor.fields.length [] 0) + (.sort (.succ (.param 0)))) + constructor.resultIndices (.sort (.succ (.param 0))) := by + dsimp only + rw [show (CheckedCtor.ofBlock treeDecl treeListType.ctors[1]).fields = + [.app (.const ``Tree [.param 0]) (.bvar 0), + .app (.const ``TreeList [.param 0]) (.bvar 1)] by rfl] + rw [show (CheckedCtor.ofBlock treeDecl treeListType.ctors[1]).recursiveAt = + [some ({ + fieldIndex := 0 + binders := [] + targetType := 0 + indices := [] } : RecArg), + some ({ + fieldIndex := 1 + binders := [] + targetType := 1 + indices := [] } : RecArg)] by rfl] + rw [show (CheckedCtor.ofBlock treeDecl treeListType.ctors[1]).resultIndices = + [] by rfl] + exact ⟨ + ⟨⟨rfl, trivial, rfl⟩, + ⟨⟨rfl, trivial, rfl⟩, trivial⟩⟩, + rfl⟩ + +theorem treeCheckedBlockWF : + treeChecked.WF VEnv.empty (.succ (.param 0)) := by + have hparams : treeChecked.params = + [.sort (.succ (.param 0))] := rfl + have hindices : treeChecked.families.indices = [[], []] := rfl + have hlevels : treeChecked.families.resultLevels = + [.succ (.param 0), .succ (.param 0)] := rfl + have hconstructors : treeChecked.families.constructors = + [treeType.ctors.map (CheckedCtor.ofBlock treeDecl), + treeListType.ctors.map (CheckedCtor.ofBlock treeDecl)] := rfl + rw [CheckedBlock.WF, hindices, hlevels, hconstructors] + rw [hparams] + simp only [checkedFamilyListsWF] + refine ⟨rfl, ?_, ?_, rfl, ?_, ?_⟩ + · exact ⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩ + · intro ctor h + simp [treeType] at h + rcases h with rfl | rfl | rfl + · exact treeLeafSemantic + · exact treeNodeSemantic + · exact treeBranchSemantic + · exact ⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩ + · refine ⟨?_, trivial⟩ + intro ctor h + simp [treeListType] at h + rcases h with rfl | rfl + · exact treeListNilSemantic + · exact treeListConsSemantic + +def treeNormalizedBlock : NormalizedCheckedBlock treeDecl where + normalization := Normalization.identity treeDecl + checked := treeChecked + checked_eq := (Option.some_get (x := treeDecl.checkedBlock?) + (by decide)).symm + +def treeValidatedBlock : ValidatedBlock treeDecl where + block := treeNormalizedBlock + resultLevel := .succ (.param 0) + +/-- Exact validation-only semantic package for the unindexed mutual block. -/ +def treeValidationCertificate : ValidationCertificate treeDecl VEnv.empty where + validated := treeValidatedBlock + blockEnv := treeBlockEnv + wf := ⟨treeNormalizationBlockWF, treeCheckedBlockWF⟩ + +/-! ## IndexedTree/IndexedTreeList Theory semantics -/ + +def indexedTreeBlockEnv : VEnv := + (natFinalEnv.stageInductiveTypes indexedTreeDecl.types).get! + +theorem indexedTreeStage : + natFinalEnv.stageInductiveTypes indexedTreeDecl.types = + some indexedTreeBlockEnv := by + rfl + +theorem indexedTreeFamilyTypeWF (type : VInductiveType) + (h : type = indexedTreeType ∨ type = indexedTreeListType) : + type.type.WF natFinalEnv type.uvars [] := by + have hNat : natFinalEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + rcases h with rfl | rfl <;> + exact ⟨_, by type_tac⟩ + +theorem indexedTreeCtorWF (ctor : VConstVal) + (h : ctor ∈ indexedTreeType.ctors ∨ + ctor ∈ indexedTreeListType.ctors) : + ctor.type.WF indexedTreeBlockEnv 1 [] := by + have hNat : indexedTreeBlockEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := by rfl + have hZero : indexedTreeBlockEnv.constants ``Nat.zero = + some InductiveFixtures.natType.ctors[0].toVConstant := by rfl + have hSucc : indexedTreeBlockEnv.constants ``Nat.succ = + some InductiveFixtures.natType.ctors[1].toVConstant := by rfl + have hTree : indexedTreeBlockEnv.constants ``IndexedTree = + some indexedTreeType.toVConstant := by rfl + have hTreeList : indexedTreeBlockEnv.constants ``IndexedTreeList = + some indexedTreeListType.toVConstant := by rfl + rcases h with h | h + · simp [indexedTreeType] at h + rcases h with (rfl | rfl) + · exact ⟨_, by type_tac⟩ + · exact ⟨_, by type_tac⟩ + · simp [indexedTreeListType] at h + rcases h with (rfl | rfl) + · exact ⟨_, by type_tac⟩ + · exact ⟨_, by type_tac⟩ + +theorem indexedTreeNormalizationBlockWF : + (Normalization.identity indexedTreeDecl).BlockWF + natFinalEnv indexedTreeBlockEnv := by + refine ⟨indexedTreeStage, ?_⟩ + change List.Forall₂ _ [indexedTreeType, indexedTreeListType] + [indexedTreeType, indexedTreeListType] + apply List.Forall₂.cons + · refine ⟨?_, ?_⟩ + · exact VEnv.IsDefEqU.refl + (indexedTreeFamilyTypeWF indexedTreeType (.inl rfl)) + · apply List.Forall₂.rfl + intro ctor h + exact VEnv.IsDefEqU.refl (indexedTreeCtorWF ctor (.inl h)) + · apply List.Forall₂.cons + · refine ⟨?_, ?_⟩ + · exact VEnv.IsDefEqU.refl + (indexedTreeFamilyTypeWF indexedTreeListType (.inr rfl)) + · apply List.Forall₂.rfl + intro ctor h + exact VEnv.IsDefEqU.refl (indexedTreeCtorWF ctor (.inr h)) + · exact .nil + +theorem indexedTreeLeafSemantic : + let constructor := CheckedCtor.ofBlock indexedTreeDecl + indexedTreeType.ctors[0] + checkedBlockFieldsWF natFinalEnv 1 (.succ (.param 0)) + [[.const ``Nat []], [.const ``Nat []]] + constructor.fields constructor.recursiveAt + [.sort (.succ (.param 0))] 0 ∧ + natFinalEnv.SpineWF 1 + (constructor.fields.reverse ++ [.sort (.succ (.param 0))]) + (VExpr.forallN + (VExpr.liftTelN constructor.fields.length [.const ``Nat []] 0) + (.sort (.succ (.param 0)))) + constructor.resultIndices (.sort (.succ (.param 0))) := by + dsimp only + rw [show (CheckedCtor.ofBlock indexedTreeDecl + indexedTreeType.ctors[0]).fields = [.bvar 0] by rfl] + rw [show (CheckedCtor.ofBlock indexedTreeDecl + indexedTreeType.ctors[0]).recursiveAt = [none] by rfl] + rw [show (CheckedCtor.ofBlock indexedTreeDecl + indexedTreeType.ctors[0]).resultIndices = [.const ``Nat.zero []] by rfl] + constructor + · exact ⟨⟨.succ (.param 0), .bvar .zero, + .inr (VLevel.le_refl _)⟩, trivial⟩ + · have hNat : natFinalEnv.constants ``Nat = + 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⟩ + +theorem indexedTreeNodeSemantic : + let constructor := CheckedCtor.ofBlock indexedTreeDecl + indexedTreeType.ctors[1] + checkedBlockFieldsWF natFinalEnv 1 (.succ (.param 0)) + [[.const ``Nat []], [.const ``Nat []]] + constructor.fields constructor.recursiveAt + [.sort (.succ (.param 0))] 0 ∧ + natFinalEnv.SpineWF 1 + (constructor.fields.reverse ++ [.sort (.succ (.param 0))]) + (VExpr.forallN + (VExpr.liftTelN constructor.fields.length [.const ``Nat []] 0) + (.sort (.succ (.param 0)))) + constructor.resultIndices (.sort (.succ (.param 0))) := by + dsimp only + rw [show (CheckedCtor.ofBlock indexedTreeDecl + indexedTreeType.ctors[1]).fields = + [.const ``Nat [], + (VExpr.const ``IndexedTreeList [.param 0]).app (.bvar 1) + |>.app (.bvar 0)] by rfl] + rw [show (CheckedCtor.ofBlock indexedTreeDecl + indexedTreeType.ctors[1]).recursiveAt = + [none, some ({ + fieldIndex := 1 + binders := [] + targetType := 1 + indices := [.bvar 0] } : RecArg)] by rfl] + rw [show (CheckedCtor.ofBlock indexedTreeDecl + indexedTreeType.ctors[1]).resultIndices = + [(VExpr.const ``Nat.succ []).app (.bvar 1)] by rfl] + have hNat : natFinalEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + have hSucc : natFinalEnv.constants ``Nat.succ = + some InductiveFixtures.natType.ctors[1].toVConstant := rfl + 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⟩ + +theorem indexedTreeListNilSemantic : + let constructor := CheckedCtor.ofBlock indexedTreeDecl + indexedTreeListType.ctors[0] + checkedBlockFieldsWF natFinalEnv 1 (.succ (.param 0)) + [[.const ``Nat []], [.const ``Nat []]] + constructor.fields constructor.recursiveAt + [.sort (.succ (.param 0))] 0 ∧ + natFinalEnv.SpineWF 1 + (constructor.fields.reverse ++ [.sort (.succ (.param 0))]) + (VExpr.forallN + (VExpr.liftTelN constructor.fields.length [.const ``Nat []] 0) + (.sort (.succ (.param 0)))) + constructor.resultIndices (.sort (.succ (.param 0))) := by + dsimp only + rw [show (CheckedCtor.ofBlock indexedTreeDecl + indexedTreeListType.ctors[0]).fields = [] by rfl] + rw [show (CheckedCtor.ofBlock indexedTreeDecl + indexedTreeListType.ctors[0]).recursiveAt = [] by rfl] + rw [show (CheckedCtor.ofBlock indexedTreeDecl + indexedTreeListType.ctors[0]).resultIndices = + [.const ``Nat.zero []] by rfl] + refine ⟨trivial, ?_⟩ + have hNat : natFinalEnv.constants ``Nat = + 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⟩ + +theorem indexedTreeListConsSemantic : + let constructor := CheckedCtor.ofBlock indexedTreeDecl + indexedTreeListType.ctors[1] + checkedBlockFieldsWF natFinalEnv 1 (.succ (.param 0)) + [[.const ``Nat []], [.const ``Nat []]] + constructor.fields constructor.recursiveAt + [.sort (.succ (.param 0))] 0 ∧ + natFinalEnv.SpineWF 1 + (constructor.fields.reverse ++ [.sort (.succ (.param 0))]) + (VExpr.forallN + (VExpr.liftTelN constructor.fields.length [.const ``Nat []] 0) + (.sort (.succ (.param 0)))) + constructor.resultIndices (.sort (.succ (.param 0))) := by + dsimp only + rw [show (CheckedCtor.ofBlock indexedTreeDecl + indexedTreeListType.ctors[1]).fields = + [.const ``Nat [], + (VExpr.const ``IndexedTree [.param 0]).app (.bvar 1) + |>.app (.bvar 0), + (VExpr.const ``IndexedTreeList [.param 0]).app (.bvar 2) + |>.app (.bvar 1)] by rfl] + rw [show (CheckedCtor.ofBlock indexedTreeDecl + indexedTreeListType.ctors[1]).recursiveAt = + [none, + some ({ + fieldIndex := 1 + binders := [] + targetType := 0 + indices := [.bvar 0] } : RecArg), + some ({ + fieldIndex := 2 + binders := [] + targetType := 1 + indices := [.bvar 1] } : RecArg)] by rfl] + rw [show (CheckedCtor.ofBlock indexedTreeDecl + indexedTreeListType.ctors[1]).resultIndices = + [(VExpr.const ``Nat.succ []).app (.bvar 2)] by rfl] + have hNat : natFinalEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + have hSucc : natFinalEnv.constants ``Nat.succ = + some InductiveFixtures.natType.ctors[1].toVConstant := rfl + 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⟩ + +theorem indexedTreeCheckedBlockWF : + indexedTreeChecked.WF natFinalEnv (.succ (.param 0)) := by + have hparams : indexedTreeChecked.params = + [.sort (.succ (.param 0))] := rfl + have hindices : indexedTreeChecked.families.indices = + [[.const ``Nat []], [.const ``Nat []]] := rfl + have hlevels : indexedTreeChecked.families.resultLevels = + [.succ (.param 0), .succ (.param 0)] := rfl + have hconstructors : indexedTreeChecked.families.constructors = + [indexedTreeType.ctors.map (CheckedCtor.ofBlock indexedTreeDecl), + indexedTreeListType.ctors.map + (CheckedCtor.ofBlock indexedTreeDecl)] := rfl + rw [CheckedBlock.WF, hindices, hlevels, hconstructors] + rw [hparams] + simp only [checkedFamilyListsWF] + have hNat : natFinalEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + refine ⟨rfl, ?_, ?_, rfl, ?_, ?_⟩ + · exact ⟨⟨_, VEnv.HasType.sort (by decide)⟩, + ⟨⟨_, (by type_tac)⟩, trivial⟩⟩ + · intro ctor h + simp [indexedTreeType] at h + rcases h with rfl | rfl + · exact indexedTreeLeafSemantic + · exact indexedTreeNodeSemantic + · exact ⟨⟨_, VEnv.HasType.sort (by decide)⟩, + ⟨⟨_, (by type_tac)⟩, trivial⟩⟩ + · refine ⟨?_, trivial⟩ + intro ctor h + simp [indexedTreeListType] at h + rcases h with rfl | rfl + · exact indexedTreeListNilSemantic + · exact indexedTreeListConsSemantic + +def indexedTreeNormalizedBlock : NormalizedCheckedBlock indexedTreeDecl where + normalization := Normalization.identity indexedTreeDecl + checked := indexedTreeChecked + checked_eq := (Option.some_get (x := indexedTreeDecl.checkedBlock?) + (by decide)).symm + +def indexedTreeValidatedBlock : ValidatedBlock indexedTreeDecl where + block := indexedTreeNormalizedBlock + resultLevel := .succ (.param 0) + +/-- Exact validation-only semantic package for the indexed mutual block. -/ +def indexedTreeValidationCertificate : + ValidationCertificate indexedTreeDecl natFinalEnv where + validated := indexedTreeValidatedBlock + blockEnv := indexedTreeBlockEnv + wf := ⟨indexedTreeNormalizationBlockWF, indexedTreeCheckedBlockWF⟩ + +/-! ## Certified block-generation semantics -/ + +theorem treeLeafGenerationWF : + NormalizedBlockCtor.WF treeGeneration treeGeneration.flatCtors[0] + treeBlockEnv := by + refine { + declaredTel := ?_ + declaredResult := ?_ + emittedTel := ?_ + emittedResult := ?_ + owner := ?_ + recursive := ?_ + resultSpine := ?_ } + · change treeBlockEnv.TelDefEq 1 [] + [.sort (.succ (.param 0)), .bvar 0] + [.sort (.succ (.param 0)), .bvar 0] + exact (show treeBlockEnv.OnTel 1 [] + [.sort (.succ (.param 0)), .bvar 0] from by + refine ⟨⟨_, VEnv.HasType.sort (by decide)⟩, ?_⟩ + exact ⟨⟨_, by type_tac⟩, trivial⟩).telDefEq_refl + · change treeBlockEnv.IsDefEq 1 + [.bvar 0, .sort (.succ (.param 0))] + (.app (.const ``Tree [.param 0]) (.bvar 1)) + (.app (.const ``Tree [.param 0]) (.bvar 1)) + (.sort (.succ (.param 0))) + have hTree : treeBlockEnv.constants ``Tree = + some treeType.toVConstant := rfl + apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .sort (.succ (.param 0))) + · exact VEnv.HasType.const hTree (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ .zero) + · change treeBlockEnv.TelDefEq 1 [] + [.sort (.succ (.param 0)), .bvar 0] + [.sort (.succ (.param 0)), .bvar 0] + exact (show treeBlockEnv.OnTel 1 [] + [.sort (.succ (.param 0)), .bvar 0] from by + refine ⟨⟨_, VEnv.HasType.sort (by decide)⟩, ?_⟩ + exact ⟨⟨_, by type_tac⟩, trivial⟩).telDefEq_refl + · change treeBlockEnv.IsDefEq 1 + [.bvar 0, .sort (.succ (.param 0))] + (.app (.const ``Tree [.param 0]) (.bvar 1)) + (.app (.const ``Tree [.param 0]) (.bvar 1)) + (.sort (.succ (.param 0))) + have hTree : treeBlockEnv.constants ``Tree = + some treeType.toVConstant := rfl + apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .sort (.succ (.param 0))) + · exact VEnv.HasType.const hTree (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ .zero) + · refine ⟨treeGeneration.families[0], ?_, rfl, rfl, rfl⟩ + exact .head _ + · intro recursive hrecursive + change recursive ∈ [] at hrecursive + nomatch hrecursive + · exact treeLeafSemantic.2 + +theorem treeNodeGenerationWF : + NormalizedBlockCtor.WF treeGeneration treeGeneration.flatCtors[1] + treeBlockEnv := by + have hTree : treeBlockEnv.constants ``Tree = + some treeType.toVConstant := rfl + have hTreeList : treeBlockEnv.constants ``TreeList = + some treeListType.toVConstant := rfl + have hbinders : treeBlockEnv.OnTel 1 [] + [.sort (.succ (.param 0)), + .app (.const ``TreeList [.param 0]) (.bvar 0)] := by + refine ⟨⟨_, VEnv.HasType.sort (by decide)⟩, ?_⟩ + refine ⟨⟨.succ (.param 0), ?_⟩, trivial⟩ + apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .sort (.succ (.param 0))) + · exact VEnv.HasType.const hTreeList (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar .zero + have hresult : treeBlockEnv.HasType 1 + [.app (.const ``TreeList [.param 0]) (.bvar 0), + .sort (.succ (.param 0))] + (.app (.const ``Tree [.param 0]) (.bvar 1)) + (.sort (.succ (.param 0))) := by + apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .sort (.succ (.param 0))) + · exact VEnv.HasType.const hTree (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ .zero) + refine { + declaredTel := ?_ + declaredResult := ?_ + emittedTel := ?_ + emittedResult := ?_ + owner := ?_ + recursive := ?_ + resultSpine := ?_ } + · exact hbinders.telDefEq_refl + · exact hresult + · exact hbinders.telDefEq_refl + · exact hresult + · refine ⟨treeGeneration.families[0], ?_, rfl, rfl, rfl⟩ + exact .head _ + · intro recursive hrecursive + change recursive ∈ [{ + fieldIndex := 0 + binders := [] + targetType := 1 + indices := [] }] at hrecursive + simp only [List.mem_cons, List.not_mem_nil, or_false] at hrecursive + subst recursive + refine ⟨treeGeneration.families[1], ?_, rfl, ?_, ?_⟩ + · exact .tail _ (.head _) + · exact ⟨.app (.const ``TreeList [.param 0]) (.bvar 0), rfl, rfl⟩ + · exact ⟨trivial, rfl⟩ + · exact treeNodeSemantic.2 + +theorem treeBranchGenerationWF : + NormalizedBlockCtor.WF treeGeneration treeGeneration.flatCtors[2] + treeBlockEnv := by + have hTree : treeBlockEnv.constants ``Tree = + some treeType.toVConstant := rfl + have hTreeList : treeBlockEnv.constants ``TreeList = + some treeListType.toVConstant := rfl + have hbinders : treeBlockEnv.OnTel 1 [] + [.sort (.succ (.param 0)), + .forallE (.bvar 0) + (.app (.const ``TreeList [.param 0]) (.bvar 1))] := by + refine ⟨⟨_, VEnv.HasType.sort (by decide)⟩, ?_⟩ + refine ⟨⟨.imax (.succ (.param 0)) (.succ (.param 0)), ?_⟩, + trivial⟩ + apply VEnv.HasType.forallE + · exact VEnv.HasType.bvar .zero + · apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .sort (.succ (.param 0))) + · exact VEnv.HasType.const hTreeList (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ .zero) + have hresult : treeBlockEnv.HasType 1 + [.forallE (.bvar 0) + (.app (.const ``TreeList [.param 0]) (.bvar 1)), + .sort (.succ (.param 0))] + (.app (.const ``Tree [.param 0]) (.bvar 1)) + (.sort (.succ (.param 0))) := by + apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .sort (.succ (.param 0))) + · exact VEnv.HasType.const hTree (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ .zero) + refine { + declaredTel := hbinders.telDefEq_refl + declaredResult := hresult + emittedTel := hbinders.telDefEq_refl + emittedResult := hresult + owner := ?_ + recursive := ?_ + resultSpine := treeBranchSemantic.2 } + · refine ⟨treeGeneration.families[0], ?_, rfl, rfl, rfl⟩ + exact .head _ + · intro recursive hrecursive + change recursive ∈ [{ + fieldIndex := 0 + binders := [.bvar 0] + targetType := 1 + indices := [] }] at hrecursive + simp only [List.mem_cons, List.not_mem_nil, or_false] at hrecursive + subst recursive + refine ⟨treeGeneration.families[1], ?_, rfl, ?_, ?_⟩ + · exact .tail _ (.head _) + · exact ⟨.forallE (.bvar 0) + (.app (.const ``TreeList [.param 0]) (.bvar 1)), rfl, rfl⟩ + · exact ⟨⟨⟨_, VEnv.HasType.bvar .zero⟩, trivial⟩, rfl⟩ + +theorem treeListNilGenerationWF : + NormalizedBlockCtor.WF treeGeneration treeGeneration.flatCtors[3] + treeBlockEnv := by + have hTreeList : treeBlockEnv.constants ``TreeList = + some treeListType.toVConstant := rfl + have hbinders : treeBlockEnv.OnTel 1 [] + [.sort (.succ (.param 0))] := + ⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩ + have hresult : treeBlockEnv.HasType 1 + [.sort (.succ (.param 0))] + (.app (.const ``TreeList [.param 0]) (.bvar 0)) + (.sort (.succ (.param 0))) := by + apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .sort (.succ (.param 0))) + · exact VEnv.HasType.const hTreeList (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar .zero + refine { + declaredTel := hbinders.telDefEq_refl + declaredResult := hresult + emittedTel := hbinders.telDefEq_refl + emittedResult := hresult + owner := ?_ + recursive := ?_ + resultSpine := treeListNilSemantic.2 } + · refine ⟨treeGeneration.families[1], ?_, rfl, rfl, rfl⟩ + exact .tail _ (.head _) + · intro recursive hrecursive + change recursive ∈ [] at hrecursive + nomatch hrecursive + +theorem treeListConsGenerationWF : + NormalizedBlockCtor.WF treeGeneration treeGeneration.flatCtors[4] + treeBlockEnv := by + have hTree : treeBlockEnv.constants ``Tree = + some treeType.toVConstant := rfl + have hTreeList : treeBlockEnv.constants ``TreeList = + some treeListType.toVConstant := rfl + have hbinders : treeBlockEnv.OnTel 1 [] + [.sort (.succ (.param 0)), + .app (.const ``Tree [.param 0]) (.bvar 0), + .app (.const ``TreeList [.param 0]) (.bvar 1)] := by + refine ⟨⟨_, VEnv.HasType.sort (by decide)⟩, ?_⟩ + refine ⟨⟨.succ (.param 0), ?_⟩, ?_⟩ + · apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .sort (.succ (.param 0))) + · exact VEnv.HasType.const hTree (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar .zero + · refine ⟨⟨.succ (.param 0), ?_⟩, trivial⟩ + apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .sort (.succ (.param 0))) + · exact VEnv.HasType.const hTreeList (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ .zero) + have hresult : treeBlockEnv.HasType 1 + [.app (.const ``TreeList [.param 0]) (.bvar 1), + .app (.const ``Tree [.param 0]) (.bvar 0), + .sort (.succ (.param 0))] + (.app (.const ``TreeList [.param 0]) (.bvar 2)) + (.sort (.succ (.param 0))) := by + apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .sort (.succ (.param 0))) + · exact VEnv.HasType.const hTreeList (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ (.succ .zero)) + refine { + declaredTel := hbinders.telDefEq_refl + declaredResult := hresult + emittedTel := hbinders.telDefEq_refl + emittedResult := hresult + owner := ?_ + recursive := ?_ + resultSpine := treeListConsSemantic.2 } + · refine ⟨treeGeneration.families[1], ?_, rfl, rfl, rfl⟩ + exact .tail _ (.head _) + · intro recursive hrecursive + change recursive ∈ [{ + fieldIndex := 0 + binders := [] + targetType := 0 + indices := [] }, { + fieldIndex := 1 + binders := [] + targetType := 1 + indices := [] }] at hrecursive + simp only [List.mem_cons, List.not_mem_nil, or_false] at hrecursive + rcases hrecursive with rfl | rfl + · refine ⟨treeGeneration.families[0], ?_, rfl, ?_, ?_⟩ + · exact .head _ + · exact ⟨.app (.const ``Tree [.param 0]) (.bvar 0), rfl, rfl⟩ + · exact ⟨trivial, rfl⟩ + · refine ⟨treeGeneration.families[1], ?_, rfl, ?_, ?_⟩ + · exact .tail _ (.head _) + · exact ⟨.app (.const ``TreeList [.param 0]) (.bvar 1), rfl, rfl⟩ + · exact ⟨trivial, rfl⟩ + +theorem treeBlockGenerationWF : + treeGeneration.WF VEnv.empty treeBlockEnv := by + refine { + blockWF := treeValidationCertificate.wf + resultLevelWF := by decide + paramsTel := ?_ + families := ?_ + constructors := ?_ } + · change VEnv.empty.TelDefEq 1 [] + [.sort (.succ (.param 0))] [.sort (.succ (.param 0))] + exact (show VEnv.empty.OnTel 1 [] + [.sort (.succ (.param 0))] from + ⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩).telDefEq_refl + · intro family hfamily + have hfamilies : treeGeneration.families = + [treeGeneration.families[0], treeGeneration.families[1]] := rfl + rw [hfamilies] at hfamily + simp only [List.mem_cons, List.not_mem_nil, or_false] at hfamily + rcases hfamily with rfl | rfl + · constructor + · change VEnv.empty.TelDefEq 1 [] + [.sort (.succ (.param 0))] [.sort (.succ (.param 0))] + exact (show VEnv.empty.OnTel 1 [] + [.sort (.succ (.param 0))] from + ⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩).telDefEq_refl + · change VEnv.empty.IsDefEq 1 [.sort (.succ (.param 0))] + (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + (.sort (.succ (.succ (.param 0)))) + exact .sortDF (by decide) (by decide) rfl + · constructor + · change VEnv.empty.TelDefEq 1 [] + [.sort (.succ (.param 0))] [.sort (.succ (.param 0))] + exact (show VEnv.empty.OnTel 1 [] + [.sort (.succ (.param 0))] from + ⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩).telDefEq_refl + · change VEnv.empty.IsDefEq 1 [.sort (.succ (.param 0))] + (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + (.sort (.succ (.succ (.param 0)))) + exact .sortDF (by decide) (by decide) rfl + · intro constructor hconstructor + have hconstructors : treeGeneration.flatCtors = + [treeGeneration.flatCtors[0], treeGeneration.flatCtors[1], + treeGeneration.flatCtors[2], treeGeneration.flatCtors[3], + treeGeneration.flatCtors[4]] := rfl + rw [hconstructors] at hconstructor + simp only [List.mem_cons, List.not_mem_nil, or_false] at hconstructor + rcases hconstructor with rfl | rfl | rfl | rfl | rfl + · exact treeLeafGenerationWF + · exact treeNodeGenerationWF + · exact treeBranchGenerationWF + · exact treeListNilGenerationWF + · exact treeListConsGenerationWF + +theorem indexedTreeBlock_le : natFinalEnv ≤ indexedTreeBlockEnv := by + have hfold : indexedTreeDecl.blockTypeConstants.foldlM + (fun env type => env.addConst type.name type.toVConstant) natFinalEnv = + some indexedTreeBlockEnv := by + rw [blockTypeConstants_foldlM_eq_stageInductiveTypes] + exact indexedTreeStage + exact (VInductDecl.ctorFold_spec indexedTreeDecl.blockTypeConstants hfold).1 + +theorem indexedTreeLeafGenerationWF : + NormalizedBlockCtor.WF indexedTreeGeneration + indexedTreeGeneration.flatCtors[0] indexedTreeBlockEnv := by + have hTree : indexedTreeBlockEnv.constants ``IndexedTree = + some indexedTreeType.toVConstant := rfl + have hZero : indexedTreeBlockEnv.constants ``Nat.zero = + some InductiveFixtures.natType.ctors[0].toVConstant := rfl + have hbinders : indexedTreeBlockEnv.OnTel 1 [] + [.sort (.succ (.param 0)), .bvar 0] := by + refine ⟨⟨_, VEnv.HasType.sort (by decide)⟩, ?_⟩ + exact ⟨⟨_, VEnv.HasType.bvar .zero⟩, trivial⟩ + have hresult : indexedTreeBlockEnv.HasType 1 + [.bvar 0, .sort (.succ (.param 0))] + (.app + (.app (.const ``IndexedTree [.param 0]) (.bvar 1)) + (.const ``Nat.zero [])) + (.sort (.succ (.param 0))) := by + apply VEnv.HasType.app + (A := .const ``Nat []) + (B := .sort (.succ (.param 0))) + · apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .forallE (.const ``Nat []) (.sort (.succ (.param 0)))) + · exact VEnv.HasType.const hTree (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ .zero) + · exact VEnv.HasType.const hZero (by simp) rfl + refine { + declaredTel := hbinders.telDefEq_refl + declaredResult := hresult + emittedTel := hbinders.telDefEq_refl + emittedResult := hresult + owner := ?_ + recursive := ?_ + resultSpine := indexedTreeLeafSemantic.2.mono indexedTreeBlock_le } + · refine ⟨indexedTreeGeneration.families[0], ?_, rfl, rfl, rfl⟩ + exact .head _ + · intro recursive hrecursive + change recursive ∈ [] at hrecursive + nomatch hrecursive + +theorem indexedTreeListNilGenerationWF : + NormalizedBlockCtor.WF indexedTreeGeneration + indexedTreeGeneration.flatCtors[2] indexedTreeBlockEnv := by + have hTreeList : indexedTreeBlockEnv.constants ``IndexedTreeList = + some indexedTreeListType.toVConstant := rfl + have hZero : indexedTreeBlockEnv.constants ``Nat.zero = + some InductiveFixtures.natType.ctors[0].toVConstant := rfl + have hbinders : indexedTreeBlockEnv.OnTel 1 [] + [.sort (.succ (.param 0))] := + ⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩ + have hresult : indexedTreeBlockEnv.HasType 1 + [.sort (.succ (.param 0))] + (.app + (.app (.const ``IndexedTreeList [.param 0]) (.bvar 0)) + (.const ``Nat.zero [])) + (.sort (.succ (.param 0))) := by + apply VEnv.HasType.app + (A := .const ``Nat []) + (B := .sort (.succ (.param 0))) + · apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .forallE (.const ``Nat []) (.sort (.succ (.param 0)))) + · exact VEnv.HasType.const hTreeList (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar .zero + · exact VEnv.HasType.const hZero (by simp) rfl + refine { + declaredTel := hbinders.telDefEq_refl + declaredResult := hresult + emittedTel := hbinders.telDefEq_refl + emittedResult := hresult + owner := ?_ + recursive := ?_ + resultSpine := indexedTreeListNilSemantic.2.mono + indexedTreeBlock_le } + · refine ⟨indexedTreeGeneration.families[1], ?_, rfl, rfl, rfl⟩ + exact .tail _ (.head _) + · intro recursive hrecursive + change recursive ∈ [] at hrecursive + nomatch hrecursive + +theorem indexedTreeNodeGenerationWF : + NormalizedBlockCtor.WF indexedTreeGeneration + indexedTreeGeneration.flatCtors[1] indexedTreeBlockEnv := by + have hNat : indexedTreeBlockEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + have hSucc : indexedTreeBlockEnv.constants ``Nat.succ = + some InductiveFixtures.natType.ctors[1].toVConstant := rfl + have hTree : indexedTreeBlockEnv.constants ``IndexedTree = + some indexedTreeType.toVConstant := rfl + have hTreeList : indexedTreeBlockEnv.constants ``IndexedTreeList = + some indexedTreeListType.toVConstant := rfl + have hbinders : indexedTreeBlockEnv.OnTel 1 [] + [.sort (.succ (.param 0)), .const ``Nat [], + .app + (.app (.const ``IndexedTreeList [.param 0]) (.bvar 1)) + (.bvar 0)] := by + refine ⟨⟨_, VEnv.HasType.sort (by decide)⟩, ?_⟩ + refine ⟨⟨.succ .zero, VEnv.HasType.const hNat (by simp) rfl⟩, ?_⟩ + refine ⟨⟨.succ (.param 0), ?_⟩, trivial⟩ + apply VEnv.HasType.app + (A := .const ``Nat []) + (B := .sort (.succ (.param 0))) + · apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .forallE (.const ``Nat []) (.sort (.succ (.param 0)))) + · exact VEnv.HasType.const hTreeList (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ .zero) + · exact VEnv.HasType.bvar .zero + have hresult : indexedTreeBlockEnv.HasType 1 + [.app + (.app (.const ``IndexedTreeList [.param 0]) (.bvar 1)) + (.bvar 0), + .const ``Nat [], .sort (.succ (.param 0))] + (.app + (.app (.const ``IndexedTree [.param 0]) (.bvar 2)) + (.app (.const ``Nat.succ []) (.bvar 1))) + (.sort (.succ (.param 0))) := by + apply VEnv.HasType.app + (A := .const ``Nat []) + (B := .sort (.succ (.param 0))) + · apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .forallE (.const ``Nat []) (.sort (.succ (.param 0)))) + · exact VEnv.HasType.const hTree (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ (.succ .zero)) + · apply VEnv.HasType.app + (A := .const ``Nat []) (B := .const ``Nat []) + · exact VEnv.HasType.const hSucc (by simp) rfl + · exact VEnv.HasType.bvar (.succ .zero) + refine { + declaredTel := hbinders.telDefEq_refl + declaredResult := hresult + emittedTel := hbinders.telDefEq_refl + emittedResult := hresult + owner := ?_ + recursive := ?_ + resultSpine := indexedTreeNodeSemantic.2.mono + indexedTreeBlock_le } + · refine ⟨indexedTreeGeneration.families[0], ?_, rfl, rfl, rfl⟩ + exact .head _ + · intro recursive hrecursive + change recursive ∈ [{ + fieldIndex := 1 + binders := [] + targetType := 1 + indices := [.bvar 0] }] at hrecursive + simp only [List.mem_cons, List.not_mem_nil, or_false] at hrecursive + subst recursive + refine ⟨indexedTreeGeneration.families[1], ?_, rfl, ?_, ?_⟩ + · exact .tail _ (.head _) + · exact ⟨.app + (.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⟩ + +theorem indexedTreeListConsGenerationWF : + NormalizedBlockCtor.WF indexedTreeGeneration + indexedTreeGeneration.flatCtors[3] indexedTreeBlockEnv := by + have hNat : indexedTreeBlockEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + have hSucc : indexedTreeBlockEnv.constants ``Nat.succ = + some InductiveFixtures.natType.ctors[1].toVConstant := rfl + have hTree : indexedTreeBlockEnv.constants ``IndexedTree = + some indexedTreeType.toVConstant := rfl + have hTreeList : indexedTreeBlockEnv.constants ``IndexedTreeList = + some indexedTreeListType.toVConstant := rfl + have hbinders : indexedTreeBlockEnv.OnTel 1 [] + [.sort (.succ (.param 0)), .const ``Nat [], + .app + (.app (.const ``IndexedTree [.param 0]) (.bvar 1)) + (.bvar 0), + .app + (.app (.const ``IndexedTreeList [.param 0]) (.bvar 2)) + (.bvar 1)] := by + refine ⟨⟨_, VEnv.HasType.sort (by decide)⟩, ?_⟩ + refine ⟨⟨.succ .zero, VEnv.HasType.const hNat (by simp) rfl⟩, ?_⟩ + refine ⟨⟨.succ (.param 0), ?_⟩, ?_⟩ + · apply VEnv.HasType.app + (A := .const ``Nat []) + (B := .sort (.succ (.param 0))) + · apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .forallE (.const ``Nat []) (.sort (.succ (.param 0)))) + · exact VEnv.HasType.const hTree (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ .zero) + · exact VEnv.HasType.bvar .zero + · refine ⟨⟨.succ (.param 0), ?_⟩, trivial⟩ + apply VEnv.HasType.app + (A := .const ``Nat []) + (B := .sort (.succ (.param 0))) + · apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .forallE (.const ``Nat []) (.sort (.succ (.param 0)))) + · exact VEnv.HasType.const hTreeList (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ (.succ .zero)) + · exact VEnv.HasType.bvar (.succ .zero) + have hresult : indexedTreeBlockEnv.HasType 1 + [.app + (.app (.const ``IndexedTreeList [.param 0]) (.bvar 2)) + (.bvar 1), + .app + (.app (.const ``IndexedTree [.param 0]) (.bvar 1)) + (.bvar 0), + .const ``Nat [], .sort (.succ (.param 0))] + (.app + (.app (.const ``IndexedTreeList [.param 0]) (.bvar 3)) + (.app (.const ``Nat.succ []) (.bvar 2))) + (.sort (.succ (.param 0))) := by + apply VEnv.HasType.app + (A := .const ``Nat []) + (B := .sort (.succ (.param 0))) + · apply VEnv.HasType.app + (A := .sort (.succ (.param 0))) + (B := .forallE (.const ``Nat []) (.sort (.succ (.param 0)))) + · exact VEnv.HasType.const hTreeList (by simp [VLevel.WF]) rfl + · exact VEnv.HasType.bvar (.succ (.succ (.succ .zero))) + · apply VEnv.HasType.app + (A := .const ``Nat []) (B := .const ``Nat []) + · exact VEnv.HasType.const hSucc (by simp) rfl + · exact VEnv.HasType.bvar (.succ (.succ .zero)) + refine { + declaredTel := hbinders.telDefEq_refl + declaredResult := hresult + emittedTel := hbinders.telDefEq_refl + emittedResult := hresult + owner := ?_ + recursive := ?_ + resultSpine := indexedTreeListConsSemantic.2.mono + indexedTreeBlock_le } + · refine ⟨indexedTreeGeneration.families[1], ?_, rfl, rfl, rfl⟩ + exact .tail _ (.head _) + · intro recursive hrecursive + change recursive ∈ [{ + fieldIndex := 1 + binders := [] + targetType := 0 + indices := [.bvar 0] }, { + fieldIndex := 2 + binders := [] + targetType := 1 + indices := [.bvar 1] }] at hrecursive + simp only [List.mem_cons, List.not_mem_nil, or_false] at hrecursive + rcases hrecursive with rfl | rfl + · refine ⟨indexedTreeGeneration.families[0], ?_, rfl, ?_, ?_⟩ + · exact .head _ + · exact ⟨.app + (.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⟩ + · 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⟩ + +theorem indexedTreeBlockGenerationWF : + indexedTreeGeneration.WF natFinalEnv indexedTreeBlockEnv := by + have hNat : natFinalEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + have hparams : natFinalEnv.OnTel 1 [] + [.sort (.succ (.param 0))] := + ⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩ + have hfamilyTel : natFinalEnv.OnTel 1 [] + [.sort (.succ (.param 0)), .const ``Nat []] := + ⟨⟨_, VEnv.HasType.sort (by decide)⟩, + ⟨⟨.succ .zero, VEnv.HasType.const hNat (by simp) rfl⟩, trivial⟩⟩ + refine { + blockWF := indexedTreeValidationCertificate.wf + resultLevelWF := by decide + paramsTel := hparams.telDefEq_refl + families := ?_ + constructors := ?_ } + · intro family hfamily + have hfamilies : indexedTreeGeneration.families = + [indexedTreeGeneration.families[0], + indexedTreeGeneration.families[1]] := rfl + rw [hfamilies] at hfamily + simp only [List.mem_cons, List.not_mem_nil, or_false] at hfamily + rcases hfamily with rfl | rfl + · constructor + · exact hfamilyTel.telDefEq_refl + · change natFinalEnv.IsDefEq 1 + [.const ``Nat [], .sort (.succ (.param 0))] + (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + (.sort (.succ (.succ (.param 0)))) + exact .sortDF (by decide) (by decide) rfl + · constructor + · exact hfamilyTel.telDefEq_refl + · change natFinalEnv.IsDefEq 1 + [.const ``Nat [], .sort (.succ (.param 0))] + (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + (.sort (.succ (.succ (.param 0)))) + exact .sortDF (by decide) (by decide) rfl + · intro constructor hconstructor + have hconstructors : indexedTreeGeneration.flatCtors = + [indexedTreeGeneration.flatCtors[0], + indexedTreeGeneration.flatCtors[1], + indexedTreeGeneration.flatCtors[2], + indexedTreeGeneration.flatCtors[3]] := rfl + rw [hconstructors] at hconstructor + simp only [List.mem_cons, List.not_mem_nil, or_false] at hconstructor + rcases hconstructor with rfl | rfl | rfl | rfl + · exact indexedTreeLeafGenerationWF + · exact indexedTreeNodeGenerationWF + · exact indexedTreeListNilGenerationWF + · exact indexedTreeListConsGenerationWF + +/-- Proof-carrying block generation for `Tree`/`TreeList`. -/ +def treeGenerationCertificate : + treeDecl.BlockGenerationCertificate VEnv.empty where + generation := treeGeneration + blockEnv := treeBlockEnv + wf := treeBlockGenerationWF + +/-- Proof-carrying block generation for the indexed mutual fixture. -/ +def indexedTreeGenerationCertificate : + indexedTreeDecl.BlockGenerationCertificate natFinalEnv where + generation := indexedTreeGeneration + blockEnv := indexedTreeBlockEnv + wf := indexedTreeBlockGenerationWF + +/-- Final Theory environment produced by the certified unindexed block +transaction. -/ +def treeFinalEnv : VEnv := + (VEnv.empty.addInductBlockCertified treeGenerationCertificate).get + (by decide) + +theorem tree_addInductBlockCertified : + VEnv.empty.addInductBlockCertified treeGenerationCertificate = + some treeFinalEnv := by + rfl + +/-- The raw public transaction selects the same retained block descriptor and +produces the same final Theory environment. -/ +theorem tree_addInduct : + VEnv.empty.addInduct treeDecl = some treeFinalEnv := by + rfl + +theorem tree_addInduct_success : + VEnv.AddInductSuccess VEnv.empty treeFinalEnv treeDecl := + VEnv.addInduct_success tree_addInduct + +/-- Exact four-phase trace for the certified unindexed block transaction. -/ +theorem treeCertifiedTrace : + Nonempty (VEnv.AddInductBlockGenerationTrace + VEnv.empty treeFinalEnv treeGeneration) := + VEnv.addInductBlockCertified_trace tree_addInductBlockCertified + +theorem treeFinalEnv_ordered : treeFinalEnv.Ordered := + VEnv.addInduct_WF .empty rfl treeBlockGenerationWF tree_addInduct + +theorem treeFinalEnv_family_lookup {type : VInductiveType} + (htype : type ∈ treeDecl.types) : + treeFinalEnv.constants type.name = some type.toVConstant := by + obtain ⟨trace⟩ := treeCertifiedTrace + exact trace.family_lookup htype + +theorem treeFinalEnv_ctor_lookup {constructor : VConstVal} + (hconstructor : constructor ∈ treeDecl.blockConstructorConstants) : + treeFinalEnv.constants constructor.name = + some constructor.toVConstant := by + obtain ⟨trace⟩ := treeCertifiedTrace + exact trace.ctor_lookup hconstructor + +theorem treeFinalEnv_rec_lookup {recursor : VConstVal} + (hrecursor : recursor ∈ treeGeneration.recursors) : + treeFinalEnv.constants recursor.name = + some recursor.toVConstant := by + obtain ⟨trace⟩ := treeCertifiedTrace + exact trace.rec_lookup hrecursor + +theorem treeFinalEnv_rule_mem {rule : VDefEq} + (hrule : rule ∈ treeGeneration.generatedRules) : + treeFinalEnv.defeqs rule := by + obtain ⟨trace⟩ := treeCertifiedTrace + exact trace.rule_mem hrule + +/-- Final Theory environment produced by the certified indexed block +transaction. -/ +def indexedTreeFinalEnv : VEnv := + (natFinalEnv.addInductBlockCertified indexedTreeGenerationCertificate).get + (by decide) + +theorem indexedTree_addInductBlockCertified : + natFinalEnv.addInductBlockCertified indexedTreeGenerationCertificate = + some indexedTreeFinalEnv := by + rfl + +/-- The indexed mutual block also runs through the same raw public entry +point once its ordinary `Nat` dependency is present. -/ +theorem indexedTree_addInduct : + natFinalEnv.addInduct indexedTreeDecl = some indexedTreeFinalEnv := by + rfl + +theorem indexedTree_addInduct_success : + VEnv.AddInductSuccess natFinalEnv indexedTreeFinalEnv indexedTreeDecl := + VEnv.addInduct_success indexedTree_addInduct + +/-- Exact four-phase trace for the certified indexed block transaction. -/ +theorem indexedTreeCertifiedTrace : + Nonempty (VEnv.AddInductBlockGenerationTrace + natFinalEnv indexedTreeFinalEnv indexedTreeGeneration) := + VEnv.addInductBlockCertified_trace indexedTree_addInductBlockCertified + +theorem indexedTreeFinalEnv_ordered : indexedTreeFinalEnv.Ordered := + VEnv.addInduct_WF natFinalEnv_ordered rfl indexedTreeBlockGenerationWF + indexedTree_addInduct + +theorem indexedTreeFinalEnv_family_lookup {type : VInductiveType} + (htype : type ∈ indexedTreeDecl.types) : + indexedTreeFinalEnv.constants type.name = some type.toVConstant := by + obtain ⟨trace⟩ := indexedTreeCertifiedTrace + exact trace.family_lookup htype + +theorem indexedTreeFinalEnv_ctor_lookup {constructor : VConstVal} + (hconstructor : + constructor ∈ indexedTreeDecl.blockConstructorConstants) : + indexedTreeFinalEnv.constants constructor.name = + some constructor.toVConstant := by + obtain ⟨trace⟩ := indexedTreeCertifiedTrace + exact trace.ctor_lookup hconstructor + +theorem indexedTreeFinalEnv_rec_lookup {recursor : VConstVal} + (hrecursor : recursor ∈ indexedTreeGeneration.recursors) : + indexedTreeFinalEnv.constants recursor.name = + some recursor.toVConstant := by + obtain ⟨trace⟩ := indexedTreeCertifiedTrace + exact trace.rec_lookup hrecursor + +theorem indexedTreeFinalEnv_rule_mem {rule : VDefEq} + (hrule : rule ∈ indexedTreeGeneration.generatedRules) : + indexedTreeFinalEnv.defeqs rule := by + obtain ⟨trace⟩ := indexedTreeCertifiedTrace + exact trace.rule_mem hrule + +/-! ## Verification-environment block replay -/ + +/-! ## Unindexed Verify block replay -/ + +def treeReplayFirstTypeEnv : VEnv := + (VEnv.empty.addConst treeType.name treeType.toVConstant).get! + +def treeReplayTypeEnv : VEnv := + (treeReplayFirstTypeEnv.addConst treeListType.name + treeListType.toVConstant).get! + +def treeReplayLeafEnv : VEnv := + (treeReplayTypeEnv.addConst treeType.ctors[0].name + treeType.ctors[0].toVConstant).get! + +def treeReplayNodeEnv : VEnv := + (treeReplayLeafEnv.addConst treeType.ctors[1].name + treeType.ctors[1].toVConstant).get! + +def treeReplayBranchEnv : VEnv := + (treeReplayNodeEnv.addConst treeType.ctors[2].name + treeType.ctors[2].toVConstant).get! + +def treeReplayNilEnv : VEnv := + (treeReplayBranchEnv.addConst treeListType.ctors[0].name + treeListType.ctors[0].toVConstant).get! + +def treeReplayCtorEnv : VEnv := + (treeReplayNilEnv.addConst treeListType.ctors[1].name + treeListType.ctors[1].toVConstant).get! + +def treeReplayFirstRecEnv : VEnv := + (treeReplayCtorEnv.addConst treeGeneration.recursors[0].name + treeGeneration.recursors[0].toVConstant).get! + +def treeReplayRecEnv : VEnv := + (treeReplayFirstRecEnv.addConst treeGeneration.recursors[1].name + treeGeneration.recursors[1].toVConstant).get! + +example : treeReplayTypeEnv = treeBlockEnv := rfl + +theorem treeReplay_addFirstType : + VEnv.empty.addConst treeType.name treeType.toVConstant = + some treeReplayFirstTypeEnv := rfl + +theorem treeReplay_addSecondType : + treeReplayFirstTypeEnv.addConst treeListType.name + treeListType.toVConstant = some treeReplayTypeEnv := rfl + +theorem treeReplay_addLeaf : + treeReplayTypeEnv.addConst treeType.ctors[0].name + treeType.ctors[0].toVConstant = some treeReplayLeafEnv := rfl + +theorem treeReplay_addNode : + treeReplayLeafEnv.addConst treeType.ctors[1].name + treeType.ctors[1].toVConstant = some treeReplayNodeEnv := rfl + +theorem treeReplay_addBranch : + treeReplayNodeEnv.addConst treeType.ctors[2].name + treeType.ctors[2].toVConstant = some treeReplayBranchEnv := rfl + +theorem treeReplay_addNil : + treeReplayBranchEnv.addConst treeListType.ctors[0].name + treeListType.ctors[0].toVConstant = some treeReplayNilEnv := rfl + +theorem treeReplay_addCons : + treeReplayNilEnv.addConst treeListType.ctors[1].name + treeListType.ctors[1].toVConstant = some treeReplayCtorEnv := rfl + +theorem treeReplay_addFirstRec : + treeReplayCtorEnv.addConst treeGeneration.recursors[0].name + treeGeneration.recursors[0].toVConstant = + some treeReplayFirstRecEnv := rfl + +theorem treeReplay_addSecondRec : + treeReplayFirstRecEnv.addConst treeGeneration.recursors[1].name + treeGeneration.recursors[1].toVConstant = + some treeReplayRecEnv := rfl + +theorem treeTypeConstantWF : treeType.toVConstant.WF VEnv.empty := by + exact treeBlockGenerationWF.rawFamily_isType (.head _) + +theorem treeListTypeConstantWF : + treeListType.toVConstant.WF VEnv.empty := by + exact treeBlockGenerationWF.rawFamily_isType (.tail _ (.head _)) + +theorem treeLeafConstantWF : + treeType.ctors[0].toVConstant.WF treeReplayTypeEnv := by + exact treeBlockGenerationWF.rawCtor_isType (.head _) + +theorem treeNodeConstantWF : + treeType.ctors[1].toVConstant.WF treeReplayTypeEnv := by + exact treeBlockGenerationWF.rawCtor_isType (.tail _ (.head _)) + +theorem treeBranchConstantWF : + treeType.ctors[2].toVConstant.WF treeReplayTypeEnv := by + exact treeBlockGenerationWF.rawCtor_isType + (.tail _ (.tail _ (.head _))) + +theorem treeNilConstantWF : + treeListType.ctors[0].toVConstant.WF treeReplayTypeEnv := by + exact treeBlockGenerationWF.rawCtor_isType + (.tail _ (.tail _ (.tail _ (.head _)))) + +theorem treeConsConstantWF : + treeListType.ctors[1].toVConstant.WF treeReplayTypeEnv := by + exact treeBlockGenerationWF.rawCtor_isType + (.tail _ (.tail _ (.tail _ (.tail _ (.head _))))) + +theorem treeReplayFirstTypeEnv_ordered : + treeReplayFirstTypeEnv.Ordered := by + exact .const .empty treeTypeConstantWF treeReplay_addFirstType + +theorem treeReplayTypeEnv_ordered : treeReplayTypeEnv.Ordered := by + refine .const treeReplayFirstTypeEnv_ordered ?_ + treeReplay_addSecondType + exact treeListTypeConstantWF.mono + (VEnv.addConst_le treeReplay_addFirstType) + +theorem treeReplayTypeEnv_le_leafEnv : + treeReplayTypeEnv ≤ treeReplayLeafEnv := + VEnv.addConst_le treeReplay_addLeaf + +theorem treeReplayLeafEnv_ordered : treeReplayLeafEnv.Ordered := by + exact .const treeReplayTypeEnv_ordered treeLeafConstantWF + treeReplay_addLeaf + +theorem treeReplayLeafEnv_le_nodeEnv : + treeReplayLeafEnv ≤ treeReplayNodeEnv := + VEnv.addConst_le treeReplay_addNode + +theorem treeReplayNodeEnv_ordered : treeReplayNodeEnv.Ordered := by + refine .const treeReplayLeafEnv_ordered ?_ treeReplay_addNode + exact treeNodeConstantWF.mono + treeReplayTypeEnv_le_leafEnv + +theorem treeReplayNodeEnv_le_branchEnv : + treeReplayNodeEnv ≤ treeReplayBranchEnv := + VEnv.addConst_le treeReplay_addBranch + +theorem treeReplayBranchEnv_ordered : treeReplayBranchEnv.Ordered := by + refine .const treeReplayNodeEnv_ordered ?_ treeReplay_addBranch + exact treeBranchConstantWF.mono + (treeReplayTypeEnv_le_leafEnv.trans treeReplayLeafEnv_le_nodeEnv) + +theorem treeReplayBranchEnv_le_nilEnv : + treeReplayBranchEnv ≤ treeReplayNilEnv := + VEnv.addConst_le treeReplay_addNil + +theorem treeReplayNilEnv_ordered : treeReplayNilEnv.Ordered := by + refine .const treeReplayBranchEnv_ordered ?_ treeReplay_addNil + exact treeNilConstantWF.mono + (treeReplayTypeEnv_le_leafEnv.trans + (treeReplayLeafEnv_le_nodeEnv.trans + treeReplayNodeEnv_le_branchEnv)) + +theorem treeReplayNilEnv_le_ctorEnv : + treeReplayNilEnv ≤ treeReplayCtorEnv := + VEnv.addConst_le treeReplay_addCons + +theorem treeReplayCtorEnv_ordered : treeReplayCtorEnv.Ordered := by + refine .const treeReplayNilEnv_ordered ?_ treeReplay_addCons + exact treeConsConstantWF.mono + (treeReplayTypeEnv_le_leafEnv.trans + (treeReplayLeafEnv_le_nodeEnv.trans + (treeReplayNodeEnv_le_branchEnv.trans + treeReplayBranchEnv_le_nilEnv))) + +theorem treeReplayInput_le_ctorEnv : VEnv.empty ≤ treeReplayCtorEnv := by + exact (VEnv.addConst_le treeReplay_addFirstType).trans + ((VEnv.addConst_le treeReplay_addSecondType).trans + (treeReplayTypeEnv_le_leafEnv.trans + (treeReplayLeafEnv_le_nodeEnv.trans + (treeReplayNodeEnv_le_branchEnv.trans + (treeReplayBranchEnv_le_nilEnv.trans + treeReplayNilEnv_le_ctorEnv))))) + +theorem treeReplayBlock_le_ctorEnv : treeBlockEnv ≤ treeReplayCtorEnv := by + exact treeReplayTypeEnv_le_leafEnv.trans + (treeReplayLeafEnv_le_nodeEnv.trans + (treeReplayNodeEnv_le_branchEnv.trans + (treeReplayBranchEnv_le_nilEnv.trans + treeReplayNilEnv_le_ctorEnv))) + +theorem treeReplayGenerationEnv : + BlockGenerationEnv treeGeneration treeReplayCtorEnv := by + apply treeBlockGenerationWF.toBlockGenerationEnv + treeReplayInput_le_ctorEnv treeReplayBlock_le_ctorEnv + treeReplayCtorEnv_ordered + · intro family hfamily + have hfamilies : treeGeneration.families = + [treeGeneration.families[0], treeGeneration.families[1]] := rfl + rw [hfamilies] at hfamily + simp only [List.mem_cons, List.not_mem_nil, or_false] at hfamily + rcases hfamily with rfl | rfl <;> rfl + · intro constructor hconstructor + have hconstructors : treeGeneration.flatCtors = + [treeGeneration.flatCtors[0], treeGeneration.flatCtors[1], + treeGeneration.flatCtors[2], treeGeneration.flatCtors[3], + treeGeneration.flatCtors[4]] := rfl + rw [hconstructors] at hconstructor + simp only [List.mem_cons, List.not_mem_nil, or_false] at hconstructor + rcases hconstructor with rfl | rfl | rfl | rfl | rfl <;> rfl + +theorem treeReplayFirstRecEnv_ordered : + treeReplayFirstRecEnv.Ordered := by + refine .const treeReplayCtorEnv_ordered ?_ treeReplay_addFirstRec + exact treeReplayGenerationEnv.recursor_wf (.head _) + +theorem treeReplayCtorEnv_le_firstRecEnv : + treeReplayCtorEnv ≤ treeReplayFirstRecEnv := + VEnv.addConst_le treeReplay_addFirstRec + +theorem treeReplayRecEnv_ordered : treeReplayRecEnv.Ordered := by + refine .const treeReplayFirstRecEnv_ordered ?_ treeReplay_addSecondRec + exact (treeReplayGenerationEnv.recursor_wf + (.tail _ (.head _))).mono treeReplayCtorEnv_le_firstRecEnv + +theorem treeKernelInfo_tr : + TrConstVal .safe VEnv.empty treeKernelInfo treeType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr VEnv.empty treeKernelInfo.levelParams [] + treeKernelInfo.type treeType.type := by tr_type_expr_tac + exact hshape.to_trExprS .empty trivial + (treeFamilyTypeWF treeType (.inl rfl)) + +theorem treeListKernelInfo_tr : + TrConstVal .safe treeReplayFirstTypeEnv treeListKernelInfo + treeListType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr treeReplayFirstTypeEnv + treeListKernelInfo.levelParams [] treeListKernelInfo.type + treeListType.type := by tr_type_expr_tac + exact hshape.to_trExprS treeReplayFirstTypeEnv_ordered trivial + ((treeFamilyTypeWF treeListType (.inr rfl)).mono + (VEnv.addConst_le (by rfl))) + +theorem treeLeafKernelInfo_tr : + TrConstVal .safe treeReplayTypeEnv treeLeafKernelInfo + treeType.ctors[0] := by + have hTree : treeReplayTypeEnv.constants ``Tree = + some treeType.toVConstant := rfl + have hTreeList : treeReplayTypeEnv.constants ``TreeList = + some treeListType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr treeReplayTypeEnv + treeLeafKernelInfo.levelParams [] treeLeafKernelInfo.type + treeType.ctors[0].type := by tr_type_expr_tac + exact hshape.to_trExprS treeReplayTypeEnv_ordered trivial + (treeCtorWF treeType.ctors[0] (.inl (by simp [treeType]))) + +theorem treeNodeKernelInfo_tr : + TrConstVal .safe treeReplayLeafEnv treeNodeKernelInfo + treeType.ctors[1] := by + have hTree : treeReplayLeafEnv.constants ``Tree = + some treeType.toVConstant := rfl + have hTreeList : treeReplayLeafEnv.constants ``TreeList = + some treeListType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr treeReplayLeafEnv + treeNodeKernelInfo.levelParams [] treeNodeKernelInfo.type + treeType.ctors[1].type := by tr_type_expr_tac + exact hshape.to_trExprS treeReplayLeafEnv_ordered trivial + ((treeCtorWF treeType.ctors[1] (.inl (by simp [treeType]))).mono + treeReplayTypeEnv_le_leafEnv) + +theorem treeBranchKernelInfo_tr : + TrConstVal .safe treeReplayNodeEnv treeBranchKernelInfo + treeType.ctors[2] := by + have hTree : treeReplayNodeEnv.constants ``Tree = + some treeType.toVConstant := rfl + have hTreeList : treeReplayNodeEnv.constants ``TreeList = + some treeListType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr treeReplayNodeEnv + treeBranchKernelInfo.levelParams [] treeBranchKernelInfo.type + treeType.ctors[2].type := by tr_type_expr_tac + exact hshape.to_trExprS treeReplayNodeEnv_ordered trivial + ((treeCtorWF treeType.ctors[2] (.inl (by simp [treeType]))).mono + (treeReplayTypeEnv_le_leafEnv.trans treeReplayLeafEnv_le_nodeEnv)) + +theorem treeListNilKernelInfo_tr : + TrConstVal .safe treeReplayBranchEnv treeListNilKernelInfo + treeListType.ctors[0] := by + have hTree : treeReplayBranchEnv.constants ``Tree = + some treeType.toVConstant := rfl + have hTreeList : treeReplayBranchEnv.constants ``TreeList = + some treeListType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr treeReplayBranchEnv + treeListNilKernelInfo.levelParams [] treeListNilKernelInfo.type + treeListType.ctors[0].type := by tr_type_expr_tac + exact hshape.to_trExprS treeReplayBranchEnv_ordered trivial + ((treeCtorWF treeListType.ctors[0] + (.inr (by simp [treeListType]))).mono + (treeReplayTypeEnv_le_leafEnv.trans + (treeReplayLeafEnv_le_nodeEnv.trans + treeReplayNodeEnv_le_branchEnv))) + +theorem treeListConsKernelInfo_tr : + TrConstVal .safe treeReplayNilEnv treeListConsKernelInfo + treeListType.ctors[1] := by + have hTree : treeReplayNilEnv.constants ``Tree = + some treeType.toVConstant := rfl + have hTreeList : treeReplayNilEnv.constants ``TreeList = + some treeListType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr treeReplayNilEnv + treeListConsKernelInfo.levelParams [] treeListConsKernelInfo.type + treeListType.ctors[1].type := by tr_type_expr_tac + exact hshape.to_trExprS treeReplayNilEnv_ordered trivial + ((treeCtorWF treeListType.ctors[1] + (.inr (by simp [treeListType]))).mono + (treeReplayTypeEnv_le_leafEnv.trans + (treeReplayLeafEnv_le_nodeEnv.trans + (treeReplayNodeEnv_le_branchEnv.trans + treeReplayBranchEnv_le_nilEnv)))) + +theorem treeRecKernelInfo_tr : + TrConstVal .safe treeReplayCtorEnv treeRecKernelInfo + treeGeneration.recursors[0] := by + have hTree : treeReplayCtorEnv.constants ``Tree = + some treeType.toVConstant := rfl + have hTreeList : treeReplayCtorEnv.constants ``TreeList = + some treeListType.toVConstant := rfl + have hLeaf : treeReplayCtorEnv.constants ``Tree.leaf = + some treeType.ctors[0].toVConstant := rfl + have hNode : treeReplayCtorEnv.constants ``Tree.node = + some treeType.ctors[1].toVConstant := rfl + have hBranch : treeReplayCtorEnv.constants ``Tree.branch = + some treeType.ctors[2].toVConstant := rfl + have hNil : treeReplayCtorEnv.constants ``TreeList.nil = + some treeListType.ctors[0].toVConstant := rfl + have hCons : treeReplayCtorEnv.constants ``TreeList.cons = + some treeListType.ctors[1].toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr treeReplayCtorEnv + treeRecKernelInfo.levelParams [] treeRecKernelInfo.type + treeGeneration.recursors[0].type := by tr_type_expr_tac + obtain ⟨u, hrec⟩ := + treeReplayGenerationEnv.recursor_wf (.head _) + exact hshape.to_trExprS treeReplayCtorEnv_ordered trivial + ⟨.sort u, hrec⟩ + +theorem treeListRecKernelInfo_tr : + TrConstVal .safe treeReplayFirstRecEnv treeListRecKernelInfo + treeGeneration.recursors[1] := by + have hTree : treeReplayFirstRecEnv.constants ``Tree = + some treeType.toVConstant := rfl + have hTreeList : treeReplayFirstRecEnv.constants ``TreeList = + some treeListType.toVConstant := rfl + have hLeaf : treeReplayFirstRecEnv.constants ``Tree.leaf = + some treeType.ctors[0].toVConstant := rfl + have hNode : treeReplayFirstRecEnv.constants ``Tree.node = + some treeType.ctors[1].toVConstant := rfl + have hBranch : treeReplayFirstRecEnv.constants ``Tree.branch = + some treeType.ctors[2].toVConstant := rfl + have hNil : treeReplayFirstRecEnv.constants ``TreeList.nil = + some treeListType.ctors[0].toVConstant := rfl + have hCons : treeReplayFirstRecEnv.constants ``TreeList.cons = + some treeListType.ctors[1].toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr treeReplayFirstRecEnv + treeListRecKernelInfo.levelParams [] treeListRecKernelInfo.type + treeGeneration.recursors[1].type := by tr_type_expr_tac + obtain ⟨u, hrec⟩ := + treeReplayGenerationEnv.recursor_wf (.tail _ (.head _)) + exact hshape.to_trExprS treeReplayFirstRecEnv_ordered trivial + ⟨.sort u, hrec.mono treeReplayCtorEnv_le_firstRecEnv⟩ + +def treeReplayFirstTypeMap : ConstMap := + ({} : ConstMap).insert ``Tree treeKernelInfo + +def treeReplayTypeMap : ConstMap := + treeReplayFirstTypeMap.insert ``TreeList treeListKernelInfo + +def treeReplayLeafMap : ConstMap := + treeReplayTypeMap.insert ``Tree.leaf treeLeafKernelInfo + +def treeReplayNodeMap : ConstMap := + treeReplayLeafMap.insert ``Tree.node treeNodeKernelInfo + +def treeReplayBranchMap : ConstMap := + treeReplayNodeMap.insert ``Tree.branch treeBranchKernelInfo + +def treeReplayNilMap : ConstMap := + treeReplayBranchMap.insert ``TreeList.nil treeListNilKernelInfo + +def treeReplayCtorMap : ConstMap := + treeReplayNilMap.insert ``TreeList.cons treeListConsKernelInfo + +def treeReplayFirstRecMap : ConstMap := + treeReplayCtorMap.insert ``Tree.rec treeRecKernelInfo + +def treeReplayMap : ConstMap := + treeReplayFirstRecMap.insert ``TreeList.rec treeListRecKernelInfo + +theorem treeReplayFirstType_fresh : + ({} : ConstMap).find? ``Tree = none := by + simp [SMap.find?] + +theorem treeReplayFirstTypeMap_wf : treeReplayFirstTypeMap.WF := + SMap.WF.empty.insert _ _ treeReplayFirstType_fresh + +theorem treeReplaySecondType_fresh : + treeReplayFirstTypeMap.find? ``TreeList = none := by + rw [treeReplayFirstTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem treeReplayTypeMap_wf : treeReplayTypeMap.WF := + treeReplayFirstTypeMap_wf.insert _ _ treeReplaySecondType_fresh + +theorem treeReplayLeaf_fresh : + treeReplayTypeMap.find? ``Tree.leaf = none := by + rw [treeReplayTypeMap, treeReplayFirstTypeMap_wf.find?_insert, + treeReplayFirstTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem treeReplayLeafMap_wf : treeReplayLeafMap.WF := + treeReplayTypeMap_wf.insert _ _ treeReplayLeaf_fresh + +theorem treeReplayNode_fresh : + treeReplayLeafMap.find? ``Tree.node = none := by + rw [treeReplayLeafMap, treeReplayTypeMap_wf.find?_insert, + treeReplayTypeMap, treeReplayFirstTypeMap_wf.find?_insert, + treeReplayFirstTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem treeReplayNodeMap_wf : treeReplayNodeMap.WF := + treeReplayLeafMap_wf.insert _ _ treeReplayNode_fresh + +theorem treeReplayBranch_fresh : + treeReplayNodeMap.find? ``Tree.branch = none := by + rw [treeReplayNodeMap, treeReplayLeafMap_wf.find?_insert, + treeReplayLeafMap, treeReplayTypeMap_wf.find?_insert, + treeReplayTypeMap, treeReplayFirstTypeMap_wf.find?_insert, + treeReplayFirstTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem treeReplayBranchMap_wf : treeReplayBranchMap.WF := + treeReplayNodeMap_wf.insert _ _ treeReplayBranch_fresh + +theorem treeReplayNil_fresh : + treeReplayBranchMap.find? ``TreeList.nil = none := by + rw [treeReplayBranchMap, treeReplayNodeMap_wf.find?_insert, + treeReplayNodeMap, treeReplayLeafMap_wf.find?_insert, + treeReplayLeafMap, treeReplayTypeMap_wf.find?_insert, + treeReplayTypeMap, treeReplayFirstTypeMap_wf.find?_insert, + treeReplayFirstTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem treeReplayNilMap_wf : treeReplayNilMap.WF := + treeReplayBranchMap_wf.insert _ _ treeReplayNil_fresh + +theorem treeReplayCons_fresh : + treeReplayNilMap.find? ``TreeList.cons = none := by + rw [treeReplayNilMap, treeReplayBranchMap_wf.find?_insert, + treeReplayBranchMap, treeReplayNodeMap_wf.find?_insert, + treeReplayNodeMap, treeReplayLeafMap_wf.find?_insert, + treeReplayLeafMap, treeReplayTypeMap_wf.find?_insert, + treeReplayTypeMap, treeReplayFirstTypeMap_wf.find?_insert, + treeReplayFirstTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem treeReplayCtorMap_wf : treeReplayCtorMap.WF := + treeReplayNilMap_wf.insert _ _ treeReplayCons_fresh + +theorem treeReplayFirstRec_fresh : + treeReplayCtorMap.find? ``Tree.rec = none := by + rw [treeReplayCtorMap, treeReplayNilMap_wf.find?_insert, + treeReplayNilMap, treeReplayBranchMap_wf.find?_insert, + treeReplayBranchMap, treeReplayNodeMap_wf.find?_insert, + treeReplayNodeMap, treeReplayLeafMap_wf.find?_insert, + treeReplayLeafMap, treeReplayTypeMap_wf.find?_insert, + treeReplayTypeMap, treeReplayFirstTypeMap_wf.find?_insert, + treeReplayFirstTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem treeReplayFirstRecMap_wf : treeReplayFirstRecMap.WF := + treeReplayCtorMap_wf.insert _ _ treeReplayFirstRec_fresh + +theorem treeReplaySecondRec_fresh : + treeReplayFirstRecMap.find? ``TreeList.rec = none := by + rw [treeReplayFirstRecMap, treeReplayCtorMap_wf.find?_insert, + treeReplayCtorMap, treeReplayNilMap_wf.find?_insert, + treeReplayNilMap, treeReplayBranchMap_wf.find?_insert, + treeReplayBranchMap, treeReplayNodeMap_wf.find?_insert, + treeReplayNodeMap, treeReplayLeafMap_wf.find?_insert, + treeReplayLeafMap, treeReplayTypeMap_wf.find?_insert, + treeReplayTypeMap, treeReplayFirstTypeMap_wf.find?_insert, + treeReplayFirstTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem treeReplayMap_wf : treeReplayMap.WF := + treeReplayFirstRecMap_wf.insert _ _ treeReplaySecondRec_fresh + +theorem treeReplay_treeRec_lookup : + treeReplayMap.find? ``Tree.rec = some treeRecKernelInfo := by + rw [treeReplayMap, treeReplayFirstRecMap_wf.find?_insert, + treeReplayFirstRecMap, treeReplayCtorMap_wf.find?_insert] + rfl + +theorem treeReplay_treeListRec_lookup : + treeReplayMap.find? ``TreeList.rec = some treeListRecKernelInfo := by + rw [treeReplayMap, treeReplayFirstRecMap_wf.find?_insert] + rfl + +def treeAddInductBlockTrace : + AddInductBlockTrace ({} : ConstMap) VEnv.empty treeDecl + treeReplayMap treeFinalEnv where + generation := treeGeneration + blockEnv := treeBlockEnv + generation_wf := treeBlockGenerationWF + typeMap := treeReplayTypeMap + typeEnv := treeReplayTypeEnv + ctorMap := treeReplayCtorMap + ctorEnv := treeReplayCtorEnv + recEnv := treeReplayRecEnv + addTypes := .cons { + info := treeKernelInfo + kind_eq := by simp [treeKernelInfo, InductConstantKind.Matches] + tr := treeKernelInfo_tr + map_fresh := treeReplayFirstType_fresh + env_add := rfl + map_add := rfl } + (.cons { + info := treeListKernelInfo + kind_eq := by simp [treeListKernelInfo, InductConstantKind.Matches] + tr := treeListKernelInfo_tr + map_fresh := treeReplaySecondType_fresh + env_add := rfl + map_add := rfl } .nil) + addCtors := .cons { + info := treeLeafKernelInfo + kind_eq := by simp [treeLeafKernelInfo, InductConstantKind.Matches] + tr := treeLeafKernelInfo_tr + map_fresh := treeReplayLeaf_fresh + env_add := rfl + map_add := rfl } + (.cons { + info := treeNodeKernelInfo + kind_eq := by simp [treeNodeKernelInfo, InductConstantKind.Matches] + tr := treeNodeKernelInfo_tr + map_fresh := treeReplayNode_fresh + env_add := rfl + map_add := rfl } + (.cons { + info := treeBranchKernelInfo + kind_eq := by simp [treeBranchKernelInfo, InductConstantKind.Matches] + tr := treeBranchKernelInfo_tr + map_fresh := treeReplayBranch_fresh + env_add := rfl + map_add := rfl } + (.cons { + info := treeListNilKernelInfo + kind_eq := by simp [treeListNilKernelInfo, InductConstantKind.Matches] + tr := treeListNilKernelInfo_tr + map_fresh := treeReplayNil_fresh + env_add := rfl + map_add := rfl } + (.cons { + info := treeListConsKernelInfo + kind_eq := by simp [treeListConsKernelInfo, InductConstantKind.Matches] + tr := treeListConsKernelInfo_tr + map_fresh := treeReplayCons_fresh + env_add := rfl + map_add := rfl } .nil)))) + addRecs := .cons { + info := treeRecKernelInfo + kind_eq := by simp [treeRecKernelInfo, InductConstantKind.Matches] + tr := treeRecKernelInfo_tr + map_fresh := treeReplayFirstRec_fresh + env_add := rfl + map_add := rfl } + (.cons { + info := treeListRecKernelInfo + kind_eq := by simp [treeListRecKernelInfo, InductConstantKind.Matches] + tr := treeListRecKernelInfo_tr + map_fresh := treeReplaySecondRec_fresh + env_add := rfl + map_add := rfl } .nil) + recK := by + intro recursor hrecursor + have hrecs : treeGeneration.recursors = + [treeGeneration.recursors[0], treeGeneration.recursors[1]] := rfl + rw [hrecs] at hrecursor + simp only [List.mem_cons, List.not_mem_nil, or_false] at hrecursor + rcases hrecursor with rfl | rfl + · exact ⟨treeRecKernelInfo, treeReplay_treeRec_lookup, by decide⟩ + · exact ⟨treeListRecKernelInfo, treeReplay_treeListRec_lookup, + by decide⟩ + addRules := ⟨rfl⟩ + +theorem treeAddInductBlock : + AddInductBlock ({} : ConstMap) VEnv.empty treeDecl + treeReplayMap treeFinalEnv := + ⟨treeAddInductBlockTrace⟩ + +theorem tree_trEnv' : TrEnv' .safe treeReplayMap false treeFinalEnv := + .inductBlock treeAddInductBlock .empty + +theorem tree_verify_env_wf : treeFinalEnv.WF := tree_trEnv'.wf + +theorem tree_verify_aligned : + Aligned .safe treeReplayMap treeFinalEnv := tree_trEnv'.aligned + +/-! ## Indexed Verify block replay -/ + +def indexedReplayFirstTypeEnv : VEnv := + (natFinalEnv.addConst indexedTreeType.name + indexedTreeType.toVConstant).get! + +def indexedReplayTypeEnv : VEnv := + (indexedReplayFirstTypeEnv.addConst indexedTreeListType.name + indexedTreeListType.toVConstant).get! + +def indexedReplayLeafEnv : VEnv := + (indexedReplayTypeEnv.addConst indexedTreeType.ctors[0].name + indexedTreeType.ctors[0].toVConstant).get! + +def indexedReplayNodeEnv : VEnv := + (indexedReplayLeafEnv.addConst indexedTreeType.ctors[1].name + indexedTreeType.ctors[1].toVConstant).get! + +def indexedReplayNilEnv : VEnv := + (indexedReplayNodeEnv.addConst indexedTreeListType.ctors[0].name + indexedTreeListType.ctors[0].toVConstant).get! + +def indexedReplayCtorEnv : VEnv := + (indexedReplayNilEnv.addConst indexedTreeListType.ctors[1].name + indexedTreeListType.ctors[1].toVConstant).get! + +def indexedReplayFirstRecEnv : VEnv := + (indexedReplayCtorEnv.addConst + indexedTreeGeneration.recursors[0].name + indexedTreeGeneration.recursors[0].toVConstant).get! + +def indexedReplayRecEnv : VEnv := + (indexedReplayFirstRecEnv.addConst + indexedTreeGeneration.recursors[1].name + indexedTreeGeneration.recursors[1].toVConstant).get! + +example : indexedReplayTypeEnv = indexedTreeBlockEnv := rfl + +theorem indexedReplay_addFirstType : + natFinalEnv.addConst indexedTreeType.name + indexedTreeType.toVConstant = some indexedReplayFirstTypeEnv := rfl + +theorem indexedReplay_addSecondType : + indexedReplayFirstTypeEnv.addConst indexedTreeListType.name + indexedTreeListType.toVConstant = some indexedReplayTypeEnv := rfl + +theorem indexedReplay_addLeaf : + indexedReplayTypeEnv.addConst indexedTreeType.ctors[0].name + indexedTreeType.ctors[0].toVConstant = + some indexedReplayLeafEnv := rfl + +theorem indexedReplay_addNode : + indexedReplayLeafEnv.addConst indexedTreeType.ctors[1].name + indexedTreeType.ctors[1].toVConstant = + some indexedReplayNodeEnv := rfl + +theorem indexedReplay_addNil : + indexedReplayNodeEnv.addConst indexedTreeListType.ctors[0].name + indexedTreeListType.ctors[0].toVConstant = + some indexedReplayNilEnv := rfl + +theorem indexedReplay_addCons : + indexedReplayNilEnv.addConst indexedTreeListType.ctors[1].name + indexedTreeListType.ctors[1].toVConstant = + some indexedReplayCtorEnv := rfl + +theorem indexedReplay_addFirstRec : + indexedReplayCtorEnv.addConst + indexedTreeGeneration.recursors[0].name + indexedTreeGeneration.recursors[0].toVConstant = + some indexedReplayFirstRecEnv := rfl + +theorem indexedReplay_addSecondRec : + indexedReplayFirstRecEnv.addConst + indexedTreeGeneration.recursors[1].name + indexedTreeGeneration.recursors[1].toVConstant = + some indexedReplayRecEnv := rfl + +theorem indexedTreeTypeConstantWF : + indexedTreeType.toVConstant.WF natFinalEnv := by + exact indexedTreeBlockGenerationWF.rawFamily_isType (.head _) + +theorem indexedTreeListTypeConstantWF : + indexedTreeListType.toVConstant.WF natFinalEnv := by + exact indexedTreeBlockGenerationWF.rawFamily_isType + (.tail _ (.head _)) + +theorem indexedTreeLeafConstantWF : + indexedTreeType.ctors[0].toVConstant.WF indexedReplayTypeEnv := by + exact indexedTreeBlockGenerationWF.rawCtor_isType (.head _) + +theorem indexedTreeNodeConstantWF : + indexedTreeType.ctors[1].toVConstant.WF indexedReplayTypeEnv := by + exact indexedTreeBlockGenerationWF.rawCtor_isType + (.tail _ (.head _)) + +theorem indexedTreeNilConstantWF : + indexedTreeListType.ctors[0].toVConstant.WF + indexedReplayTypeEnv := by + exact indexedTreeBlockGenerationWF.rawCtor_isType + (.tail _ (.tail _ (.head _))) + +theorem indexedTreeConsConstantWF : + indexedTreeListType.ctors[1].toVConstant.WF + indexedReplayTypeEnv := by + exact indexedTreeBlockGenerationWF.rawCtor_isType + (.tail _ (.tail _ (.tail _ (.head _)))) + +theorem indexedReplayFirstTypeEnv_ordered : + indexedReplayFirstTypeEnv.Ordered := by + exact .const natFinalEnv_ordered indexedTreeTypeConstantWF + indexedReplay_addFirstType + +theorem indexedReplayTypeEnv_ordered : indexedReplayTypeEnv.Ordered := by + refine .const indexedReplayFirstTypeEnv_ordered ?_ + indexedReplay_addSecondType + exact indexedTreeListTypeConstantWF.mono + (VEnv.addConst_le indexedReplay_addFirstType) + +theorem indexedReplayTypeEnv_le_leafEnv : + indexedReplayTypeEnv ≤ indexedReplayLeafEnv := + VEnv.addConst_le indexedReplay_addLeaf + +theorem indexedReplayLeafEnv_ordered : indexedReplayLeafEnv.Ordered := by + exact .const indexedReplayTypeEnv_ordered indexedTreeLeafConstantWF + indexedReplay_addLeaf + +theorem indexedReplayLeafEnv_le_nodeEnv : + indexedReplayLeafEnv ≤ indexedReplayNodeEnv := + VEnv.addConst_le indexedReplay_addNode + +theorem indexedReplayNodeEnv_ordered : indexedReplayNodeEnv.Ordered := by + refine .const indexedReplayLeafEnv_ordered ?_ indexedReplay_addNode + exact indexedTreeNodeConstantWF.mono indexedReplayTypeEnv_le_leafEnv + +theorem indexedReplayNodeEnv_le_nilEnv : + indexedReplayNodeEnv ≤ indexedReplayNilEnv := + VEnv.addConst_le indexedReplay_addNil + +theorem indexedReplayNilEnv_ordered : indexedReplayNilEnv.Ordered := by + refine .const indexedReplayNodeEnv_ordered ?_ indexedReplay_addNil + exact indexedTreeNilConstantWF.mono + (indexedReplayTypeEnv_le_leafEnv.trans + indexedReplayLeafEnv_le_nodeEnv) + +theorem indexedReplayNilEnv_le_ctorEnv : + indexedReplayNilEnv ≤ indexedReplayCtorEnv := + VEnv.addConst_le indexedReplay_addCons + +theorem indexedReplayCtorEnv_ordered : indexedReplayCtorEnv.Ordered := by + refine .const indexedReplayNilEnv_ordered ?_ indexedReplay_addCons + exact indexedTreeConsConstantWF.mono + (indexedReplayTypeEnv_le_leafEnv.trans + (indexedReplayLeafEnv_le_nodeEnv.trans + indexedReplayNodeEnv_le_nilEnv)) + +theorem indexedReplayInput_le_ctorEnv : + natFinalEnv ≤ indexedReplayCtorEnv := by + exact (VEnv.addConst_le indexedReplay_addFirstType).trans + ((VEnv.addConst_le indexedReplay_addSecondType).trans + (indexedReplayTypeEnv_le_leafEnv.trans + (indexedReplayLeafEnv_le_nodeEnv.trans + (indexedReplayNodeEnv_le_nilEnv.trans + indexedReplayNilEnv_le_ctorEnv)))) + +theorem indexedReplayBlock_le_ctorEnv : + indexedTreeBlockEnv ≤ indexedReplayCtorEnv := by + exact indexedReplayTypeEnv_le_leafEnv.trans + (indexedReplayLeafEnv_le_nodeEnv.trans + (indexedReplayNodeEnv_le_nilEnv.trans + indexedReplayNilEnv_le_ctorEnv)) + +theorem indexedReplayGenerationEnv : + BlockGenerationEnv indexedTreeGeneration indexedReplayCtorEnv := by + apply indexedTreeBlockGenerationWF.toBlockGenerationEnv + indexedReplayInput_le_ctorEnv indexedReplayBlock_le_ctorEnv + indexedReplayCtorEnv_ordered + · intro family hfamily + have hfamilies : indexedTreeGeneration.families = + [indexedTreeGeneration.families[0], + indexedTreeGeneration.families[1]] := rfl + rw [hfamilies] at hfamily + simp only [List.mem_cons, List.not_mem_nil, or_false] at hfamily + rcases hfamily with rfl | rfl <;> rfl + · intro constructor hconstructor + have hconstructors : indexedTreeGeneration.flatCtors = + [indexedTreeGeneration.flatCtors[0], + indexedTreeGeneration.flatCtors[1], + indexedTreeGeneration.flatCtors[2], + indexedTreeGeneration.flatCtors[3]] := rfl + rw [hconstructors] at hconstructor + simp only [List.mem_cons, List.not_mem_nil, or_false] at hconstructor + rcases hconstructor with rfl | rfl | rfl | rfl <;> rfl + +theorem indexedReplayFirstRecEnv_ordered : + indexedReplayFirstRecEnv.Ordered := by + refine .const indexedReplayCtorEnv_ordered ?_ + indexedReplay_addFirstRec + exact indexedReplayGenerationEnv.recursor_wf (.head _) + +theorem indexedReplayCtorEnv_le_firstRecEnv : + indexedReplayCtorEnv ≤ indexedReplayFirstRecEnv := + VEnv.addConst_le indexedReplay_addFirstRec + +theorem indexedReplayRecEnv_ordered : indexedReplayRecEnv.Ordered := by + refine .const indexedReplayFirstRecEnv_ordered ?_ + indexedReplay_addSecondRec + exact (indexedReplayGenerationEnv.recursor_wf + (.tail _ (.head _))).mono indexedReplayCtorEnv_le_firstRecEnv + +theorem indexedTreeKernelInfo_tr : + TrConstVal .safe natFinalEnv indexedTreeKernelInfo + indexedTreeType.toVConstVal := by + have hNat : natFinalEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr natFinalEnv indexedTreeKernelInfo.levelParams [] + indexedTreeKernelInfo.type indexedTreeType.type := by + tr_type_expr_tac + exact hshape.to_trExprS natFinalEnv_ordered trivial + (indexedTreeFamilyTypeWF indexedTreeType (.inl rfl)) + +theorem indexedTreeListKernelInfo_tr : + TrConstVal .safe indexedReplayFirstTypeEnv indexedTreeListKernelInfo + indexedTreeListType.toVConstVal := by + have hNat : indexedReplayFirstTypeEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr indexedReplayFirstTypeEnv + indexedTreeListKernelInfo.levelParams [] indexedTreeListKernelInfo.type + indexedTreeListType.type := by tr_type_expr_tac + exact hshape.to_trExprS indexedReplayFirstTypeEnv_ordered trivial + ((indexedTreeFamilyTypeWF indexedTreeListType (.inr rfl)).mono + (VEnv.addConst_le indexedReplay_addFirstType)) + +theorem indexedTreeLeafKernelInfo_tr : + TrConstVal .safe indexedReplayTypeEnv indexedTreeLeafKernelInfo + indexedTreeType.ctors[0] := by + have hNat : indexedReplayTypeEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + have hZero : indexedReplayTypeEnv.constants ``Nat.zero = + some InductiveFixtures.natType.ctors[0].toVConstant := rfl + have hSucc : indexedReplayTypeEnv.constants ``Nat.succ = + some InductiveFixtures.natType.ctors[1].toVConstant := rfl + have hTree : indexedReplayTypeEnv.constants ``IndexedTree = + some indexedTreeType.toVConstant := rfl + have hTreeList : indexedReplayTypeEnv.constants ``IndexedTreeList = + some indexedTreeListType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr indexedReplayTypeEnv + indexedTreeLeafKernelInfo.levelParams [] indexedTreeLeafKernelInfo.type + indexedTreeType.ctors[0].type := by tr_type_expr_tac + exact hshape.to_trExprS indexedReplayTypeEnv_ordered trivial + (indexedTreeCtorWF indexedTreeType.ctors[0] + (.inl (by simp [indexedTreeType]))) + +theorem indexedTreeNodeKernelInfo_tr : + TrConstVal .safe indexedReplayLeafEnv indexedTreeNodeKernelInfo + indexedTreeType.ctors[1] := by + have hNat : indexedReplayLeafEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + have hZero : indexedReplayLeafEnv.constants ``Nat.zero = + some InductiveFixtures.natType.ctors[0].toVConstant := rfl + have hSucc : indexedReplayLeafEnv.constants ``Nat.succ = + some InductiveFixtures.natType.ctors[1].toVConstant := rfl + have hTree : indexedReplayLeafEnv.constants ``IndexedTree = + some indexedTreeType.toVConstant := rfl + have hTreeList : indexedReplayLeafEnv.constants ``IndexedTreeList = + some indexedTreeListType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr indexedReplayLeafEnv + indexedTreeNodeKernelInfo.levelParams [] indexedTreeNodeKernelInfo.type + indexedTreeType.ctors[1].type := by tr_type_expr_tac + exact hshape.to_trExprS indexedReplayLeafEnv_ordered trivial + ((indexedTreeCtorWF indexedTreeType.ctors[1] + (.inl (by simp [indexedTreeType]))).mono + indexedReplayTypeEnv_le_leafEnv) + +theorem indexedTreeListNilKernelInfo_tr : + TrConstVal .safe indexedReplayNodeEnv indexedTreeListNilKernelInfo + indexedTreeListType.ctors[0] := by + have hNat : indexedReplayNodeEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + have hZero : indexedReplayNodeEnv.constants ``Nat.zero = + some InductiveFixtures.natType.ctors[0].toVConstant := rfl + have hSucc : indexedReplayNodeEnv.constants ``Nat.succ = + some InductiveFixtures.natType.ctors[1].toVConstant := rfl + have hTree : indexedReplayNodeEnv.constants ``IndexedTree = + some indexedTreeType.toVConstant := rfl + have hTreeList : indexedReplayNodeEnv.constants ``IndexedTreeList = + some indexedTreeListType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr indexedReplayNodeEnv + indexedTreeListNilKernelInfo.levelParams [] + indexedTreeListNilKernelInfo.type indexedTreeListType.ctors[0].type := by + tr_type_expr_tac + exact hshape.to_trExprS indexedReplayNodeEnv_ordered trivial + ((indexedTreeCtorWF indexedTreeListType.ctors[0] + (.inr (by simp [indexedTreeListType]))).mono + (indexedReplayTypeEnv_le_leafEnv.trans + indexedReplayLeafEnv_le_nodeEnv)) + +theorem indexedTreeListConsKernelInfo_tr : + TrConstVal .safe indexedReplayNilEnv indexedTreeListConsKernelInfo + indexedTreeListType.ctors[1] := by + have hNat : indexedReplayNilEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + have hZero : indexedReplayNilEnv.constants ``Nat.zero = + some InductiveFixtures.natType.ctors[0].toVConstant := rfl + have hSucc : indexedReplayNilEnv.constants ``Nat.succ = + some InductiveFixtures.natType.ctors[1].toVConstant := rfl + have hTree : indexedReplayNilEnv.constants ``IndexedTree = + some indexedTreeType.toVConstant := rfl + have hTreeList : indexedReplayNilEnv.constants ``IndexedTreeList = + some indexedTreeListType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr indexedReplayNilEnv + indexedTreeListConsKernelInfo.levelParams [] + indexedTreeListConsKernelInfo.type indexedTreeListType.ctors[1].type := by + tr_type_expr_tac + exact hshape.to_trExprS indexedReplayNilEnv_ordered trivial + ((indexedTreeCtorWF indexedTreeListType.ctors[1] + (.inr (by simp [indexedTreeListType]))).mono + (indexedReplayTypeEnv_le_leafEnv.trans + (indexedReplayLeafEnv_le_nodeEnv.trans + indexedReplayNodeEnv_le_nilEnv))) + +theorem indexedTreeRecKernelInfo_tr : + TrConstVal .safe indexedReplayCtorEnv indexedTreeRecKernelInfo + indexedTreeGeneration.recursors[0] := by + have hNat : indexedReplayCtorEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + have hZero : indexedReplayCtorEnv.constants ``Nat.zero = + some InductiveFixtures.natType.ctors[0].toVConstant := rfl + have hSucc : indexedReplayCtorEnv.constants ``Nat.succ = + some InductiveFixtures.natType.ctors[1].toVConstant := rfl + have hTree : indexedReplayCtorEnv.constants ``IndexedTree = + some indexedTreeType.toVConstant := rfl + have hTreeList : indexedReplayCtorEnv.constants ``IndexedTreeList = + some indexedTreeListType.toVConstant := rfl + have hLeaf : indexedReplayCtorEnv.constants ``IndexedTree.leaf = + some indexedTreeType.ctors[0].toVConstant := rfl + have hNode : indexedReplayCtorEnv.constants ``IndexedTree.node = + some indexedTreeType.ctors[1].toVConstant := rfl + have hNil : indexedReplayCtorEnv.constants ``IndexedTreeList.nil = + some indexedTreeListType.ctors[0].toVConstant := rfl + have hCons : indexedReplayCtorEnv.constants ``IndexedTreeList.cons = + some indexedTreeListType.ctors[1].toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr indexedReplayCtorEnv + indexedTreeRecKernelInfo.levelParams [] indexedTreeRecKernelInfo.type + indexedTreeGeneration.recursors[0].type := by tr_type_expr_tac + obtain ⟨u, hrec⟩ := indexedReplayGenerationEnv.recursor_wf (.head _) + exact hshape.to_trExprS indexedReplayCtorEnv_ordered trivial + ⟨.sort u, hrec⟩ + +theorem indexedTreeListRecKernelInfo_tr : + TrConstVal .safe indexedReplayFirstRecEnv indexedTreeListRecKernelInfo + indexedTreeGeneration.recursors[1] := by + have hNat : indexedReplayFirstRecEnv.constants ``Nat = + some InductiveFixtures.natType.toVConstant := rfl + have hZero : indexedReplayFirstRecEnv.constants ``Nat.zero = + some InductiveFixtures.natType.ctors[0].toVConstant := rfl + have hSucc : indexedReplayFirstRecEnv.constants ``Nat.succ = + some InductiveFixtures.natType.ctors[1].toVConstant := rfl + have hTree : indexedReplayFirstRecEnv.constants ``IndexedTree = + some indexedTreeType.toVConstant := rfl + have hTreeList : indexedReplayFirstRecEnv.constants ``IndexedTreeList = + some indexedTreeListType.toVConstant := rfl + have hLeaf : indexedReplayFirstRecEnv.constants ``IndexedTree.leaf = + some indexedTreeType.ctors[0].toVConstant := rfl + have hNode : indexedReplayFirstRecEnv.constants ``IndexedTree.node = + some indexedTreeType.ctors[1].toVConstant := rfl + have hNil : indexedReplayFirstRecEnv.constants ``IndexedTreeList.nil = + some indexedTreeListType.ctors[0].toVConstant := rfl + have hCons : indexedReplayFirstRecEnv.constants ``IndexedTreeList.cons = + some indexedTreeListType.ctors[1].toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr indexedReplayFirstRecEnv + indexedTreeListRecKernelInfo.levelParams [] + indexedTreeListRecKernelInfo.type + indexedTreeGeneration.recursors[1].type := by tr_type_expr_tac + obtain ⟨u, hrec⟩ := indexedReplayGenerationEnv.recursor_wf + (.tail _ (.head _)) + exact hshape.to_trExprS indexedReplayFirstRecEnv_ordered trivial + ⟨.sort u, hrec.mono indexedReplayCtorEnv_le_firstRecEnv⟩ + +def indexedReplayFirstTypeMap : ConstMap := + natMap.insert ``IndexedTree indexedTreeKernelInfo + +def indexedReplayTypeMap : ConstMap := + indexedReplayFirstTypeMap.insert ``IndexedTreeList + indexedTreeListKernelInfo + +def indexedReplayLeafMap : ConstMap := + indexedReplayTypeMap.insert ``IndexedTree.leaf indexedTreeLeafKernelInfo + +def indexedReplayNodeMap : ConstMap := + indexedReplayLeafMap.insert ``IndexedTree.node indexedTreeNodeKernelInfo + +def indexedReplayNilMap : ConstMap := + indexedReplayNodeMap.insert ``IndexedTreeList.nil + indexedTreeListNilKernelInfo + +def indexedReplayCtorMap : ConstMap := + indexedReplayNilMap.insert ``IndexedTreeList.cons + indexedTreeListConsKernelInfo + +def indexedReplayFirstRecMap : ConstMap := + indexedReplayCtorMap.insert ``IndexedTree.rec indexedTreeRecKernelInfo + +def indexedReplayMap : ConstMap := + indexedReplayFirstRecMap.insert ``IndexedTreeList.rec + indexedTreeListRecKernelInfo + +theorem indexedReplayFirstType_fresh : + natMap.find? ``IndexedTree = 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 indexedReplayFirstTypeMap_wf : indexedReplayFirstTypeMap.WF := + nat_aligned.map_wf.insert _ _ indexedReplayFirstType_fresh + +theorem indexedReplaySecondType_fresh : + indexedReplayFirstTypeMap.find? ``IndexedTreeList = none := by + rw [indexedReplayFirstTypeMap, nat_aligned.map_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 indexedReplayTypeMap_wf : indexedReplayTypeMap.WF := + indexedReplayFirstTypeMap_wf.insert _ _ indexedReplaySecondType_fresh + +theorem indexedReplayLeaf_fresh : + indexedReplayTypeMap.find? ``IndexedTree.leaf = none := by + rw [indexedReplayTypeMap, indexedReplayFirstTypeMap_wf.find?_insert, + indexedReplayFirstTypeMap, nat_aligned.map_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 indexedReplayLeafMap_wf : indexedReplayLeafMap.WF := + indexedReplayTypeMap_wf.insert _ _ indexedReplayLeaf_fresh + +theorem indexedReplayNode_fresh : + indexedReplayLeafMap.find? ``IndexedTree.node = none := by + rw [indexedReplayLeafMap, indexedReplayTypeMap_wf.find?_insert, + indexedReplayTypeMap, indexedReplayFirstTypeMap_wf.find?_insert, + indexedReplayFirstTypeMap, nat_aligned.map_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 indexedReplayNodeMap_wf : indexedReplayNodeMap.WF := + indexedReplayLeafMap_wf.insert _ _ indexedReplayNode_fresh + +theorem indexedReplayNil_fresh : + indexedReplayNodeMap.find? ``IndexedTreeList.nil = none := by + rw [indexedReplayNodeMap, indexedReplayLeafMap_wf.find?_insert, + indexedReplayLeafMap, indexedReplayTypeMap_wf.find?_insert, + indexedReplayTypeMap, indexedReplayFirstTypeMap_wf.find?_insert, + indexedReplayFirstTypeMap, nat_aligned.map_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 indexedReplayNilMap_wf : indexedReplayNilMap.WF := + indexedReplayNodeMap_wf.insert _ _ indexedReplayNil_fresh + +theorem indexedReplayCons_fresh : + indexedReplayNilMap.find? ``IndexedTreeList.cons = none := by + rw [indexedReplayNilMap, indexedReplayNodeMap_wf.find?_insert, + indexedReplayNodeMap, indexedReplayLeafMap_wf.find?_insert, + indexedReplayLeafMap, indexedReplayTypeMap_wf.find?_insert, + indexedReplayTypeMap, indexedReplayFirstTypeMap_wf.find?_insert, + indexedReplayFirstTypeMap, nat_aligned.map_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 indexedReplayCtorMap_wf : indexedReplayCtorMap.WF := + indexedReplayNilMap_wf.insert _ _ indexedReplayCons_fresh + +theorem indexedReplayFirstRec_fresh : + indexedReplayCtorMap.find? ``IndexedTree.rec = none := by + rw [indexedReplayCtorMap, indexedReplayNilMap_wf.find?_insert, + indexedReplayNilMap, indexedReplayNodeMap_wf.find?_insert, + indexedReplayNodeMap, indexedReplayLeafMap_wf.find?_insert, + indexedReplayLeafMap, indexedReplayTypeMap_wf.find?_insert, + indexedReplayTypeMap, indexedReplayFirstTypeMap_wf.find?_insert, + indexedReplayFirstTypeMap, nat_aligned.map_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 indexedReplayFirstRecMap_wf : indexedReplayFirstRecMap.WF := + indexedReplayCtorMap_wf.insert _ _ indexedReplayFirstRec_fresh + +theorem indexedReplaySecondRec_fresh : + indexedReplayFirstRecMap.find? ``IndexedTreeList.rec = none := by + rw [indexedReplayFirstRecMap, indexedReplayCtorMap_wf.find?_insert, + indexedReplayCtorMap, indexedReplayNilMap_wf.find?_insert, + indexedReplayNilMap, indexedReplayNodeMap_wf.find?_insert, + indexedReplayNodeMap, indexedReplayLeafMap_wf.find?_insert, + indexedReplayLeafMap, indexedReplayTypeMap_wf.find?_insert, + indexedReplayTypeMap, indexedReplayFirstTypeMap_wf.find?_insert, + indexedReplayFirstTypeMap, nat_aligned.map_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 indexedReplayMap_wf : indexedReplayMap.WF := + indexedReplayFirstRecMap_wf.insert _ _ indexedReplaySecondRec_fresh + +theorem indexedReplay_treeRec_lookup : + indexedReplayMap.find? ``IndexedTree.rec = + some indexedTreeRecKernelInfo := by + rw [indexedReplayMap, indexedReplayFirstRecMap_wf.find?_insert, + indexedReplayFirstRecMap, indexedReplayCtorMap_wf.find?_insert] + rfl + +theorem indexedReplay_treeListRec_lookup : + indexedReplayMap.find? ``IndexedTreeList.rec = + some indexedTreeListRecKernelInfo := by + rw [indexedReplayMap, indexedReplayFirstRecMap_wf.find?_insert] + rfl + +def indexedTreeAddInductBlockTrace : + AddInductBlockTrace natMap natFinalEnv indexedTreeDecl + indexedReplayMap indexedTreeFinalEnv where + generation := indexedTreeGeneration + blockEnv := indexedTreeBlockEnv + generation_wf := indexedTreeBlockGenerationWF + typeMap := indexedReplayTypeMap + typeEnv := indexedReplayTypeEnv + ctorMap := indexedReplayCtorMap + ctorEnv := indexedReplayCtorEnv + recEnv := indexedReplayRecEnv + addTypes := .cons { + info := indexedTreeKernelInfo + kind_eq := by simp [indexedTreeKernelInfo, + InductConstantKind.Matches] + tr := indexedTreeKernelInfo_tr + map_fresh := indexedReplayFirstType_fresh + env_add := rfl + map_add := rfl } + (.cons { + info := indexedTreeListKernelInfo + kind_eq := by simp [indexedTreeListKernelInfo, + InductConstantKind.Matches] + tr := indexedTreeListKernelInfo_tr + map_fresh := indexedReplaySecondType_fresh + env_add := rfl + map_add := rfl } .nil) + addCtors := .cons { + info := indexedTreeLeafKernelInfo + kind_eq := by simp [indexedTreeLeafKernelInfo, + InductConstantKind.Matches] + tr := indexedTreeLeafKernelInfo_tr + map_fresh := indexedReplayLeaf_fresh + env_add := rfl + map_add := rfl } + (.cons { + info := indexedTreeNodeKernelInfo + kind_eq := by simp [indexedTreeNodeKernelInfo, + InductConstantKind.Matches] + tr := indexedTreeNodeKernelInfo_tr + map_fresh := indexedReplayNode_fresh + env_add := rfl + map_add := rfl } + (.cons { + info := indexedTreeListNilKernelInfo + kind_eq := by simp [indexedTreeListNilKernelInfo, + InductConstantKind.Matches] + tr := indexedTreeListNilKernelInfo_tr + map_fresh := indexedReplayNil_fresh + env_add := rfl + map_add := rfl } + (.cons { + info := indexedTreeListConsKernelInfo + kind_eq := by simp [indexedTreeListConsKernelInfo, + InductConstantKind.Matches] + tr := indexedTreeListConsKernelInfo_tr + map_fresh := indexedReplayCons_fresh + env_add := rfl + map_add := rfl } .nil))) + addRecs := .cons { + info := indexedTreeRecKernelInfo + kind_eq := by simp [indexedTreeRecKernelInfo, + InductConstantKind.Matches] + tr := indexedTreeRecKernelInfo_tr + map_fresh := indexedReplayFirstRec_fresh + env_add := rfl + map_add := rfl } + (.cons { + info := indexedTreeListRecKernelInfo + kind_eq := by simp [indexedTreeListRecKernelInfo, + InductConstantKind.Matches] + tr := indexedTreeListRecKernelInfo_tr + map_fresh := indexedReplaySecondRec_fresh + env_add := rfl + map_add := rfl } .nil) + recK := by + intro recursor hrecursor + have hrecs : indexedTreeGeneration.recursors = + [indexedTreeGeneration.recursors[0], + indexedTreeGeneration.recursors[1]] := rfl + rw [hrecs] at hrecursor + simp only [List.mem_cons, List.not_mem_nil, or_false] at hrecursor + rcases hrecursor with rfl | rfl + · exact ⟨indexedTreeRecKernelInfo, + indexedReplay_treeRec_lookup, by decide⟩ + · exact ⟨indexedTreeListRecKernelInfo, + indexedReplay_treeListRec_lookup, by decide⟩ + addRules := ⟨rfl⟩ + +theorem indexedTreeAddInductBlock : + AddInductBlock natMap natFinalEnv indexedTreeDecl + indexedReplayMap indexedTreeFinalEnv := + ⟨indexedTreeAddInductBlockTrace⟩ + +theorem indexedTree_trEnv' : + TrEnv' .safe indexedReplayMap false indexedTreeFinalEnv := + .inductBlock indexedTreeAddInductBlock nat_trEnv' + +theorem indexedTree_verify_env_wf : indexedTreeFinalEnv.WF := + indexedTree_trEnv'.wf + +theorem indexedTree_verify_aligned : + Aligned .safe indexedReplayMap indexedTreeFinalEnv := + indexedTree_trEnv'.aligned + + + +/-! ## Trust-boundary manifests -/ + +/- The semantic generation and raw public transaction remain inside the +accepted Theory trust baseline. -/ +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.treeBlockGenerationWF' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms treeBlockGenerationWF + +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeBlockGenerationWF' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms indexedTreeBlockGenerationWF + +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.treeFinalEnv_ordered' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms treeFinalEnv_ordered + +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeFinalEnv_ordered' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#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 +axioms are deliberately absent. -/ +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.treeAddInductBlock' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms treeAddInductBlock + +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeAddInductBlock' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms indexedTreeAddInductBlock + +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.tree_verify_aligned' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms tree_verify_aligned + +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTree_verify_aligned' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms indexedTree_verify_aligned + +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.treeCheckedBlockWF' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms treeCheckedBlockWF + +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeCheckedBlockWF' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms indexedTreeCheckedBlockWF + +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.treeNormalizationBlockWF' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms treeNormalizationBlockWF + +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeNormalizationBlockWF' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms indexedTreeNormalizationBlockWF + +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.treeValidationCertificate' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms treeValidationCertificate + +/-- +info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeValidationCertificate' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms indexedTreeValidationCertificate + +end Lean4Lean.MutualInductiveReplayFixtures diff --git a/Lean4Lean/Verify/Environment/Normalization.lean b/Lean4Lean/Verify/Environment/Normalization.lean index 2aafb958..b5a87ea6 100644 --- a/Lean4Lean/Verify/Environment/Normalization.lean +++ b/Lean4Lean/Verify/Environment/Normalization.lean @@ -1,5 +1,5 @@ import Lean4Lean.Verify.TypeChecker -import Lean4Lean.Inductive.Add +import Lean4Lean.Inductive.ValidationTrace namespace Lean4Lean open Lean hiding Environment Exception @@ -192,6 +192,23 @@ theorem VEnv.HasPrimitives.addConst (by simp [reflectedPrimitiveNames])] using h) exact ⟨hconstant, hnil.mono hle, hcons.mono hle⟩ } +/-- A verified implementation local context remains verified when the Theory +environment grows. Kernel local declarations and their free-variable names +are unchanged; only their translations and typing derivations are transported +monotonically. -/ +theorem MLCtx.WF.mono + {env env' : VEnv} (henv : env ≤ env') : + ∀ {context : MLCtx} {Us : List Name}, + context.WF env Us → context.WF env' Us + | .nil, _, _ => trivial + | .vlam fv name type type' binderInfo tail, Us, + ⟨tailWF, fresh, type_tr, typeWF⟩ => + ⟨tailWF.mono henv, fresh, type_tr.mono henv, typeWF.mono henv⟩ + | .vlet fv name type value type' value' tail, Us, + ⟨tailWF, fresh, type_tr, value_tr, valueWF⟩ => + ⟨tailWF.mono henv, fresh, type_tr.mono henv, + value_tr.mono henv, valueWF.mono henv⟩ + /-- Kernel-side counterpart of `VEnv.HasPrimitives.of_avoids`: if an isolated constant map contains no hard-coded primitive name, the safety premise needed by `VContext` is vacuous. -/ @@ -252,7 +269,7 @@ structure WhnfRun (env : VEnv) (Us : List Name) (Δ : VLCtx) vlctx_eq : context.vlctx = Δ state_wf : VState.WF context {} lhs_tr : TrExprS env Us Δ lhs lhs' - rhs_tr : TrExpr env Us Δ rhs rhs' + rhs_tr : TrExprS env Us Δ rhs rhs' recursionFuel : Nat run_eq : ∃ state : State, Inner.whnf' lhs (Methods.withFuel recursionFuel) @@ -276,7 +293,7 @@ def WhnfRun.ofCandidateStep (vlctx_eq : context.vlctx = Δ) (state_wf : VState.WF context {}) (lhs_tr : TrExprS env Us Δ step.source lhs') - (rhs_tr : TrExpr env Us Δ step.result rhs') + (rhs_tr : TrExprS env Us Δ step.result rhs') (recursionFuel : Nat) (hdepth : step.context.fuel.recDepth = recursionFuel + 1) : WhnfRun env Us Δ step.source step.result lhs' rhs' where @@ -316,8 +333,10 @@ theorem WhnfRun.isDefEqU simpa only [VContext.TrExprS, run.venv_eq, run.lparams_eq, run.vlctx_eq] using run.lhs_tr have hrhs : run.context.TrExpr rhs rhs' := by - simpa only [VContext.TrExpr, run.venv_eq, run.lparams_eq, - run.vlctx_eq] using run.rhs_tr + have strict : run.context.TrExprS rhs rhs' := by + simpa only [VContext.TrExprS, run.venv_eq, run.lparams_eq, + run.vlctx_eq] using run.rhs_tr + exact strict.trExpr run.context.Ewf run.context.Δwf obtain ⟨state, hrun⟩ := run.run_eq obtain ⟨_, _, _, _, _, htr⟩ := (TypeChecker.Inner.whnf'.WF hlhs @@ -677,6 +696,101 @@ def CandidateContextRun.root have h := congrArg (fun c : TypeChecker.Context => c.fuel) run.context_eq simpa only [AddInductive.Context.toTypeChecker] using h +/-- Reset only the implementation and Theory local contexts while retaining +the exact environment, safety mode, level parameters, fuel, and name +generator owned by a candidate context. Constructor root `checkType` uses +precisely this context before the validation telescope re-enters the retained +family locals. -/ +def CandidateContextRun.withEmptyLocalContext + (run : CandidateContextRun candidateContext) : + CandidateContextRun candidateContext.withEmptyLocalContext := by + let context : VContext := + { run.context with + lctx := {} + mlctx := .nil + mlctx_wf := trivial + lctx_eq := rfl } + have context_eq : context.toContext = + candidateContext.withEmptyLocalContext.toTypeChecker := by + change { run.context.toContext with lctx := {} } = + candidateContext.withEmptyLocalContext.toTypeChecker + rw [run.context_eq] + rfl + refine ⟨context, context_eq, ?_, run.namePrefix_ne⟩ + exact VState.WF.empty_of_reserves context (by + intro fv hfv + change fv ∈ VLCtx.fvars ([] : VLCtx) at hfv + simp at hfv) + +/-- Package a retained full-check observation at an already named strict +Theory source. The verified execution still chooses the inferred Theory +type; the duplicate source translation returned by refinement is discarded, +not identified by syntactic equality. -/ +theorem CheckTypeRun.exists_ofCandidateStep + (step : AddInductive.CandidateCheckTypeStep) + (hvalid : step.Valid) + (contextRun : CandidateContextRun step.context) + (source' : VExpr) + (source_tr : contextRun.context.TrExprS step.source source') : + ∃ inferred', Nonempty + (CheckTypeRun contextRun.context.venv contextRun.context.lparams + contextRun.context.vlctx step.source step.inferred source' inferred') := by + obtain ⟨_, inferred', _, inferred_tr, _⟩ := + candidateCheckTypeStep_exists_translation step hvalid + contextRun.context contextRun.context_eq contextRun.state_wf + source_tr.fvarsIn step.context.fuel.recDepth rfl + exact ⟨inferred', ⟨CheckTypeRun.ofCandidateStep step hvalid + contextRun.context contextRun.context_eq rfl rfl rfl + contextRun.state_wf source_tr inferred_tr + step.context.fuel.recDepth rfl⟩⟩ + +/-- Full-check packaging when only the checker's syntactic free-variable +premise is known. Both strict Theory endpoints are then selected by the +verified refinement of the retained execution. -/ +theorem CheckTypeRun.exists_ofCandidateStepFVars + (step : AddInductive.CandidateCheckTypeStep) + (hvalid : step.Valid) + (contextRun : CandidateContextRun step.context) + (source_fvars : + step.source.FVarsIn (· ∈ contextRun.context.vlctx.fvars)) : + ∃ source' inferred', Nonempty + (CheckTypeRun contextRun.context.venv contextRun.context.lparams + contextRun.context.vlctx step.source step.inferred source' inferred') := by + obtain ⟨source', inferred', source_tr, inferred_tr, _⟩ := + candidateCheckTypeStep_exists_translation step hvalid + contextRun.context contextRun.context_eq contextRun.state_wf + source_fvars step.context.fuel.recDepth rfl + exact ⟨source', inferred', ⟨CheckTypeRun.ofCandidateStep step hvalid + contextRun.context contextRun.context_eq rfl rfl rfl + contextRun.state_wf source_tr inferred_tr + step.context.fuel.recDepth rfl⟩⟩ + +/-- Package one retained WHNF observation and keep the strict Theory +translation selected for its exact kernel result. -/ +theorem WhnfRun.exists_ofCandidateStep + (step : AddInductive.CandidateWhnfStep) + (hvalid : step.Valid) + (contextRun : CandidateContextRun step.context) + (source' : VExpr) + (source_tr : contextRun.context.TrExprS step.source source') + (recursionFuel : Nat) + (hdepth : step.context.fuel.recDepth = recursionFuel + 1) : + ∃ result', contextRun.context.TrExprS step.result result' ∧ + Nonempty (WhnfRun contextRun.context.venv + contextRun.context.lparams contextRun.context.vlctx + step.source step.result source' result') := by + obtain ⟨state, run⟩ := step.innerRun recursionFuel hdepth hvalid + rw [← contextRun.context_eq] at run + obtain ⟨_, _, _, _, _, resultTranslation⟩ := + (Inner.whnf'.WF source_tr + (Methods.withFuel recursionFuel) Methods.withFuel.WF) + contextRun.state_wf step.result state run + obtain ⟨result', result_tr, _⟩ := resultTranslation + exact ⟨result', result_tr, ⟨WhnfRun.ofCandidateStep step hvalid + contextRun.context contextRun.context_eq rfl rfl rfl + contextRun.state_wf source_tr result_tr + recursionFuel hdepth⟩⟩ + /-- Extend a verified candidate context by precisely the raw local declaration used by `AddInductive.Context.pushLocalDecl`. @@ -786,7 +900,7 @@ def CandidateNodeRun.ofCandidate (state_wf : VState.WF context {}) (source_tr : TrExprS env Us Δ source source') (inferred_tr : TrExprS env Us Δ inferred inferred') - (result_tr : TrExpr env Us Δ result result') + (result_tr : TrExprS env Us Δ result result') (checkFuel whnfFuel : Nat) (checkDepth : candidateContext.fuel.recDepth = checkFuel) (whnfDepth : candidateContext.fuel.recDepth = whnfFuel + 1) : @@ -850,7 +964,7 @@ theorem CandidateNodeRun.exists_ofCandidate candidateContext source inferred result checked normalized context context_eq rfl rfl rfl state_wf source_tr checkedTyping.2.2.1 - (result_tr.trExpr context.Ewf context.Δwf) + result_tr checkFuel whnfFuel checkDepth whnfDepth /-- Construct a paired candidate node with a caller-selected Theory endpoint @@ -869,7 +983,7 @@ theorem CandidateNodeRun.exists_ofCandidateAtResult (state_wf : VState.WF context {}) (source' result' : VExpr) (source_tr : context.TrExprS source source') - (result_tr : context.TrExpr result result') + (result_tr : context.TrExprS result result') (checkFuel whnfFuel : Nat) (checkDepth : candidateContext.fuel.recDepth = checkFuel) (whnfDepth : candidateContext.fuel.recDepth = whnfFuel + 1) : @@ -1019,6 +1133,167 @@ inductive CandidateExprIdentity : annotations annotationsEq checked normalized domainCandidate bodyCandidate) +private def candidateExprIdentityBinderInfoEq : + Lean.BinderInfo → Lean.BinderInfo → Bool + | .default, .default + | .implicit, .implicit + | .strictImplicit, .strictImplicit + | .instImplicit, .instImplicit => true + | _, _ => false + +private theorem candidateExprIdentityBinderInfoEq_sound + (left right : Lean.BinderInfo) + (h : candidateExprIdentityBinderInfoEq left right = true) : + left = right := by + cases left <;> cases right <;> + simp_all [candidateExprIdentityBinderInfoEq] + +/-- Transparent structural equality sufficient for identity-normalizing +candidate traces. Metadata nodes are conservatively rejected: the retained +generation spine never needs an opaque metadata equality to justify source +identity. -/ +private def candidateExprIdentityExprEq : Lean.Expr → Lean.Expr → Bool + | .bvar i, .bvar j => i == j + | .fvar i, .fvar j => i == j + | .mvar i, .mvar j => i == j + | .sort u, .sort v => u == v + | .const n us, .const n' us' => n == n' && us == us' + | .app f a, .app f' a' => + candidateExprIdentityExprEq f f' && + candidateExprIdentityExprEq a a' + | .lam n t b bi, .lam n' t' b' bi' => + n == n' && candidateExprIdentityExprEq t t' && + candidateExprIdentityExprEq b b' && + candidateExprIdentityBinderInfoEq bi bi' + | .forallE n t b bi, .forallE n' t' b' bi' => + n == n' && candidateExprIdentityExprEq t t' && + candidateExprIdentityExprEq b b' && + candidateExprIdentityBinderInfoEq bi bi' + | .letE n t v b nd, .letE n' t' v' b' nd' => + n == n' && candidateExprIdentityExprEq t t' && + candidateExprIdentityExprEq v v' && + candidateExprIdentityExprEq b b' && nd == nd' + | .lit a, .lit b => a == b + | .proj n i s, .proj n' i' s' => + n == n' && i == i' && candidateExprIdentityExprEq s s' + | _, _ => false + +private theorem candidateExprIdentityExprEq_sound : + ∀ (left right : Lean.Expr), + candidateExprIdentityExprEq left right = true → left = right := by + intro left right h + induction left generalizing right with + | bvar i => + cases right <;> + simp_all [candidateExprIdentityExprEq, beq_iff_eq] + | fvar i => + cases right <;> + simp_all [candidateExprIdentityExprEq, beq_iff_eq] + | mvar i => + cases right <;> + simp_all [candidateExprIdentityExprEq, beq_iff_eq] + | sort u => + cases right <;> + simp_all [candidateExprIdentityExprEq, beq_iff_eq] + | const n us => + cases right <;> + simp_all [candidateExprIdentityExprEq, beq_iff_eq] + | app fn arg fnIH argIH => + cases right with + | app fn' arg' => + simp only [candidateExprIdentityExprEq, + Bool.and_eq_true] at h + rw [fnIH fn' h.1, argIH arg' h.2] + | _ => simp_all [candidateExprIdentityExprEq] + | lam name type body binderInfo typeIH bodyIH => + cases right with + | lam name' type' body' binderInfo' => + simp only [candidateExprIdentityExprEq, Bool.and_eq_true, + beq_iff_eq] at h + rw [h.1.1.1, typeIH type' h.1.1.2, + bodyIH body' h.1.2, + candidateExprIdentityBinderInfoEq_sound _ _ h.2] + | _ => simp_all [candidateExprIdentityExprEq] + | forallE name type body binderInfo typeIH bodyIH => + cases right with + | forallE name' type' body' binderInfo' => + simp only [candidateExprIdentityExprEq, Bool.and_eq_true, + beq_iff_eq] at h + rw [h.1.1.1, typeIH type' h.1.1.2, + bodyIH body' h.1.2, + candidateExprIdentityBinderInfoEq_sound _ _ h.2] + | _ => simp_all [candidateExprIdentityExprEq] + | letE name type value body nondep typeIH valueIH bodyIH => + cases right with + | letE name' type' value' body' nondep' => + simp only [candidateExprIdentityExprEq, Bool.and_eq_true, + beq_iff_eq] at h + rw [h.1.1.1.1, typeIH type' h.1.1.1.2, + valueIH value' h.1.1.2, bodyIH body' h.1.2, h.2] + | _ => simp_all [candidateExprIdentityExprEq] + | lit literal => + cases right <;> + simp_all [candidateExprIdentityExprEq, beq_iff_eq] + | mdata data expr exprIH => + cases right <;> simp_all [candidateExprIdentityExprEq] + | proj typeName idx struct structIH => + cases right with + | proj typeName' idx' struct' => + simp only [candidateExprIdentityExprEq, Bool.and_eq_true, + beq_iff_eq] at h + rw [h.1.1, h.1.2, structIH struct' h.2] + | _ => simp_all [candidateExprIdentityExprEq] + +/-- Executable sufficient check for the recursive identity witness consumed +by generation. Unlike a root-only equality, it checks every retained domain, +body, annotation result, and terminal node. -/ +def CandidateExprIdentity.check : + {candidateContext : AddInductive.Context} → {source : Lean.Expr} → + AddInductive.CandidateExprTrace candidateContext source → Bool + | _, _, .terminal _ source _ result _ _ => + candidateExprIdentityExprEq result source + | _, _, .forallE _ source _ name domain body binderInfo _ annotations _ _ _ + domainCandidate bodyCandidate => + candidateExprIdentityExprEq source + (.forallE name domain body binderInfo) && + candidateExprIdentityExprEq annotations.consumed domain && + CandidateExprIdentity.check domainCandidate && + CandidateExprIdentity.check bodyCandidate + +/-- Executable sufficient equality check for the terminal expression selected +by a candidate trace. This is useful when the family validator must name its +result universe without unfolding the proof-carrying trace. -/ +def CandidateExprIdentity.terminalCheck + (trace : AddInductive.CandidateExprTrace candidateContext source) + (expected : Lean.Expr) : Bool := + candidateExprIdentityExprEq trace.terminalResult expected + +theorem CandidateExprIdentity.terminalResult_eq_of_check + {trace : AddInductive.CandidateExprTrace candidateContext source} + {expected : Lean.Expr} + (h : CandidateExprIdentity.terminalCheck trace expected = true) : + trace.terminalResult = expected := + candidateExprIdentityExprEq_sound _ _ h + +/-- A successful structural check yields the full recursive identity witness; +the Boolean contributes no semantic authority beyond these proved equalities. -/ +theorem CandidateExprIdentity.of_check + {trace : AddInductive.CandidateExprTrace candidateContext source} + (h : CandidateExprIdentity.check trace = true) : + CandidateExprIdentity trace := by + induction trace with + | terminal context source inferred result checked normalized => + simp only [CandidateExprIdentity.check] at h + exact .terminal (candidateExprIdentityExprEq_sound result source h) + | forallE context source inferred name domain body binderInfo fresh + annotations annotationsEq checked normalized domainCandidate + bodyCandidate domainIH bodyIH => + simp only [CandidateExprIdentity.check, Bool.and_eq_true] at h + exact .forallE domainCandidate bodyCandidate + (candidateExprIdentityExprEq_sound _ _ h.1.1.1) + (candidateExprIdentityExprEq_sound _ _ h.1.1.2) + (domainIH h.1.2) (bodyIH h.2) + /-- An identity-normalizing trace necessarily preserves the stored main Pi spine. This turns the recursive identity witness into the Boolean gate used by the generation assembler. -/ @@ -1030,7 +1305,7 @@ theorem CandidateExprIdentity.storedSpine | terminal => rfl | forallE _ _ source_eq _ _ _ _ bodyIH => simp [AddInductive.CandidateExprTrace.storedSpine, - source_eq, bodyIH] + source_eq, Expr.structuralEq_refl, bodyIH] /-- Exact component inversion for a strict translation of a kernel Pi. -/ theorem TrExprS.forallE_components @@ -1168,13 +1443,11 @@ theorem CandidateExprRun.exists_ofIdentity induction identity generalizing source' with | @terminal result source context inferred checked normalized result_eq => subst result - have result_tr : candidateRun.context.TrExpr source source' := - source_tr.trExpr candidateRun.context.Ewf candidateRun.context.Δwf obtain ⟨inferred', ⟨node⟩⟩ := CandidateNodeRun.exists_ofCandidateAtResult context source inferred source checked normalized candidateRun.context candidateRun.context_eq candidateRun.state_wf - source' source' source_tr result_tr + source' source' source_tr source_tr context.fuel.recDepth whnfFuel rfl whnfDepth exact ⟨inferred', ⟨.terminal node⟩⟩ | @forallE context domain name binderInfo source inferred body fresh @@ -1186,17 +1459,13 @@ theorem CandidateExprRun.exists_ofIdentity TypeChecker.TrExprS.forallE_components source_tr obtain ⟨u, domainType⟩ := domainWF obtain ⟨v, bodyType⟩ := bodyWF - have result_tr : candidateRun.context.TrExpr - (.forallE name domain body binderInfo) - (.forallE domain' body') := - source_tr.trExpr candidateRun.context.Ewf candidateRun.context.Δwf obtain ⟨inferred', ⟨node⟩⟩ := CandidateNodeRun.exists_ofCandidateAtResult context (.forallE name domain body binderInfo) inferred (.forallE name domain body binderInfo) checked normalized candidateRun.context candidateRun.context_eq candidateRun.state_wf (.forallE domain' body') (.forallE domain' body') - source_tr result_tr + source_tr source_tr context.fuel.recDepth whnfFuel rfl whnfDepth obtain ⟨domainInferred', ⟨domainRun⟩⟩ := domainIH candidateRun domain' domain_tr whnfDepth @@ -1378,7 +1647,15 @@ theorem CandidateExprRun.view_tr (run : CandidateExprRun env Us trace Δ source' view' inferred') : TrExpr env Us Δ trace.view view' := by induction run with - | terminal node => exact node.whnf.rhs_tr + | @terminal Δ context source inferred result source' result' inferred' + checked normalized node => + have henv : VEnv.WF env := by + simpa only [node.whnf.venv_eq] using node.whnf.context.Ewf + have hΔ : VLCtx.WF env Us.length Δ := by + simpa only [node.whnf.venv_eq, node.whnf.lparams_eq, + node.whnf.vlctx_eq] using node.whnf.context.Δwf + simpa only [AddInductive.CandidateExprTrace.view] using + node.whnf.rhs_tr.trExpr henv hΔ | @forallE domain context name binderInfo Δ source inferred body source' domain' body' inferred' domainView' domainInferred' storedDomain' bodyΔ storedBody' bodyView' bodyInferred' u v fresh @@ -1444,6 +1721,133 @@ theorem CandidateExprRun.view_tr · simpa only [AddInductive.CandidateExprTrace.view, habstract] using bodyMoved +/-- Exact-translation uniqueness for every expression that contributes to a +candidate view. The abstracted-body clause names the syntax stored by +`CandidateExprTrace.view`, while the recursive body clause supports the next +candidate node. Projections are intentionally excluded: their verified +Theory relation is only unique up to definitional equality. -/ +def CandidateExprTraceViewIsUnique : + {context : AddInductive.Context} → {source : Expr} → + AddInductive.CandidateExprTrace context source → Prop + | _, _, .terminal _ _ _ result _ _ => TrExprS.IsUnique result + | _, _, .forallE context _ _ _ _ _ _ _ _ _ _ _ domain body => + CandidateExprTraceViewIsUnique domain ∧ + CandidateExprTraceViewIsUnique body ∧ + TrExprS.IsUnique (body.view.abstract #[context.freshExpr]) + +/-- The recursive uniqueness certificate in particular covers the complete +view reconstructed at this candidate node. -/ +theorem CandidateExprTraceViewIsUnique.view + {context : AddInductive.Context} {source : Expr} + {trace : AddInductive.CandidateExprTrace context source} + (unique : CandidateExprTraceViewIsUnique trace) : + TrExprS.IsUnique trace.view := by + induction trace with + | terminal => exact unique + | forallE context source inferred name domain body binderInfo fresh + annotations annotationsEq checked normalized domainCandidate bodyCandidate + domainIH bodyIH => + exact ⟨domainIH unique.1, unique.2.2⟩ + +/-- A projection-free candidate view retains the strict Theory translation +selected componentwise by its recursive semantic run. + +The ordinary `view_tr` theorem must use weak translation because a projection +endpoint is only definitionally determined. Under the explicit uniqueness +condition, recursive abstraction and context transport select the exact +analyzer-owned expression instead. -/ +theorem CandidateExprRun.view_tr_strict + {env : VEnv} {Us : List Name} + {candidateContext : AddInductive.Context} {source : Expr} + {trace : AddInductive.CandidateExprTrace candidateContext source} + {Δ : VLCtx} {source' view' inferred' : VExpr} + (run : CandidateExprRun env Us trace Δ source' view' inferred') + (unique : CandidateExprTraceViewIsUnique trace) : + TrExprS env Us Δ trace.view view' := by + induction run with + | terminal node => + simpa only [AddInductive.CandidateExprTrace.view] using + node.whnf.rhs_tr + | @forallE domain context name binderInfo Δ source inferred body + source' domain' body' inferred' domainView' domainInferred' + storedDomain' bodyΔ storedBody' bodyView' bodyInferred' u v fresh + checked normalized annotations annotationsEq domainCandidate + bodyCandidate node domainRun annotationsRun bodyRun domainType bodyType + bodySource bodyContext domainIH bodyIH => + rcases unique with ⟨domainUnique, bodyUnique, abstractUnique⟩ + have domainStrict := domainIH domainUnique + have bodyStrict : TrExprS env Us + ((some (context.freshFVarId, + annotations.consumed.fvarsList), .vlam storedDomain') :: Δ) + bodyCandidate.view bodyView' := by + simpa only [bodyContext] using bodyIH bodyUnique + have bodyAbstract := bodyStrict.abstract VLCtx.Abstract.zero + have henv : VEnv.WF env := by + simpa only [node.check.venv_eq] using node.check.context.Ewf + have hΔ : VLCtx.WF env Us.length Δ := by + simpa only [node.check.venv_eq, node.check.lparams_eq, + node.check.vlctx_eq] using node.check.context.Δwf + obtain ⟨_, domainTypeEq⟩ := + domainType.uniq henv hΔ.toCtx domainRun.evidence.isDefEq + have domainDef : env.IsDefEq Us.length Δ.toCtx + domain' domainView' (.sort u) := + (DefEqEvidence.change domainTypeEq.symm domainRun.evidence).isDefEq + have annotationDef := + annotationsRun.isDefEqU.of_l henv hΔ.toCtx domainType + have storedToView : env.IsDefEq Us.length Δ.toCtx + storedDomain' domainView' (.sort u) := + annotationDef.symm.trans domainDef + have hctx : VLCtx.IsDefEq env Us.length + ((none, .vlam storedDomain') :: Δ) + ((none, .vlam domainView') :: Δ) := + .cons (.refl henv hΔ) (by nofun) (.vlam storedToView) + obtain ⟨bodyMoved', bodyMoved⟩ := + bodyAbstract.defeqDFC henv hctx + have habstract : + bodyCandidate.view.abstract #[context.freshExpr] = + Expr.abstract1 context.freshFVarId bodyCandidate.view := by + rw [show #[context.freshExpr] = + ⟨[context.freshFVarId].map Expr.fvar⟩ by rfl] + simp only [Expr.abstract_eq, Expr.abstractList] + have bodyAbstractArray : TrExprS env Us + ((none, .vlam storedDomain') :: Δ) + (bodyCandidate.view.abstract #[context.freshExpr]) bodyView' := by + simpa only [habstract] using bodyAbstract + have bodyMovedArray : TrExprS env Us + ((none, .vlam domainView') :: Δ) + (bodyCandidate.view.abstract #[context.freshExpr]) bodyMoved' := by + simpa only [habstract] using bodyMoved + have bodyMoved_eq : bodyMoved' = bodyView' := by + exact (bodyAbstractArray.unique' + (.cons .base .vlam) abstractUnique bodyMovedArray).symm + subst bodyMoved' + have bodyEvidence := bodyRun.evidence + rw [bodyContext] at bodyEvidence + simp only [VLCtx.toCtx] at bodyEvidence + have annotationContext : VLCtx.IsDefEq env Us.length + ((none, .vlam domain') :: Δ) + ((none, .vlam storedDomain') :: Δ) := + .cons (.refl henv hΔ) (by nofun) (.vlam annotationDef) + have bodyStoredType := + bodySource.hasType.2.defeqDFC henv annotationContext.defeqCtx + have hBodyΓ : OnCtx (storedDomain' :: Δ.toCtx) + (env.IsType Us.length) := + ⟨hΔ.toCtx, ⟨_, annotationDef.hasType.2⟩⟩ + obtain ⟨_, bodyTypeEq⟩ := + bodyStoredType.uniq henv hBodyΓ bodyEvidence.isDefEq + have bodyDefStored : env.IsDefEq Us.length + (storedDomain' :: Δ.toCtx) storedBody' bodyView' (.sort v) := + (DefEqEvidence.change bodyTypeEq.symm bodyEvidence).isDefEq + have bodyDefMoved := + bodyDefStored.defeqDFC henv hctx.defeqCtx + simpa only [AddInductive.CandidateExprTrace.view, habstract] using + TrExprS.forallE + (⟨u, domainDef.hasType.2⟩ : + env.IsType Us.length Δ.toCtx domainView') + (⟨v, bodyDefMoved.hasType.2⟩ : + env.IsType Us.length (domainView' :: Δ.toCtx) bodyView') + domainStrict bodyMoved + /-- Root-level verified context and translations for an exact executable candidate expression and an explicitly named Theory view. @@ -1606,6 +2010,35 @@ theorem CandidateExprSemanticRootInput.exists input.venv_eq input.lparams_eq input.vlctx_eq input.source_tr input.whnfFuel input.whnfDepth +/-- Interpret an identity-normalizing staged root at the strict Theory +translation already owned by its source input. This keeps the endpoint +definitionally fixed without caller-supplied WHNF data or a +`Classical.choice` over the general semantic interpreter. -/ +def CandidateExprSemanticRootInput.semanticOfIdentity + {env : VEnv} {Us : List Name} {source : Expr} + {candidate : AddInductive.CandidateExpr source} {source' : VExpr} + (input : CandidateExprSemanticRootInput env Us candidate source') + (identity : CandidateExprIdentity candidate.trace) : + CandidateExprSemanticRootRun env Us candidate source' where + 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 := source' + recursive := by + have source_tr : input.contextRun.context.TrExprS source source' := by + simpa only [VContext.TrExprS, input.venv_eq, input.lparams_eq, + input.vlctx_eq] using input.source_tr + obtain ⟨inferred, ⟨recursive⟩⟩ := + CandidateExprRun.exists_ofIdentity candidate.trace identity + input.contextRun source' source_tr input.whnfFuel input.whnfDepth + refine ⟨inferred, ?_⟩ + simpa only [input.venv_eq, input.lparams_eq, input.vlctx_eq] using + recursive + /-- One explicitly verified root stage shared by every candidate expression interpreted before or after family insertion. @@ -1966,7 +2399,7 @@ private theorem CandidateExprRun.spineEvidenceAux obtain ⟨sourceEq, bodyAligned⟩ := aligned have alignedSource_tr : TrExprS env Us rawΔ (.forallE name domain body binderInfo) rawSource' := - rawSource_tr.eqv sourceEq + rawSource_tr.eqv (Expr.structuralEq_eqv sourceEq) let @TrExprS.forallE _ _ rawDomain rawBody _ _ _ _ _ rawDomainType rawBodyType rawDomain_tr rawBody_tr := alignedSource_tr have henv : VEnv.WF env := by @@ -2126,6 +2559,208 @@ theorem CandidateExprRun.env_wf | forallE _ _ _ _ node => simpa only [node.check.venv_eq] using node.check.context.Ewf +/-- Recover the exact verified candidate context reached at the end of the +main Pi spine. + +`CandidateExprRun` retains the semantic context at every recursive node, but +its public indices deliberately mention only the translated local context. +Constructor validation, on the other hand, resumes in the implementation +`Context` returned by the family traversal. This projection reconnects the +two without reconstructing a local context from names: starting from the +root `CandidateContextRun`, each Pi case repeats the already-certified +annotation equality and the exact `pushLocalDecl` used by the candidate. -/ +theorem CandidateExprRun.terminalContextRun + {env : VEnv} {Us : List Name} + {candidateContext : AddInductive.Context} {source : Expr} + {trace : AddInductive.CandidateExprTrace candidateContext source} + {Δ : VLCtx} {source' view' inferred' : VExpr} + (run : CandidateExprRun env Us trace Δ source' view' inferred') + (contextRun : CandidateContextRun candidateContext) + (venv_eq : contextRun.context.venv = env) + (lparams_eq : contextRun.context.lparams = Us) + (vlctx_eq : contextRun.context.vlctx = Δ) : + ∃ terminalRun : CandidateContextRun trace.terminalContext, + terminalRun.context.venv = env ∧ + terminalRun.context.lparams = Us := by + induction run with + | terminal node => + exact ⟨by + simpa only [AddInductive.CandidateExprTrace.terminalContext] using + contextRun, + venv_eq, lparams_eq⟩ + | @forallE domain context name binderInfo Δ source inferred body + source' domain' body' inferred' domainView' domainInferred' + storedDomain' bodyΔ storedBody' bodyView' bodyInferred' u v fresh + checked normalized annotations annotationsEq domainCandidate + bodyCandidate node domainRun annotationsRun bodyRun domainType bodyType + bodySource bodyContext domainIH bodyIH => + have storedDomain_tr : contextRun.context.TrExprS + annotations.consumed storedDomain' := by + simpa only [VContext.TrExprS, venv_eq, lparams_eq, vlctx_eq] using + annotationsRun.rhs_tr + have henv : VEnv.WF env := by + simpa only [venv_eq] using contextRun.context.Ewf + have hΔ : OnCtx Δ.toCtx (env.IsType Us.length) := by + simpa only [venv_eq, lparams_eq, vlctx_eq] using + contextRun.context.Δwf.toCtx + have storedDomain_type : env.IsType Us.length Δ.toCtx storedDomain' := by + have annotationDef := annotationsRun.isDefEqU.of_l henv hΔ domainType + exact ⟨u, annotationDef.hasType.2⟩ + let nextContextRun := contextRun.pushLocalDecl name binderInfo + annotations.consumed fresh storedDomain' storedDomain_tr (by + change contextRun.context.venv.IsType + contextRun.context.lparams.length + contextRun.context.vlctx.toCtx storedDomain' + rw [venv_eq, lparams_eq, vlctx_eq] + exact storedDomain_type) + have nextVenv : nextContextRun.context.venv = env := by + simp only [nextContextRun, CandidateContextRun.pushLocalDecl_venv, + venv_eq] + have nextLparams : nextContextRun.context.lparams = Us := by + simp only [nextContextRun, CandidateContextRun.pushLocalDecl_lparams, + lparams_eq] + have nextVlctx : nextContextRun.context.vlctx = bodyΔ := by + simp only [nextContextRun, CandidateContextRun.pushLocalDecl_vlctx] + rw [vlctx_eq, bodyContext] + obtain ⟨terminalRun, terminalVenv, terminalLparams⟩ := + bodyIH nextContextRun nextVenv nextLparams nextVlctx + exact ⟨by + simpa only [AddInductive.CandidateExprTrace.terminalContext] using + terminalRun, + terminalVenv, terminalLparams⟩ + +private theorem candidateFVLift'_comp + (left : VLCtx.FVLift' Δ₁ Δ₂ 0 (.skipN .refl n₁) 0) + (right : VLCtx.FVLift' Δ₂ Δ₃ 0 (.skipN .refl n₂) 0) : + VLCtx.FVLift' Δ₁ Δ₃ 0 (.skipN .refl (n₁ + n₂)) 0 := by + simpa only [Lift.comp_skipN, Lift.comp, Lift.skipN_skipN] using + left.comp right + +/-- Recover the terminal implementation context together with the exact +candidate-view telescope occupying the same local positions. + +The two `VLCtx`s keep the identical free-variable metadata and declaration +kinds. Their declaration types may differ, but strict translation uniqueness +only needs this positional relation. The view-side `toCtx` is definitionally +the reversed telescope selected by the recursive semantic run, followed by +the caller's view-side base context. -/ +theorem CandidateExprRun.terminalContextRunView + {env : VEnv} {Us : List Name} + {candidateContext : AddInductive.Context} {source : Expr} + {trace : AddInductive.CandidateExprTrace candidateContext source} + {Δ : VLCtx} {source' view' inferred' : VExpr} + (run : CandidateExprRun env Us trace Δ source' view' inferred') + (contextRun : CandidateContextRun candidateContext) + (venv_eq : contextRun.context.venv = env) + (lparams_eq : contextRun.context.lparams = Us) + (vlctx_eq : contextRun.context.vlctx = Δ) + {viewΔ : VLCtx} + (viewDefEq : VLCtx.IsDefEq env Us.length Δ viewΔ) + (viewContext : TrExprS.IsUniqueCtx Δ viewΔ) : + ∃ (terminalRun : CandidateContextRun trace.terminalContext) + (viewTerminal : VLCtx), + terminalRun.context.venv = env ∧ + terminalRun.context.lparams = Us ∧ + VLCtx.IsDefEq env Us.length terminalRun.context.vlctx viewTerminal ∧ + TrExprS.IsUniqueCtx terminalRun.context.vlctx viewTerminal ∧ + VLCtx.FVLift' viewΔ viewTerminal 0 + (.skipN .refl trace.spineLength) 0 ∧ + viewTerminal.toCtx = + (VExpr.telN trace.spineLength view').reverse ++ viewΔ.toCtx := by + induction run generalizing viewΔ with + | @terminal Δ context source inferred result source' result' inferred' + checked normalized node => + let terminalRun : CandidateContextRun + (AddInductive.CandidateExprTrace.terminal + context source inferred result checked normalized).terminalContext := by + simpa only [AddInductive.CandidateExprTrace.terminalContext] using + contextRun + refine ⟨terminalRun, viewΔ, venv_eq, lparams_eq, ?_, ?_, .refl, ?_⟩ + · change VLCtx.IsDefEq env Us.length contextRun.context.vlctx viewΔ + rw [vlctx_eq] + exact viewDefEq + · change TrExprS.IsUniqueCtx contextRun.context.vlctx viewΔ + rw [vlctx_eq] + exact viewContext + · simp only [AddInductive.CandidateExprTrace.spineLength, + VExpr.telN, List.reverse_nil, List.nil_append] + | @forallE domain context name binderInfo Δ source inferred body + source' domain' body' inferred' domainView' domainInferred' + storedDomain' bodyΔ storedBody' bodyView' bodyInferred' u v fresh + checked normalized annotations annotationsEq domainCandidate + bodyCandidate node domainRun annotationsRun bodyRun domainType bodyType + bodySource bodyContext domainIH bodyIH => + have storedDomain_tr : contextRun.context.TrExprS + annotations.consumed storedDomain' := by + simpa only [VContext.TrExprS, venv_eq, lparams_eq, vlctx_eq] using + annotationsRun.rhs_tr + have henv : VEnv.WF env := by + simpa only [venv_eq] using contextRun.context.Ewf + have hΔ : OnCtx Δ.toCtx (env.IsType Us.length) := by + simpa only [venv_eq, lparams_eq, vlctx_eq] using + contextRun.context.Δwf.toCtx + have storedDomain_type : env.IsType Us.length Δ.toCtx storedDomain' := by + have annotationDef := annotationsRun.isDefEqU.of_l henv hΔ domainType + exact ⟨u, annotationDef.hasType.2⟩ + have domainDef : env.IsDefEq Us.length Δ.toCtx + domain' domainView' (.sort u) := + domainRun.evidence.isDefEq.toU.of_l henv hΔ domainType + have annotationDef : env.IsDefEq Us.length Δ.toCtx + domain' storedDomain' (.sort u) := + annotationsRun.isDefEqU.of_l henv hΔ domainType + have storedToView : env.IsDefEq Us.length Δ.toCtx + storedDomain' domainView' (.sort u) := + annotationDef.symm.trans domainDef + let nextContextRun := contextRun.pushLocalDecl name binderInfo + annotations.consumed fresh storedDomain' storedDomain_tr (by + change contextRun.context.venv.IsType + contextRun.context.lparams.length + contextRun.context.vlctx.toCtx storedDomain' + rw [venv_eq, lparams_eq, vlctx_eq] + exact storedDomain_type) + have nextVenv : nextContextRun.context.venv = env := by + simp only [nextContextRun, CandidateContextRun.pushLocalDecl_venv, + venv_eq] + have nextLparams : nextContextRun.context.lparams = Us := by + simp only [nextContextRun, CandidateContextRun.pushLocalDecl_lparams, + lparams_eq] + have nextVlctx : nextContextRun.context.vlctx = bodyΔ := by + simp only [nextContextRun, CandidateContextRun.pushLocalDecl_vlctx] + rw [vlctx_eq, bodyContext] + let viewBodyΔ : VLCtx := + (some (context.freshFVarId, annotations.consumed.fvarsList), + .vlam domainView') :: viewΔ + have bodyWF := bodyRun.context_wf + rw [bodyContext] at bodyWF + have bodyViewDefEq : VLCtx.IsDefEq env Us.length bodyΔ viewBodyΔ := by + rw [bodyContext] + exact .cons viewDefEq bodyWF.2.1 (.vlam storedToView) + have bodyViewContext : TrExprS.IsUniqueCtx bodyΔ viewBodyΔ := by + rw [bodyContext] + exact viewContext.cons .vlam + obtain ⟨terminalRun, viewTerminal, terminalVenv, terminalLparams, + terminalViewDefEq, terminalViewContext, terminalViewLift, + terminalViewEq⟩ := + bodyIH nextContextRun nextVenv nextLparams nextVlctx bodyViewDefEq + bodyViewContext + refine ⟨by + simpa only [AddInductive.CandidateExprTrace.terminalContext] using + terminalRun, + viewTerminal, terminalVenv, terminalLparams, terminalViewDefEq, + terminalViewContext, ?_, ?_⟩ + · have headLift : VLCtx.FVLift' viewΔ viewBodyΔ 0 + (.skipN .refl 1) 0 := by + exact VLCtx.FVLift'.skip_fvar + (context.freshFVarId, annotations.consumed.fvarsList) + (.vlam domainView') (.refl : + VLCtx.FVLift' viewΔ viewΔ 0 .refl 0) + simpa only [AddInductive.CandidateExprTrace.spineLength, + Nat.add_comm 1] using + candidateFVLift'_comp headLift terminalViewLift + simpa only [AddInductive.CandidateExprTrace.spineLength, + VExpr.telN, List.reverse_cons, List.singleton_append, + List.append_assoc, viewBodyΔ, VLCtx.toCtx] using terminalViewEq + /-- Interpret the terminal-sort fact retained by family validation. At a terminal node the verified WHNF result translates the exact kernel sort. @@ -2144,16 +2779,10 @@ theorem CandidateExprRun.view_isType_of_terminalSort induction run with | terminal node => simp only [AddInductive.CandidateExprTrace.terminalResult] at terminal - have henv : VEnv.WF env := by - simpa only [node.check.venv_eq] using node.check.context.Ewf - obtain ⟨strict, strict_tr, strict_def⟩ := node.whnf.rhs_tr - rw [terminal] at strict_tr - cases strict_tr with + rw [terminal] at node + cases node.whnf.rhs_tr with | sort level_tr => - exact VEnv.IsType.defeqU_l henv (by - simpa only [node.check.venv_eq, node.check.lparams_eq, - node.check.vlctx_eq] using node.check.context.Δwf.toCtx) - strict_def ⟨_, .sort (VLevel.WF.of_ofLevel level_tr)⟩ + exact ⟨_, .sort (VLevel.WF.of_ofLevel level_tr)⟩ | @forallE domain context name binderInfo Δ source inferred body source' domain' body' inferred' domainView' domainInferred' storedDomain' bodyΔ storedBody' bodyView' bodyInferred' u v fresh @@ -2373,6 +3002,37 @@ theorem NormalizationRun.wf obtain ⟨_, hctor⟩ := h exact hctor.isDefEq.toU +/-- Checker-validated normalization for an arbitrary mutual block. + +Family equalities are interpreted in the common pre-family environment. The +raw family constants are then staged as one exact source-ordered fold, and +all constructor equalities are interpreted in the resulting shared block +environment. -/ +structure NormalizationBlockRun {source : VInductDecl} + (norm : Normalization source) (env blockEnv : VEnv) where + stage : env.stageInductiveTypes source.types = some blockEnv + families : List.Forall₂ + (fun raw view => + (∃ A, TypeChecker.DefEqEvidence env source.uvars [] + raw.type view.type A) ∧ + List.Forall₂ + (fun rawCtor viewCtor => + ∃ A, TypeChecker.DefEqEvidence blockEnv source.uvars [] + rawCtor.type viewCtor.type A) + raw.ctors view.ctors) + source.types norm.view.types + +/-- The verified checker interpretation discharges the complete Theory +mutual-normalization contract without a singleton projection. -/ +theorem NormalizationBlockRun.wf + (run : NormalizationBlockRun norm env blockEnv) : + norm.BlockWF env blockEnv := by + refine ⟨run.stage, ?_⟩ + exact Lean4Lean.List.Forall₂.imp (h := run.families) fun _ _ h => by + refine ⟨h.1.choose_spec.isDefEq.toU, ?_⟩ + exact Lean4Lean.List.Forall₂.imp (h := h.2) fun _ _ hctor => + hctor.choose_spec.isDefEq.toU + /-- One constructor candidate tied to the corresponding raw Theory constant. Its expression payload may normalize, but its name, universe arity, and exact source position remain fixed. -/ @@ -2558,6 +3218,131 @@ def CandidateConstructorSemanticListRun.roots : | .nil => .nil | .cons head tail => .cons head.root tail.roots +/-- One family in a mutual normalization candidate. Its type is interpreted +in the common pre-family environment, while every constructor is interpreted +in the single environment obtained after staging the complete raw family +block. -/ +structure CandidateBlockFamilySemanticRun + (env blockEnv : VEnv) (Us : List Name) + {source : InductiveType} + (candidate : AddInductive.CandidateFamily source) + (raw : VInductiveType) where + name_eq : source.name = raw.name + uvars_eq : raw.uvars = Us.length + type : TypeChecker.CandidateExprSemanticRootRun env Us + candidate.familyType.type raw.type + constructors : CandidateConstructorSemanticListRun blockEnv Us + candidate.constructors raw.ctors + +/-- Replace only the expression payloads selected by the retained checker +runs; all family and constructor headers remain raw and source-indexed. -/ +def CandidateBlockFamilySemanticRun.view + (run : CandidateBlockFamilySemanticRun env blockEnv Us candidate raw) : + VInductiveType := + { raw with + type := run.type.view + ctors := run.constructors.roots.views } + +/-- Exact source-order semantic ownership for every family in an arbitrary +block. Both the kernel candidate list and raw Theory list are indices, so +family reordering and truncation are unrepresentable. -/ +inductive CandidateBlockFamilySemanticListRun + (env blockEnv : VEnv) (Us : List Name) : + {sources : List InductiveType} → + AddInductive.CandidateList AddInductive.CandidateFamily sources → + List VInductiveType → Type where + | nil : CandidateBlockFamilySemanticListRun env blockEnv Us .nil [] + | cons + (head : CandidateBlockFamilySemanticRun env blockEnv Us candidate raw) + (tail : CandidateBlockFamilySemanticListRun env blockEnv Us + candidates raws) : + CandidateBlockFamilySemanticListRun env blockEnv Us + (.cons candidate candidates) (raw :: raws) + +/-- Exact normalized family views in source order. -/ +def CandidateBlockFamilySemanticListRun.views : + CandidateBlockFamilySemanticListRun env blockEnv Us candidates raws → + List VInductiveType + | .nil => [] + | .cons head tail => head.view :: tail.views + +/-- Block semantic runs preserve every family and constructor header. -/ +theorem CandidateBlockFamilySemanticListRun.sameHeaders + (run : CandidateBlockFamilySemanticListRun env blockEnv Us + candidates raws) : + sameTypeHeaders raws run.views = true := by + induction run with + | nil => rfl + | cons head tail ih => + simp [CandidateBlockFamilySemanticListRun.views, + CandidateBlockFamilySemanticRun.view, sameTypeHeaders, + head.constructors.roots.sameHeaders, ih] + +/-- Collect the exact family/constructor definitional equalities selected by +the retained semantic checker hierarchy. -/ +theorem CandidateBlockFamilySemanticListRun.evidence + (run : CandidateBlockFamilySemanticListRun env blockEnv Us + candidates raws) : + List.Forall₂ + (fun raw view => + (∃ A, TypeChecker.DefEqEvidence env Us.length [] + raw.type view.type A) ∧ + List.Forall₂ + (fun rawCtor viewCtor => + ∃ A, TypeChecker.DefEqEvidence blockEnv Us.length [] + rawCtor.type viewCtor.type A) + raw.ctors view.ctors) + raws run.views := by + induction run with + | nil => exact .nil + | cons head tail ih => + exact .cons + ⟨head.type.root.evidence, head.constructors.roots.evidence⟩ ih + +/-- Complete semantic ownership for an arbitrary normalization candidate. +The raw staging equation and dependent family list share the same exact raw +declaration; no independently supplied normalized declaration is accepted. -/ +structure NormalizationCandidateBlockSemanticRun + (env blockEnv : VEnv) (Us : List Name) + {sources : List InductiveType} + (candidate : AddInductive.NormalizationCandidate sources) + (rawDecl : VInductDecl) where + uvars_eq : rawDecl.uvars = Us.length + stage : env.stageInductiveTypes rawDecl.types = some blockEnv + families : CandidateBlockFamilySemanticListRun env blockEnv Us + candidate.families rawDecl.types + +/-- Theory declaration selected by the exact block semantic hierarchy. -/ +def NormalizationCandidateBlockSemanticRun.viewDecl + (run : NormalizationCandidateBlockSemanticRun env blockEnv Us + candidate rawDecl) : VInductDecl := + { rawDecl with types := run.families.views } + +/-- Construct the header-preserving Theory normalization boundary selected by +the candidate semantic hierarchy. -/ +def NormalizationCandidateBlockSemanticRun.normalization + (run : NormalizationCandidateBlockSemanticRun env blockEnv Us + candidate rawDecl) : Normalization rawDecl where + view := run.viewDecl + shape_eq := by + simp only [normalizationShape, + NormalizationCandidateBlockSemanticRun.viewDecl, + beq_self_eq_true, Bool.true_and] + exact run.families.sameHeaders + +/-- Project the generic verified normalization run for the same raw block and +shared staged environment. -/ +def NormalizationCandidateBlockSemanticRun.normalizationRun + (run : NormalizationCandidateBlockSemanticRun env blockEnv Us + candidate rawDecl) : + NormalizationBlockRun run.normalization env blockEnv where + stage := run.stage + families := by + simpa only [run.uvars_eq, + NormalizationCandidateBlockSemanticRun.normalization, + NormalizationCandidateBlockSemanticRun.viewDecl] using + run.families.evidence + /-- A singleton-family semantic hierarchy spanning the pre-family candidate, the exact raw-family insertion, and every post-family constructor candidate. The normalized expression payloads are selected by retained recursive checker @@ -2662,6 +3447,120 @@ theorem CandidateConstructorSemanticListInput.exists obtain ⟨tailRun⟩ := ih exact ⟨.cons headRun tailRun⟩ +/-- Pre-run semantic evidence for one family in a shared mutual stage. +Family types use `env`; all constructor types use the same `blockEnv` after +every raw family has been staged. -/ +structure CandidateBlockFamilySemanticInput + (env blockEnv : VEnv) (Us : List Name) + {source : InductiveType} + (candidate : AddInductive.CandidateFamily source) + (raw : VInductiveType) where + name_eq : source.name = raw.name + uvars_eq : raw.uvars = Us.length + type : TypeChecker.CandidateExprSemanticRootInput env Us + candidate.familyType.type raw.type + constructors : CandidateConstructorSemanticListInput blockEnv Us + candidate.constructors raw.ctors + +/-- Interpret one family and its complete constructor list without selecting +a normalized expression at the call site. -/ +theorem CandidateBlockFamilySemanticInput.exists + (input : CandidateBlockFamilySemanticInput env blockEnv Us + candidate raw) : + Nonempty (CandidateBlockFamilySemanticRun env blockEnv Us + candidate raw) := by + obtain ⟨type⟩ := input.type.exists + obtain ⟨constructors⟩ := input.constructors.exists + exact ⟨{ + name_eq := input.name_eq + uvars_eq := input.uvars_eq + type + constructors }⟩ + +/-- Exact source-order semantic inputs for every family in a mutual block. -/ +inductive CandidateBlockFamilySemanticListInput + (env blockEnv : VEnv) (Us : List Name) : + {sources : List InductiveType} → + AddInductive.CandidateList AddInductive.CandidateFamily sources → + List VInductiveType → Type where + | nil : CandidateBlockFamilySemanticListInput env blockEnv Us .nil [] + | cons + (head : CandidateBlockFamilySemanticInput env blockEnv Us candidate raw) + (tail : CandidateBlockFamilySemanticListInput env blockEnv Us + candidates raws) : + CandidateBlockFamilySemanticListInput env blockEnv Us + (.cons candidate candidates) (raw :: raws) + +/-- Interpret every family and constructor input in lockstep. -/ +theorem CandidateBlockFamilySemanticListInput.exists + (input : CandidateBlockFamilySemanticListInput env blockEnv Us + candidates raws) : + Nonempty (CandidateBlockFamilySemanticListRun env blockEnv Us + candidates raws) := by + induction input with + | nil => exact ⟨.nil⟩ + | cons head tail ih => + obtain ⟨headRun⟩ := head.exists + obtain ⟨tailRun⟩ := ih + exact ⟨.cons headRun tailRun⟩ + +/-- Complete verified semantic input for an arbitrary normalization +candidate. The exact raw family list owns both the all-family staging fold and +the dependent family interpretation, ruling out a reordered staging witness. -/ +structure NormalizationCandidateBlockSemanticInput + (env blockEnv : VEnv) (Us : List Name) + {sources : List InductiveType} + (candidate : AddInductive.NormalizationCandidate sources) + (rawDecl : VInductDecl) where + uvars_eq : rawDecl.uvars = Us.length + stage : env.stageInductiveTypes rawDecl.types = some blockEnv + families : CandidateBlockFamilySemanticListInput env blockEnv Us + candidate.families rawDecl.types + +/-- Automatically interpret the complete mutual semantic hierarchy. -/ +theorem NormalizationCandidateBlockSemanticInput.exists + (input : NormalizationCandidateBlockSemanticInput env blockEnv Us + candidate rawDecl) : + Nonempty (NormalizationCandidateBlockSemanticRun env blockEnv Us + candidate rawDecl) := by + obtain ⟨families⟩ := input.families.exists + exact ⟨{ + uvars_eq := input.uvars_eq + stage := input.stage + families }⟩ + +/-- A mutual semantic hierarchy paired with the exact arbitrary-length +producer traversals that selected the same dependent candidate. -/ +structure ProducedNormalizationCandidateBlockSemanticRun + (familyContext constructorContext : AddInductive.Context) + (env blockEnv : VEnv) (Us : List Name) + {sources : List InductiveType} + (candidate : AddInductive.NormalizationCandidate sources) + (rawDecl : VInductDecl) where + semantic : NormalizationCandidateBlockSemanticRun env blockEnv Us + candidate rawDecl + familyTypesProduced : AddInductive.CandidateFamilyTypeListProduced + familyContext candidate.families.familyTypes + familiesProduced : AddInductive.CandidateFamilyListProduced + constructorContext candidate.families.familyTypes candidate.families + +/-- Combine verified semantic inputs with exact producer provenance for the +same source-indexed mutual candidate. -/ +theorem NormalizationCandidateBlockSemanticInput.exists_ofProduced + (input : NormalizationCandidateBlockSemanticInput env blockEnv Us + candidate rawDecl) + (familyTypesProduced : AddInductive.CandidateFamilyTypeListProduced + familyContext candidate.families.familyTypes) + (familiesProduced : AddInductive.CandidateFamilyListProduced + constructorContext candidate.families.familyTypes candidate.families) : + Nonempty (ProducedNormalizationCandidateBlockSemanticRun + familyContext constructorContext env blockEnv Us candidate rawDecl) := by + obtain ⟨semantic⟩ := input.exists + exact ⟨{ + semantic + familyTypesProduced + familiesProduced }⟩ + /-- One validated singleton family stage derived from a verified entry candidate context and the exact kernel/Theory family insertion. @@ -2790,6 +3689,141 @@ def CandidateFamilyStagedInput.postFamily _ = Us := preFamily.lparams_eq vlctx_eq := rfl +/-- Recover the exact verified pre-family context at the end of the family +telescope. + +Constructor validation starts from this local telescope after changing only +the kernel/Theory environment to the staged post-family pair. D3 reuses the +pre-change context to replay family-free constructor checks; no local +declaration or fresh identifier is reconstructed. -/ +theorem CandidateFamilyStagedInput.preValidationContextRun + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.CandidateFamilyType source} + {raw : VInductiveType} + {preFamily : TypeChecker.CandidateSemanticStage familyContext env Us} + (_input : CandidateFamilyStagedInput familyContext constructorContext + env Us candidate raw preFamily) + (semantic : TypeChecker.CandidateExprSemanticRootRun env Us + candidate.type raw.type) : + ∃ preRun : TypeChecker.CandidateContextRun + candidate.type.trace.terminalContext, + preRun.context.venv = env ∧ + preRun.context.lparams = Us := by + obtain ⟨inferred, recursive⟩ := semantic.recursive + exact recursive.terminalContextRun semantic.contextRun semantic.venv_eq + semantic.lparams_eq semantic.vlctx_eq + +/-- Rebuild the verified constructor-validation context from the exact +pre-family terminal context run. + +The returned run preserves the implementation local context definitionally; +only the kernel/Theory environment and the primitive evidence are changed to +the staged post-family pair. -/ +theorem CandidateFamilyStagedInput.validationContextRunFromPre + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.CandidateFamilyType source} + {raw : VInductiveType} + {preFamily : TypeChecker.CandidateSemanticStage familyContext env Us} + (input : CandidateFamilyStagedInput familyContext constructorContext + env Us candidate raw preFamily) + (terminalRun : TypeChecker.CandidateContextRun + candidate.type.trace.terminalContext) + (terminalVenv : terminalRun.context.venv = env) + (terminalLparams : terminalRun.context.lparams = Us) : + ∃ validationRun : TypeChecker.CandidateContextRun + { candidate.type.trace.terminalContext with + env := constructorContext.env }, + validationRun.context.venv = input.typeEnv ∧ + validationRun.context.lparams = Us ∧ + validationRun.context.vlctx = terminalRun.context.vlctx := by + have terminalMLWF : terminalRun.context.mlctx.WF env Us := by + simpa only [terminalVenv, terminalLparams] using + terminalRun.context.mlctx_wf + have postMLWF : terminalRun.context.mlctx.WF input.typeEnv Us := + terminalMLWF.mono (VEnv.addConst_le input.addInduct.env_add) + have validationSafety : terminalRun.context.safety = + input.postContext.safety := by + calc + terminalRun.context.safety = + candidate.type.trace.terminalContext.safety := + terminalRun.context_safety + _ = candidate.type.context.safety := + candidate.type.trace.terminalContext_safety + _ = familyContext.safety := by rw [input.type.context_eq] + _ = constructorContext.safety := by rw [input.constructorContext_eq] + _ = input.postContext.safety := rfl + let validationContext : TypeChecker.VContext := + { terminalRun.context with + env := constructorContext.env + venv := input.typeEnv + hasPrimitives := input.postContext.hasPrimitives + safePrimitives := input.postContext.safePrimitives + trenv := by + have postEnv : input.postContext.env = constructorContext.env := rfl + have postVenv : input.postContext.venv = input.typeEnv := rfl + simpa only [validationSafety, postEnv, postVenv] using + input.postContext.trenv + mlctx_wf := by + simpa only [terminalLparams] using postMLWF } + have validationContextEq : validationContext.toContext = + ({ candidate.type.trace.terminalContext with + env := constructorContext.env } : AddInductive.Context).toTypeChecker := by + calc + validationContext.toContext = + { terminalRun.context.toContext with + env := constructorContext.env } := rfl + _ = { candidate.type.trace.terminalContext.toTypeChecker with + env := constructorContext.env } := + congrArg (fun c : TypeChecker.Context => + { c with env := constructorContext.env }) terminalRun.context_eq + _ = ({ candidate.type.trace.terminalContext with + env := constructorContext.env } : AddInductive.Context).toTypeChecker := + rfl + let validationRun : TypeChecker.CandidateContextRun + { candidate.type.trace.terminalContext with + env := constructorContext.env } := + TypeChecker.CandidateContextRun.ofVContext _ validationContext + validationContextEq + (TypeChecker.VState.WF.empty_of_reserves validationContext (by + intro fv hfv + exact terminalRun.state_wf.ngen_wf fv (by + simpa only [validationContext] using hfv))) + terminalRun.namePrefix_ne + exact ⟨validationRun, rfl, terminalLparams, rfl⟩ + +/-- Rebuild the verified context in which constructor validation actually +runs. + +Family candidates are interpreted before the raw family is inserted, so the +recursive run reaches the correct local telescope in the pre-family Theory +environment. Constructor validation keeps that exact implementation local +context while replacing only the kernel/Theory environment with the staged +post-family pair. Monotonicity of local-context verification justifies that +replacement; no local declaration, free-variable identifier, or binder order +is regenerated. -/ +theorem CandidateFamilyStagedInput.validationContextRun + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.CandidateFamilyType source} + {raw : VInductiveType} + {preFamily : TypeChecker.CandidateSemanticStage familyContext env Us} + (input : CandidateFamilyStagedInput familyContext constructorContext + env Us candidate raw preFamily) + (semantic : TypeChecker.CandidateExprSemanticRootRun env Us + candidate.type raw.type) : + ∃ validationRun : TypeChecker.CandidateContextRun + { candidate.type.trace.terminalContext with + env := constructorContext.env }, + validationRun.context.venv = input.typeEnv ∧ + validationRun.context.lparams = Us := by + obtain ⟨terminalRun, terminalVenv, terminalLparams⟩ := + input.preValidationContextRun semantic + obtain ⟨validationRun, validationVenv, validationLparams, _⟩ := + input.validationContextRunFromPre terminalRun terminalVenv terminalLparams + exact ⟨validationRun, validationVenv, validationLparams⟩ + /-- One source-indexed constructor interpreted in the shared post-family stage. Header equality and universe alignment stay attached to the exact raw constructor position; the expression payload contains no independently @@ -2967,6 +4001,11 @@ structure StagedNormalizationCandidateSemanticInput preFamily : TypeChecker.CandidateSemanticStage familyContext env Us family : CandidateFamilyStagedInput familyContext constructorContext env Us candidate.families.singleton.familyType raw preFamily + validation_nparams_eq : family.validation.nparams = rawDecl.nparams + constructorValidation : AddInductive.ConstructorValidationRun + source family.validation.stats false + { candidate.families.singleton.familyType.type.trace.terminalContext with + env := constructorContext.env } constructors : CandidateConstructorStagedListInput family.postFamily candidate.families.singleton.constructors raw.ctors familyTypesProduced : AddInductive.CandidateFamilyTypeListProduced @@ -2977,6 +4016,21 @@ structure StagedNormalizationCandidateSemanticInput (.cons candidate.families.singleton.familyType .nil) candidate.families +/-- The staged owner retains exactly the successful executable constructor +validation that selected its source-indexed constructor list. -/ +theorem StagedNormalizationCandidateSemanticInput.constructorValidation_run + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.NormalizationCandidate [source]} + {rawDecl : VInductDecl} + (input : StagedNormalizationCandidateSemanticInput familyContext + constructorContext env Us candidate rawDecl) : + AddInductive.checkConstructors #[source] input.family.validation.stats + false + { candidate.families.singleton.familyType.type.trace.terminalContext with + env := constructorContext.env } = .ok () := + input.constructorValidation.run + /-- Project the established semantic-input hierarchy from the consolidated two-stage owner. This projection remains data-free with respect to checker semantics: it only rearranges verified stage and translation evidence. -/ @@ -3358,9 +4412,9 @@ theorem CandidateNormalizedCtorRun.rightType_ofChecked /-- Produce both constructor paths required by `NormalizedCtorRun`. The declared path comes directly from the constructor candidate. The emitted -path replaces the stored constructor parameter prefix by the raw family -parameter prefix, transporting fields and result through the induced -definitionally equal context. -/ +path replaces the stored constructor parameter prefix by the checked family +parameter prefix used by Lean's recursor generator, transporting fields and +result through the induced definitionally equal context. -/ def CandidateNormalizedCtorRun.normalizedCtorRun {source : VInductDecl} {generation : GenerationChecked source} {env : VEnv} {Us : List Name} @@ -3391,7 +4445,10 @@ def CandidateNormalizedCtorRun.normalizedCtorRun (.sort generation.block.checked.resultLevel) := by simpa only [NormalizedCtor.declaredBinders, NormalizedCtor.viewBinders] using declared - have emitted := declaredSplit.replacePrefix henv familyParams prefixLength + have checkedParams : TypeChecker.TelDefEqEvidence env Us.length [] + generation.block.checked.params generation.block.checked.params := + .ofTelDefEq <| (familyParams.telDefEq.view_onTel henv.ordered).telDefEq_refl + have emitted := declaredSplit.replacePrefix henv checkedParams prefixLength exact { declaredTel := by simpa only [uvars_eq] using declared.telescope @@ -4023,30 +5080,13 @@ private def _ = normalization.family.constructors.roots.views := rfl · exact fun _ hctor => hctor -/-- Reconstruct the established semantic-generation run from the reduced -shape boundary. No raw/view pair or component equation is supplied here. -/ -def GenerationCandidateSemanticShapeRun.run - {env : VEnv} {Us : List Name} - {kernelSource : InductiveType} {source : VInductDecl} - {candidate : AddInductive.NormalizationCandidate [kernelSource]} - {normalization : NormalizationCandidateSemanticRun env Us candidate source} - {generation : GenerationChecked source} - (input : GenerationCandidateSemanticShapeRun normalization generation) : - GenerationCandidateSemanticRun normalization generation where - analysis := input.analysis - checked := input.checked - family := input.family.generationRun input.analysis - constructors := input.constructors.ofAnalysis input.analysis - -/-- Build the reduced semantic generation owner from exact dependent -analysis, semantic WF of the analyzer-owned view declaration, and the single -executable hierarchy shape check. - -`checked` is derived from the exact declaration analyzed by `generation?`; -callers no longer provide a parallel `Checked.WF` value. Likewise, the -family and all constructor shape records are projections of one complete -source-indexed Boolean gate. -/ -def GenerationCandidateSemanticRun.ofGenerationShape +/-- Recover every analyzer-owned constructor pairing from the retained +semantic hierarchy, dependent analysis, and executable structural gate. + +This projection deliberately does not require `Checked.WF`: it exposes only +the exact source/candidate/raw/view alignment needed to derive that semantic +fact in the constructor-validation layer. -/ +def NormalizationCandidateSemanticRun.constructorGenerationRuns {env : VEnv} {Us : List Name} {kernelSource : InductiveType} {source : VInductDecl} {candidate : AddInductive.NormalizationCandidate [kernelSource]} @@ -4054,38 +5094,30 @@ def GenerationCandidateSemanticRun.ofGenerationShape (generation : GenerationChecked source) (analysis : normalization.root.normalization.generation? = some generation) - (viewWF : normalization.root.viewDecl.WF env) (shape : normalization.generationShape = true) : - GenerationCandidateSemanticRun normalization generation := by + CandidateSemanticNormalizedCtorListRun generation.block + normalization.family.typeEnv Us normalization.family.constructors + generation.block.ctorPairs := by simp only [NormalizationCandidateSemanticRun.generationShape, normalizationCandidateGenerationShape, Bool.and_eq_true, beq_iff_eq] at shape - have sourceType_eq : generation.block.sourceType = normalization.raw := by - simpa only [NormalizationCandidateSemanticRun.root] using - normalization.root.sourceType_eq generation - have normalization_eq : generation.block.normalization = - normalization.root.normalization := - Normalization.generation?_normalization analysis - have view_eq : generation.block.normalization.view = - normalization.root.viewDecl := by - simpa only [NormalizationCandidateRun.normalization] using - congrArg (fun norm : Normalization source => norm.view) - normalization_eq - have checked : generation.block.checked.WF env := - generation.block.checked.wf_of_decl (by - rw [view_eq] - exact viewWF) - apply GenerationCandidateSemanticShapeRun.run { - analysis := analysis - checked := checked - family := { - storedSpine := shape.1.1 - spineLength_eq := by - simpa only [NormalizedChecked.rawParams, - NormalizedChecked.rawIndices, sourceType_eq] using shape.1.2 } - constructors := - CandidateConstructorSemanticGenerationShapeList.ofCheck - normalization.family.constructors shape.2 } + exact (CandidateConstructorSemanticGenerationShapeList.ofCheck + normalization.family.constructors shape.2).ofAnalysis analysis + +/-- Reconstruct the established semantic-generation run from the reduced +shape boundary. No raw/view pair or component equation is supplied here. -/ +def GenerationCandidateSemanticShapeRun.run + {env : VEnv} {Us : List Name} + {kernelSource : InductiveType} {source : VInductDecl} + {candidate : AddInductive.NormalizationCandidate [kernelSource]} + {normalization : NormalizationCandidateSemanticRun env Us candidate source} + {generation : GenerationChecked source} + (input : GenerationCandidateSemanticShapeRun normalization generation) : + GenerationCandidateSemanticRun normalization generation where + analysis := input.analysis + checked := input.checked + family := input.family.generationRun input.analysis + constructors := input.constructors.ofAnalysis input.analysis /-- Reconstruct well-formedness of the post-family environment from the retained pre-family context, candidate raw/view equality, checked family view, @@ -4280,6 +5312,7 @@ def GenerationCandidatePackage.addInductTrace package.generation.block.sourceType.ctors ctorMap ctorEnv) (addRec : AddInductConstant .recursor ctorMap ctorEnv (inductGenerationRecVal package.generation) m₂ recEnv) + (recK : RecursorKMatches addRec.info package.generation.kTarget) (addRules : AddDefEqs recEnv package.generation.generatedRules env₂) : AddInductTrace m₁ env package.source m₂ env₂ where @@ -4293,6 +5326,7 @@ def GenerationCandidatePackage.addInductTrace addType := addType addCtors := addCtors addRec := addRec + recK := recK addRules := addRules /-- Optional outer provenance for packages obtained by the executable @@ -4368,63 +5402,6 @@ def GenerationCandidateSemanticRun.producedPackage ProducedGenerationCandidatePackage env Us := run.run.producedPackage context nparams numNested isUnsafe produced -/-- Construct the complete produced package at the consolidated generation -shape boundary. - -The exact outer metadata equation selects the source-indexed candidate. The -retained semantic hierarchy, dependent analysis, analyzer-owned view WF, and -single executable shape check then determine the generation run used by the -package. In particular, callers do not separately provide checked WF or any -family/constructor shape record. -/ -def NormalizationCandidateSemanticRun.producedPackageOfGenerationShape - {env : VEnv} {Us : List Name} - {kernelSource : InductiveType} {source : VInductDecl} - {candidate : AddInductive.NormalizationCandidate [kernelSource]} - (normalization : NormalizationCandidateSemanticRun env Us candidate source) - (generation : GenerationChecked source) - (analysis : normalization.root.normalization.generation? = - some generation) - (viewWF : normalization.root.viewDecl.WF env) - (shape : normalization.generationShape = true) - (context : AddInductive.Context) - (nparams numNested : Nat) (isUnsafe : Bool) - (produced : - AddInductive.buildNormalizationCandidate nparams - [kernelSource] numNested isUnsafe context = .ok candidate) : - ProducedGenerationCandidatePackage env Us := - (GenerationCandidateSemanticRun.ofGenerationShape normalization generation - analysis viewWF shape).producedPackage context nparams numNested isUnsafe - produced - -/-- Interpret one successful executable shape-producing outer result as the -complete semantic package for the same dependent candidate. - -`raw_eq` only identifies the raw family carried by the semantic hierarchy -with the raw family passed to the executable shape gate. All other -provenance, including the candidate itself, the outer producer equation, and -the complete family/constructor shape check, is owned by `producedCandidate`. --/ -def ProducedGenerationShapeCandidate.producedPackage - {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) - (normalization : NormalizationCandidateSemanticRun env Us - producedCandidate.candidate source) - (raw_eq : raw = normalization.raw) - (generation : GenerationChecked source) - (analysis : normalization.root.normalization.generation? = - some generation) - (viewWF : normalization.root.viewDecl.WF env) : - ProducedGenerationCandidatePackage env Us := - normalization.producedPackageOfGenerationShape generation analysis viewWF - (by - simpa only [NormalizationCandidateSemanticRun.generationShape, - raw_eq] using producedCandidate.shape) - context source.nparams numNested isUnsafe producedCandidate.produced - /- The evidence types mention exact verifier executions, so these semantic interpretation roots intentionally inherit the same transitional Verify @@ -5030,106 +6007,6 @@ info: 'Lean4Lean.VInductDecl.produceGenerationShapeCandidate_eq_ok' depends on a -/ #guard_msgs in #print axioms produceGenerationShapeCandidate_eq_ok - -/-- -info: 'Lean4Lean.VInductDecl.GenerationCandidateSemanticRun.ofGenerationShape' depends on axioms: [propext, - sorryAx, - Classical.choice, - ptrEqConstantInfo_eq, - ptrEqExpr_eq, - Quot.sound, - Expr.abstractRange_eq, - Expr.abstract_eq, - Expr.eqv_eq, - Expr.hasLooseBVar_eq, - Expr.instantiate1_eq, - Expr.instantiateRange_eq, - Expr.instantiateRevRange_eq, - Expr.instantiateRev_eq, - Expr.instantiate_eq, - Expr.looseBVarRange_eq, - Expr.lowerLooseBVars_eq, - Expr.mkAppData_eq, - Expr.mkData_eq, - Expr.replace_eq, - Level.hasMVar_eq, - Level.hasParam_eq, - Level.instLawfulBEqLevel, - PersistentArray.toList'_push, - PersistentHashMap.findAux_isSome, - Syntax.structEq_eq, - PersistentHashMap.WF.find?_eq, - PersistentHashMap.WF.toList'_insert] --/ -#guard_msgs in -#print axioms GenerationCandidateSemanticRun.ofGenerationShape - -/-- -info: 'Lean4Lean.VInductDecl.NormalizationCandidateSemanticRun.producedPackageOfGenerationShape' depends on axioms: [propext, - sorryAx, - Classical.choice, - ptrEqConstantInfo_eq, - ptrEqExpr_eq, - Quot.sound, - Expr.abstractRange_eq, - Expr.abstract_eq, - Expr.eqv_eq, - Expr.hasLooseBVar_eq, - Expr.instantiate1_eq, - Expr.instantiateRange_eq, - Expr.instantiateRevRange_eq, - Expr.instantiateRev_eq, - Expr.instantiate_eq, - Expr.looseBVarRange_eq, - Expr.lowerLooseBVars_eq, - Expr.mkAppData_eq, - Expr.mkData_eq, - Expr.replace_eq, - Level.hasMVar_eq, - Level.hasParam_eq, - Level.instLawfulBEqLevel, - PersistentArray.toList'_push, - PersistentHashMap.findAux_isSome, - Syntax.structEq_eq, - PersistentHashMap.WF.find?_eq, - PersistentHashMap.WF.toList'_insert] --/ -#guard_msgs in -#print axioms NormalizationCandidateSemanticRun.producedPackageOfGenerationShape - -/-- -info: 'Lean4Lean.VInductDecl.ProducedGenerationShapeCandidate.producedPackage' depends on axioms: [propext, - sorryAx, - Classical.choice, - ptrEqConstantInfo_eq, - ptrEqExpr_eq, - Quot.sound, - Expr.abstractRange_eq, - Expr.abstract_eq, - Expr.eqv_eq, - Expr.hasLooseBVar_eq, - Expr.instantiate1_eq, - Expr.instantiateRange_eq, - Expr.instantiateRevRange_eq, - Expr.instantiateRev_eq, - Expr.instantiate_eq, - Expr.looseBVarRange_eq, - Expr.lowerLooseBVars_eq, - Expr.mkAppData_eq, - Expr.mkData_eq, - Expr.replace_eq, - Level.hasMVar_eq, - Level.hasParam_eq, - Level.instLawfulBEqLevel, - PersistentArray.toList'_push, - PersistentHashMap.findAux_isSome, - Syntax.structEq_eq, - PersistentHashMap.WF.find?_eq, - PersistentHashMap.WF.toList'_insert] --/ -#guard_msgs in -#print axioms ProducedGenerationShapeCandidate.producedPackage - /-- info: 'Lean4Lean.VInductDecl.GenerationCandidateSemanticRun.package' depends on axioms: [propext, sorryAx, @@ -6168,6 +7045,271 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidatePackage.addInductTrace' depends #guard_msgs in #print axioms GenerationCandidatePackage.addInductTrace +/-- +info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidateSemanticInput.constructorValidation_run' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms StagedNormalizationCandidateSemanticInput.constructorValidation_run + +/-- +info: 'Lean4Lean.VInductDecl.NormalizationBlockRun.wf' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms NormalizationBlockRun.wf + +/-- +info: 'Lean4Lean.VInductDecl.CandidateBlockFamilySemanticListRun.sameHeaders' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms CandidateBlockFamilySemanticListRun.sameHeaders + +/-- +info: 'Lean4Lean.VInductDecl.CandidateBlockFamilySemanticListRun.evidence' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms CandidateBlockFamilySemanticListRun.evidence + +/-- +info: 'Lean4Lean.VInductDecl.CandidateBlockFamilySemanticInput.exists' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms CandidateBlockFamilySemanticInput.exists + +/-- +info: 'Lean4Lean.VInductDecl.CandidateBlockFamilySemanticListInput.exists' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms CandidateBlockFamilySemanticListInput.exists + +/-- +info: 'Lean4Lean.VInductDecl.NormalizationCandidateBlockSemanticInput.exists' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms NormalizationCandidateBlockSemanticInput.exists + +/-- +info: 'Lean4Lean.VInductDecl.NormalizationCandidateBlockSemanticInput.exists_ofProduced' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms NormalizationCandidateBlockSemanticInput.exists_ofProduced + + end VInductDecl end Lean4Lean diff --git a/Lean4Lean/Verify/Environment/NormalizationMatrix.lean b/Lean4Lean/Verify/Environment/NormalizationMatrix.lean new file mode 100644 index 00000000..d9b4ce14 --- /dev/null +++ b/Lean4Lean/Verify/Environment/NormalizationMatrix.lean @@ -0,0 +1,750 @@ +import Lean4Lean.Verify.Environment.InductiveFixtures + +/-! +# Normalization differential matrix + +Executable and semantic replay for the L4L-04 matrix. The fixture deliberately +places reducible aliases at every inductive-analysis boundary, including a +Pi-producing alias around a recursive target. This file observes the actual +kernel declarations, pins the exact analyzer output and its fuel boundary, and +then translates the same declarations into the Theory environment. +-/ + +namespace Lean4Lean.InductiveReplayFixtures + +open Lean Meta +open Lean4Lean.InductiveFixtures + +/-! ## Actual kernel metadata and executable analysis -/ + +def matrixBetaKernelDef : DefinitionVal := kernelDefVal% MatrixBetaAlias +def matrixLetKernelDef : DefinitionVal := kernelDefVal% MatrixLetAlias +def matrixPiKernelDef : DefinitionVal := kernelDefVal% MatrixPiAlias +def matrixIndexKernelDef : DefinitionVal := kernelDefVal% MatrixIndexAlias + +def matrixBetaInfo : ConstantInfo := .defnInfo matrixBetaKernelDef +def matrixLetInfo : ConstantInfo := .defnInfo matrixLetKernelDef +def matrixPiInfo : ConstantInfo := .defnInfo matrixPiKernelDef +def matrixIndexInfo : ConstantInfo := .defnInfo matrixIndexKernelDef + +def matrixRecMap : ConstMap := + typeFamilyAliasMap.insert ``RecAlias recAliasInfo + +def matrixBetaMap : ConstMap := + matrixRecMap.insert ``MatrixBetaAlias matrixBetaInfo + +def matrixLetMap : ConstMap := + matrixBetaMap.insert ``MatrixLetAlias matrixLetInfo + +def matrixPiMap : ConstMap := + matrixLetMap.insert ``MatrixPiAlias matrixPiInfo + +def matrixAliasMap : ConstMap := + matrixPiMap.insert ``MatrixIndexAlias matrixIndexInfo + +theorem matrixRec_fresh : + typeFamilyAliasMap.find? ``RecAlias = none := by + rw [typeFamilyAliasMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem matrixRecMap_wf : matrixRecMap.WF := + typeFamilyAliasMap_wf.insert _ _ matrixRec_fresh + +theorem matrixBeta_fresh : + matrixRecMap.find? ``MatrixBetaAlias = none := by + rw [matrixRecMap, typeFamilyAliasMap_wf.find?_insert, + typeFamilyAliasMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem matrixBetaMap_wf : matrixBetaMap.WF := + matrixRecMap_wf.insert _ _ matrixBeta_fresh + +theorem matrixLet_fresh : + matrixBetaMap.find? ``MatrixLetAlias = none := by + rw [matrixBetaMap, matrixRecMap_wf.find?_insert, + matrixRecMap, typeFamilyAliasMap_wf.find?_insert, + typeFamilyAliasMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem matrixLetMap_wf : matrixLetMap.WF := + matrixBetaMap_wf.insert _ _ matrixLet_fresh + +theorem matrixPi_fresh : matrixLetMap.find? ``MatrixPiAlias = none := by + rw [matrixLetMap, matrixBetaMap_wf.find?_insert, + matrixBetaMap, matrixRecMap_wf.find?_insert, + matrixRecMap, typeFamilyAliasMap_wf.find?_insert, + typeFamilyAliasMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem matrixPiMap_wf : matrixPiMap.WF := + matrixLetMap_wf.insert _ _ matrixPi_fresh + +theorem matrixIndex_fresh : + matrixPiMap.find? ``MatrixIndexAlias = none := by + rw [matrixPiMap, matrixLetMap_wf.find?_insert, + matrixLetMap, matrixBetaMap_wf.find?_insert, + matrixBetaMap, matrixRecMap_wf.find?_insert, + matrixRecMap, typeFamilyAliasMap_wf.find?_insert, + typeFamilyAliasMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem matrixAliasMap_wf : matrixAliasMap.WF := + matrixPiMap_wf.insert _ _ matrixIndex_fresh + +def matrixKernelEnv : Kernel.Environment := + Kernel.Environment.ofConstants `_normalizationMatrix matrixAliasMap + +def normalizationMatrixInfo : ConstantInfo := + kernelInductInfo% NormalizationMatrix + +def normalizationMatrixMkInfo : ConstantInfo := + kernelCtorInfo% NormalizationMatrix.mk + +def normalizationMatrixRecInfo : ConstantInfo := + kernelRecInfo% NormalizationMatrix.rec + +def normalizationMatrixKernelRuleRhs : VExpr := + kernelRecRuleRhs% NormalizationMatrix.rec 0 + +def normalizationMatrixKernelCtor : Constructor where + name := normalizationMatrixMkInfo.name + type := normalizationMatrixMkInfo.type + +def normalizationMatrixKernelType : InductiveType where + name := normalizationMatrixInfo.name + type := normalizationMatrixInfo.type + ctors := [normalizationMatrixKernelCtor] + +theorem normalizationMatrix_kernel_family_name : + normalizationMatrixInfo.name = ``NormalizationMatrix := rfl + +theorem normalizationMatrix_kernel_ctor_name : + normalizationMatrixMkInfo.name = ``NormalizationMatrix.mk := rfl + +theorem normalizationMatrix_kernel_recursor_name : + normalizationMatrixRecInfo.name = ``NormalizationMatrix.rec := rfl + +theorem normalizationMatrix_kernel_constructor_shape : + (match normalizationMatrixMkInfo with + | .ctorInfo info => (info.numParams, info.numFields) + | _ => (0, 0)) = (1, 8) := rfl + +theorem normalizationMatrix_kernel_recursor_shape : + (match normalizationMatrixRecInfo with + | .recInfo info => + (info.numParams, info.numIndices, info.numMotives, + info.numMinors, info.rules.length) + | _ => (0, 0, 0, 0, 0)) = (1, 1, 1, 1, 1) := rfl + +theorem normalizationMatrix_kernel_rule_exact : + normalizationMatrixKernelRuleRhs = + normalizationMatrixGenerationChecked.generatedRules[0].rhs := rfl + +theorem normalizationMatrix_recursive_positions_exact : + normalizationMatrixViewChecked.constructors[0].recursive.map + (fun position => (position.fieldIndex, position.binders.length)) = + [(4, 0), (5, 1), (6, 0), (7, 0)] := rfl + +def matrixCandidateContext (fuel : Nat) : AddInductive.Context where + env := matrixKernelEnv + lparams := [] + safety := .safe + allowPrimitive := false + fuel := { inductiveFuel := fuel } + +def matrixCandidateAccepted (fuel : Nat) : Bool := + match AddInductive.buildNormalizationCandidate 1 + [normalizationMatrixKernelType] 0 false (matrixCandidateContext fuel) with + | .ok _ => true + | .error _ => false + +def matrixTargetExpr (alpha index : Expr) : Expr := + .app (.app (.const ``NormalizationMatrix []) alpha) + (.app (.const ``MatrixIndexAlias []) index) + +def matrixExpectedFamilyView : Expr := + .forallE `alpha (.sort (.succ .zero)) + (.forallE `index (.sort (.succ .zero)) + (.sort (.succ (.succ .zero))) .default) .default + +def matrixExpectedCtorView : Expr := + .forallE `alpha (.sort (.succ .zero)) + (.forallE `index (.sort (.succ .zero)) + (.forallE `ordinary (.sort .zero) + (.forallE `beta (.sort .zero) + (.forallE `letBound (.sort .zero) + (.forallE `direct (matrixTargetExpr (.bvar 4) (.bvar 3)) + (.forallE `piHidden + (.forallE `proof (.sort .zero) + (matrixTargetExpr (.bvar 6) (.bvar 5)) .default) + (.forallE `betaRecursive + (matrixTargetExpr (.bvar 6) (.bvar 5)) + (.forallE `letRecursive + (matrixTargetExpr (.bvar 7) (.bvar 6)) + (matrixTargetExpr (.bvar 8) (.bvar 7)) .default) + .default) + .default) + .default) + .default) + .default) + .default) + .default) + .implicit + +/-- Binder names are not semantic metadata, so exact executable comparisons +canonicalize only those names and preserve every other expression node. -/ +def matrixCanonicalExpr : Expr → Expr + | .app fn arg => .app (matrixCanonicalExpr fn) (matrixCanonicalExpr arg) + | .forallE _ domain body bi => + .forallE `_ (matrixCanonicalExpr domain) (matrixCanonicalExpr body) bi + | expr => expr + +def matrixCandidateExact (context : AddInductive.Context) : Bool := + match AddInductive.buildNormalizationCandidate 1 + [normalizationMatrixKernelType] 0 false context with + | .ok candidate => + (matrixCanonicalExpr candidate.families.singleton.familyType.type.view).equal + (matrixCanonicalExpr matrixExpectedFamilyView) && + match candidate.families.singleton.constructors with + | .cons constructor .nil => + (matrixCanonicalExpr constructor.type.view).equal + (matrixCanonicalExpr matrixExpectedCtorView) + | .error _ => false + +#guard matrixCandidateExact (matrixCandidateContext 10) +#guard matrixCandidateAccepted 10 +#guard !(matrixCandidateAccepted 9) + +def matrixOpaquePiAliasInfo : ConstantInfo := + .axiomInfo { + name := ``MatrixPiAlias + levelParams := matrixPiKernelDef.levelParams + type := matrixPiKernelDef.type + isUnsafe := false } + +def matrixOpaquePiAliasMap : ConstMap := + matrixAliasMap.insert ``MatrixPiAlias matrixOpaquePiAliasInfo + +def matrixOpaquePiAliasContext : AddInductive.Context where + env := Kernel.Environment.ofConstants `_normalizationMatrixOpaquePi + matrixOpaquePiAliasMap + lparams := [] + safety := .safe + allowPrimitive := false + fuel := { inductiveFuel := 10 } + +#guard !(matrixCandidateExact matrixOpaquePiAliasContext) + +def matrixNonDefEqCtor : Constructor where + name := normalizationMatrixMkInfo.name + type := .forallE `alpha (.sort .zero) + (matrixTargetExpr (.sort .zero) (.sort .zero)) .implicit + +def matrixNonDefEqType : InductiveType := + { normalizationMatrixKernelType with ctors := [matrixNonDefEqCtor] } + +#guard match AddInductive.buildNormalizationCandidate 1 + [matrixNonDefEqType] 0 false (matrixCandidateContext 10) with + | .error (.other message) => + message == + "arg #1 of 'Lean4Lean.InductiveFixtures.NormalizationMatrix.mk' does not match inductive datatype parameters" + | _ => false + +/-! ## Translation of every retained alias -/ + +def matrixBetaVal : VDefVal where + name := ``MatrixBetaAlias + uvars := (vconst(type_of% @MatrixBetaAlias) : VConstant).uvars + type := (vconst(type_of% @MatrixBetaAlias) : VConstant).type + value := matrixBetaAliasDefEq.rhs + +def matrixLetVal : VDefVal where + name := ``MatrixLetAlias + uvars := (vconst(type_of% @MatrixLetAlias) : VConstant).uvars + type := (vconst(type_of% @MatrixLetAlias) : VConstant).type + value := matrixLetAliasDefEq.rhs + +def matrixPiVal : VDefVal where + name := ``MatrixPiAlias + uvars := (vconst(type_of% @MatrixPiAlias) : VConstant).uvars + type := (vconst(type_of% @MatrixPiAlias) : VConstant).type + value := matrixPiAliasDefEq.rhs + +def matrixIndexVal : VDefVal where + name := ``MatrixIndexAlias + uvars := (vconst(type_of% @MatrixIndexAlias) : VConstant).uvars + type := (vconst(type_of% @MatrixIndexAlias) : VConstant).type + value := matrixIndexAliasDefEq.rhs + +theorem matrixRecInfo_tr : + TrDefVal .safe typeFamilyAliasEnv recAliasInfo recAliasVal := + recAliasInfo_tr.mono + ((VEnv.addConst_le (by rfl : + VEnv.empty.addConst ``TypeFamilyAlias + (vconst(type_of% @TypeFamilyAlias)) = + some typeFamilyAliasConstEnv)).trans VEnv.addDefEq_le) + +theorem matrixBetaInfo_tr : + TrDefVal .safe normalizationMatrixRecAliasEnv + matrixBetaInfo matrixBetaVal := by + refine ⟨⟨⟨by decide, rfl, ?_⟩, rfl⟩, ?_⟩ + · have hshape : TrTypeExpr normalizationMatrixRecAliasEnv + matrixBetaInfo.levelParams [] matrixBetaInfo.type matrixBetaVal.type := by + tr_type_expr_tac + exact hshape.to_trExprS normalizationMatrixRecAliasEnv_ordered trivial + ⟨_, by type_tac⟩ + · refine .lam ⟨_, VEnv.HasType.sort (by decide)⟩ (.sort rfl) ?_ + refine .app + (VEnv.HasType.lam + (VEnv.HasType.sort (by decide)) + (VEnv.HasType.bvar .zero)) + (VEnv.HasType.bvar .zero) ?_ (.bvar rfl) + exact .lam ⟨_, VEnv.HasType.sort (by decide)⟩ (.sort rfl) (.bvar rfl) + +theorem matrixLetInfo_tr : + TrDefVal .safe normalizationMatrixBetaAliasEnv + matrixLetInfo matrixLetVal := by + refine ⟨⟨⟨by decide, rfl, ?_⟩, rfl⟩, ?_⟩ + · have hshape : TrTypeExpr normalizationMatrixBetaAliasEnv + matrixLetInfo.levelParams [] matrixLetInfo.type matrixLetVal.type := by + tr_type_expr_tac + exact hshape.to_trExprS normalizationMatrixBetaAliasEnv_ordered trivial + ⟨_, by type_tac⟩ + · refine .lam ⟨_, VEnv.HasType.sort (by decide)⟩ (.sort rfl) ?_ + exact .letE (by type_tac) (.sort rfl) (.bvar rfl) (.bvar rfl) + +theorem matrixPiInfo_tr : + TrDefVal .safe normalizationMatrixLetAliasEnv matrixPiInfo matrixPiVal := by + refine ⟨⟨⟨by decide, rfl, ?_⟩, rfl⟩, ?_⟩ + · have hshape : TrTypeExpr normalizationMatrixLetAliasEnv + matrixPiInfo.levelParams [] matrixPiInfo.type matrixPiVal.type := by + tr_type_expr_tac + exact hshape.to_trExprS normalizationMatrixLetAliasEnv_ordered trivial + ⟨_, by type_tac⟩ + · refine .lam ⟨_, VEnv.HasType.sort (by decide)⟩ (.sort rfl) ?_ + apply TrExprS.forallE + · exact ⟨_, VEnv.HasType.sort (by decide)⟩ + · exact ⟨.param 0, VEnv.HasType.bvar (.succ .zero)⟩ + · exact .sort rfl + · exact .bvar rfl + +theorem matrixIndexInfo_tr : + TrDefVal .safe normalizationMatrixPiAliasEnv + matrixIndexInfo matrixIndexVal := by + have hfamily : normalizationMatrixPiAliasEnv.constants + ``TypeFamilyAlias = some (vconst(type_of% @TypeFamilyAlias)) := rfl + refine ⟨⟨⟨by decide, rfl, ?_⟩, rfl⟩, ?_⟩ + · have hshape : TrTypeExpr normalizationMatrixPiAliasEnv + matrixIndexInfo.levelParams [] matrixIndexInfo.type matrixIndexVal.type := by + tr_type_expr_tac + exact hshape.to_trExprS normalizationMatrixPiAliasEnv_ordered trivial + ⟨_, by type_tac⟩ + · refine .lam ⟨_, by type_tac⟩ ?_ (.bvar rfl) + exact .const rfl rfl rfl + +theorem matrixBetaVal_wf : matrixBetaVal.WF + normalizationMatrixRecAliasEnv := by + type_tac + +theorem matrixLetVal_wf : matrixLetVal.WF + normalizationMatrixBetaAliasEnv := by + type_tac + +theorem matrixPiVal_wf : matrixPiVal.WF + normalizationMatrixLetAliasEnv := by + apply VEnv.HasType.lam + · exact VEnv.HasType.sort (by decide) + · apply VEnv.IsDefEq.defeq + (VEnv.IsDefEq.sortDF + (l := .imax (.succ .zero) (.param 0)) (l' := .param 0) + (by decide) (by decide) (by + rw [VLevel.equiv_def] + intro ls + simp only [VLevel.eval, Nat.zero_add] + let n := ls.getD 0 0 + change Nat.imax 1 n = n + by_cases h : n = 0 + · simp [Nat.imax, h] + · have hn : 1 ≤ n := Nat.one_le_iff_ne_zero.mpr h + simp [Nat.imax, h, Nat.max_eq_right hn])) + exact VEnv.HasType.forallE (VEnv.HasType.sort (by decide)) + (VEnv.HasType.bvar (.succ .zero)) + +theorem matrixIndexVal_wf : matrixIndexVal.WF + normalizationMatrixPiAliasEnv := by + have hfamily : normalizationMatrixPiAliasEnv.constants + ``TypeFamilyAlias = some (vconst(type_of% @TypeFamilyAlias)) := rfl + type_tac + +theorem matrixRec_trEnv' : + TrEnv' .safe matrixRecMap false normalizationMatrixRecAliasEnv := + .defn (ci := recAliasKernelDef) (ci' := recAliasVal) + matrixRecInfo_tr matrixRec_fresh + (recAliasVal_wf.mono + ((VEnv.addConst_le (by rfl : + VEnv.empty.addConst ``TypeFamilyAlias + (vconst(type_of% @TypeFamilyAlias)) = + some typeFamilyAliasConstEnv)).trans VEnv.addDefEq_le)) + rfl typeFamilyAlias_trEnv' + +theorem matrixBeta_trEnv' : + TrEnv' .safe matrixBetaMap false normalizationMatrixBetaAliasEnv := + .defn (ci := matrixBetaKernelDef) (ci' := matrixBetaVal) + matrixBetaInfo_tr matrixBeta_fresh matrixBetaVal_wf rfl matrixRec_trEnv' + +theorem matrixLet_trEnv' : + TrEnv' .safe matrixLetMap false normalizationMatrixLetAliasEnv := + .defn (ci := matrixLetKernelDef) (ci' := matrixLetVal) + matrixLetInfo_tr matrixLet_fresh matrixLetVal_wf rfl matrixBeta_trEnv' + +theorem matrixPi_trEnv' : + TrEnv' .safe matrixPiMap false normalizationMatrixPiAliasEnv := + .defn (ci := matrixPiKernelDef) (ci' := matrixPiVal) + matrixPiInfo_tr matrixPi_fresh matrixPiVal_wf rfl matrixLet_trEnv' + +theorem matrixAlias_trEnv' : + TrEnv' .safe matrixAliasMap false normalizationMatrixAliasEnv := + .defn (ci := matrixIndexKernelDef) (ci' := matrixIndexVal) + matrixIndexInfo_tr matrixIndex_fresh matrixIndexVal_wf rfl matrixPi_trEnv' + +/-! ## Replay of the actual inductive transaction -/ + +def normalizationMatrixTypeEnv : VEnv := + (normalizationMatrixAliasEnv.addConst normalizationMatrixRawType.name + normalizationMatrixRawType.toVConstant).get (by decide) + +def normalizationMatrixCtorEnv : VEnv := + (normalizationMatrixTypeEnv.addConst + normalizationMatrixRawType.ctors[0].name + normalizationMatrixRawType.ctors[0].toVConstant).get (by decide) + +def normalizationMatrixRecEnv : VEnv := + (normalizationMatrixCtorEnv.addConst ``NormalizationMatrix.rec + normalizationMatrixGenerationChecked.recursor).get (by decide) + +theorem normalizationMatrixTypeEnv_ordered : + normalizationMatrixTypeEnv.Ordered := by + refine .const (n := normalizationMatrixRawType.name) + (ci := normalizationMatrixRawType.toVConstant) + normalizationMatrixAliasEnv_ordered ?_ rfl + show normalizationMatrixAliasEnv.IsType + normalizationMatrixGenerationChecked.block.sourceType.uvars [] + normalizationMatrixGenerationChecked.block.sourceType.type + rw [normalizationMatrixGenerationChecked.block.sourceType_uvars_eq] + exact normalizationMatrixGenerationChecked_wf.rawFamily_isType + +theorem normalizationMatrixRawCtor_wf : + normalizationMatrixRawType.ctors[0].toVConstant.WF + normalizationMatrixTypeEnv := by + have hctor : + (⟨normalizationMatrixRawType.ctors[0], + normalizationMatrixViewChecked.constructors[0]⟩ : + VInductDecl.NormalizedCtor) ∈ + normalizationMatrixGenerationChecked.block.ctorPairs := by + exact .head _ + show normalizationMatrixTypeEnv.IsType + normalizationMatrixRawType.ctors[0].uvars [] + normalizationMatrixRawType.ctors[0].type + rw [normalizationMatrixGenerationChecked.ctor_uvars_eq hctor] + exact normalizationMatrixGenerationChecked_wf.rawCtor_isType rfl hctor + +theorem normalizationMatrixCtorEnv_ordered : + normalizationMatrixCtorEnv.Ordered := + .const (n := normalizationMatrixRawType.ctors[0].name) + (ci := normalizationMatrixRawType.ctors[0].toVConstant) + normalizationMatrixTypeEnv_ordered normalizationMatrixRawCtor_wf rfl + +theorem normalizationMatrixGenerationEnv : + VInductDecl.GenerationEnv normalizationMatrixGenerationChecked + normalizationMatrixCtorEnv := by + apply normalizationMatrixGenerationChecked_wf.toGenerationEnv + (envT := normalizationMatrixTypeEnv) + · rfl + · exact (VEnv.addConst_le (show + normalizationMatrixAliasEnv.addConst normalizationMatrixRawType.name + normalizationMatrixRawType.toVConstant = + some normalizationMatrixTypeEnv from rfl)).trans + (VEnv.addConst_le (show + normalizationMatrixTypeEnv.addConst + normalizationMatrixRawType.ctors[0].name + normalizationMatrixRawType.ctors[0].toVConstant = + some normalizationMatrixCtorEnv from rfl)) + · exact VEnv.addConst_le (show + normalizationMatrixTypeEnv.addConst + normalizationMatrixRawType.ctors[0].name + normalizationMatrixRawType.ctors[0].toVConstant = + some normalizationMatrixCtorEnv from rfl) + · exact normalizationMatrixCtorEnv_ordered + · rfl + · intro ctor hctor + change ctor ∈ + [⟨normalizationMatrixRawType.ctors[0], + normalizationMatrixViewChecked.constructors[0]⟩] at hctor + obtain rfl := List.mem_singleton.1 hctor + rfl + +theorem normalizationMatrixInfo_tr : + TrConstVal .safe normalizationMatrixAliasEnv normalizationMatrixInfo + normalizationMatrixRawType.toVConstVal := by + have hTypeFamily : normalizationMatrixAliasEnv.constants + ``TypeFamilyAlias = some (vconst(type_of% @TypeFamilyAlias)) := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr normalizationMatrixAliasEnv + normalizationMatrixInfo.levelParams [] normalizationMatrixInfo.type + normalizationMatrixRawType.type := by + tr_type_expr_tac + obtain ⟨u, htype⟩ := + normalizationMatrixGenerationChecked_wf.rawFamily_isType + exact hshape.to_trExprS normalizationMatrixAliasEnv_ordered trivial + ⟨.sort u, htype⟩ + +theorem normalizationMatrixMkInfo_tr : + TrConstVal .safe normalizationMatrixTypeEnv normalizationMatrixMkInfo + normalizationMatrixRawType.ctors[0] := by + have hTypeFamily : normalizationMatrixTypeEnv.constants + ``TypeFamilyAlias = some (vconst(type_of% @TypeFamilyAlias)) := rfl + have hRecAlias : normalizationMatrixTypeEnv.constants + ``RecAlias = some (vconst(type_of% @RecAlias)) := rfl + have hBetaAlias : normalizationMatrixTypeEnv.constants + ``MatrixBetaAlias = some (vconst(type_of% @MatrixBetaAlias)) := rfl + have hLetAlias : normalizationMatrixTypeEnv.constants + ``MatrixLetAlias = some (vconst(type_of% @MatrixLetAlias)) := rfl + have hPiAlias : normalizationMatrixTypeEnv.constants + ``MatrixPiAlias = some (vconst(type_of% @MatrixPiAlias)) := rfl + have hIndexAlias : normalizationMatrixTypeEnv.constants + ``MatrixIndexAlias = some (vconst(type_of% @MatrixIndexAlias)) := rfl + have hFamily : normalizationMatrixTypeEnv.constants + ``NormalizationMatrix = some normalizationMatrixRawType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr normalizationMatrixTypeEnv + normalizationMatrixMkInfo.levelParams [] normalizationMatrixMkInfo.type + normalizationMatrixRawType.ctors[0].type := by + tr_type_expr_tac + obtain ⟨u, htype⟩ := normalizationMatrixRawCtor_wf + exact hshape.to_trExprS normalizationMatrixTypeEnv_ordered trivial + ⟨.sort u, htype⟩ + +theorem normalizationMatrixRecInfo_tr : + TrConstVal .safe normalizationMatrixCtorEnv normalizationMatrixRecInfo + (inductGenerationRecVal normalizationMatrixGenerationChecked) := by + have hTypeFamily : normalizationMatrixCtorEnv.constants + ``TypeFamilyAlias = some (vconst(type_of% @TypeFamilyAlias)) := rfl + have hIndexAlias : normalizationMatrixCtorEnv.constants + ``MatrixIndexAlias = some (vconst(type_of% @MatrixIndexAlias)) := rfl + have hFamily : normalizationMatrixCtorEnv.constants + ``NormalizationMatrix = some normalizationMatrixRawType.toVConstant := rfl + have hMk : normalizationMatrixCtorEnv.constants + ``NormalizationMatrix.mk = + some normalizationMatrixRawType.ctors[0].toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have hshape : TrTypeExpr normalizationMatrixCtorEnv + normalizationMatrixRecInfo.levelParams [] normalizationMatrixRecInfo.type + (inductGenerationRecVal normalizationMatrixGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨u, hrec⟩ := normalizationMatrixGenerationEnv.recursor_wf + exact hshape.to_trExprS normalizationMatrixCtorEnv_ordered trivial + ⟨.sort u, hrec⟩ + +def normalizationMatrixTypeMap : ConstMap := + matrixAliasMap.insert ``NormalizationMatrix normalizationMatrixInfo + +def normalizationMatrixCtorMap : ConstMap := + normalizationMatrixTypeMap.insert ``NormalizationMatrix.mk + normalizationMatrixMkInfo + +def normalizationMatrixMap : ConstMap := + normalizationMatrixCtorMap.insert ``NormalizationMatrix.rec + normalizationMatrixRecInfo + +theorem normalizationMatrixType_fresh : + matrixAliasMap.find? ``NormalizationMatrix = none := by + rw [matrixAliasMap, matrixPiMap_wf.find?_insert, + matrixPiMap, matrixLetMap_wf.find?_insert, + matrixLetMap, matrixBetaMap_wf.find?_insert, + matrixBetaMap, matrixRecMap_wf.find?_insert, + matrixRecMap, typeFamilyAliasMap_wf.find?_insert, + typeFamilyAliasMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem normalizationMatrixTypeMap_wf : normalizationMatrixTypeMap.WF := + matrixAliasMap_wf.insert _ _ normalizationMatrixType_fresh + +theorem normalizationMatrixMk_fresh : + normalizationMatrixTypeMap.find? ``NormalizationMatrix.mk = none := by + rw [normalizationMatrixTypeMap, matrixAliasMap_wf.find?_insert, + matrixAliasMap, matrixPiMap_wf.find?_insert, + matrixPiMap, matrixLetMap_wf.find?_insert, + matrixLetMap, matrixBetaMap_wf.find?_insert, + matrixBetaMap, matrixRecMap_wf.find?_insert, + matrixRecMap, typeFamilyAliasMap_wf.find?_insert, + typeFamilyAliasMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem normalizationMatrixCtorMap_wf : normalizationMatrixCtorMap.WF := + normalizationMatrixTypeMap_wf.insert _ _ normalizationMatrixMk_fresh + +theorem normalizationMatrixRec_fresh : + normalizationMatrixCtorMap.find? ``NormalizationMatrix.rec = none := by + rw [normalizationMatrixCtorMap, + normalizationMatrixTypeMap_wf.find?_insert, + normalizationMatrixTypeMap, matrixAliasMap_wf.find?_insert, + matrixAliasMap, matrixPiMap_wf.find?_insert, + matrixPiMap, matrixLetMap_wf.find?_insert, + matrixLetMap, matrixBetaMap_wf.find?_insert, + matrixBetaMap, matrixRecMap_wf.find?_insert, + matrixRecMap, typeFamilyAliasMap_wf.find?_insert, + typeFamilyAliasMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +private def normalizationMatrixAddInductTraceWith + (generation_wf : + normalizationMatrixGenerationChecked.WF normalizationMatrixAliasEnv) : + AddInductTrace matrixAliasMap normalizationMatrixAliasEnv + normalizationMatrixRawDecl normalizationMatrixMap + normalizationMatrixFinalEnv := by + refine { + generation := normalizationMatrixGenerationChecked + generation_wf := generation_wf + typeMap := normalizationMatrixTypeMap + typeEnv := normalizationMatrixTypeEnv + ctorMap := normalizationMatrixCtorMap + ctorEnv := normalizationMatrixCtorEnv + recEnv := normalizationMatrixRecEnv + addType := { + info := normalizationMatrixInfo + kind_eq := by simp [normalizationMatrixInfo, InductConstantKind.Matches] + tr := normalizationMatrixInfo_tr + map_fresh := by + change matrixAliasMap.find? ``NormalizationMatrix = none + exact normalizationMatrixType_fresh + env_add := rfl + map_add := rfl } + addCtors := ?_ + addRec := { + info := normalizationMatrixRecInfo + kind_eq := by + simp [normalizationMatrixRecInfo, InductConstantKind.Matches] + tr := normalizationMatrixRecInfo_tr + map_fresh := by + change normalizationMatrixCtorMap.find? + ``NormalizationMatrix.rec = none + exact normalizationMatrixRec_fresh + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ } + exact .cons { + info := normalizationMatrixMkInfo + kind_eq := by + simp [normalizationMatrixMkInfo, InductConstantKind.Matches] + tr := normalizationMatrixMkInfo_tr + map_fresh := by + simpa [normalizationMatrixRawType] using normalizationMatrixMk_fresh + env_add := rfl + map_add := rfl } .nil + +theorem normalizationMatrix_addInduct : + AddInduct matrixAliasMap normalizationMatrixAliasEnv + normalizationMatrixRawDecl normalizationMatrixMap + normalizationMatrixFinalEnv := + ⟨normalizationMatrixAddInductTraceWith + normalizationMatrixGenerationChecked_wf⟩ + +/-- Actual kernel metadata for the complete matrix is aligned with the Theory +environment obtained from the semantically checked normalization transaction. -/ +theorem normalizationMatrix_trEnv' : + TrEnv' .safe normalizationMatrixMap false normalizationMatrixFinalEnv := + .induct normalizationMatrix_addInduct matrixAlias_trEnv' + +theorem normalizationMatrix_final_matches_generation : + normalizationMatrixAliasEnv.addInductGeneration + normalizationMatrixGenerationChecked = + some normalizationMatrixFinalEnv := + normalizationMatrix_addInductGeneration + +theorem normalizationMatrix_env_wf : normalizationMatrixFinalEnv.WF := + normalizationMatrix_trEnv'.wf + +theorem normalizationMatrix_aligned : + Aligned .safe normalizationMatrixMap normalizationMatrixFinalEnv := + normalizationMatrix_trEnv'.aligned + +theorem normalizationMatrix_type_map_lookup : + normalizationMatrixMap.find? ``NormalizationMatrix = + some normalizationMatrixInfo := by + rw [normalizationMatrixMap, normalizationMatrixCtorMap_wf.find?_insert, + normalizationMatrixCtorMap, normalizationMatrixTypeMap_wf.find?_insert, + normalizationMatrixTypeMap, matrixAliasMap_wf.find?_insert] + rfl + +theorem normalizationMatrix_type_lookup_unique : + normalizationMatrixInfo.name = ``NormalizationMatrix ∧ + TrConstant .safe normalizationMatrixFinalEnv normalizationMatrixInfo + normalizationMatrixRawType.toVConstant := + normalizationMatrix_aligned.find?_uniq + normalizationMatrix_type_map_lookup + normalizationMatrixFinalEnv_family_lookup + +theorem normalizationMatrix_mk_map_lookup : + normalizationMatrixMap.find? ``NormalizationMatrix.mk = + some normalizationMatrixMkInfo := by + rw [normalizationMatrixMap, normalizationMatrixCtorMap_wf.find?_insert, + normalizationMatrixCtorMap, normalizationMatrixTypeMap_wf.find?_insert] + rfl + +theorem normalizationMatrix_mk_lookup_unique : + normalizationMatrixMkInfo.name = ``NormalizationMatrix.mk ∧ + TrConstant .safe normalizationMatrixFinalEnv normalizationMatrixMkInfo + normalizationMatrixRawType.ctors[0].toVConstant := + normalizationMatrix_aligned.find?_uniq + normalizationMatrix_mk_map_lookup + normalizationMatrixFinalEnv_ctor_lookup + +theorem normalizationMatrix_rec_map_lookup : + normalizationMatrixMap.find? ``NormalizationMatrix.rec = + some normalizationMatrixRecInfo := by + rw [normalizationMatrixMap, normalizationMatrixCtorMap_wf.find?_insert] + rfl + +theorem normalizationMatrix_rec_lookup_unique : + normalizationMatrixRecInfo.name = ``NormalizationMatrix.rec ∧ + TrConstant .safe normalizationMatrixFinalEnv normalizationMatrixRecInfo + normalizationMatrixGenerationChecked.recursor := + normalizationMatrix_aligned.find?_uniq + normalizationMatrix_rec_map_lookup + 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. -/ + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.normalizationMatrixInfo_tr' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms normalizationMatrixInfo_tr + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.normalizationMatrix_trEnv'' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms normalizationMatrix_trEnv' + +end Lean4Lean.InductiveReplayFixtures diff --git a/Lean4Lean/Verify/Environment/SingletonParityMatrix.lean b/Lean4Lean/Verify/Environment/SingletonParityMatrix.lean new file mode 100644 index 00000000..1a582cee --- /dev/null +++ b/Lean4Lean/Verify/Environment/SingletonParityMatrix.lean @@ -0,0 +1,471 @@ +import Lean4Lean.Theory.SingletonParity +import Lean4Lean.Verify.Environment.ConstructorValidityMatrix +import Lean4Lean.Verify.Environment.EliminationFixturesEqNat +import Lean4Lean.Verify.Environment.EliminationFixturesOrAnd +import Lean4Lean.Verify.Environment.EliminationFixturesEdges +import Lean4Lean.Verify.Environment.NormalizationMatrix + +/-! +# L4L-07 complete singleton kernel matrix + +The rows below join the single Theory artifact inventory to Lean's actual +`inductInfo`/`ctorInfo`/`recInfo` records. The executable predicate compares +the retained raw types, names, parameter/index and field counts, universe +order, elimination/K metadata, recursor type, rule count, and every iota RHS. +It also reruns the ordinary normalization producer on the exact kernel source. +-/ + +namespace Lean4Lean.InductiveReplayFixtures + +open Lean Meta Elab Term +open Lean4Lean.InductiveFixtures + +/-! ## Exact conversion of stored kernel types -/ + +syntax "kernelConstVType%" ident : term + +/-- Quote the stored `ConstantInfo.type` using that record's own universe +parameter order. Unlike `vconst(type_of% ...)`, this observes the raw kernel +record directly. -/ +elab_rules : term + | `(kernelConstVType% $n:ident) => do + let name ← realizeGlobalConstNoOverloadWithInfo n + let info ← getConstInfo name + let type ← Lean4Lean.Meta.expandExpr info.type + let type ← Lean4Lean.Meta.ofExpr info.levelParams {} type + return toExpr type + +/-! ## Missing standard-library metadata rows -/ + +def boolInfo07 : ConstantInfo := kernelInductInfo% Bool +def boolFalseInfo07 : ConstantInfo := kernelCtorInfo% Bool.false +def boolTrueInfo07 : ConstantInfo := kernelCtorInfo% Bool.true +def boolRecInfo07 : ConstantInfo := kernelRecInfo% Bool.rec +def boolFalseRuleRhs07 : VExpr := kernelRecRuleRhs% Bool.rec 0 +def boolTrueRuleRhs07 : VExpr := kernelRecRuleRhs% Bool.rec 1 + +def listInfo07 : ConstantInfo := kernelInductInfo% List +def listNilInfo07 : ConstantInfo := kernelCtorInfo% List.nil +def listConsInfo07 : ConstantInfo := kernelCtorInfo% List.cons +def listRecInfo07 : ConstantInfo := kernelRecInfo% List.rec +def listNilRuleRhs07 : VExpr := kernelRecRuleRhs% List.rec 0 +def listConsRuleRhs07 : VExpr := kernelRecRuleRhs% List.rec 1 + +def optionInfo07 : ConstantInfo := kernelInductInfo% Option +def optionNoneInfo07 : ConstantInfo := kernelCtorInfo% Option.none +def optionSomeInfo07 : ConstantInfo := kernelCtorInfo% Option.some +def optionRecInfo07 : ConstantInfo := kernelRecInfo% Option.rec +def optionNoneRuleRhs07 : VExpr := kernelRecRuleRhs% Option.rec 0 +def optionSomeRuleRhs07 : VExpr := kernelRecRuleRhs% Option.rec 1 + +def prodInfo07 : ConstantInfo := kernelInductInfo% Prod +def prodMkInfo07 : ConstantInfo := kernelCtorInfo% Prod.mk +def prodRecInfo07 : ConstantInfo := kernelRecInfo% Prod.rec +def prodRuleRhs07 : VExpr := kernelRecRuleRhs% Prod.rec 0 + +def heqInfo07 : ConstantInfo := kernelInductInfo% HEq +def heqReflInfo07 : ConstantInfo := kernelCtorInfo% HEq.refl +def heqRecInfo07 : ConstantInfo := kernelRecInfo% HEq.rec +def heqRuleRhs07 : VExpr := kernelRecRuleRhs% HEq.rec 0 + +def finInfo07 : ConstantInfo := kernelInductInfo% Fin +def finMkInfo07 : ConstantInfo := kernelCtorInfo% Fin.mk +def finRecInfo07 : ConstantInfo := kernelRecInfo% Fin.rec +def finRuleRhs07 : VExpr := kernelRecRuleRhs% Fin.rec 0 + +def vectorInfo07 : ConstantInfo := kernelInductInfo% Vector +def vectorMkInfo07 : ConstantInfo := kernelCtorInfo% Vector.mk +def vectorRecInfo07 : ConstantInfo := kernelRecInfo% Vector.rec +def vectorRuleRhs07 : VExpr := kernelRecRuleRhs% Vector.rec 0 + +/-! ## Producer dependency contexts -/ + +def finDependencyMap07 : ConstMap := + ((((({} : ConstMap).insert ``Nat natInfo).insert ``LT + (kernelInductInfo% LT)).insert ``LT.mk + (kernelCtorInfo% LT.mk)).insert ``LT.lt + (.defnInfo (kernelDefVal% LT.lt))).insert ``instLTNat + (.defnInfo (kernelDefVal% instLTNat)) + +def vectorDependencyMap07 : ConstMap := + (((({} : ConstMap).insert ``Nat natInfo).insert ``Eq eqInfo).insert ``Array + (kernelInductInfo% Array)).insert ``Array.size + (.defnInfo (kernelDefVal% Array.size)) + +/-! ## Integrated row type -/ + +structure SingletonKernelRow where + artifact : SingletonParityArtifact + inductInfo : ConstantInfo + ctorInfos : List ConstantInfo + recInfo : ConstantInfo + familyType : VExpr + ctorTypes : List VExpr + recType : VExpr + ruleRhs : List VExpr + dependencies : ConstMap := {} + +namespace SingletonKernelRow + +def constructor? : ConstantInfo → Option Constructor + | .ctorInfo ctor => some { name := ctor.name, type := ctor.type } + | _ => none + +def kernelType? (row : SingletonKernelRow) : Option InductiveType := do + let .inductInfo induct := row.inductInfo | none + let ctors ← row.ctorInfos.mapM constructor? + some { name := induct.name, type := induct.type, ctors := ctors } + +def context (row : SingletonKernelRow) : AddInductive.Context where + env := Kernel.Environment.ofConstants + (.str `_singletonParity row.artifact.label.toString) row.dependencies + lparams := row.inductInfo.levelParams + safety := .safe + allowPrimitive := row.artifact.typeName == ``Nat || + row.artifact.typeName == ``Bool + +def producerAccepted (row : SingletonKernelRow) : Bool := + match row.kernelType? with + | none => false + | some kernelType => + match AddInductive.buildNormalizationCandidate + row.artifact.source.nparams [kernelType] 0 false row.context with + | .ok _ => true + | .error _ => false + +def ctorMatches (row : SingletonKernelRow) (info : ConstantInfo) + (raw : VConstVal) (rawType : VExpr) : Bool := + match info with + | .ctorInfo ctor => + ctor.name == raw.name && + ctor.levelParams.length == row.artifact.source.uvars && + ctor.induct == row.artifact.typeName && + ctor.numParams == row.artifact.source.nparams && + ctor.numFields == (VInductDecl.ctorFields + (VExpr.dropN row.artifact.source.nparams raw.type)).length && + !ctor.isUnsafe && rawType == raw.type + | _ => false + +def constructorsMatch (row : SingletonKernelRow) : + List ConstantInfo → List VConstVal → List VExpr → Bool + | [], [], [] => true + | info :: infos, raw :: raws, rawType :: rawTypes => + row.ctorMatches info raw rawType && + row.constructorsMatch infos raws rawTypes + | _, _, _ => false + +def recursorMatches (row : SingletonKernelRow) : Bool := + match row.recInfo with + | .recInfo rec => + rec.name == .str row.artifact.typeName "rec" && + rec.levelParams.length == row.artifact.generation.recUvars && + rec.all == [row.artifact.typeName] && + rec.numParams == row.artifact.source.nparams && + rec.numIndices == + row.artifact.generation.block.checked.indices.length && + rec.numMotives == 1 && + rec.numMinors == + row.artifact.generation.block.sourceType.ctors.length && + rec.k == row.artifact.generation.kTarget && + !rec.isUnsafe && + rec.rules.map (fun rule => (rule.ctor, rule.nfields)) == + row.artifact.generation.block.sourceType.ctors.map (fun ctor => + (ctor.name, (VInductDecl.ctorFields + (VExpr.dropN row.artifact.source.nparams ctor.type)).length)) && + row.recType == row.artifact.generation.recursor.type && + row.ruleRhs == + row.artifact.generation.generatedRules.map (·.rhs) + | _ => false + +/-- Exact fixed-row agreement after binder-name erasure. Universe order is +still observed: `familyType`/`ctorTypes`/`recType` were converted with the +stored metadata parameter lists, not with elaborator-inferred ordering. -/ +def agrees (row : SingletonKernelRow) : Bool := + match row.inductInfo with + | .inductInfo induct => + induct.name == row.artifact.typeName && + induct.levelParams.length == row.artifact.source.uvars && + induct.numParams == row.artifact.source.nparams && + induct.numIndices == + row.artifact.generation.block.checked.indices.length && + induct.all == [row.artifact.typeName] && + induct.ctors == row.artifact.constructorNames && + induct.numNested == 0 && !induct.isUnsafe && + row.familyType == row.artifact.generation.block.sourceType.type && + row.constructorsMatch row.ctorInfos + row.artifact.generation.block.sourceType.ctors row.ctorTypes && + row.recursorMatches + | _ => false + +end SingletonKernelRow + +/-! ## The fixed rows -/ + +def singletonKernelRows : List SingletonKernelRow := + [ { artifact := singletonPositiveArtifacts[0] + inductInfo := natInfo + ctorInfos := [natZeroInfo, natSuccInfo] + recInfo := natRecInfo + familyType := kernelConstVType% Nat + ctorTypes := [kernelConstVType% Nat.zero, kernelConstVType% Nat.succ] + recType := kernelConstVType% Nat.rec + ruleRhs := [natZeroKernelRuleRhs, natSuccKernelRuleRhs] }, + { artifact := singletonPositiveArtifacts[1] + inductInfo := boolInfo07 + ctorInfos := [boolFalseInfo07, boolTrueInfo07] + recInfo := boolRecInfo07 + familyType := kernelConstVType% Bool + ctorTypes := [kernelConstVType% Bool.false, kernelConstVType% Bool.true] + recType := kernelConstVType% Bool.rec + ruleRhs := [boolFalseRuleRhs07, boolTrueRuleRhs07] }, + { artifact := singletonPositiveArtifacts[2] + inductInfo := listInfo07 + ctorInfos := [listNilInfo07, listConsInfo07] + recInfo := listRecInfo07 + familyType := kernelConstVType% List + ctorTypes := [kernelConstVType% List.nil, kernelConstVType% List.cons] + recType := kernelConstVType% List.rec + ruleRhs := [listNilRuleRhs07, listConsRuleRhs07] }, + { artifact := singletonPositiveArtifacts[3] + inductInfo := optionInfo07 + ctorInfos := [optionNoneInfo07, optionSomeInfo07] + recInfo := optionRecInfo07 + familyType := kernelConstVType% Option + ctorTypes := [kernelConstVType% Option.none, + kernelConstVType% Option.some] + recType := kernelConstVType% Option.rec + ruleRhs := [optionNoneRuleRhs07, optionSomeRuleRhs07] }, + { artifact := singletonPositiveArtifacts[4] + inductInfo := prodInfo07 + ctorInfos := [prodMkInfo07] + recInfo := prodRecInfo07 + familyType := kernelConstVType% Prod + ctorTypes := [kernelConstVType% Prod.mk] + recType := kernelConstVType% Prod.rec + ruleRhs := [prodRuleRhs07] }, + { artifact := singletonPositiveArtifacts[5] + inductInfo := punitInfo06C + ctorInfos := [punitCtorInfo06C] + recInfo := punitRecInfo06C + familyType := kernelConstVType% PUnit + ctorTypes := [kernelConstVType% PUnit.unit] + recType := kernelConstVType% PUnit.rec + ruleRhs := [punitRuleRhs06C] }, + { artifact := singletonPositiveArtifacts[6] + inductInfo := emptyInfo06C + ctorInfos := [] + recInfo := emptyRecInfo06C + familyType := kernelConstVType% Empty + ctorTypes := [] + recType := kernelConstVType% Empty.rec + ruleRhs := [] }, + { artifact := singletonPositiveArtifacts[7] + inductInfo := orInfo06 + ctorInfos := [orInlInfo06, orInrInfo06] + recInfo := orRecInfo06 + familyType := kernelConstVType% Or + ctorTypes := [kernelConstVType% Or.inl, kernelConstVType% Or.inr] + recType := kernelConstVType% Or.rec + ruleRhs := [orInlKernelRuleRhs06, orInrKernelRuleRhs06] }, + { artifact := singletonPositiveArtifacts[8] + inductInfo := andInfo06 + ctorInfos := [andIntroInfo06] + recInfo := andRecInfo06 + familyType := kernelConstVType% And + ctorTypes := [kernelConstVType% And.intro] + recType := kernelConstVType% And.rec + ruleRhs := [andKernelRuleRhs06] }, + { artifact := singletonPositiveArtifacts[9] + inductInfo := eqInfo + ctorInfos := [eqReflInfo] + recInfo := eqRecInfo + familyType := kernelConstVType% Eq + ctorTypes := [kernelConstVType% Eq.refl] + recType := kernelConstVType% Eq.rec + ruleRhs := [eqReflKernelRuleRhs] }, + { artifact := singletonPositiveArtifacts[10] + inductInfo := heqInfo07 + ctorInfos := [heqReflInfo07] + recInfo := heqRecInfo07 + familyType := kernelConstVType% HEq + ctorTypes := [kernelConstVType% HEq.refl] + recType := kernelConstVType% HEq.rec + ruleRhs := [heqRuleRhs07] }, + { artifact := singletonPositiveArtifacts[11] + inductInfo := finInfo07 + ctorInfos := [finMkInfo07] + recInfo := finRecInfo07 + familyType := kernelConstVType% Fin + ctorTypes := [kernelConstVType% Fin.mk] + recType := kernelConstVType% Fin.rec + ruleRhs := [finRuleRhs07] + dependencies := finDependencyMap07 }, + { artifact := singletonPositiveArtifacts[12] + inductInfo := vectorInfo07 + ctorInfos := [vectorMkInfo07] + recInfo := vectorRecInfo07 + familyType := kernelConstVType% Vector + ctorTypes := [kernelConstVType% Vector.mk] + recType := kernelConstVType% Vector.rec + ruleRhs := [vectorRuleRhs07] + dependencies := vectorDependencyMap07 }, + { artifact := singletonPositiveArtifacts[13] + inductInfo := accInfo + ctorInfos := [accIntroInfo] + recInfo := accRecInfo + familyType := kernelConstVType% Acc + ctorTypes := [kernelConstVType% Acc.intro] + recType := kernelConstVType% Acc.rec + ruleRhs := [accKernelRuleRhs] } ] + +example : singletonKernelRows.map (·.artifact.label) = + singletonPositiveArtifacts.map (·.label) := rfl + +#guard singletonKernelRows.all (·.agrees) +#guard singletonKernelRows.all (·.producerAccepted) + +/-! ## Consolidated rejection matrix -/ + +/-- One named rejection whose Boolean is computed by the public Theory +analyzer, the ordinary metadata producer, or the environment transaction it +is intended to guard. -/ +structure SingletonNegativeRow where + label : Name + rejected : Bool + +def theoryDeclarationRejected07 (decl : VInductDecl) : Bool := + decl.checked?.isNone && (VEnv.empty.addInduct decl).isNone + +def producerRejected07 (nparams : Nat) (source : InductiveType) + (context : AddInductive.Context) : Bool := + match AddInductive.buildNormalizationCandidate nparams [source] 0 false + context with + | .error _ => true + | .ok _ => false + +def aliasFormerTruncatedViewType07 : VInductiveType := + { aliasFormerViewType with ctors := [] } + +def aliasFormerTruncatedViewDecl07 : VInductDecl := + { aliasFormerViewDecl with types := [aliasFormerTruncatedViewType07] } + +def listReorderedViewType07 : VInductiveType := + { listType with ctors := listType.ctors.reverse } + +def listReorderedViewDecl07 : VInductDecl := + { listDecl with types := [listReorderedViewType07] } + +def recursorKRejected07 (info : ConstantInfo) (expected : Bool) : Bool := + match info with + | .recInfo rec => rec.k != expected + | _ => false + +/-- A large recursor has one fresh universe parameter and a small recursor +has none. Supplying the wrong mode must therefore disagree with the actual +metadata even when the source-universe list itself is otherwise unchanged. -/ +def recursorEliminationRejected07 (info : ConstantInfo) (sourceUvars : Nat) : + VInductDecl.ElimMode → Bool + | VInductDecl.ElimMode.large => + info.levelParams.length != sourceUvars + 1 + | VInductDecl.ElimMode.small => + info.levelParams.length != sourceUvars + +def typeCollisionEnv07 : VEnv := + (VEnv.empty.addConst ``Nat ⟨0, .sort .zero⟩).get (by decide) + +/-- The complete L4L-07 negative matrix. Earlier phase-specific fixtures +retain their exact kernel error messages; this table makes their coverage and +combined acceptance result executable from one public artifact path. -/ +def singletonNegativeRows : List SingletonNegativeRow := + [ ⟨.mkSimple "loose-variables", + theoryDeclarationRejected07 looseIndexDecl⟩, + ⟨.mkSimple "duplicate-constructor-name", + theoryDeclarationRejected07 duplicateCtorDecl⟩, + ⟨.mkSimple "type-constructor-name-alias", + theoryDeclarationRejected07 typeCtorAliasDecl⟩, + ⟨.mkSimple "constructor-recursor-name-alias", + theoryDeclarationRejected07 ctorRecAliasDecl⟩, + ⟨.mkSimple "self-reference-before-family-staging", + theoryDeclarationRejected07 selfParamDecl⟩, + ⟨.mkSimple "bad-parameter-universe", + theoryDeclarationRejected07 badParamLevelDecl⟩, + ⟨.mkSimple "bad-constructor-universe", + theoryDeclarationRejected07 badCtorLevelDecl⟩, + ⟨.mkSimple "non-sort-family-result", + theoryDeclarationRejected07 nonSortResultDecl⟩, + ⟨.mkSimple "wrong-constructor-result-head", + theoryDeclarationRejected07 wrongCtorHeadDecl⟩, + ⟨.mkSimple "wrong-parameter-spine", + theoryDeclarationRejected07 wrongParamSpineDecl⟩, + ⟨.mkSimple "parameter-count-mismatch", + theoryDeclarationRejected07 shortParamDecl⟩, + ⟨.mkSimple "family-universe-count-mismatch", + theoryDeclarationRejected07 badTypeUvarsDecl⟩, + ⟨.mkSimple "constructor-universe-count-mismatch", + theoryDeclarationRejected07 badCtorUvarsDecl⟩, + ⟨.mkSimple "negative-recursive-pi-domain", + theoryDeclarationRejected07 recDomainDecl⟩, + ⟨.mkSimple "changed-recursive-target-parameter", + theoryDeclarationRejected07 recTargetDecl⟩, + ⟨.mkSimple "recursive-index-family-occurrence", + theoryDeclarationRejected07 recIndexDecl⟩, + ⟨.mkSimple "truncated-normalization-view", + (VInductDecl.normalizedGeneration? aliasFormerRawDecl + aliasFormerTruncatedViewDecl07).isNone⟩, + ⟨.mkSimple "reordered-normalization-view", + (VInductDecl.normalizedGeneration? listDecl + listReorderedViewDecl07).isNone⟩, + ⟨.mkSimple "opaque-normalization-view", + !matrixCandidateExact matrixOpaquePiAliasContext⟩, + ⟨.mkSimple "non-defeq-normalization-view", + producerRejected07 1 matrixNonDefEqType (matrixCandidateContext 10)⟩, + ⟨.mkSimple "nested-negativity", + (l4l05CandidateError l4l05NestedNegativeType).isSome⟩, + ⟨.mkSimple "family-in-nonrecursive-field", + (l4l05CandidateError l4l05FamilyNonrecursiveType).isSome⟩, + ⟨.mkSimple "family-in-proof-field", + (l4l05CandidateError l4l05FamilyProofType).isSome⟩, + ⟨.mkSimple "recursive-local-dependency", + (l4l05CandidateError l4l05RecursiveDependencyType).isSome && + l4l05RecursiveDependencyPreFamilyError.isSome⟩, + ⟨.mkSimple "constructor-field-universe-boundary", + (l4l05CandidateError l4l05UniverseRejectType).isSome⟩, + ⟨.mkSimple "preexisting-type-name", + (typeCollisionEnv07.addInduct natDecl).isNone⟩, + ⟨.mkSimple "preexisting-constructor-name", + (ctorCollisionEnv.addInduct natDecl).isNone⟩, + ⟨.mkSimple "preexisting-recursor-name", + (recCollisionEnv.addInduct natDecl).isNone⟩, + ⟨.mkSimple "eq-wrong-k-target", recursorKRejected07 eqRecInfo false⟩, + ⟨.mkSimple "and-wrong-k-target", recursorKRejected07 andRecInfo06 true⟩, + ⟨.mkSimple "eq-wrong-small-elimination", + recursorEliminationRejected07 eqRecInfo eqDecl.uvars + VInductDecl.ElimMode.small⟩, + ⟨.mkSimple "or-wrong-large-elimination", + recursorEliminationRejected07 orRecInfo06 orDecl.uvars + VInductDecl.ElimMode.large⟩ ] + +example : singletonNegativeRows.length = 32 := rfl + +#guard singletonNegativeRows.all (·.rejected) + +/-! ## Exact trust manifests for the public matrix roots -/ + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.singletonKernelRows' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms singletonKernelRows + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.singletonNegativeRows' depends on axioms: [propext, + Classical.choice, + Quot.sound, + Expr.mkAppData_eq, + Expr.mkData_eq, + Level.hasMVar_eq] +-/ +#guard_msgs in +#print axioms singletonNegativeRows + +end Lean4Lean.InductiveReplayFixtures diff --git a/Lean4Lean/Verify/Environment/SingletonParityReplay.lean b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean new file mode 100644 index 00000000..2a5c6c21 --- /dev/null +++ b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean @@ -0,0 +1,2807 @@ +import Lean4Lean.Verify.Environment.SingletonParityMatrix + +/-! +# L4L-07 environment replay inventory + +This module is the sole public environment-facing inventory for singleton +parity. A row packages the actual implementation map, the Theory input and +output environments, input alignment/order, and the proof-carrying inductive +transaction. Consequently every row exposes final alignment and orderedness; +mere Theory generation is not enough to inhabit this structure. +-/ + +namespace Lean4Lean.InductiveReplayFixtures + +open Lean +open Lean4Lean.InductiveFixtures + +local instance instInhabitedVEnvParityReplay : Inhabited VEnv := ⟨.empty⟩ + +structure SingletonReplayArtifact where + label : Name + source : VInductDecl + inputMap : ConstMap + inputEnv : VEnv + outputMap : ConstMap + outputEnv : VEnv + inputOrdered : inputEnv.Ordered + transaction : AddInduct inputMap inputEnv source outputMap outputEnv + aligned : Aligned .safe outputMap outputEnv + +namespace SingletonReplayArtifact + +theorem outputAligned (artifact : SingletonReplayArtifact) : + Aligned .safe artifact.outputMap artifact.outputEnv := artifact.aligned + +theorem outputOrdered (artifact : SingletonReplayArtifact) : + artifact.outputEnv.Ordered := by + obtain ⟨generation, generation_wf, transaction⟩ := + artifact.transaction.to_addInduct + exact VEnv.addInductGeneration_WF artifact.inputOrdered generation_wf + transaction + +end SingletonReplayArtifact + +/-! ## Reusable staging facts for fixed-family replays -/ + +/-- The raw family constant retained by a generation certificate is a type in +the replay input environment. -/ +theorem replayRawFamilyWF07 + {source : VInductDecl} {generation : source.GenerationChecked} + {inputEnv : VEnv} (generationWF : generation.WF inputEnv) : + generation.block.sourceType.toVConstant.WF inputEnv := by + show inputEnv.IsType generation.block.sourceType.uvars [] + generation.block.sourceType.type + rw [generation.block.sourceType_uvars_eq] + exact generationWF.rawFamily_isType + +/-- The raw family insertion preserves ordering whenever the retained +generation certificate is well formed in the replay input environment. -/ +theorem replayTypeEnv_ordered07 + {source : VInductDecl} {generation : source.GenerationChecked} + {inputEnv typeEnv : VEnv} + (inputOrdered : inputEnv.Ordered) + (generationWF : generation.WF inputEnv) + (addType : inputEnv.addConst generation.block.sourceType.name + generation.block.sourceType.toVConstant = some typeEnv) : + typeEnv.Ordered := by + refine .const inputOrdered ?_ addType + show inputEnv.IsType generation.block.sourceType.uvars [] + generation.block.sourceType.type + rw [generation.block.sourceType_uvars_eq] + exact generationWF.rawFamily_isType + +/-- Each stored raw constructor is well formed immediately after the raw +family insertion. Later constructor stages use monotonicity to transport +this certificate across earlier constructor insertions. -/ +theorem replayRawCtorWF07 + {source : VInductDecl} {generation : source.GenerationChecked} + {inputEnv typeEnv : VEnv} + (generationWF : generation.WF inputEnv) + (addType : inputEnv.addConst generation.block.sourceType.name + generation.block.sourceType.toVConstant = some typeEnv) + (raw : VConstVal) (hraw : raw ∈ generation.block.sourceType.ctors) : + raw.toVConstant.WF typeEnv := by + have hraw' : raw ∈ generation.block.ctorPairs.map (·.raw) := by + rw [generation.rawCtors_eq] + exact hraw + obtain ⟨ctor, hctor, rfl⟩ := List.mem_map.1 hraw' + show typeEnv.IsType ctor.raw.uvars [] ctor.raw.type + rw [generation.ctor_uvars_eq hctor] + exact generationWF.rawCtor_isType addType hctor + +/-- The complete raw-constructor fold preserves ordering. This includes the +zero-constructor case, where the fold is the identity. -/ +theorem replayCtorEnv_ordered07 + {source : VInductDecl} {generation : source.GenerationChecked} + {inputEnv typeEnv ctorEnv : VEnv} + (generationWF : generation.WF inputEnv) + (addType : inputEnv.addConst generation.block.sourceType.name + generation.block.sourceType.toVConstant = some typeEnv) + (typeOrdered : typeEnv.Ordered) + (addCtors : List.foldlM + (fun env (ctor : VConstVal) => + env.addConst ctor.name ctor.toVConstant) + typeEnv generation.block.sourceType.ctors = some ctorEnv) : + ctorEnv.Ordered := by + have ctorWF : ∀ ctor ∈ generation.block.sourceType.ctors, + ctor.toVConstant.WF typeEnv := by + intro raw hraw + exact replayRawCtorWF07 generationWF addType raw hraw + exact VInductDecl.constFold_ordered + generation.block.sourceType.ctors typeOrdered ctorWF addCtors + +/-- Reconstruct the precise mixed-generation environment after the family and +constructor constants have been inserted. Its recursor certificate is what +turns exact kernel recursor metadata into a `TrConstVal`. -/ +def replayGenerationEnv07 + {source : VInductDecl} {generation : source.GenerationChecked} + {inputEnv typeEnv ctorEnv : VEnv} + (generationWF : generation.WF inputEnv) + (addType : inputEnv.addConst generation.block.sourceType.name + generation.block.sourceType.toVConstant = some typeEnv) + (addCtors : List.foldlM + (fun env (ctor : VConstVal) => + env.addConst ctor.name ctor.toVConstant) + typeEnv generation.block.sourceType.ctors = some ctorEnv) + (ctorOrdered : ctorEnv.Ordered) : + VInductDecl.GenerationEnv generation ctorEnv := by + obtain ⟨typeToCtor, ctorLookup, -⟩ := + VInductDecl.ctorFold_spec generation.block.sourceType.ctors addCtors + have inputToType := VEnv.addConst_le addType + have inputToCtor := inputToType.trans typeToCtor + have familyLookup : ctorEnv.constants + generation.block.sourceType.name = + some generation.block.sourceType.toVConstant := + typeToCtor.constants (VEnv.addConst_self addType) + have constructorsLookup : ∀ ctor ∈ generation.block.ctorPairs, + ctorEnv.constants ctor.raw.name = some ctor.raw.toVConstant := by + intro ctor hctor + apply ctorLookup ctor.raw + rw [← generation.rawCtors_eq] + exact List.mem_map.2 ⟨ctor, hctor, rfl⟩ + exact generationWF.toGenerationEnv addType inputToCtor typeToCtor + ctorOrdered familyLookup constructorsLookup + +/-! ## Replays already established by the completed singleton pipeline -/ + +def natReplay07 : SingletonReplayArtifact where + label := ``Nat + source := natDecl + inputMap := {} + inputEnv := .empty + outputMap := natMap + outputEnv := natFinalEnv + inputOrdered := .empty + transaction := nat_addInduct + aligned := nat_aligned + +def eqReplay07 : SingletonReplayArtifact where + label := ``Eq + source := eqDecl + inputMap := {} + inputEnv := .empty + outputMap := eqMap + outputEnv := eqFinalEnv + inputOrdered := .empty + transaction := eq_addInduct + aligned := eq_aligned + +def accReplay07 : SingletonReplayArtifact where + label := ``Acc + source := accDecl + inputMap := {} + inputEnv := .empty + outputMap := accMap + outputEnv := accFinalEnv + inputOrdered := .empty + transaction := acc_addInduct + aligned := acc_aligned + +def aliasFormerReplay07 : SingletonReplayArtifact where + label := ``AliasFormer + source := aliasFormerRawDecl + inputMap := typeFamilyAliasMap + inputEnv := typeFamilyAliasEnv + outputMap := aliasFormerMap + outputEnv := aliasFormerFinalEnv + inputOrdered := typeFamilyAliasEnv_ordered + transaction := aliasFormer_addInduct_checked + aligned := aliasFormer_aligned_checked + +def aliasRecReplay07 : SingletonReplayArtifact where + label := ``AliasRec + source := aliasRecRawDecl + inputMap := recAliasMap + inputEnv := recAliasEnv + outputMap := aliasRecMap + outputEnv := aliasRecFinalEnv + inputOrdered := recAliasEnv_ordered + transaction := aliasRec_addInduct_checked + aligned := aliasRec_aligned_checked + +def normalizationMatrixReplay07 : SingletonReplayArtifact where + label := ``NormalizationMatrix + source := normalizationMatrixRawDecl + inputMap := matrixAliasMap + inputEnv := normalizationMatrixAliasEnv + outputMap := normalizationMatrixMap + outputEnv := normalizationMatrixFinalEnv + inputOrdered := normalizationMatrixAliasEnv_ordered + transaction := normalizationMatrix_addInduct + aligned := normalizationMatrix_aligned + +noncomputable def annotatedPiReplay07 : SingletonReplayArtifact where + label := ``AnnotatedPi + source := annotatedPiRawDecl + inputMap := _ + inputEnv := outParamEnv + outputMap := _ + outputEnv := annotatedPiFinalEnv + inputOrdered := outParamEnv_ordered + transaction := annotatedPi_addInduct_checked + aligned := annotatedPi_aligned_checked + +def annotatedParamReplay07 : SingletonReplayArtifact where + label := ``AnnotatedParam + source := annotatedParamRawDecl + inputMap := _ + inputEnv := outParamEnv + outputMap := _ + outputEnv := annotatedParamFinalEnv + inputOrdered := outParamEnv_ordered + transaction := annotatedParam_addInduct_checked + aligned := annotatedParam_aligned_checked + +/-! ## Fixed-family replays -/ + +/-! ### Bool -/ + +theorem boolDeclWF07 : boolDecl.WF VEnv.empty := by + refine ⟨rfl, ?_⟩ + intro type htype + have htype' : type = boolType := + List.mem_singleton.1 (by simpa [boolDecl] using htype) + subst type + refine ⟨?_, ?_⟩ + · change True + trivial + · intro ctor hctor + rcases List.mem_cons.1 hctor with rfl | hctor + · constructor + · change True + trivial + · change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero) + rfl + · have hctor' := List.mem_singleton.1 hctor + subst ctor + constructor + · change True + trivial + · change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero) + rfl + +def boolGenerationWF07 : boolGenerationChecked.WF VEnv.empty := by + exact (boolChecked.wf_of_decl boolDeclWF07).identityGeneration .empty + +def boolTypeEnv07 : VEnv := + (VEnv.empty.addConst boolType.name boolType.toVConstant).get! + +def boolFalseEnv07 : VEnv := + (boolTypeEnv07.addConst boolType.ctors[0].name + boolType.ctors[0].toVConstant).get! + +def boolCtorEnv07 : VEnv := + (boolFalseEnv07.addConst boolType.ctors[1].name + boolType.ctors[1].toVConstant).get! + +def boolRecEnv07 : VEnv := + (boolCtorEnv07.addConst ``Bool.rec + (inductGenerationRecVal boolGenerationChecked).toVConstant).get! + +def boolFinalEnv07 : VEnv := + boolGenerationChecked.generatedRules.foldl VEnv.addDefEq boolRecEnv07 + +def boolTypeMap07 : ConstMap := + ({} : ConstMap).insert ``Bool boolInfo07 + +def boolFalseMap07 : ConstMap := + boolTypeMap07.insert ``Bool.false boolFalseInfo07 + +def boolCtorMap07 : ConstMap := + boolFalseMap07.insert ``Bool.true boolTrueInfo07 + +def boolMap07 : ConstMap := + boolCtorMap07.insert ``Bool.rec boolRecInfo07 + +theorem boolTypeEnv_ordered07 : boolTypeEnv07.Ordered := + replayTypeEnv_ordered07 .empty boolGenerationWF07 rfl + +theorem boolCtorEnv_ordered07 : boolCtorEnv07.Ordered := + replayCtorEnv_ordered07 boolGenerationWF07 rfl + boolTypeEnv_ordered07 rfl + +def boolGenerationEnv07 : + VInductDecl.GenerationEnv boolGenerationChecked boolCtorEnv07 := + replayGenerationEnv07 boolGenerationWF07 rfl rfl + boolCtorEnv_ordered07 + +theorem boolInfoTr07 : + TrConstVal .safe VEnv.empty boolInfo07 boolType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + exact .sort rfl + +theorem boolFalseInfoTr07 : + TrConstVal .safe boolTypeEnv07 boolFalseInfo07 boolType.ctors[0] := by + have hBool : boolTypeEnv07.constants ``Bool = + some boolType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr boolTypeEnv07 boolFalseInfo07.levelParams [] + boolFalseInfo07.type boolType.ctors[0].type := by + tr_type_expr_tac + exact shape.to_trExprS boolTypeEnv_ordered07 trivial + ⟨.sort (.succ .zero), by type_tac⟩ + +theorem boolTrueInfoTr07 : + TrConstVal .safe boolFalseEnv07 boolTrueInfo07 boolType.ctors[1] := by + have hBool : boolFalseEnv07.constants ``Bool = + some boolType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr boolFalseEnv07 boolTrueInfo07.levelParams [] + boolTrueInfo07.type boolType.ctors[1].type := by + tr_type_expr_tac + have falseOrdered : boolFalseEnv07.Ordered := by + refine .const (n := boolType.ctors[0].name) + (ci := boolType.ctors[0].toVConstant) boolTypeEnv_ordered07 ?_ rfl + exact ⟨.succ .zero, by type_tac⟩ + exact shape.to_trExprS falseOrdered trivial + ⟨.sort (.succ .zero), by type_tac⟩ + +theorem boolRecInfoTr07 : + TrConstVal .safe boolCtorEnv07 boolRecInfo07 + (inductGenerationRecVal boolGenerationChecked) := by + have hBool : boolCtorEnv07.constants ``Bool = + some boolType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr boolCtorEnv07 boolRecInfo07.levelParams [] + boolRecInfo07.type + (inductGenerationRecVal boolGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨sort, recursorType⟩ := boolGenerationEnv07.recursor_wf + exact shape.to_trExprS boolCtorEnv_ordered07 trivial + ⟨.sort sort, recursorType⟩ + +theorem boolTypeFresh07 : ({} : ConstMap).find? ``Bool = none := by + simp [SMap.find?] + +theorem boolTypeMapWF07 : boolTypeMap07.WF := + SMap.WF.empty.insert _ _ boolTypeFresh07 + +theorem boolFalseFresh07 : boolTypeMap07.find? ``Bool.false = none := by + rw [boolTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem boolFalseMapWF07 : boolFalseMap07.WF := + boolTypeMapWF07.insert _ _ boolFalseFresh07 + +theorem boolTrueFresh07 : boolFalseMap07.find? ``Bool.true = none := by + rw [boolFalseMap07, boolTypeMapWF07.find?_insert, boolTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem boolCtorMapWF07 : boolCtorMap07.WF := + boolFalseMapWF07.insert _ _ boolTrueFresh07 + +theorem boolRecFresh07 : boolCtorMap07.find? ``Bool.rec = none := by + rw [boolCtorMap07, boolFalseMapWF07.find?_insert, boolFalseMap07, + boolTypeMapWF07.find?_insert, boolTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem boolAddInduct07 : AddInduct ({} : ConstMap) VEnv.empty boolDecl + boolMap07 boolFinalEnv07 := by + refine ⟨{ + generation := boolGenerationChecked + generation_wf := boolGenerationWF07 + typeMap := boolTypeMap07 + typeEnv := boolTypeEnv07 + ctorMap := boolCtorMap07 + ctorEnv := boolCtorEnv07 + recEnv := boolRecEnv07 + addType := { + info := boolInfo07 + kind_eq := by simp [boolInfo07, InductConstantKind.Matches] + tr := boolInfoTr07 + map_fresh := boolTypeFresh07 + env_add := rfl + map_add := rfl } + addCtors := ?_ + addRec := { + info := boolRecInfo07 + kind_eq := by simp [boolRecInfo07, InductConstantKind.Matches] + tr := boolRecInfoTr07 + map_fresh := boolRecFresh07 + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ }⟩ + exact .cons { + info := boolFalseInfo07 + kind_eq := by simp [boolFalseInfo07, InductConstantKind.Matches] + tr := boolFalseInfoTr07 + map_fresh := by simpa [boolType] using boolFalseFresh07 + env_add := rfl + map_add := rfl } + (.cons { + info := boolTrueInfo07 + kind_eq := by simp [boolTrueInfo07, InductConstantKind.Matches] + tr := boolTrueInfoTr07 + map_fresh := by + change boolFalseMap07.find? ``Bool.true = none + exact boolTrueFresh07 + env_add := rfl + map_add := rfl } .nil) + +theorem boolAligned07 : Aligned .safe boolMap07 boolFinalEnv07 := + Aligned.addInduct boolAddInduct07 .empty + +def boolReplay07 : SingletonReplayArtifact where + label := ``Bool + source := boolDecl + inputMap := {} + inputEnv := .empty + outputMap := boolMap07 + outputEnv := boolFinalEnv07 + inputOrdered := .empty + transaction := boolAddInduct07 + aligned := boolAligned07 + +/-! ### List -/ + +theorem listCheckedWF07 : listChecked.WF VEnv.empty := by + constructor + · change VEnv.empty.OnTel 1 [] [.sort (.succ (.param 0))] + exact ⟨⟨.succ (.succ (.param 0)), VEnv.HasType.sort (by decide)⟩, + trivial⟩ + · intro ctor hctor + rcases List.mem_cons.1 hctor with rfl | hctor + · constructor + · change True + trivial + · rfl + · have hctor' := List.mem_singleton.1 hctor + subst ctor + constructor + · change VInductDecl.fieldsWF 1 ``List 1 VEnv.empty + (.succ (.param 0)) [] [.sort (.succ (.param 0))] 0 + [.bvar 0, + .app (.const ``List [.param 0]) (.bvar 1)] + constructor + · exact .inr (.inr ⟨rfl, .succ (.param 0), by type_tac, + .inr (VLevel.le_refl _)⟩) + constructor + · intro recursive + contradiction + constructor + · exact .inl rfl + constructor + · intro _ + rfl + · trivial + · rfl + +def listGenerationWF07 : listGenerationChecked.WF VEnv.empty := by + exact listCheckedWF07.identityGeneration .empty + +def listTypeEnv07 : VEnv := + (VEnv.empty.addConst listType.name listType.toVConstant).get! + +def listNilEnv07 : VEnv := + (listTypeEnv07.addConst listType.ctors[0].name + listType.ctors[0].toVConstant).get! + +def listCtorEnv07 : VEnv := + (listNilEnv07.addConst listType.ctors[1].name + listType.ctors[1].toVConstant).get! + +def listRecEnv07 : VEnv := + (listCtorEnv07.addConst ``List.rec + (inductGenerationRecVal listGenerationChecked).toVConstant).get! + +def listFinalEnv07 : VEnv := + listGenerationChecked.generatedRules.foldl VEnv.addDefEq listRecEnv07 + +def listTypeMap07 : ConstMap := + ({} : ConstMap).insert ``List listInfo07 + +def listNilMap07 : ConstMap := + listTypeMap07.insert ``List.nil listNilInfo07 + +def listCtorMap07 : ConstMap := + listNilMap07.insert ``List.cons listConsInfo07 + +def listMap07 : ConstMap := + listCtorMap07.insert ``List.rec listRecInfo07 + +theorem listTypeEnv_ordered07 : listTypeEnv07.Ordered := + replayTypeEnv_ordered07 .empty listGenerationWF07 rfl + +theorem listNilEnv_ordered07 : listNilEnv07.Ordered := by + refine .const (n := listType.ctors[0].name) + (ci := listType.ctors[0].toVConstant) listTypeEnv_ordered07 ?_ rfl + exact replayRawCtorWF07 listGenerationWF07 rfl listType.ctors[0] + (.head _) + +theorem listCtorEnv_ordered07 : listCtorEnv07.Ordered := + replayCtorEnv_ordered07 listGenerationWF07 rfl + listTypeEnv_ordered07 rfl + +def listGenerationEnv07 : + VInductDecl.GenerationEnv listGenerationChecked listCtorEnv07 := + replayGenerationEnv07 listGenerationWF07 rfl rfl + listCtorEnv_ordered07 + +theorem listInfoTr07 : + TrConstVal .safe VEnv.empty listInfo07 listType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr VEnv.empty listInfo07.levelParams [] + listInfo07.type listType.type := by + tr_type_expr_tac + obtain ⟨sort, familyType⟩ := replayRawFamilyWF07 listGenerationWF07 + exact shape.to_trExprS .empty trivial ⟨.sort sort, familyType⟩ + +theorem listNilInfoTr07 : + TrConstVal .safe listTypeEnv07 listNilInfo07 listType.ctors[0] := by + have hList : listTypeEnv07.constants ``List = + some listType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr listTypeEnv07 listNilInfo07.levelParams [] + listNilInfo07.type listType.ctors[0].type := by + tr_type_expr_tac + obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 listGenerationWF07 rfl + listType.ctors[0] (.head _) + exact shape.to_trExprS listTypeEnv_ordered07 trivial + ⟨.sort sort, ctorType⟩ + +theorem listConsInfoTr07 : + TrConstVal .safe listNilEnv07 listConsInfo07 listType.ctors[1] := by + have hList : listNilEnv07.constants ``List = + some listType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr listNilEnv07 listConsInfo07.levelParams [] + listConsInfo07.type listType.ctors[1].type := by + tr_type_expr_tac + obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 listGenerationWF07 rfl + listType.ctors[1] (.tail _ (.head _)) + have typeToNil : listTypeEnv07 ≤ listNilEnv07 := + VEnv.addConst_le (show listTypeEnv07.addConst + listType.ctors[0].name listType.ctors[0].toVConstant = + some listNilEnv07 from rfl) + exact shape.to_trExprS listNilEnv_ordered07 trivial + ⟨.sort sort, ctorType.mono typeToNil⟩ + +theorem listRecInfoTr07 : + TrConstVal .safe listCtorEnv07 listRecInfo07 + (inductGenerationRecVal listGenerationChecked) := by + have hList : listCtorEnv07.constants ``List = + some listType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr listCtorEnv07 listRecInfo07.levelParams [] + listRecInfo07.type + (inductGenerationRecVal listGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨sort, recursorType⟩ := listGenerationEnv07.recursor_wf + exact shape.to_trExprS listCtorEnv_ordered07 trivial + ⟨.sort sort, recursorType⟩ + +theorem listTypeFresh07 : ({} : ConstMap).find? ``List = none := by + simp [SMap.find?] + +theorem listTypeMapWF07 : listTypeMap07.WF := + SMap.WF.empty.insert _ _ listTypeFresh07 + +theorem listNilFresh07 : listTypeMap07.find? ``List.nil = none := by + rw [listTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem listNilMapWF07 : listNilMap07.WF := + listTypeMapWF07.insert _ _ listNilFresh07 + +theorem listConsFresh07 : listNilMap07.find? ``List.cons = none := by + rw [listNilMap07, listTypeMapWF07.find?_insert, listTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem listCtorMapWF07 : listCtorMap07.WF := + listNilMapWF07.insert _ _ listConsFresh07 + +theorem listRecFresh07 : listCtorMap07.find? ``List.rec = none := by + rw [listCtorMap07, listNilMapWF07.find?_insert, listNilMap07, + listTypeMapWF07.find?_insert, listTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem listAddInduct07 : AddInduct ({} : ConstMap) VEnv.empty listDecl + listMap07 listFinalEnv07 := by + refine ⟨{ + generation := listGenerationChecked + generation_wf := listGenerationWF07 + typeMap := listTypeMap07 + typeEnv := listTypeEnv07 + ctorMap := listCtorMap07 + ctorEnv := listCtorEnv07 + recEnv := listRecEnv07 + addType := { + info := listInfo07 + kind_eq := by simp [listInfo07, InductConstantKind.Matches] + tr := listInfoTr07 + map_fresh := listTypeFresh07 + env_add := rfl + map_add := rfl } + addCtors := ?_ + addRec := { + info := listRecInfo07 + kind_eq := by simp [listRecInfo07, InductConstantKind.Matches] + tr := listRecInfoTr07 + map_fresh := listRecFresh07 + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ }⟩ + exact .cons { + info := listNilInfo07 + kind_eq := by simp [listNilInfo07, InductConstantKind.Matches] + tr := listNilInfoTr07 + map_fresh := by simpa [listType] using listNilFresh07 + env_add := rfl + map_add := rfl } + (.cons { + info := listConsInfo07 + kind_eq := by simp [listConsInfo07, InductConstantKind.Matches] + tr := listConsInfoTr07 + map_fresh := by + change listNilMap07.find? ``List.cons = none + exact listConsFresh07 + env_add := rfl + map_add := rfl } .nil) + +theorem listAligned07 : Aligned .safe listMap07 listFinalEnv07 := + Aligned.addInduct listAddInduct07 .empty + +def listReplay07 : SingletonReplayArtifact where + label := ``List + source := listDecl + inputMap := {} + inputEnv := .empty + outputMap := listMap07 + outputEnv := listFinalEnv07 + inputOrdered := .empty + transaction := listAddInduct07 + aligned := listAligned07 + +/-! ### Option -/ + +theorem optionDeclWF07 : optionDecl.WF VEnv.empty := by + refine ⟨rfl, ?_⟩ + intro type htype + have htype' : type = optionType := + List.mem_singleton.1 (by simpa [optionDecl] using htype) + subst type + refine ⟨?_, ?_⟩ + · change VEnv.empty.OnTel 1 [] [.sort (.succ (.param 0))] + exact ⟨⟨.succ (.succ (.param 0)), VEnv.HasType.sort (by decide)⟩, + trivial⟩ + · intro ctor hctor + rcases List.mem_cons.1 hctor with rfl | hctor + · constructor + · change True + trivial + · rfl + · have hctor' := List.mem_singleton.1 hctor + subst ctor + constructor + · change VInductDecl.fieldsWF 1 ``Option 1 VEnv.empty + (.succ (.param 0)) [] [.sort (.succ (.param 0))] 0 [.bvar 0] + constructor + · exact .inr (.inr ⟨rfl, .succ (.param 0), by type_tac, + .inr (VLevel.le_refl _)⟩) + constructor + · intro recursive + contradiction + · trivial + · rfl + +def optionGenerationWF07 : optionGenerationChecked.WF VEnv.empty := by + exact (optionChecked.wf_of_decl optionDeclWF07).identityGeneration .empty + +def optionTypeEnv07 : VEnv := + (VEnv.empty.addConst optionType.name optionType.toVConstant).get! + +def optionNoneEnv07 : VEnv := + (optionTypeEnv07.addConst optionType.ctors[0].name + optionType.ctors[0].toVConstant).get! + +def optionCtorEnv07 : VEnv := + (optionNoneEnv07.addConst optionType.ctors[1].name + optionType.ctors[1].toVConstant).get! + +def optionRecEnv07 : VEnv := + (optionCtorEnv07.addConst ``Option.rec + (inductGenerationRecVal optionGenerationChecked).toVConstant).get! + +def optionFinalEnv07 : VEnv := + optionGenerationChecked.generatedRules.foldl VEnv.addDefEq optionRecEnv07 + +def optionTypeMap07 : ConstMap := + ({} : ConstMap).insert ``Option optionInfo07 + +def optionNoneMap07 : ConstMap := + optionTypeMap07.insert ``Option.none optionNoneInfo07 + +def optionCtorMap07 : ConstMap := + optionNoneMap07.insert ``Option.some optionSomeInfo07 + +def optionMap07 : ConstMap := + optionCtorMap07.insert ``Option.rec optionRecInfo07 + +theorem optionTypeEnv_ordered07 : optionTypeEnv07.Ordered := + replayTypeEnv_ordered07 .empty optionGenerationWF07 rfl + +theorem optionNoneEnv_ordered07 : optionNoneEnv07.Ordered := by + refine .const (n := optionType.ctors[0].name) + (ci := optionType.ctors[0].toVConstant) optionTypeEnv_ordered07 ?_ rfl + exact replayRawCtorWF07 optionGenerationWF07 rfl optionType.ctors[0] + (.head _) + +theorem optionCtorEnv_ordered07 : optionCtorEnv07.Ordered := + replayCtorEnv_ordered07 optionGenerationWF07 rfl + optionTypeEnv_ordered07 rfl + +def optionGenerationEnv07 : + VInductDecl.GenerationEnv optionGenerationChecked optionCtorEnv07 := + replayGenerationEnv07 optionGenerationWF07 rfl rfl + optionCtorEnv_ordered07 + +theorem optionInfoTr07 : + TrConstVal .safe VEnv.empty optionInfo07 optionType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr VEnv.empty optionInfo07.levelParams [] + optionInfo07.type optionType.type := by + tr_type_expr_tac + obtain ⟨sort, familyType⟩ := replayRawFamilyWF07 optionGenerationWF07 + exact shape.to_trExprS .empty trivial ⟨.sort sort, familyType⟩ + +theorem optionNoneInfoTr07 : + TrConstVal .safe optionTypeEnv07 optionNoneInfo07 optionType.ctors[0] := by + have hOption : optionTypeEnv07.constants ``Option = + some optionType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr optionTypeEnv07 optionNoneInfo07.levelParams [] + optionNoneInfo07.type optionType.ctors[0].type := by + tr_type_expr_tac + obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 optionGenerationWF07 rfl + optionType.ctors[0] (.head _) + exact shape.to_trExprS optionTypeEnv_ordered07 trivial + ⟨.sort sort, ctorType⟩ + +theorem optionSomeInfoTr07 : + TrConstVal .safe optionNoneEnv07 optionSomeInfo07 optionType.ctors[1] := by + have hOption : optionNoneEnv07.constants ``Option = + some optionType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr optionNoneEnv07 optionSomeInfo07.levelParams [] + optionSomeInfo07.type optionType.ctors[1].type := by + tr_type_expr_tac + obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 optionGenerationWF07 rfl + optionType.ctors[1] (.tail _ (.head _)) + have typeToNone : optionTypeEnv07 ≤ optionNoneEnv07 := + VEnv.addConst_le (show optionTypeEnv07.addConst + optionType.ctors[0].name optionType.ctors[0].toVConstant = + some optionNoneEnv07 from rfl) + exact shape.to_trExprS optionNoneEnv_ordered07 trivial + ⟨.sort sort, ctorType.mono typeToNone⟩ + +theorem optionRecInfoTr07 : + TrConstVal .safe optionCtorEnv07 optionRecInfo07 + (inductGenerationRecVal optionGenerationChecked) := by + have hOption : optionCtorEnv07.constants ``Option = + some optionType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr optionCtorEnv07 optionRecInfo07.levelParams [] + optionRecInfo07.type + (inductGenerationRecVal optionGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨sort, recursorType⟩ := optionGenerationEnv07.recursor_wf + exact shape.to_trExprS optionCtorEnv_ordered07 trivial + ⟨.sort sort, recursorType⟩ + +theorem optionTypeFresh07 : ({} : ConstMap).find? ``Option = none := by + simp [SMap.find?] + +theorem optionTypeMapWF07 : optionTypeMap07.WF := + SMap.WF.empty.insert _ _ optionTypeFresh07 + +theorem optionNoneFresh07 : optionTypeMap07.find? ``Option.none = none := by + rw [optionTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem optionNoneMapWF07 : optionNoneMap07.WF := + optionTypeMapWF07.insert _ _ optionNoneFresh07 + +theorem optionSomeFresh07 : optionNoneMap07.find? ``Option.some = none := by + rw [optionNoneMap07, optionTypeMapWF07.find?_insert, optionTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem optionCtorMapWF07 : optionCtorMap07.WF := + optionNoneMapWF07.insert _ _ optionSomeFresh07 + +theorem optionRecFresh07 : optionCtorMap07.find? ``Option.rec = none := by + rw [optionCtorMap07, optionNoneMapWF07.find?_insert, optionNoneMap07, + optionTypeMapWF07.find?_insert, optionTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem optionAddInduct07 : AddInduct ({} : ConstMap) VEnv.empty optionDecl + optionMap07 optionFinalEnv07 := by + refine ⟨{ + generation := optionGenerationChecked + generation_wf := optionGenerationWF07 + typeMap := optionTypeMap07 + typeEnv := optionTypeEnv07 + ctorMap := optionCtorMap07 + ctorEnv := optionCtorEnv07 + recEnv := optionRecEnv07 + addType := { + info := optionInfo07 + kind_eq := by simp [optionInfo07, InductConstantKind.Matches] + tr := optionInfoTr07 + map_fresh := optionTypeFresh07 + env_add := rfl + map_add := rfl } + addCtors := ?_ + addRec := { + info := optionRecInfo07 + kind_eq := by simp [optionRecInfo07, InductConstantKind.Matches] + tr := optionRecInfoTr07 + map_fresh := optionRecFresh07 + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ }⟩ + exact .cons { + info := optionNoneInfo07 + kind_eq := by simp [optionNoneInfo07, InductConstantKind.Matches] + tr := optionNoneInfoTr07 + map_fresh := by simpa [optionType] using optionNoneFresh07 + env_add := rfl + map_add := rfl } + (.cons { + info := optionSomeInfo07 + kind_eq := by simp [optionSomeInfo07, InductConstantKind.Matches] + tr := optionSomeInfoTr07 + map_fresh := by + change optionNoneMap07.find? ``Option.some = none + exact optionSomeFresh07 + env_add := rfl + map_add := rfl } .nil) + +theorem optionAligned07 : Aligned .safe optionMap07 optionFinalEnv07 := + Aligned.addInduct optionAddInduct07 .empty + +def optionReplay07 : SingletonReplayArtifact where + label := ``Option + source := optionDecl + inputMap := {} + inputEnv := .empty + outputMap := optionMap07 + outputEnv := optionFinalEnv07 + inputOrdered := .empty + transaction := optionAddInduct07 + aligned := optionAligned07 + +/-! ### Prod -/ + +theorem prodCheckedWF07 : prodChecked.WF VEnv.empty := by + constructor + · change VEnv.empty.OnTel 2 [] + [.sort (.succ (.param 0)), .sort (.succ (.param 1))] + exact ⟨⟨.succ (.succ (.param 0)), VEnv.HasType.sort (by decide)⟩, + ⟨⟨.succ (.succ (.param 1)), VEnv.HasType.sort (by decide)⟩, + trivial⟩⟩ + · intro ctor hctor + have hctor' := List.mem_singleton.1 hctor + subst ctor + constructor + · change VInductDecl.fieldsWF 2 ``Prod 2 VEnv.empty + (.max (.succ (.param 0)) (.succ (.param 1))) [] + [.sort (.succ (.param 1)), .sort (.succ (.param 0))] 0 + [.bvar 1, .bvar 1] + constructor + · exact .inr (.inr ⟨rfl, .succ (.param 0), by type_tac, + .inr VLevel.le_max_left⟩) + constructor + · intro recursive + contradiction + constructor + · exact .inr (.inr ⟨rfl, .succ (.param 1), by type_tac, + .inr VLevel.le_max_right⟩) + constructor + · intro recursive + contradiction + · trivial + · rfl + +def prodGenerationWF07 : prodGenerationChecked.WF VEnv.empty := by + exact prodCheckedWF07.identityGeneration .empty + +def prodTypeEnv07 : VEnv := + (VEnv.empty.addConst prodType.name prodType.toVConstant).get! + +def prodCtorEnv07 : VEnv := + (prodTypeEnv07.addConst prodType.ctors[0].name + prodType.ctors[0].toVConstant).get! + +def prodRecEnv07 : VEnv := + (prodCtorEnv07.addConst ``Prod.rec + (inductGenerationRecVal prodGenerationChecked).toVConstant).get! + +def prodFinalEnv07 : VEnv := + prodGenerationChecked.generatedRules.foldl VEnv.addDefEq prodRecEnv07 + +def prodTypeMap07 : ConstMap := + ({} : ConstMap).insert ``Prod prodInfo07 + +def prodCtorMap07 : ConstMap := + prodTypeMap07.insert ``Prod.mk prodMkInfo07 + +def prodMap07 : ConstMap := + prodCtorMap07.insert ``Prod.rec prodRecInfo07 + +theorem prodTypeEnv_ordered07 : prodTypeEnv07.Ordered := + replayTypeEnv_ordered07 .empty prodGenerationWF07 rfl + +theorem prodCtorEnv_ordered07 : prodCtorEnv07.Ordered := + replayCtorEnv_ordered07 prodGenerationWF07 rfl + prodTypeEnv_ordered07 rfl + +def prodGenerationEnv07 : + VInductDecl.GenerationEnv prodGenerationChecked prodCtorEnv07 := + replayGenerationEnv07 prodGenerationWF07 rfl rfl + prodCtorEnv_ordered07 + +theorem prodInfoTr07 : + TrConstVal .safe VEnv.empty prodInfo07 prodType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr VEnv.empty prodInfo07.levelParams [] + prodInfo07.type prodType.type := by + tr_type_expr_tac + obtain ⟨sort, familyType⟩ := replayRawFamilyWF07 prodGenerationWF07 + exact shape.to_trExprS .empty trivial ⟨.sort sort, familyType⟩ + +theorem prodCtorInfoTr07 : + TrConstVal .safe prodTypeEnv07 prodMkInfo07 prodType.ctors[0] := by + have hProd : prodTypeEnv07.constants ``Prod = + some prodType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr prodTypeEnv07 prodMkInfo07.levelParams [] + prodMkInfo07.type prodType.ctors[0].type := by + tr_type_expr_tac + obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 prodGenerationWF07 rfl + prodType.ctors[0] (.head _) + exact shape.to_trExprS prodTypeEnv_ordered07 trivial + ⟨.sort sort, ctorType⟩ + +theorem prodRecInfoTr07 : + TrConstVal .safe prodCtorEnv07 prodRecInfo07 + (inductGenerationRecVal prodGenerationChecked) := by + have hProd : prodCtorEnv07.constants ``Prod = + some prodType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr prodCtorEnv07 prodRecInfo07.levelParams [] + prodRecInfo07.type + (inductGenerationRecVal prodGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨sort, recursorType⟩ := prodGenerationEnv07.recursor_wf + exact shape.to_trExprS prodCtorEnv_ordered07 trivial + ⟨.sort sort, recursorType⟩ + +theorem prodTypeFresh07 : ({} : ConstMap).find? ``Prod = none := by + simp [SMap.find?] + +theorem prodTypeMapWF07 : prodTypeMap07.WF := + SMap.WF.empty.insert _ _ prodTypeFresh07 + +theorem prodCtorFresh07 : prodTypeMap07.find? ``Prod.mk = none := by + rw [prodTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem prodCtorMapWF07 : prodCtorMap07.WF := + prodTypeMapWF07.insert _ _ prodCtorFresh07 + +theorem prodRecFresh07 : prodCtorMap07.find? ``Prod.rec = none := by + rw [prodCtorMap07, prodTypeMapWF07.find?_insert, prodTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem prodAddInduct07 : AddInduct ({} : ConstMap) VEnv.empty prodDecl + prodMap07 prodFinalEnv07 := by + refine ⟨{ + generation := prodGenerationChecked + generation_wf := prodGenerationWF07 + typeMap := prodTypeMap07 + typeEnv := prodTypeEnv07 + ctorMap := prodCtorMap07 + ctorEnv := prodCtorEnv07 + recEnv := prodRecEnv07 + addType := { + info := prodInfo07 + kind_eq := by simp [prodInfo07, InductConstantKind.Matches] + tr := prodInfoTr07 + map_fresh := prodTypeFresh07 + env_add := rfl + map_add := rfl } + addCtors := ?_ + addRec := { + info := prodRecInfo07 + kind_eq := by simp [prodRecInfo07, InductConstantKind.Matches] + tr := prodRecInfoTr07 + map_fresh := prodRecFresh07 + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ }⟩ + exact .cons { + info := prodMkInfo07 + kind_eq := by simp [prodMkInfo07, InductConstantKind.Matches] + tr := prodCtorInfoTr07 + map_fresh := by simpa [prodType] using prodCtorFresh07 + env_add := rfl + map_add := rfl } .nil + +theorem prodAligned07 : Aligned .safe prodMap07 prodFinalEnv07 := + Aligned.addInduct prodAddInduct07 .empty + +def prodReplay07 : SingletonReplayArtifact where + label := ``Prod + source := prodDecl + inputMap := {} + inputEnv := .empty + outputMap := prodMap07 + outputEnv := prodFinalEnv07 + inputOrdered := .empty + transaction := prodAddInduct07 + aligned := prodAligned07 + +/-! ### And -/ + +theorem andCheckedWF07 : andChecked.WF VEnv.empty := by + constructor + · change VEnv.empty.OnTel 0 [] [.sort .zero, .sort .zero] + exact ⟨⟨.succ .zero, VEnv.HasType.sort trivial⟩, + ⟨⟨.succ .zero, VEnv.HasType.sort trivial⟩, trivial⟩⟩ + · intro ctor hctor + have hctor' := List.mem_singleton.1 hctor + subst ctor + constructor + · change VInductDecl.fieldsWF 0 ``And 2 VEnv.empty .zero [] + [.sort .zero, .sort .zero] 0 [.bvar 1, .bvar 1] + constructor + · exact .inr (.inr ⟨rfl, .zero, by type_tac, .inl rfl⟩) + constructor + · intro recursive + contradiction + constructor + · exact .inr (.inr ⟨rfl, .zero, by type_tac, .inl rfl⟩) + constructor + · intro recursive + contradiction + · trivial + · rfl + +def andGenerationWF07 : andGenerationChecked.WF VEnv.empty := by + exact andCheckedWF07.identityGeneration .empty + +def andTypeEnv07 : VEnv := + (VEnv.empty.addConst andType.name andType.toVConstant).get! + +def andCtorEnv07 : VEnv := + (andTypeEnv07.addConst andType.ctors[0].name + andType.ctors[0].toVConstant).get! + +def andRecEnv07 : VEnv := + (andCtorEnv07.addConst ``And.rec + (inductGenerationRecVal andGenerationChecked).toVConstant).get! + +def andFinalEnv07 : VEnv := + andGenerationChecked.generatedRules.foldl VEnv.addDefEq andRecEnv07 + +def andTypeMap07 : ConstMap := + ({} : ConstMap).insert ``And andInfo06 + +def andCtorMap07 : ConstMap := + andTypeMap07.insert ``And.intro andIntroInfo06 + +def andMap07 : ConstMap := + andCtorMap07.insert ``And.rec andRecInfo06 + +theorem andTypeEnv_ordered07 : andTypeEnv07.Ordered := + replayTypeEnv_ordered07 .empty andGenerationWF07 rfl + +theorem andCtorEnv_ordered07 : andCtorEnv07.Ordered := + replayCtorEnv_ordered07 andGenerationWF07 rfl + andTypeEnv_ordered07 rfl + +def andGenerationEnv07 : + VInductDecl.GenerationEnv andGenerationChecked andCtorEnv07 := + replayGenerationEnv07 andGenerationWF07 rfl rfl + andCtorEnv_ordered07 + +theorem andInfoTr07 : + TrConstVal .safe VEnv.empty andInfo06 andType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr VEnv.empty andInfo06.levelParams [] + andInfo06.type andType.type := by + tr_type_expr_tac + obtain ⟨sort, familyType⟩ := replayRawFamilyWF07 andGenerationWF07 + exact shape.to_trExprS .empty trivial ⟨.sort sort, familyType⟩ + +theorem andCtorInfoTr07 : + TrConstVal .safe andTypeEnv07 andIntroInfo06 andType.ctors[0] := by + have hAnd : andTypeEnv07.constants ``And = + some andType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr andTypeEnv07 andIntroInfo06.levelParams [] + andIntroInfo06.type andType.ctors[0].type := by + tr_type_expr_tac + obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 andGenerationWF07 rfl + andType.ctors[0] (.head _) + exact shape.to_trExprS andTypeEnv_ordered07 trivial + ⟨.sort sort, ctorType⟩ + +theorem andRecInfoTr07 : + TrConstVal .safe andCtorEnv07 andRecInfo06 + (inductGenerationRecVal andGenerationChecked) := by + have hAnd : andCtorEnv07.constants ``And = + some andType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr andCtorEnv07 andRecInfo06.levelParams [] + andRecInfo06.type + (inductGenerationRecVal andGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨sort, recursorType⟩ := andGenerationEnv07.recursor_wf + exact shape.to_trExprS andCtorEnv_ordered07 trivial + ⟨.sort sort, recursorType⟩ + +theorem andTypeFresh07 : ({} : ConstMap).find? ``And = none := by + simp [SMap.find?] + +theorem andTypeMapWF07 : andTypeMap07.WF := + SMap.WF.empty.insert _ _ andTypeFresh07 + +theorem andCtorFresh07 : andTypeMap07.find? ``And.intro = none := by + rw [andTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem andCtorMapWF07 : andCtorMap07.WF := + andTypeMapWF07.insert _ _ andCtorFresh07 + +theorem andRecFresh07 : andCtorMap07.find? ``And.rec = none := by + rw [andCtorMap07, andTypeMapWF07.find?_insert, andTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem andAddInduct07 : AddInduct ({} : ConstMap) VEnv.empty andDecl + andMap07 andFinalEnv07 := by + refine ⟨{ + generation := andGenerationChecked + generation_wf := andGenerationWF07 + typeMap := andTypeMap07 + typeEnv := andTypeEnv07 + ctorMap := andCtorMap07 + ctorEnv := andCtorEnv07 + recEnv := andRecEnv07 + addType := { + info := andInfo06 + kind_eq := by simp [andInfo06, InductConstantKind.Matches] + tr := andInfoTr07 + map_fresh := andTypeFresh07 + env_add := rfl + map_add := rfl } + addCtors := ?_ + addRec := { + info := andRecInfo06 + kind_eq := by simp [andRecInfo06, InductConstantKind.Matches] + tr := andRecInfoTr07 + map_fresh := andRecFresh07 + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ }⟩ + exact .cons { + info := andIntroInfo06 + kind_eq := by simp [andIntroInfo06, InductConstantKind.Matches] + tr := andCtorInfoTr07 + map_fresh := by simpa [andType] using andCtorFresh07 + env_add := rfl + map_add := rfl } .nil + +theorem andAligned07 : Aligned .safe andMap07 andFinalEnv07 := + Aligned.addInduct andAddInduct07 .empty + +def andReplay07 : SingletonReplayArtifact where + label := ``And + source := andDecl + inputMap := {} + inputEnv := .empty + outputMap := andMap07 + outputEnv := andFinalEnv07 + inputOrdered := .empty + transaction := andAddInduct07 + aligned := andAligned07 + +/-! ### Or -/ + +theorem orCheckedWF07 : orChecked.WF VEnv.empty := by + constructor + · change VEnv.empty.OnTel 0 [] [.sort .zero, .sort .zero] + exact ⟨⟨.succ .zero, VEnv.HasType.sort trivial⟩, + ⟨⟨.succ .zero, VEnv.HasType.sort trivial⟩, trivial⟩⟩ + · intro ctor hctor + rcases List.mem_cons.1 hctor with rfl | hctor + · constructor + · change VInductDecl.fieldsWF 0 ``Or 2 VEnv.empty .zero [] + [.sort .zero, .sort .zero] 0 [.bvar 1] + constructor + · exact .inr (.inr ⟨rfl, .zero, by type_tac, .inl rfl⟩) + constructor + · intro recursive + contradiction + · trivial + · rfl + · have hctor' := List.mem_singleton.1 hctor + subst ctor + constructor + · change VInductDecl.fieldsWF 0 ``Or 2 VEnv.empty .zero [] + [.sort .zero, .sort .zero] 0 [.bvar 0] + constructor + · exact .inr (.inr ⟨rfl, .zero, by type_tac, .inl rfl⟩) + constructor + · intro recursive + contradiction + · trivial + · rfl + +def orGenerationWF07 : orGenerationChecked.WF VEnv.empty := by + exact orCheckedWF07.identityGeneration .empty + +def orTypeEnv07 : VEnv := + (VEnv.empty.addConst orType.name orType.toVConstant).get! + +def orInlEnv07 : VEnv := + (orTypeEnv07.addConst orType.ctors[0].name + orType.ctors[0].toVConstant).get! + +def orCtorEnv07 : VEnv := + (orInlEnv07.addConst orType.ctors[1].name + orType.ctors[1].toVConstant).get! + +def orRecEnv07 : VEnv := + (orCtorEnv07.addConst ``Or.rec + (inductGenerationRecVal orGenerationChecked).toVConstant).get! + +def orFinalEnv07 : VEnv := + orGenerationChecked.generatedRules.foldl VEnv.addDefEq orRecEnv07 + +def orTypeMap07 : ConstMap := + ({} : ConstMap).insert ``Or orInfo06 + +def orInlMap07 : ConstMap := + orTypeMap07.insert ``Or.inl orInlInfo06 + +def orCtorMap07 : ConstMap := + orInlMap07.insert ``Or.inr orInrInfo06 + +def orMap07 : ConstMap := + orCtorMap07.insert ``Or.rec orRecInfo06 + +theorem orTypeEnv_ordered07 : orTypeEnv07.Ordered := + replayTypeEnv_ordered07 .empty orGenerationWF07 rfl + +theorem orInlEnv_ordered07 : orInlEnv07.Ordered := by + refine .const (n := orType.ctors[0].name) + (ci := orType.ctors[0].toVConstant) orTypeEnv_ordered07 ?_ rfl + exact replayRawCtorWF07 orGenerationWF07 rfl orType.ctors[0] + (.head _) + +theorem orCtorEnv_ordered07 : orCtorEnv07.Ordered := + replayCtorEnv_ordered07 orGenerationWF07 rfl + orTypeEnv_ordered07 rfl + +def orGenerationEnv07 : + VInductDecl.GenerationEnv orGenerationChecked orCtorEnv07 := + replayGenerationEnv07 orGenerationWF07 rfl rfl + orCtorEnv_ordered07 + +theorem orInfoTr07 : + TrConstVal .safe VEnv.empty orInfo06 orType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr VEnv.empty orInfo06.levelParams [] + orInfo06.type orType.type := by + tr_type_expr_tac + obtain ⟨sort, familyType⟩ := replayRawFamilyWF07 orGenerationWF07 + exact shape.to_trExprS .empty trivial ⟨.sort sort, familyType⟩ + +theorem orInlInfoTr07 : + TrConstVal .safe orTypeEnv07 orInlInfo06 orType.ctors[0] := by + have hOr : orTypeEnv07.constants ``Or = some orType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr orTypeEnv07 orInlInfo06.levelParams [] + orInlInfo06.type orType.ctors[0].type := by + tr_type_expr_tac + obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 orGenerationWF07 rfl + orType.ctors[0] (.head _) + exact shape.to_trExprS orTypeEnv_ordered07 trivial + ⟨.sort sort, ctorType⟩ + +theorem orInrInfoTr07 : + TrConstVal .safe orInlEnv07 orInrInfo06 orType.ctors[1] := by + have hOr : orInlEnv07.constants ``Or = some orType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr orInlEnv07 orInrInfo06.levelParams [] + orInrInfo06.type orType.ctors[1].type := by + tr_type_expr_tac + obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 orGenerationWF07 rfl + orType.ctors[1] (.tail _ (.head _)) + have typeToInl : orTypeEnv07 ≤ orInlEnv07 := + VEnv.addConst_le (show orTypeEnv07.addConst orType.ctors[0].name + orType.ctors[0].toVConstant = some orInlEnv07 from rfl) + exact shape.to_trExprS orInlEnv_ordered07 trivial + ⟨.sort sort, ctorType.mono typeToInl⟩ + +theorem orRecInfoTr07 : + TrConstVal .safe orCtorEnv07 orRecInfo06 + (inductGenerationRecVal orGenerationChecked) := by + have hOr : orCtorEnv07.constants ``Or = some orType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr orCtorEnv07 orRecInfo06.levelParams [] + orRecInfo06.type + (inductGenerationRecVal orGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨sort, recursorType⟩ := orGenerationEnv07.recursor_wf + exact shape.to_trExprS orCtorEnv_ordered07 trivial + ⟨.sort sort, recursorType⟩ + +theorem orTypeFresh07 : ({} : ConstMap).find? ``Or = none := by + simp [SMap.find?] + +theorem orTypeMapWF07 : orTypeMap07.WF := + SMap.WF.empty.insert _ _ orTypeFresh07 + +theorem orInlFresh07 : orTypeMap07.find? ``Or.inl = none := by + rw [orTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem orInlMapWF07 : orInlMap07.WF := + orTypeMapWF07.insert _ _ orInlFresh07 + +theorem orInrFresh07 : orInlMap07.find? ``Or.inr = none := by + rw [orInlMap07, orTypeMapWF07.find?_insert, orTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem orCtorMapWF07 : orCtorMap07.WF := + orInlMapWF07.insert _ _ orInrFresh07 + +theorem orRecFresh07 : orCtorMap07.find? ``Or.rec = none := by + rw [orCtorMap07, orInlMapWF07.find?_insert, orInlMap07, + orTypeMapWF07.find?_insert, orTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem orAddInduct07 : AddInduct ({} : ConstMap) VEnv.empty orDecl + orMap07 orFinalEnv07 := by + refine ⟨{ + generation := orGenerationChecked + generation_wf := orGenerationWF07 + typeMap := orTypeMap07 + typeEnv := orTypeEnv07 + ctorMap := orCtorMap07 + ctorEnv := orCtorEnv07 + recEnv := orRecEnv07 + addType := { + info := orInfo06 + kind_eq := by simp [orInfo06, InductConstantKind.Matches] + tr := orInfoTr07 + map_fresh := orTypeFresh07 + env_add := rfl + map_add := rfl } + addCtors := ?_ + addRec := { + info := orRecInfo06 + kind_eq := by simp [orRecInfo06, InductConstantKind.Matches] + tr := orRecInfoTr07 + map_fresh := orRecFresh07 + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ }⟩ + exact .cons { + info := orInlInfo06 + kind_eq := by simp [orInlInfo06, InductConstantKind.Matches] + tr := orInlInfoTr07 + map_fresh := by simpa [orType] using orInlFresh07 + env_add := rfl + map_add := rfl } + (.cons { + info := orInrInfo06 + kind_eq := by simp [orInrInfo06, InductConstantKind.Matches] + tr := orInrInfoTr07 + map_fresh := by + change orInlMap07.find? ``Or.inr = none + exact orInrFresh07 + env_add := rfl + map_add := rfl } .nil) + +theorem orAligned07 : Aligned .safe orMap07 orFinalEnv07 := + Aligned.addInduct orAddInduct07 .empty + +def orReplay07 : SingletonReplayArtifact where + label := ``Or + source := orDecl + inputMap := {} + inputEnv := .empty + outputMap := orMap07 + outputEnv := orFinalEnv07 + inputOrdered := .empty + transaction := orAddInduct07 + aligned := orAligned07 + +/-! ### HEq -/ + +theorem heqCheckedWF07 : heqChecked.WF VEnv.empty := by + constructor + · change VEnv.empty.OnTel 1 [] + [.sort (.param 0), .bvar 0, .sort (.param 0), .bvar 0] + exact ⟨⟨.succ (.param 0), VEnv.HasType.sort (by decide)⟩, + ⟨⟨.param 0, by type_tac⟩, + ⟨⟨.succ (.param 0), VEnv.HasType.sort (by decide)⟩, + ⟨⟨.param 0, by type_tac⟩, trivial⟩⟩⟩⟩ + · intro ctor hctor + have hctor' := List.mem_singleton.1 hctor + subst ctor + constructor + · change True + trivial + · change VEnv.empty.SpineWF 1 [.bvar 0, .sort (.param 0)] + (.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⟩ + +def heqGenerationWF07 : heqGenerationChecked.WF VEnv.empty := by + exact heqCheckedWF07.identityGeneration .empty + +def heqTypeEnv07 : VEnv := + (VEnv.empty.addConst heqType.name heqType.toVConstant).get! + +def heqCtorEnv07 : VEnv := + (heqTypeEnv07.addConst heqType.ctors[0].name + heqType.ctors[0].toVConstant).get! + +def heqRecEnv07 : VEnv := + (heqCtorEnv07.addConst ``HEq.rec + (inductGenerationRecVal heqGenerationChecked).toVConstant).get! + +def heqFinalEnv07 : VEnv := + heqGenerationChecked.generatedRules.foldl VEnv.addDefEq heqRecEnv07 + +def heqTypeMap07 : ConstMap := + ({} : ConstMap).insert ``HEq heqInfo07 + +def heqCtorMap07 : ConstMap := + heqTypeMap07.insert ``HEq.refl heqReflInfo07 + +def heqMap07 : ConstMap := + heqCtorMap07.insert ``HEq.rec heqRecInfo07 + +theorem heqTypeEnv_ordered07 : heqTypeEnv07.Ordered := + replayTypeEnv_ordered07 .empty heqGenerationWF07 rfl + +theorem heqCtorEnv_ordered07 : heqCtorEnv07.Ordered := + replayCtorEnv_ordered07 heqGenerationWF07 rfl + heqTypeEnv_ordered07 rfl + +def heqGenerationEnv07 : + VInductDecl.GenerationEnv heqGenerationChecked heqCtorEnv07 := + replayGenerationEnv07 heqGenerationWF07 rfl rfl + heqCtorEnv_ordered07 + +theorem heqInfoTr07 : + TrConstVal .safe VEnv.empty heqInfo07 heqType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr VEnv.empty heqInfo07.levelParams [] + heqInfo07.type heqType.type := by + tr_type_expr_tac + obtain ⟨sort, familyType⟩ := replayRawFamilyWF07 heqGenerationWF07 + exact shape.to_trExprS .empty trivial ⟨.sort sort, familyType⟩ + +theorem heqCtorInfoTr07 : + TrConstVal .safe heqTypeEnv07 heqReflInfo07 heqType.ctors[0] := by + have hHEq : heqTypeEnv07.constants ``HEq = + some heqType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr heqTypeEnv07 heqReflInfo07.levelParams [] + heqReflInfo07.type heqType.ctors[0].type := by + tr_type_expr_tac + obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 heqGenerationWF07 rfl + heqType.ctors[0] (.head _) + exact shape.to_trExprS heqTypeEnv_ordered07 trivial + ⟨.sort sort, ctorType⟩ + +theorem heqRecInfoTr07 : + TrConstVal .safe heqCtorEnv07 heqRecInfo07 + (inductGenerationRecVal heqGenerationChecked) := by + have hHEq : heqCtorEnv07.constants ``HEq = + some heqType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr heqCtorEnv07 heqRecInfo07.levelParams [] + heqRecInfo07.type + (inductGenerationRecVal heqGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨sort, recursorType⟩ := heqGenerationEnv07.recursor_wf + exact shape.to_trExprS heqCtorEnv_ordered07 trivial + ⟨.sort sort, recursorType⟩ + +theorem heqTypeFresh07 : ({} : ConstMap).find? ``HEq = none := by + simp [SMap.find?] + +theorem heqTypeMapWF07 : heqTypeMap07.WF := + SMap.WF.empty.insert _ _ heqTypeFresh07 + +theorem heqCtorFresh07 : heqTypeMap07.find? ``HEq.refl = none := by + rw [heqTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem heqCtorMapWF07 : heqCtorMap07.WF := + heqTypeMapWF07.insert _ _ heqCtorFresh07 + +theorem heqRecFresh07 : heqCtorMap07.find? ``HEq.rec = none := by + rw [heqCtorMap07, heqTypeMapWF07.find?_insert, heqTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem heqAddInduct07 : AddInduct ({} : ConstMap) VEnv.empty heqDecl + heqMap07 heqFinalEnv07 := by + refine ⟨{ + generation := heqGenerationChecked + generation_wf := heqGenerationWF07 + typeMap := heqTypeMap07 + typeEnv := heqTypeEnv07 + ctorMap := heqCtorMap07 + ctorEnv := heqCtorEnv07 + recEnv := heqRecEnv07 + addType := { + info := heqInfo07 + kind_eq := by simp [heqInfo07, InductConstantKind.Matches] + tr := heqInfoTr07 + map_fresh := heqTypeFresh07 + env_add := rfl + map_add := rfl } + addCtors := ?_ + addRec := { + info := heqRecInfo07 + kind_eq := by simp [heqRecInfo07, InductConstantKind.Matches] + tr := heqRecInfoTr07 + map_fresh := heqRecFresh07 + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ }⟩ + exact .cons { + info := heqReflInfo07 + kind_eq := by simp [heqReflInfo07, InductConstantKind.Matches] + tr := heqCtorInfoTr07 + map_fresh := by simpa [heqType] using heqCtorFresh07 + env_add := rfl + map_add := rfl } .nil + +theorem heqAligned07 : Aligned .safe heqMap07 heqFinalEnv07 := + Aligned.addInduct heqAddInduct07 .empty + +def heqReplay07 : SingletonReplayArtifact where + label := ``HEq + source := heqDecl + inputMap := {} + inputEnv := .empty + outputMap := heqMap07 + outputEnv := heqFinalEnv07 + inputOrdered := .empty + transaction := heqAddInduct07 + aligned := heqAligned07 + +/-! ### Fin dependency environment -/ + +def finLTInfo07 : ConstantInfo := kernelInductInfo% LT +def finLTMkInfo07 : ConstantInfo := kernelCtorInfo% LT.mk +def finLTLtInfo07 : ConstantInfo := .defnInfo (kernelDefVal% LT.lt) +def finInstLTNatInfo07 : ConstantInfo := + .defnInfo (kernelDefVal% instLTNat) + +def finLTConst07 : VConstVal := ⟨vconst(type_of% @LT), ``LT⟩ +def finLTMkConst07 : VConstVal := ⟨vconst(type_of% @LT.mk), ``LT.mk⟩ +def finLTLtConst07 : VConstVal := ⟨vconst(type_of% @LT.lt), ``LT.lt⟩ +def finInstLTNatConst07 : VConstVal := + ⟨vconst(type_of% @instLTNat), ``instLTNat⟩ + +def finLTMap07 : ConstMap := natTypeMap.insert ``LT finLTInfo07 +def finLTMkMap07 : ConstMap := finLTMap07.insert ``LT.mk finLTMkInfo07 +def finLTLtMap07 : ConstMap := finLTMkMap07.insert ``LT.lt finLTLtInfo07 +def finInputMap07 : ConstMap := + finLTLtMap07.insert ``instLTNat finInstLTNatInfo07 + +def finLTEnv07 : VEnv := + (natTypeEnv.addConst ``LT finLTConst07.toVConstant).get! + +def finLTMkEnv07 : VEnv := + (finLTEnv07.addConst ``LT.mk finLTMkConst07.toVConstant).get! + +def finLTLtEnv07 : VEnv := + (finLTMkEnv07.addConst ``LT.lt finLTLtConst07.toVConstant).get! + +def finInputEnv07 : VEnv := + (finLTLtEnv07.addConst ``instLTNat + finInstLTNatConst07.toVConstant).get! + +theorem natTypeAligned07 : Aligned .safe natTypeMap natTypeEnv := by + exact Aligned.const .empty natType_fresh natInfo_tr.1 rfl natInfo_tr.2 + +theorem finLTConstWF07 : finLTConst07.toVConstant.WF natTypeEnv := by + change natTypeEnv.IsType finLTConst07.uvars [] finLTConst07.type + dsimp [finLTConst07] + refine ⟨.imax (.succ (.succ (.param 0))) + (.succ (.succ (.param 0))), ?_⟩ + refine VEnv.HasType.forallE + (u := .succ (.succ (.param 0))) + (v := .succ (.succ (.param 0))) ?_ ?_ + · exact VEnv.HasType.sort (by decide) + · exact VEnv.HasType.sort (by decide) + +theorem finLTInfoTr07 : + TrConstVal .safe natTypeEnv finLTInfo07 finLTConst07 := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr natTypeEnv finLTInfo07.levelParams [] + finLTInfo07.type finLTConst07.type := by + tr_type_expr_tac + obtain ⟨sort, familyType⟩ := finLTConstWF07 + exact shape.to_trExprS natTypeEnv_ordered trivial + ⟨.sort sort, familyType⟩ + +theorem finLTFresh07 : natTypeMap.find? ``LT = none := by + rw [natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem finLTMapWF07 : finLTMap07.WF := + natTypeMap_wf.insert _ _ finLTFresh07 + +theorem finLTEnv_ordered07 : finLTEnv07.Ordered := + .const (n := ``LT) (ci := finLTConst07.toVConstant) + natTypeEnv_ordered finLTConstWF07 rfl + +theorem finLTAligned07 : Aligned .safe finLTMap07 finLTEnv07 := + Aligned.const natTypeAligned07 finLTFresh07 finLTInfoTr07.1 rfl + finLTInfoTr07.2 + +theorem finLTMkConstWF07 : finLTMkConst07.toVConstant.WF finLTEnv07 := by + have hLT : finLTEnv07.constants ``LT = + some finLTConst07.toVConstant := rfl + change finLTEnv07.IsType finLTMkConst07.uvars [] finLTMkConst07.type + dsimp [finLTMkConst07] + refine ⟨.imax (.succ (.succ (.param 0))) + (.imax + (.imax (.succ (.param 0)) + (.imax (.succ (.param 0)) (.succ .zero))) + (.succ (.param 0))), ?_⟩ + refine VEnv.HasType.forallE + (u := .succ (.succ (.param 0))) + (v := .imax + (.imax (.succ (.param 0)) + (.imax (.succ (.param 0)) (.succ .zero))) + (.succ (.param 0))) ?_ ?_ + · exact VEnv.HasType.sort (by decide) + · refine VEnv.HasType.forallE + (u := .imax (.succ (.param 0)) + (.imax (.succ (.param 0)) (.succ .zero))) + (v := .succ (.param 0)) ?_ ?_ + · refine VEnv.HasType.forallE + (u := .succ (.param 0)) + (v := .imax (.succ (.param 0)) (.succ .zero)) ?_ ?_ + · type_tac + · refine VEnv.HasType.forallE + (u := .succ (.param 0)) (v := .succ .zero) ?_ ?_ + · type_tac + · exact VEnv.HasType.sort (by decide) + · type_tac + +theorem finLTMkInfoTr07 : + TrConstVal .safe finLTEnv07 finLTMkInfo07 finLTMkConst07 := by + have hLT : finLTEnv07.constants ``LT = + some finLTConst07.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr finLTEnv07 finLTMkInfo07.levelParams [] + finLTMkInfo07.type finLTMkConst07.type := by + tr_type_expr_tac + obtain ⟨sort, ctorType⟩ := finLTMkConstWF07 + exact shape.to_trExprS finLTEnv_ordered07 trivial + ⟨.sort sort, ctorType⟩ + +theorem finLTMkFresh07 : finLTMap07.find? ``LT.mk = none := by + rw [finLTMap07, natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem finLTMkMapWF07 : finLTMkMap07.WF := + finLTMapWF07.insert _ _ finLTMkFresh07 + +theorem finLTMkEnv_ordered07 : finLTMkEnv07.Ordered := + .const (n := ``LT.mk) (ci := finLTMkConst07.toVConstant) + finLTEnv_ordered07 finLTMkConstWF07 rfl + +theorem finLTMkAligned07 : Aligned .safe finLTMkMap07 finLTMkEnv07 := + Aligned.const finLTAligned07 finLTMkFresh07 finLTMkInfoTr07.1 rfl + finLTMkInfoTr07.2 + +theorem finLTLtConstWF07 : finLTLtConst07.toVConstant.WF finLTMkEnv07 := by + have hLT : finLTMkEnv07.constants ``LT = + some finLTConst07.toVConstant := rfl + change finLTMkEnv07.IsType finLTLtConst07.uvars [] finLTLtConst07.type + dsimp [finLTLtConst07] + refine ⟨.imax (.succ (.succ (.param 0))) + (.imax (.succ (.param 0)) + (.imax (.succ (.param 0)) + (.imax (.succ (.param 0)) (.succ .zero)))), ?_⟩ + refine VEnv.HasType.forallE + (u := .succ (.succ (.param 0))) + (v := .imax (.succ (.param 0)) + (.imax (.succ (.param 0)) + (.imax (.succ (.param 0)) (.succ .zero)))) ?_ ?_ + · exact VEnv.HasType.sort (by decide) + · refine VEnv.HasType.forallE + (u := .succ (.param 0)) + (v := .imax (.succ (.param 0)) + (.imax (.succ (.param 0)) (.succ .zero))) ?_ ?_ + · type_tac + · refine VEnv.HasType.forallE + (u := .succ (.param 0)) + (v := .imax (.succ (.param 0)) (.succ .zero)) ?_ ?_ + · type_tac + · refine VEnv.HasType.forallE + (u := .succ (.param 0)) (v := .succ .zero) ?_ ?_ + · type_tac + · exact VEnv.HasType.sort (by decide) + +theorem finLTLtInfoTr07 : + TrConstVal .safe finLTMkEnv07 finLTLtInfo07 finLTLtConst07 := by + have hLT : finLTMkEnv07.constants ``LT = + some finLTConst07.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr finLTMkEnv07 finLTLtInfo07.levelParams [] + finLTLtInfo07.type finLTLtConst07.type := by + tr_type_expr_tac + obtain ⟨sort, projectionType⟩ := finLTLtConstWF07 + exact shape.to_trExprS finLTMkEnv_ordered07 trivial + ⟨.sort sort, projectionType⟩ + +theorem finLTLtFresh07 : finLTMkMap07.find? ``LT.lt = none := by + rw [finLTMkMap07, finLTMapWF07.find?_insert, finLTMap07, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem finLTLtMapWF07 : finLTLtMap07.WF := + finLTMkMapWF07.insert _ _ finLTLtFresh07 + +theorem finLTLtEnv_ordered07 : finLTLtEnv07.Ordered := + .const (n := ``LT.lt) (ci := finLTLtConst07.toVConstant) + finLTMkEnv_ordered07 finLTLtConstWF07 rfl + +theorem finLTLtAligned07 : Aligned .safe finLTLtMap07 finLTLtEnv07 := + Aligned.const finLTMkAligned07 finLTLtFresh07 finLTLtInfoTr07.1 rfl + finLTLtInfoTr07.2 + +theorem finInstLTNatConstWF07 : + finInstLTNatConst07.toVConstant.WF finLTLtEnv07 := by + have hNat : finLTLtEnv07.constants ``Nat = + some natType.toVConstant := rfl + have hLT : finLTLtEnv07.constants ``LT = + some finLTConst07.toVConstant := rfl + change finLTLtEnv07.IsType finInstLTNatConst07.uvars [] + finInstLTNatConst07.type + dsimp [finInstLTNatConst07] + refine ⟨.succ .zero, ?_⟩ + type_tac + +theorem finInstLTNatInfoTr07 : + TrConstVal .safe finLTLtEnv07 finInstLTNatInfo07 + finInstLTNatConst07 := by + have hNat : finLTLtEnv07.constants ``Nat = + some natType.toVConstant := rfl + have hLT : finLTLtEnv07.constants ``LT = + some finLTConst07.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr finLTLtEnv07 finInstLTNatInfo07.levelParams [] + finInstLTNatInfo07.type finInstLTNatConst07.type := by + tr_type_expr_tac + obtain ⟨sort, instanceType⟩ := finInstLTNatConstWF07 + exact shape.to_trExprS finLTLtEnv_ordered07 trivial + ⟨.sort sort, instanceType⟩ + +theorem finInstLTNatFresh07 : + finLTLtMap07.find? ``instLTNat = none := by + rw [finLTLtMap07, finLTMkMapWF07.find?_insert, finLTMkMap07, + finLTMapWF07.find?_insert, finLTMap07, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem finInputMapWF07 : finInputMap07.WF := + finLTLtMapWF07.insert _ _ finInstLTNatFresh07 + +theorem finInputEnv_ordered07 : finInputEnv07.Ordered := + .const (n := ``instLTNat) (ci := finInstLTNatConst07.toVConstant) + finLTLtEnv_ordered07 finInstLTNatConstWF07 rfl + +theorem finInputAligned07 : Aligned .safe finInputMap07 finInputEnv07 := + Aligned.const finLTLtAligned07 finInstLTNatFresh07 + finInstLTNatInfoTr07.1 rfl finInstLTNatInfoTr07.2 + +example : finInputMap07 = finDependencyMap07 := rfl + +/-! ### Fin -/ + +theorem finCheckedWF07 : finChecked.WF finInputEnv07 := by + constructor + · change finInputEnv07.OnTel 0 [] [.const ``Nat []] + have hNat : finInputEnv07.constants ``Nat = + some natType.toVConstant := rfl + exact ⟨⟨.succ .zero, by type_tac⟩, trivial⟩ + · intro ctor hctor + have hctor' := List.mem_singleton.1 hctor + subst ctor + constructor + · change VInductDecl.fieldsWF 0 ``Fin 1 finInputEnv07 + (.succ .zero) [] [.const ``Nat []] 0 + [.const ``Nat [], + .app + (.app + (.app + (.app (.const ``LT.lt [.zero]) (.const ``Nat [])) + (.const ``instLTNat [])) + (.bvar 0)) + (.bvar 1)] + have hNat : finInputEnv07.constants ``Nat = + some natType.toVConstant := rfl + have hLT : finInputEnv07.constants ``LT = + some finLTConst07.toVConstant := rfl + have hLTLt : finInputEnv07.constants ``LT.lt = + some finLTLtConst07.toVConstant := rfl + have hInst : finInputEnv07.constants ``instLTNat = + some finInstLTNatConst07.toVConstant := rfl + constructor + · exact .inr (.inr ⟨rfl, .succ .zero, by type_tac, + .inr (VLevel.le_refl _)⟩) + constructor + · intro recursive + contradiction + constructor + · exact .inr (.inr ⟨rfl, .zero, by type_tac, + .inr VLevel.zero_le⟩) + constructor + · intro recursive + contradiction + · trivial + · rfl + +def finGenerationWF07 : finGenerationChecked.WF finInputEnv07 := by + exact finCheckedWF07.identityGeneration finInputEnv_ordered07 + +def finTypeEnv07 : VEnv := + (finInputEnv07.addConst finType.name finType.toVConstant).get! + +def finCtorEnv07 : VEnv := + (finTypeEnv07.addConst finType.ctors[0].name + finType.ctors[0].toVConstant).get! + +def finRecEnv07 : VEnv := + (finCtorEnv07.addConst ``Fin.rec + (inductGenerationRecVal finGenerationChecked).toVConstant).get! + +def finFinalEnv07 : VEnv := + finGenerationChecked.generatedRules.foldl VEnv.addDefEq finRecEnv07 + +def finTypeMap07 : ConstMap := finInputMap07.insert ``Fin finInfo07 +def finCtorMap07 : ConstMap := finTypeMap07.insert ``Fin.mk finMkInfo07 +def finMap07 : ConstMap := finCtorMap07.insert ``Fin.rec finRecInfo07 + +theorem finTypeEnv_ordered07 : finTypeEnv07.Ordered := + replayTypeEnv_ordered07 finInputEnv_ordered07 finGenerationWF07 rfl + +theorem finCtorEnv_ordered07 : finCtorEnv07.Ordered := + replayCtorEnv_ordered07 finGenerationWF07 rfl finTypeEnv_ordered07 rfl + +def finGenerationEnv07 : + VInductDecl.GenerationEnv finGenerationChecked finCtorEnv07 := + replayGenerationEnv07 finGenerationWF07 rfl rfl finCtorEnv_ordered07 + +theorem finInfoTr07 : + TrConstVal .safe finInputEnv07 finInfo07 finType.toVConstVal := by + have hNat : finInputEnv07.constants ``Nat = + some natType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr finInputEnv07 finInfo07.levelParams [] + finInfo07.type finType.type := by + tr_type_expr_tac + obtain ⟨sort, familyType⟩ := replayRawFamilyWF07 finGenerationWF07 + exact shape.to_trExprS finInputEnv_ordered07 trivial + ⟨.sort sort, familyType⟩ + +theorem finCtorInfoTr07 : + TrConstVal .safe finTypeEnv07 finMkInfo07 finType.ctors[0] := by + have hNat : finTypeEnv07.constants ``Nat = + some natType.toVConstant := rfl + have hLT : finTypeEnv07.constants ``LT = + some finLTConst07.toVConstant := rfl + have hLTLt : finTypeEnv07.constants ``LT.lt = + some finLTLtConst07.toVConstant := rfl + have hInst : finTypeEnv07.constants ``instLTNat = + some finInstLTNatConst07.toVConstant := rfl + have hFin : finTypeEnv07.constants ``Fin = + some finType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr finTypeEnv07 finMkInfo07.levelParams [] + finMkInfo07.type finType.ctors[0].type := by + tr_type_expr_tac + obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 finGenerationWF07 rfl + finType.ctors[0] (.head _) + exact shape.to_trExprS finTypeEnv_ordered07 trivial + ⟨.sort sort, ctorType⟩ + +theorem finRecInfoTr07 : + TrConstVal .safe finCtorEnv07 finRecInfo07 + (inductGenerationRecVal finGenerationChecked) := by + have hNat : finCtorEnv07.constants ``Nat = + some natType.toVConstant := rfl + have hLT : finCtorEnv07.constants ``LT = + some finLTConst07.toVConstant := rfl + have hLTLt : finCtorEnv07.constants ``LT.lt = + some finLTLtConst07.toVConstant := rfl + have hInst : finCtorEnv07.constants ``instLTNat = + some finInstLTNatConst07.toVConstant := rfl + have hFin : finCtorEnv07.constants ``Fin = + some finType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr finCtorEnv07 finRecInfo07.levelParams [] + finRecInfo07.type + (inductGenerationRecVal finGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨sort, recursorType⟩ := finGenerationEnv07.recursor_wf + exact shape.to_trExprS finCtorEnv_ordered07 trivial + ⟨.sort sort, recursorType⟩ + +theorem finTypeFresh07 : finInputMap07.find? ``Fin = none := by + rw [finInputMap07, finLTLtMapWF07.find?_insert, finLTLtMap07, + finLTMkMapWF07.find?_insert, finLTMkMap07, + finLTMapWF07.find?_insert, finLTMap07, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem finTypeMapWF07 : finTypeMap07.WF := + finInputMapWF07.insert _ _ finTypeFresh07 + +theorem finCtorFresh07 : finTypeMap07.find? ``Fin.mk = none := by + rw [finTypeMap07, finInputMapWF07.find?_insert, finInputMap07, + finLTLtMapWF07.find?_insert, finLTLtMap07, + finLTMkMapWF07.find?_insert, finLTMkMap07, + finLTMapWF07.find?_insert, finLTMap07, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem finCtorMapWF07 : finCtorMap07.WF := + finTypeMapWF07.insert _ _ finCtorFresh07 + +theorem finRecFresh07 : finCtorMap07.find? ``Fin.rec = none := by + rw [finCtorMap07, finTypeMapWF07.find?_insert, finTypeMap07, + finInputMapWF07.find?_insert, finInputMap07, + finLTLtMapWF07.find?_insert, finLTLtMap07, + finLTMkMapWF07.find?_insert, finLTMkMap07, + finLTMapWF07.find?_insert, finLTMap07, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem finAddInduct07 : AddInduct finInputMap07 finInputEnv07 finDecl + finMap07 finFinalEnv07 := by + refine ⟨{ + generation := finGenerationChecked + generation_wf := finGenerationWF07 + typeMap := finTypeMap07 + typeEnv := finTypeEnv07 + ctorMap := finCtorMap07 + ctorEnv := finCtorEnv07 + recEnv := finRecEnv07 + addType := { + info := finInfo07 + kind_eq := by simp [finInfo07, InductConstantKind.Matches] + tr := finInfoTr07 + map_fresh := finTypeFresh07 + env_add := rfl + map_add := rfl } + addCtors := ?_ + addRec := { + info := finRecInfo07 + kind_eq := by simp [finRecInfo07, InductConstantKind.Matches] + tr := finRecInfoTr07 + map_fresh := finRecFresh07 + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ }⟩ + exact .cons { + info := finMkInfo07 + kind_eq := by simp [finMkInfo07, InductConstantKind.Matches] + tr := finCtorInfoTr07 + map_fresh := by simpa [finType] using finCtorFresh07 + env_add := rfl + map_add := rfl } .nil + +theorem finAligned07 : Aligned .safe finMap07 finFinalEnv07 := + Aligned.addInduct finAddInduct07 finInputAligned07 + +def finReplay07 : SingletonReplayArtifact where + label := ``Fin + source := finDecl + inputMap := finInputMap07 + inputEnv := finInputEnv07 + outputMap := finMap07 + outputEnv := finFinalEnv07 + inputOrdered := finInputEnv_ordered07 + transaction := finAddInduct07 + aligned := finAligned07 + +/-! ### Vector dependency environment -/ + +def vectorArrayInfo07 : ConstantInfo := kernelInductInfo% Array +def vectorArraySizeInfo07 : ConstantInfo := + .defnInfo (kernelDefVal% Array.size) + +def vectorArrayConst07 : VConstVal := + ⟨vconst(type_of% @Array), ``Array⟩ + +def vectorArraySizeConst07 : VConstVal := + ⟨vconst(type_of% @Array.size), ``Array.size⟩ + +def vectorEqMap07 : ConstMap := natTypeMap.insert ``Eq eqInfo +def vectorArrayMap07 : ConstMap := + vectorEqMap07.insert ``Array vectorArrayInfo07 +def vectorInputMap07 : ConstMap := + vectorArrayMap07.insert ``Array.size vectorArraySizeInfo07 + +def vectorEqEnv07 : VEnv := + (natTypeEnv.addConst ``Eq eqType.toVConstant).get! + +def vectorArrayEnv07 : VEnv := + (vectorEqEnv07.addConst ``Array vectorArrayConst07.toVConstant).get! + +def vectorInputEnv07 : VEnv := + (vectorArrayEnv07.addConst ``Array.size + vectorArraySizeConst07.toVConstant).get! + +theorem empty_le_natTypeEnv07 : VEnv.empty ≤ natTypeEnv := + VEnv.addConst_le (show VEnv.empty.addConst natType.name + natType.toVConstant = some natTypeEnv from rfl) + +theorem vectorEqTypeWF07 : eqType.toVConstant.WF natTypeEnv := + eqType_wf.mono empty_le_natTypeEnv07 + +theorem vectorEqInfoTr07 : + TrConstVal .safe natTypeEnv eqInfo eqType.toVConstVal := + eqInfo_tr.mono empty_le_natTypeEnv07 + +theorem vectorEqFresh07 : natTypeMap.find? ``Eq = none := by + rw [natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem vectorEqMapWF07 : vectorEqMap07.WF := + natTypeMap_wf.insert _ _ vectorEqFresh07 + +theorem vectorEqEnv_ordered07 : vectorEqEnv07.Ordered := + .const (n := ``Eq) (ci := eqType.toVConstant) + natTypeEnv_ordered vectorEqTypeWF07 rfl + +theorem vectorEqAligned07 : Aligned .safe vectorEqMap07 vectorEqEnv07 := + Aligned.const natTypeAligned07 vectorEqFresh07 vectorEqInfoTr07.1 rfl + vectorEqInfoTr07.2 + +theorem vectorArrayConstWF07 : + vectorArrayConst07.toVConstant.WF vectorEqEnv07 := by + change vectorEqEnv07.IsType vectorArrayConst07.uvars [] + vectorArrayConst07.type + dsimp [vectorArrayConst07] + refine ⟨.imax (.succ (.succ (.param 0))) + (.succ (.succ (.param 0))), ?_⟩ + refine VEnv.HasType.forallE + (u := .succ (.succ (.param 0))) + (v := .succ (.succ (.param 0))) ?_ ?_ + · exact VEnv.HasType.sort (by decide) + · exact VEnv.HasType.sort (by decide) + +theorem vectorArrayInfoTr07 : + TrConstVal .safe vectorEqEnv07 vectorArrayInfo07 + vectorArrayConst07 := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr vectorEqEnv07 vectorArrayInfo07.levelParams [] + vectorArrayInfo07.type vectorArrayConst07.type := by + tr_type_expr_tac + obtain ⟨sort, arrayType⟩ := vectorArrayConstWF07 + exact shape.to_trExprS vectorEqEnv_ordered07 trivial + ⟨.sort sort, arrayType⟩ + +theorem vectorArrayFresh07 : vectorEqMap07.find? ``Array = none := by + rw [vectorEqMap07, natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem vectorArrayMapWF07 : vectorArrayMap07.WF := + vectorEqMapWF07.insert _ _ vectorArrayFresh07 + +theorem vectorArrayEnv_ordered07 : vectorArrayEnv07.Ordered := + .const (n := ``Array) (ci := vectorArrayConst07.toVConstant) + vectorEqEnv_ordered07 vectorArrayConstWF07 rfl + +theorem vectorArrayAligned07 : + Aligned .safe vectorArrayMap07 vectorArrayEnv07 := + Aligned.const vectorEqAligned07 vectorArrayFresh07 + vectorArrayInfoTr07.1 rfl vectorArrayInfoTr07.2 + +theorem vectorArraySizeConstWF07 : + vectorArraySizeConst07.toVConstant.WF vectorArrayEnv07 := by + have hNat : vectorArrayEnv07.constants ``Nat = + some natType.toVConstant := rfl + have hArray : vectorArrayEnv07.constants ``Array = + some vectorArrayConst07.toVConstant := rfl + change vectorArrayEnv07.IsType vectorArraySizeConst07.uvars [] + vectorArraySizeConst07.type + dsimp [vectorArraySizeConst07] + refine ⟨.imax (.succ (.succ (.param 0))) + (.imax (.succ (.param 0)) (.succ .zero)), ?_⟩ + refine VEnv.HasType.forallE + (u := .succ (.succ (.param 0))) + (v := .imax (.succ (.param 0)) (.succ .zero)) ?_ ?_ + · exact VEnv.HasType.sort (by decide) + · refine VEnv.HasType.forallE + (u := .succ (.param 0)) (v := .succ .zero) ?_ ?_ + · type_tac + · type_tac + +theorem vectorArraySizeInfoTr07 : + TrConstVal .safe vectorArrayEnv07 vectorArraySizeInfo07 + vectorArraySizeConst07 := by + have hNat : vectorArrayEnv07.constants ``Nat = + some natType.toVConstant := rfl + have hArray : vectorArrayEnv07.constants ``Array = + some vectorArrayConst07.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr vectorArrayEnv07 + vectorArraySizeInfo07.levelParams [] vectorArraySizeInfo07.type + vectorArraySizeConst07.type := by + tr_type_expr_tac + obtain ⟨sort, sizeType⟩ := vectorArraySizeConstWF07 + exact shape.to_trExprS vectorArrayEnv_ordered07 trivial + ⟨.sort sort, sizeType⟩ + +theorem vectorArraySizeFresh07 : + vectorArrayMap07.find? ``Array.size = none := by + rw [vectorArrayMap07, vectorEqMapWF07.find?_insert, vectorEqMap07, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem vectorInputMapWF07 : vectorInputMap07.WF := + vectorArrayMapWF07.insert _ _ vectorArraySizeFresh07 + +theorem vectorInputEnv_ordered07 : vectorInputEnv07.Ordered := + .const (n := ``Array.size) (ci := vectorArraySizeConst07.toVConstant) + vectorArrayEnv_ordered07 vectorArraySizeConstWF07 rfl + +theorem vectorInputAligned07 : + Aligned .safe vectorInputMap07 vectorInputEnv07 := + Aligned.const vectorArrayAligned07 vectorArraySizeFresh07 + vectorArraySizeInfoTr07.1 rfl vectorArraySizeInfoTr07.2 + +example : vectorInputMap07 = vectorDependencyMap07 := rfl + +/-! ### Vector -/ + +theorem vectorCheckedWF07 : vectorChecked.WF vectorInputEnv07 := by + constructor + · change vectorInputEnv07.OnTel 1 [] + [.sort (.succ (.param 0)), .const ``Nat []] + have hNat : vectorInputEnv07.constants ``Nat = + some natType.toVConstant := rfl + exact ⟨⟨.succ (.succ (.param 0)), VEnv.HasType.sort (by decide)⟩, + ⟨⟨.succ .zero, by type_tac⟩, trivial⟩⟩ + · intro ctor hctor + have hctor' := List.mem_singleton.1 hctor + subst ctor + constructor + · change VInductDecl.fieldsWF 1 ``Vector 2 vectorInputEnv07 + (.succ (.param 0)) [] + [.const ``Nat [], .sort (.succ (.param 0))] 0 + [.app (.const ``Array [.param 0]) (.bvar 1), + .app + (.app + (.app (.const ``Eq [.succ .zero]) (.const ``Nat [])) + (.app + (.app (.const ``Array.size [.param 0]) (.bvar 2)) + (.bvar 0))) + (.bvar 1)] + have hNat : vectorInputEnv07.constants ``Nat = + some natType.toVConstant := rfl + have hEq : vectorInputEnv07.constants ``Eq = + some eqType.toVConstant := rfl + have hArray : vectorInputEnv07.constants ``Array = + some vectorArrayConst07.toVConstant := rfl + have hSize : vectorInputEnv07.constants ``Array.size = + some vectorArraySizeConst07.toVConstant := rfl + constructor + · exact .inr (.inr ⟨rfl, .succ (.param 0), by type_tac, + .inr (VLevel.le_refl _)⟩) + constructor + · intro recursive + contradiction + constructor + · exact .inr (.inr ⟨rfl, .zero, by type_tac, + .inr VLevel.zero_le⟩) + constructor + · intro recursive + contradiction + · trivial + · rfl + +def vectorGenerationWF07 : + vectorGenerationChecked.WF vectorInputEnv07 := by + exact vectorCheckedWF07.identityGeneration vectorInputEnv_ordered07 + +def vectorTypeEnv07 : VEnv := + (vectorInputEnv07.addConst vectorType.name vectorType.toVConstant).get! + +def vectorCtorEnv07 : VEnv := + (vectorTypeEnv07.addConst vectorType.ctors[0].name + vectorType.ctors[0].toVConstant).get! + +def vectorRecEnv07 : VEnv := + (vectorCtorEnv07.addConst ``Vector.rec + (inductGenerationRecVal vectorGenerationChecked).toVConstant).get! + +def vectorFinalEnv07 : VEnv := + vectorGenerationChecked.generatedRules.foldl VEnv.addDefEq vectorRecEnv07 + +def vectorTypeMap07 : ConstMap := + vectorInputMap07.insert ``Vector vectorInfo07 +def vectorCtorMap07 : ConstMap := + vectorTypeMap07.insert ``Vector.mk vectorMkInfo07 +def vectorMap07 : ConstMap := + vectorCtorMap07.insert ``Vector.rec vectorRecInfo07 + +theorem vectorTypeEnv_ordered07 : vectorTypeEnv07.Ordered := + replayTypeEnv_ordered07 vectorInputEnv_ordered07 vectorGenerationWF07 rfl + +theorem vectorCtorEnv_ordered07 : vectorCtorEnv07.Ordered := + replayCtorEnv_ordered07 vectorGenerationWF07 rfl + vectorTypeEnv_ordered07 rfl + +def vectorGenerationEnv07 : + VInductDecl.GenerationEnv vectorGenerationChecked vectorCtorEnv07 := + replayGenerationEnv07 vectorGenerationWF07 rfl rfl + vectorCtorEnv_ordered07 + +theorem vectorInfoTr07 : + TrConstVal .safe vectorInputEnv07 vectorInfo07 + vectorType.toVConstVal := by + have hNat : vectorInputEnv07.constants ``Nat = + some natType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr vectorInputEnv07 vectorInfo07.levelParams [] + vectorInfo07.type vectorType.type := by + tr_type_expr_tac + obtain ⟨sort, familyType⟩ := replayRawFamilyWF07 vectorGenerationWF07 + exact shape.to_trExprS vectorInputEnv_ordered07 trivial + ⟨.sort sort, familyType⟩ + +theorem vectorCtorInfoTr07 : + TrConstVal .safe vectorTypeEnv07 vectorMkInfo07 vectorType.ctors[0] := by + have hNat : vectorTypeEnv07.constants ``Nat = + some natType.toVConstant := rfl + have hEq : vectorTypeEnv07.constants ``Eq = + some eqType.toVConstant := rfl + have hArray : vectorTypeEnv07.constants ``Array = + some vectorArrayConst07.toVConstant := rfl + have hSize : vectorTypeEnv07.constants ``Array.size = + some vectorArraySizeConst07.toVConstant := rfl + have hVector : vectorTypeEnv07.constants ``Vector = + some vectorType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr vectorTypeEnv07 vectorMkInfo07.levelParams [] + vectorMkInfo07.type vectorType.ctors[0].type := by + tr_type_expr_tac + obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 vectorGenerationWF07 rfl + vectorType.ctors[0] (.head _) + exact shape.to_trExprS vectorTypeEnv_ordered07 trivial + ⟨.sort sort, ctorType⟩ + +theorem vectorRecInfoTr07 : + TrConstVal .safe vectorCtorEnv07 vectorRecInfo07 + (inductGenerationRecVal vectorGenerationChecked) := by + have hNat : vectorCtorEnv07.constants ``Nat = + some natType.toVConstant := rfl + have hEq : vectorCtorEnv07.constants ``Eq = + some eqType.toVConstant := rfl + have hArray : vectorCtorEnv07.constants ``Array = + some vectorArrayConst07.toVConstant := rfl + have hSize : vectorCtorEnv07.constants ``Array.size = + some vectorArraySizeConst07.toVConstant := rfl + have hVector : vectorCtorEnv07.constants ``Vector = + some vectorType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr vectorCtorEnv07 vectorRecInfo07.levelParams [] + vectorRecInfo07.type + (inductGenerationRecVal vectorGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨sort, recursorType⟩ := vectorGenerationEnv07.recursor_wf + exact shape.to_trExprS vectorCtorEnv_ordered07 trivial + ⟨.sort sort, recursorType⟩ + +theorem vectorTypeFresh07 : + vectorInputMap07.find? ``Vector = none := by + rw [vectorInputMap07, vectorArrayMapWF07.find?_insert, + vectorArrayMap07, vectorEqMapWF07.find?_insert, vectorEqMap07, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem vectorTypeMapWF07 : vectorTypeMap07.WF := + vectorInputMapWF07.insert _ _ vectorTypeFresh07 + +theorem vectorCtorFresh07 : + vectorTypeMap07.find? ``Vector.mk = none := by + rw [vectorTypeMap07, vectorInputMapWF07.find?_insert, + vectorInputMap07, vectorArrayMapWF07.find?_insert, + vectorArrayMap07, vectorEqMapWF07.find?_insert, vectorEqMap07, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem vectorCtorMapWF07 : vectorCtorMap07.WF := + vectorTypeMapWF07.insert _ _ vectorCtorFresh07 + +theorem vectorRecFresh07 : + vectorCtorMap07.find? ``Vector.rec = none := by + rw [vectorCtorMap07, vectorTypeMapWF07.find?_insert, + vectorTypeMap07, vectorInputMapWF07.find?_insert, + vectorInputMap07, vectorArrayMapWF07.find?_insert, + vectorArrayMap07, vectorEqMapWF07.find?_insert, vectorEqMap07, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem vectorAddInduct07 : + AddInduct vectorInputMap07 vectorInputEnv07 vectorDecl + vectorMap07 vectorFinalEnv07 := by + refine ⟨{ + generation := vectorGenerationChecked + generation_wf := vectorGenerationWF07 + typeMap := vectorTypeMap07 + typeEnv := vectorTypeEnv07 + ctorMap := vectorCtorMap07 + ctorEnv := vectorCtorEnv07 + recEnv := vectorRecEnv07 + addType := { + info := vectorInfo07 + kind_eq := by simp [vectorInfo07, InductConstantKind.Matches] + tr := vectorInfoTr07 + map_fresh := vectorTypeFresh07 + env_add := rfl + map_add := rfl } + addCtors := ?_ + addRec := { + info := vectorRecInfo07 + kind_eq := by simp [vectorRecInfo07, InductConstantKind.Matches] + tr := vectorRecInfoTr07 + map_fresh := vectorRecFresh07 + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ }⟩ + exact .cons { + info := vectorMkInfo07 + kind_eq := by simp [vectorMkInfo07, InductConstantKind.Matches] + tr := vectorCtorInfoTr07 + map_fresh := by simpa [vectorType] using vectorCtorFresh07 + env_add := rfl + map_add := rfl } .nil + +theorem vectorAligned07 : Aligned .safe vectorMap07 vectorFinalEnv07 := + Aligned.addInduct vectorAddInduct07 vectorInputAligned07 + +def vectorReplay07 : SingletonReplayArtifact where + label := ``Vector + source := vectorDecl + inputMap := vectorInputMap07 + inputEnv := vectorInputEnv07 + outputMap := vectorMap07 + outputEnv := vectorFinalEnv07 + inputOrdered := vectorInputEnv_ordered07 + transaction := vectorAddInduct07 + aligned := vectorAligned07 + +/-! ### Unit/Empty edge cases -/ + +def punitGenerationWF07 : punitGenerationChecked.WF VEnv.empty := by + exact (punitChecked.wf_of_decl punitDecl_wf).identityGeneration .empty + +def punitTypeEnv07 : VEnv := + (VEnv.empty.addConst punitType.name punitType.toVConstant).get! + +def punitCtorEnv07 : VEnv := + (punitTypeEnv07.addConst punitType.ctors[0].name + punitType.ctors[0].toVConstant).get! + +def punitRecEnv07 : VEnv := + (punitCtorEnv07.addConst ``PUnit.rec + (inductGenerationRecVal punitGenerationChecked).toVConstant).get! + +def punitFinalEnv07 : VEnv := + punitGenerationChecked.generatedRules.foldl VEnv.addDefEq punitRecEnv07 + +def punitTypeMap07 : ConstMap := + ({} : ConstMap).insert ``PUnit punitInfo06C + +def punitCtorMap07 : ConstMap := + punitTypeMap07.insert ``PUnit.unit punitCtorInfo06C + +def punitMap07 : ConstMap := + punitCtorMap07.insert ``PUnit.rec punitRecInfo06C + +theorem punitTypeEnv_ordered07 : punitTypeEnv07.Ordered := + replayTypeEnv_ordered07 .empty punitGenerationWF07 rfl + +theorem punitCtorEnv_ordered07 : punitCtorEnv07.Ordered := + replayCtorEnv_ordered07 punitGenerationWF07 rfl + punitTypeEnv_ordered07 rfl + +def punitGenerationEnv07 : + VInductDecl.GenerationEnv punitGenerationChecked punitCtorEnv07 := + replayGenerationEnv07 punitGenerationWF07 rfl rfl + punitCtorEnv_ordered07 + +theorem punitInfoTr07 : + TrConstVal .safe VEnv.empty punitInfo06C punitType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + exact .sort rfl + +theorem punitCtorInfoTr07 : + TrConstVal .safe punitTypeEnv07 punitCtorInfo06C punitType.ctors[0] := by + have hPUnit : punitTypeEnv07.constants ``PUnit = + some punitType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr punitTypeEnv07 punitCtorInfo06C.levelParams [] + punitCtorInfo06C.type punitType.ctors[0].type := by + tr_type_expr_tac + exact shape.to_trExprS punitTypeEnv_ordered07 trivial + ⟨.sort (.param 0), by type_tac⟩ + +theorem punitRecInfoTr07 : + TrConstVal .safe punitCtorEnv07 punitRecInfo06C + (inductGenerationRecVal punitGenerationChecked) := by + have hPUnit : punitCtorEnv07.constants ``PUnit = + some punitType.toVConstant := rfl + have hUnit : punitCtorEnv07.constants ``PUnit.unit = + some punitType.ctors[0].toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr punitCtorEnv07 punitRecInfo06C.levelParams [] + punitRecInfo06C.type + (inductGenerationRecVal punitGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨sort, recursorType⟩ := punitGenerationEnv07.recursor_wf + exact shape.to_trExprS punitCtorEnv_ordered07 trivial + ⟨.sort sort, recursorType⟩ + +theorem punitTypeFresh07 : ({} : ConstMap).find? ``PUnit = none := by + simp [SMap.find?] + +theorem punitTypeMapWF07 : punitTypeMap07.WF := + SMap.WF.empty.insert _ _ punitTypeFresh07 + +theorem punitCtorFresh07 : punitTypeMap07.find? ``PUnit.unit = none := by + rw [punitTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem punitCtorMapWF07 : punitCtorMap07.WF := + punitTypeMapWF07.insert _ _ punitCtorFresh07 + +theorem punitRecFresh07 : punitCtorMap07.find? ``PUnit.rec = none := by + rw [punitCtorMap07, punitTypeMapWF07.find?_insert, punitTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem punitAddInduct07 : AddInduct ({} : ConstMap) VEnv.empty punitDecl + punitMap07 punitFinalEnv07 := by + refine ⟨{ + generation := punitGenerationChecked + generation_wf := punitGenerationWF07 + typeMap := punitTypeMap07 + typeEnv := punitTypeEnv07 + ctorMap := punitCtorMap07 + ctorEnv := punitCtorEnv07 + recEnv := punitRecEnv07 + addType := { + info := punitInfo06C + kind_eq := by simp [punitInfo06C, InductConstantKind.Matches] + tr := punitInfoTr07 + map_fresh := punitTypeFresh07 + env_add := rfl + map_add := rfl } + addCtors := ?_ + addRec := { + info := punitRecInfo06C + kind_eq := by simp [punitRecInfo06C, InductConstantKind.Matches] + tr := punitRecInfoTr07 + map_fresh := punitRecFresh07 + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ }⟩ + exact .cons { + info := punitCtorInfo06C + kind_eq := by simp [punitCtorInfo06C, InductConstantKind.Matches] + tr := punitCtorInfoTr07 + map_fresh := by simpa [punitType] using punitCtorFresh07 + env_add := rfl + map_add := rfl } .nil + +theorem punitAligned07 : Aligned .safe punitMap07 punitFinalEnv07 := + Aligned.addInduct punitAddInduct07 .empty + +def punitReplay07 : SingletonReplayArtifact where + label := ``Unit + source := punitDecl + inputMap := {} + inputEnv := .empty + outputMap := punitMap07 + outputEnv := punitFinalEnv07 + inputOrdered := .empty + transaction := punitAddInduct07 + aligned := punitAligned07 + +def emptyGenerationWF07 : emptyGenerationChecked.WF VEnv.empty := by + exact (emptyChecked.wf_of_decl emptyDecl_wf).identityGeneration .empty + +def emptyTypeEnv07 : VEnv := + (VEnv.empty.addConst emptyType.name emptyType.toVConstant).get! + +def emptyRecEnv07 : VEnv := + (emptyTypeEnv07.addConst ``Empty.rec + (inductGenerationRecVal emptyGenerationChecked).toVConstant).get! + +def emptyFinalEnv07 : VEnv := + emptyGenerationChecked.generatedRules.foldl VEnv.addDefEq emptyRecEnv07 + +def emptyTypeMap07 : ConstMap := + ({} : ConstMap).insert ``Empty emptyInfo06C + +def emptyMap07 : ConstMap := + emptyTypeMap07.insert ``Empty.rec emptyRecInfo06C + +theorem emptyTypeEnv_ordered07 : emptyTypeEnv07.Ordered := + replayTypeEnv_ordered07 .empty emptyGenerationWF07 rfl + +def emptyGenerationEnv07 : + VInductDecl.GenerationEnv emptyGenerationChecked emptyTypeEnv07 := + replayGenerationEnv07 emptyGenerationWF07 rfl rfl + emptyTypeEnv_ordered07 + +theorem emptyInfoTr07 : + TrConstVal .safe VEnv.empty emptyInfo06C emptyType.toVConstVal := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + exact .sort rfl + +theorem emptyRecInfoTr07 : + TrConstVal .safe emptyTypeEnv07 emptyRecInfo06C + (inductGenerationRecVal emptyGenerationChecked) := by + have hEmpty : emptyTypeEnv07.constants ``Empty = + some emptyType.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr emptyTypeEnv07 emptyRecInfo06C.levelParams [] + emptyRecInfo06C.type + (inductGenerationRecVal emptyGenerationChecked).type := by + tr_type_expr_tac + obtain ⟨sort, recursorType⟩ := emptyGenerationEnv07.recursor_wf + exact shape.to_trExprS emptyTypeEnv_ordered07 trivial + ⟨.sort sort, recursorType⟩ + +theorem emptyTypeFresh07 : ({} : ConstMap).find? ``Empty = none := by + simp [SMap.find?] + +theorem emptyTypeMapWF07 : emptyTypeMap07.WF := + SMap.WF.empty.insert _ _ emptyTypeFresh07 + +theorem emptyRecFresh07 : emptyTypeMap07.find? ``Empty.rec = none := by + rw [emptyTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem emptyAddInduct07 : AddInduct ({} : ConstMap) VEnv.empty emptyDecl + emptyMap07 emptyFinalEnv07 := by + refine ⟨{ + generation := emptyGenerationChecked + generation_wf := emptyGenerationWF07 + typeMap := emptyTypeMap07 + typeEnv := emptyTypeEnv07 + ctorMap := emptyTypeMap07 + ctorEnv := emptyTypeEnv07 + recEnv := emptyRecEnv07 + addType := { + info := emptyInfo06C + kind_eq := by simp [emptyInfo06C, InductConstantKind.Matches] + tr := emptyInfoTr07 + map_fresh := emptyTypeFresh07 + env_add := rfl + map_add := rfl } + addCtors := .nil + addRec := { + info := emptyRecInfo06C + kind_eq := by simp [emptyRecInfo06C, InductConstantKind.Matches] + tr := emptyRecInfoTr07 + map_fresh := emptyRecFresh07 + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ }⟩ + +theorem emptyAligned07 : Aligned .safe emptyMap07 emptyFinalEnv07 := + Aligned.addInduct emptyAddInduct07 .empty + +def emptyReplay07 : SingletonReplayArtifact where + label := ``Empty + source := emptyDecl + inputMap := {} + inputEnv := .empty + outputMap := emptyMap07 + outputEnv := emptyFinalEnv07 + inputOrdered := .empty + transaction := emptyAddInduct07 + aligned := emptyAligned07 + +/-- Every fixed L4L-07 positive row, in exactly the same order as the +Theory/kernel parity matrix. Each entry carries an actual `ConstantInfo` +transaction and final environment alignment, including the real dependency +environments required by `Fin` and `Vector`. -/ +def singletonFixedReplays : List SingletonReplayArtifact := + [natReplay07, boolReplay07, listReplay07, optionReplay07, prodReplay07, + punitReplay07, emptyReplay07, orReplay07, andReplay07, eqReplay07, + heqReplay07, finReplay07, vectorReplay07, accReplay07] + +/-- The focused non-identity normalization rows use the same public replay +artifact as the standard-library matrix. -/ +noncomputable def singletonNormalizationReplays : + List SingletonReplayArtifact := + [aliasFormerReplay07, aliasRecReplay07, normalizationMatrixReplay07, + annotatedPiReplay07, annotatedParamReplay07] + +/-- The sole public L4L-07 environment replay inventory. -/ +noncomputable def singletonReplayMatrix : List SingletonReplayArtifact := + singletonFixedReplays ++ singletonNormalizationReplays + +example : singletonFixedReplays.map (·.label) = + singletonPositiveArtifacts.map (·.label) := rfl + +example : singletonFixedReplays.map (·.source) = + singletonPositiveArtifacts.map (·.source) := rfl + +example : singletonNormalizationReplays.map (·.label) = + singletonNormalizationArtifacts.map (·.label) := rfl + +example : singletonNormalizationReplays.map (·.source) = + singletonNormalizationArtifacts.map (·.source) := rfl + +example : singletonReplayMatrix.map (·.source) = + (singletonPositiveArtifacts ++ singletonNormalizationArtifacts).map + (·.source) := rfl + +example : singletonFixedReplays.length = 14 := rfl +example : singletonNormalizationReplays.length = 5 := rfl +example : singletonReplayMatrix.length = 19 := rfl + +/-! ## Exact trust manifests for the public replay seam -/ + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.SingletonReplayArtifact.outputOrdered' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms SingletonReplayArtifact.outputOrdered + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.singletonFixedReplays' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms singletonFixedReplays + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.singletonNormalizationReplays' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms singletonNormalizationReplays + +/-- +info: 'Lean4Lean.InductiveReplayFixtures.singletonReplayMatrix' depends on axioms: [propext, + sorryAx, + Classical.choice, + ptrEqConstantInfo_eq, + ptrEqExpr_eq, + Quot.sound, + Expr.abstractRange_eq, + Expr.abstract_eq, + Expr.eqv_eq, + Expr.hasLooseBVar_eq, + Expr.instantiate1_eq, + Expr.instantiateRange_eq, + Expr.instantiateRevRange_eq, + Expr.instantiateRev_eq, + Expr.instantiate_eq, + Expr.looseBVarRange_eq, + Expr.lowerLooseBVars_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + Syntax.structEq_eq, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms singletonReplayMatrix + +end Lean4Lean.InductiveReplayFixtures diff --git a/Lean4Lean/Verify/Expr.lean b/Lean4Lean/Verify/Expr.lean index fddf7504..36055465 100644 --- a/Lean4Lean/Verify/Expr.lean +++ b/Lean4Lean/Verify/Expr.lean @@ -1229,6 +1229,22 @@ theorem eqv_const {e : Expr} : e == .const c ls ↔ e = .const c ls := by conv => lhs; simp [(· == ·)] cases e <;> simp [eqv'] +theorem structuralEq_const {e : Expr} : + structuralEq e (.const c ls) = true ↔ e = .const c ls := by + cases e <;> simp [structuralEq] + +theorem structuralEq_refl (e : Expr) : structuralEq e e = true := by + induction e <;> simp [structuralEq, *] + +/-- Transparent structural equality implies Lean's non-strict expression +equivalence. This direction deliberately does not identify binder names or +binder information, which `Expr.eqv` also ignores. -/ +theorem structuralEq_eqv {a b : Expr} : + structuralEq a b = true → a == b := by + simp only [(· == ·)] + induction a generalizing b <;> cases b <;> + simp_all [structuralEq, eqv'] + theorem eqv_refl (e : Expr) : e == e := by simp [(· == ·)]; induction e <;> simp [eqv', *] diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index 6d63a0a3..22f828ff 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -540,9 +540,391 @@ theorem normalizeAux_eval (hu : VLevel.ofLevel ls u = some u') · 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 + 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} : s.subsumption.eval ls ρ = s.eval ls ρ := by - sorry + 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 theorem normalize_eval (hu : VLevel.ofLevel ls u = some u') : (normalize u).eval ls ρ = u'.eval ρ := by @@ -552,32 +934,139 @@ theorem normalize_eval (hu : VLevel.ofLevel ls u = some u') : 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 - 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 + change a.toList == b.toList at H simp only [eval, Std.TreeMap.foldl_eq_foldl_toList] - 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 ..) + 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₂) end Normalize -theorem isEquiv_wf (h : isEquiv u v) +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] +-/ +#guard_msgs in +#print axioms Normalize.NormLevel.le_eval + +/-- +info: 'Lean.Level.geq'_wf' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms geq'_wf + +theorem isStructEq_eq {u v : Level} (h : isStructEq u v) : u = v := by + induction u generalizing v with + | zero => cases v <;> simp_all [isStructEq] + | succ u ih => + cases v <;> simp [isStructEq] at h + exact congrArg Level.succ (ih h) + | max u₁ u₂ ih₁ ih₂ => + cases v <;> simp [isStructEq] at h + cases ih₁ h.1 + cases ih₂ h.2 + rfl + | imax u₁ u₂ ih₁ ih₂ => + cases v <;> simp [isStructEq] at h + cases ih₁ h.1 + cases ih₂ h.2 + rfl + | param u => + cases v <;> simp_all [isStructEq] + | mvar u => + rcases u with ⟨u⟩ + cases v <;> simp_all [isStructEq] + +theorem isStructEq_iff_eq {u v : Level} : isStructEq u v ↔ u = v := by + constructor + · exact isStructEq_eq + · rintro rfl + induction u <;> simp_all [isStructEq] + +theorem isEquiv_wf (h : isEquiv' u v) (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') : u' ≈ v' := by - sorry + 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 Normalize.NormLevel.eval_congr h theorem isEquivList_wf (H : Level.isEquivList us vs) : List.mapM (VLevel.ofLevel Us) us = some us' → diff --git a/Lean4Lean/Verify/TypeChecker/Reduce.lean b/Lean4Lean/Verify/TypeChecker/Reduce.lean index 549d2a61..49d9799d 100644 --- a/Lean4Lean/Verify/TypeChecker/Reduce.lean +++ b/Lean4Lean/Verify/TypeChecker/Reduce.lean @@ -97,7 +97,7 @@ theorem reduceNat.WF {c : VContext} (he : c.TrExprS e e') : 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.eqv_const] at h2 ⊢; subst h2 + 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⟩ => ?_ diff --git a/Lean4Lean/Verify/Typing/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean index 4778e76c..11f51804 100644 --- a/Lean4Lean/Verify/Typing/Lemmas.lean +++ b/Lean4Lean/Verify/Typing/Lemmas.lean @@ -213,6 +213,16 @@ theorem WF.toCtx : ∀ {Δ}, WF env U Δ → OnCtx Δ.toCtx (env.IsType U) | (_, .vlam _) :: _, ⟨hΔ, _, hA⟩ => ⟨hΔ.toCtx, hA⟩ | (_, .vlet ..) :: _, ⟨hΔ, _, _⟩ => hΔ.toCtx +/-- A verified local context remains well formed when the global environment +is extended. -/ +theorem WF.mono (henv : env ≤ env') : ∀ {Δ}, WF env U Δ → WF env' U Δ + | [], _ => trivial + | (_, d) :: Δ, ⟨hΔ, hfvars, hd⟩ => + ⟨hΔ.mono henv, hfvars, by + cases d with + | vlam => exact hd.mono henv + | vlet => exact hd.mono henv⟩ + instance : Coe (WF env U Δ) (OnCtx Δ.toCtx (env.IsType U)) := ⟨(·.toCtx)⟩ theorem WF.fvars_nodup : ∀ {Δ}, WF env U Δ → Δ.fvars.Nodup @@ -581,6 +591,7 @@ inductive TrTypeExpr : VLCtx → Expr → VExpr → Prop where TrTypeExpr Δ (.const c us) (.const c us') | app : TrTypeExpr Δ f f' → TrTypeExpr Δ a a' → TrTypeExpr Δ (.app f a) (.app f' a') + | mdata : TrTypeExpr Δ e e' → TrTypeExpr Δ (.mdata data e) e' | forallE : TrTypeExpr Δ ty ty' → TrTypeExpr ((none, .vlam ty') :: Δ) body body' → TrTypeExpr Δ (.forallE name ty body bi) (.forallE ty' body') @@ -600,6 +611,7 @@ theorem TrTypeExpr.to_trExprS | app _ _ ihf iha => obtain ⟨A, B, htf, hta⟩ := hwf.app_inv henv hΔ exact .app htf hta (ihf hΔ ⟨_, htf⟩) (iha hΔ ⟨_, hta⟩) + | mdata _ ih => exact .mdata (ih hΔ hwf) | forallE _ _ ihty ihbody => obtain ⟨_, hwf⟩ := hwf obtain ⟨hty, hbody⟩ := VEnv.HasType.forallE_inv henv hwf @@ -750,6 +762,15 @@ theorem VLCtx.IsDefEq.fvars : VLCtx.IsDefEq env U Δ₁ Δ₂ → Δ₁.fvars = | .cons (ofv := none) h1 h2 _ => h1.fvars | .cons (ofv := some fv) h1 h2 _ => by simp [h1.fvars] +/-- Definitionally equal verified local contexts have bound-variable entries +in exactly the same positions. -/ +theorem VLCtx.IsDefEq.bvars : VLCtx.IsDefEq env U Δ₁ Δ₂ → Δ₁.bvars = Δ₂.bvars + | .nil => rfl + | .cons (ofv := none) h1 _ _ => by + simp only [VLCtx.bvars, h1.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 @@ -758,6 +779,99 @@ 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 + | .cons h₁ h₂ h₃ => .cons (h₁.mono henv) h₂ (h₃.mono henv) + +/-- Definitionally equal verified contexts whose free-variable slots use the +same identifiers. Dependency metadata may differ because normalization can +change the syntactic free-variable list of a definitionally equal local type; +that metadata is irrelevant to Theory lookup and typing. -/ +inductive VLCtx.IsDefEqFVars (env : VEnv) (U : Nat) : VLCtx → VLCtx → Prop + | nil : IsDefEqFVars env U [] [] + | cons_bvar : + IsDefEqFVars env U Δ₁ Δ₂ → + VLocalDecl.IsDefEq env U Δ₁.toCtx d₁ d₂ → + IsDefEqFVars env U ((none, d₁) :: Δ₁) ((none, d₂) :: Δ₂) + | cons_fvar : + IsDefEqFVars env U Δ₁ Δ₂ → + VLocalDecl.IsDefEq env U Δ₁.toCtx d₁ d₂ → + IsDefEqFVars env U + ((some (fv, deps₁), d₁) :: Δ₁) + ((some (fv, deps₂), d₂) :: Δ₂) + +theorem VLCtx.IsDefEq.toFVars : + VLCtx.IsDefEq env U Δ₁ Δ₂ → VLCtx.IsDefEqFVars env U Δ₁ Δ₂ + | .nil => .nil + | .cons (ofv := none) h₁ _ h₃ => .cons_bvar h₁.toFVars h₃ + | .cons (ofv := some _) h₁ _ h₃ => .cons_fvar h₁.toFVars h₃ + +theorem VLCtx.IsDefEqFVars.defeqCtx : + VLCtx.IsDefEqFVars env U Δ₁ Δ₂ → + env.IsDefEqCtx U [] Δ₁.toCtx Δ₂.toCtx + | .nil => .zero + | .cons_bvar h₁ (.vlam h₂) => .succ h₁.defeqCtx h₂ + | .cons_bvar h₁ (.vlet ..) => h₁.defeqCtx + | .cons_fvar h₁ (.vlam h₂) => .succ h₁.defeqCtx h₂ + | .cons_fvar h₁ (.vlet ..) => h₁.defeqCtx + +theorem VLCtx.IsDefEqFVars.find?_uniq (henv : VEnv.WF env) + (hΔ : VLCtx.IsDefEqFVars env U Δ₁ Δ₂) + (H₁ : Δ₁.find? v = some (e₁, A₁)) + (H₂ : Δ₂.find? v = some (e₂, A₂)) : + env.IsDefEqU U Δ₁.toCtx A₁ A₂ ∧ + env.IsDefEq U Δ₁.toCtx e₁ e₂ A₁ := by + induction hΔ generalizing v e₁ e₂ A₁ A₂ with + | nil => simp [VLCtx.find?] at H₁ + | cons_bvar hΔ hd ih => + revert H₁ H₂ + simp only [VLCtx.find?] + split + · rintro ⟨⟩ ⟨⟩ + cases hd with + | vlam h => exact ⟨⟨_, h.weak henv⟩, .bvar .zero⟩ + | vlet h₁ h₂ => exact ⟨⟨_, h₂⟩, h₁⟩ + · simp + rintro d₁' n₁' H₁' rfl rfl d₂' n₂' H₂' rfl rfl + obtain ⟨h₂, h₃⟩ := ih H₁' H₂' + cases hd with + | vlam => exact ⟨h₂.weakN henv .one, h₃.weak henv⟩ + | vlet => simpa [VLocalDecl.depth] using ⟨h₂, h₃⟩ + | @cons_fvar Δ₁ Δ₂ d₁ d₂ fv deps₁ deps₂ hΔ hd ih => + revert H₁ H₂ + simp only [VLCtx.find?] + cases same : fv == (match v with | .inl _ => fv | .inr fv' => fv') <;> + simp only [VLCtx.next] + all_goals + cases v with + | inl i => + simp + rintro d₁' n₁' H₁' rfl rfl d₂' n₂' H₂' rfl rfl + obtain ⟨h₂, h₃⟩ := ih H₁' H₂' + cases hd with + | vlam => exact ⟨h₂.weakN henv .one, h₃.weak henv⟩ + | vlet => simpa [VLocalDecl.depth] using ⟨h₂, h₃⟩ + | inr fv' => + simp only [same] + split + · rintro ⟨⟩ ⟨⟩ + cases hd with + | vlam h => exact ⟨⟨_, h.weak henv⟩, .bvar .zero⟩ + | vlet h₁ h₂ => exact ⟨⟨_, h₂⟩, h₁⟩ + · simp + rintro d₁' n₁' H₁' rfl rfl d₂' n₂' H₂' rfl rfl + obtain ⟨h₂, h₃⟩ := ih H₁' H₂' + cases hd with + | 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 @@ -944,6 +1058,71 @@ theorem TrExprS.uniq (H1 : TrExprS env Us Δ₁ e e₁) (H2 : TrExprS env Us Δ | mdata _ ih1 => let .mdata r1 := H2; exact ih1 hΔ r1 | proj _ l2 ih1 => let .proj r1 r2 := H2; exact l2.uniq henv hΔ.defeqCtx r2 (ih1 hΔ r1) +variable! (henv : VEnv.WF env) {Us : List Name} + (hΔ : VLCtx.IsDefEqFVars env Us.length Δ₁ Δ₂) + (hΔwf : VLCtx.WF env Us.length Δ₁) in +/-- Translation congruence across contexts with the same free-variable +identifiers but potentially different dependency metadata. -/ +theorem TrExprS.uniqFVars + (H₁ : TrExprS env Us Δ₁ e e₁) (H₂ : TrExprS env Us Δ₂ e e₂) : + env.IsDefEqU Us.length Δ₁.toCtx e₁ e₂ := by + induction H₁ generalizing Δ₂ e₂ with + | bvar l₁ => + let .bvar r₁ := H₂ + exact ⟨_, (hΔ.find?_uniq henv l₁ r₁).2⟩ + | fvar l₁ => + let .fvar r₁ := H₂ + exact ⟨_, (hΔ.find?_uniq henv l₁ r₁).2⟩ + | sort l₁ => + let .sort r₁ := H₂ + cases l₁.symm.trans r₁ + exact ⟨_, HasType.sort (.of_ofLevel l₁)⟩ + | const l₁ l₂ l₃ => + let .const r₁ r₂ r₃ := H₂ + cases l₁.symm.trans r₁ + cases l₂.symm.trans r₂ + exact (TrExprS.const l₁ l₂ l₃).wf henv hΔwf + | app l₁ l₂ _ _ ih₃ ih₄ => + let .app _ _ r₃ r₄ := H₂ + exact ⟨_, .appDF + (ih₃ hΔ hΔwf r₃ |>.of_l henv hΔwf.toCtx l₁) + (ih₄ hΔ hΔwf r₄ |>.of_l henv hΔwf.toCtx l₂)⟩ + | lam l₁ _ _ ih₂ ih₃ => + let ⟨u, l₁'⟩ := l₁ + let .lam _ r₂ r₃ := H₂ + have hA := ih₂ hΔ hΔwf r₂ |>.of_l henv hΔwf.toCtx l₁' + have ⟨_, hb⟩ := ih₃ (.cons_bvar hΔ (.vlam hA)) + ⟨hΔwf, nofun, ⟨u, l₁'⟩⟩ r₃ + exact ⟨_, .lamDF hA hb⟩ + | forallE l₁ l₂ _ _ ih₃ ih₄ => + let ⟨_, l₁'⟩ := l₁ + let ⟨_, l₂⟩ := l₂ + let .forallE _ _ r₃ r₄ := H₂ + have hA := ih₃ hΔ hΔwf r₃ |>.of_l henv hΔwf.toCtx l₁' + have hbody := ih₄ (.cons_bvar hΔ (.vlam hA)) + ⟨hΔwf, nofun, l₁⟩ r₄ + have hbodyCtx : OnCtx (_ :: _) (env.IsType Us.length) := + ⟨hΔwf.toCtx, l₁⟩ + have hB := hbody.of_l henv hbodyCtx l₂ + exact ⟨_, .forallEDF hA hB⟩ + | letE l₁ _ _ _ ih₂ ih₃ ih₄ => + have hΓ := hΔwf.toCtx + let .letE _ r₂ r₃ r₄ := H₂ + have ⟨_, hb⟩ := l₁.isType henv hΓ + refine ih₄ (.cons_bvar hΔ ?_) ⟨hΔwf, nofun, l₁⟩ r₄ + exact .vlet + (ih₃ hΔ hΔwf r₃ |>.of_l henv hΓ l₁) + (ih₂ hΔ hΔwf r₂ |>.of_l henv hΓ hb) + | lit _ _ ih₁ => + let .lit _ r₂ := H₂ + exact ih₁ hΔ hΔwf r₂ + | mdata _ ih₁ => + let .mdata r₁ := H₂ + exact ih₁ hΔ hΔwf r₁ + | proj _ l₂ ih₁ => + let .proj r₁ r₂ := H₂ + exact l₂.uniq henv hΔ.defeqCtx r₂ (ih₁ hΔ hΔwf r₁) + variable! (henv : VEnv.WF env) {Us : List Name} (hΔ : VLCtx.IsDefEq env Us.length Δ₁ Δ₂) in theorem TrExpr.uniq (H1 : TrExpr env Us Δ₁ e e₁) (H2 : TrExpr env Us Δ₂ e e₂) : env.IsDefEqU Us.length Δ₁.toCtx e₁ e₂ := by diff --git a/README.md b/README.md index ed51e6a5..ced940ee 100644 --- a/README.md +++ b/README.md @@ -44,16 +44,15 @@ paths under `lake env` (see below). Other outputs: * `nix build .#lake-dependency` builds the `Lean4Lean` library artifact (oleans, `.export` files, static/shared libraries — no CLI or proofs) that downstream Lake packages can consume via lean4-nix's - `depOverrideDeriv.lean4lean`; `.#lake-dependency-full` additionally - includes the `Theory` and `Verify` proof libraries for consumers that - import the metatheory. + `depOverrideDeriv.lean4lean`. * `nix flake check` builds the `Lean4Lean.Theory` and `Lean4Lean.Verify` - proof libraries (`checks.proofs`), builds and runs a minimal downstream - consumer of the library artifact (`checks.downstream-consumer`), and - audits that the `sorry` tokens in the tree exactly match the known - frontier pinned in - [.github/scripts/check_sorry_frontier.pl](.github/scripts/check_sorry_frontier.pl) - (`checks.sorry-frontier`). + proof libraries plus the sorry audit + ([Lean4Lean/Audit/SorryFrontier.lean](Lean4Lean/Audit/SorryFrontier.lean), + which fails if any `Theory`/`Verify` declaration gains, loses, or renames + a `sorry` versus its exact allowlist) under `checks.proofs`, builds the + `Lean4Lean.Tests` regression modules (`checks.tests`), and builds and + runs a minimal downstream consumer of the library artifact + (`checks.downstream-consumer`). * `nix develop` provides a shell with the pinned `lean`/`lake` toolchain, and the checked-in [.envrc](.envrc) loads it automatically for [direnv](https://direnv.net/) users (run `direnv allow` once). diff --git a/divergences.md b/divergences.md index dbcfd9c6..01bf8222 100644 --- a/divergences.md +++ b/divergences.md @@ -6,7 +6,7 @@ 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`: Lean4lean uses the level operations from Lean's standard library. These currently differ from the C++ kernel implementation; [leanprover/lean4#14356](https://github.com/leanprover/lean4/pull/14356) tracks aligning them. The primed operations in [`Lean4Lean/Level.lean`](Lean4Lean/Level.lean) are an unused experimental decision procedure for level algebra. +* [`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. * [`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. diff --git a/plans/roadmap.md b/plans/roadmap.md index 113d6f5c..0692fcda 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -1,623 +1,16 @@ -# Lean4Lean completion roadmap, with Ix as the first external consumer - -**Status:** authoritative local roadmap, audited 2026-08-04 against the -committed fork, the current `jcb/induct` development branch, and ix's -formalization branch. - -**Overall assessment:** progressing, not stalled. The fork has a published, -green vertical slice through checked single-family generation, normalized -Verify replay, and a proof-carrying non-identity Theory transaction. The live -critical path has moved past `IndexedVec`'s executable outer producer: -the real one-parameter, one-index family and its ordered `nil`/`cons` -constructors now pass exact family validation, post-family constructor -validation, dependent candidate-list assembly, and the complete successful -`buildNormalizationCandidate` call. The published identity-replay bridge can -interpret syntactically identity-normalizing traces at caller-selected Theory -endpoints. The published semantic checkpoint uses that bridge to assemble the -complete `IndexedVec` semantic generation package, producer-selected -certificate, proof-erased Theory transaction, and checked E1 environment -replay. The executable list boundary is now reusable: dependent -`CandidateFamilyTypeListProduced`, `CandidateConstructorListProduced`, and -`CandidateFamilyListProduced` witnesses prove exact family-type, ordered -constructor, and complete-family traversal results at arbitrary list lengths. -AliasFormer and AnnotatedPi use the singleton instances, while `IndexedVec` is -the two-constructor regression. The outer singleton boundary is also reusable: -`GenerationCandidateSemanticRun.producedPackage` attaches an exact successful -whole-metadata equation to the same source- and candidate-indexed semantic -owner, and all three fixtures now use it instead of hand-assembling outer -records. -The retained semantic boundary is now reusable and automatically assembled. -`CandidateExprSemanticRootInput` lets the retained checker run select one -Theory view from a verified context and strict source translation. Dependent -constructor, family, and normalization inputs combine with the arbitrary-length -operational `Produced` witnesses to return a -`Nonempty ProducedNormalizationCandidateSemanticRun`; no caller supplies a -view, and no choice-based data extractor is added. Semantic generation owners -project every family and constructor spine from that same hierarchy, so -normalization, generation, packaging, and produced packaging cannot drift onto -parallel roots. AliasFormer, AnnotatedPi, and `IndexedVec` all use this path. -The `IndexedVec` regression additionally proves that the automatically -assembled hierarchy retains exact `nil`/`cons` source order and rejects a -swapped view at the computational normalization-shape gate. Exact compile-time -axiom guards cover the generic constructors and projections plus all three -fixture roots. The published analyzer-provenance checkpoint closes two more -structural gaps. `GenerationCandidateRun` now retains the exact equation that -the candidate normalization's dependent `generation?` analysis returned its -`GenerationChecked`; a successful analysis generically determines the retained -normalization. Post-family `VEnv.WF` is reconstructed from the verified -pre-family context, candidate raw/view definitional equality, checked family -typing, and exact raw-family insertion. AliasFormer, AnnotatedPi, and -`IndexedVec` consequently supply neither an independent `normalization_eq` nor -`typeEnv_wf`. The generation shape-alignment checkpoint closes the remaining -component-alignment gap. `GenerationCandidateSemanticShapeRun` accepts only -checked WF plus source-indexed family/constructor `storedSpine` and total -spine-length data. Exact dependent analysis determines the raw family, full -checked family view, normalized constructor pairs, and complete constructor -order; the total binder counts determine raw telescopes/results, while exact -checked shape determines view terminals. Its generic projection reconstructs -the established semantic generation owner without `zip`, truncation, -reordering, a caller-selected pair, or fixture component equations. -AliasFormer, AnnotatedPi, and the two-constructor `IndexedVec` regression now -use this reduced boundary. Together with the preceding structural-evidence -checkpoint, fixtures no longer supply `viewTel`, terminal typing, raw/result or -view-terminal equations, normalized pair identities, normalization equality, -post-family WF, or dependent-list alignment. The consolidated -generation-readiness checkpoint removes the remaining fixture-owned checked WF -and per-position generation-shape records. One source-indexed executable gate -checks the complete singleton family and constructor hierarchy, including -retained emitted Pi spines, full raw telescope lengths, and exact constructor -list cardinality; missing and extra raw constructors are rejected explicitly. -`ProducedGenerationShapeCandidate` retains both that successful gate and the -exact ordinary `buildNormalizationCandidate` equation. Exact dependent -analysis plus WF of the analyzer-owned view declaration then derives checked -WF and expands the one Boolean result into every dependent family/constructor -stored-spine/count record. AliasFormer, AnnotatedPi, and `IndexedVec` all use -this path. Bare producer success deliberately remains neither generation-shape -authority nor Theory semantics: WHNF can change the visible Pi spine, and the -ordinary producer checks neither `storedSpine` nor semantic WF. Complete -one-family parity (L4L-07) and the ix oracle handoff (L4L-11) remain beyond the -narrowed boundary. -Ix Pin A is complete against the -certificate-bearing -`5e5bb767b3491d21a71908d4c58bcbaa007283bb` checkpoint; it deliberately makes -no oracle claim. - -**Completed milestone: L4L-01A — staged semantic-input consolidation.** Source -checkpoint `7c7922091f94b4a4f51c6834b376de376be22e71` introduces one -source-indexed staged owner over verified pre-family/post-family candidate -contexts, strict source translations, exact insertion alignment, and the -existing family/constructor `Produced` traversals. AliasFormer, AnnotatedPi, -and `IndexedVec` use that owner, preserve exact constructor order, and no -longer define the repeated per-root semantic-input tower. The theorem returns -only `Nonempty ProducedNormalizationCandidateSemanticRun`; no view-WF, -generation-package, or choice-extraction claim was added. The explicit -downstream witnesses and analyzer-owned `viewWF` proofs remain visibly -temporary for L4L-01D/L4L-01E. - -**Completed milestone: L4L-01B — family-validation semantics and staging.** -Source checkpoint `da45b536220a3eff5ed78cf2f5afcf5e7491c40f` interprets the -exact singleton `checkInductiveTypes`/family-candidate execution from one -verified entry candidate context. It derives the analyzer-owned -parameter/index telescope, terminal-sort typing, raw-family constant WF through -semantic definitional equality, exact raw-family insertion, and the verified -post-family candidate stage. AliasFormer, AnnotatedPi, and `IndexedVec` no -longer supply independently verified post-family environments, contexts, or -fixture-specific post-family `VEnvs.WF` reconstructions. Exact axiom guards and -the universal Lake/Nix gates pass; constructors are not semantically -interpreted. - -**Completed milestone: L4L-01U — upstream v4.31 reconciliation.** -The source reconciliation is complete at -`7f864b459e4a6062b468d6e5416688feac0f9f99`: digama `upstream/master` -through `ef849dfbd94a` is a merge parent, Lean and lean4-nix are on v4.31, the -overlapping inductive/checker/Verify/level proofs build, and the fork's staged -family APIs remain intact. The merge removes four cached-`Expr` axioms and the -obsolete hand-declared `Expr.mkAppRangeAux.eq_def`, reducing the custom-axiom -inventory from 34 to 29. It adds two classified sorry-frontier entries: -`NormLevel.isEquiv_wf` (L4L-02B) and `addDecl.WF` (L4L-19B), taking the exact -frontier from 20 to 22 without increasing the supported-root trust budget. -All local Lean/Lake/Nix, exact-axiom, and sorry-frontier gates pass. An isolated -ix v4.31 probe replayed the merged Lean4Lean modules and built ix's runtime -typechecker modules; the remaining failures are ix-owned Lean/Batteries proof -API migrations. Because L4L-01U is not an ix pin, that consumer migration is -deferred and does not block this checkpoint. The source and this completion -ledger are published to origin `jcb/induct`; neither master nor the digama -remote moved. This was an integration-only checkpoint: it added no -constructor-trace work. - -**Active milestone: L4L-01C — retained constructor-validation trace.** Retain -the complete successful singleton `checkConstructors` -traversal as dependent, source-ordered operational evidence and prove exact -decomposition/recomposition while preserving phase-specific failures. This -checkpoint makes no Theory-WF claim; semantic interpretation remains L4L-01D. - -The former generic-package milestone was not independently closable: its -requested view-WF conclusion depends on a semantic interpretation of -`checkInductiveTypes` and `checkConstructors`, while those proofs were assigned -to later validation milestones. Section 13 now decomposes that boundary into -L4L-01A through L4L-01E: consolidate staged inputs; derive family-validation -semantics and the post-family verified stage; retain the complete constructor -validation trace; interpret that trace as analyzer-owned view WF; and only -then close and migrate the produced-package theorem. The mandatory L4L-01U -upstream-reconciliation checkpoint is interposed between L4L-01B and L4L-01C -because upstream moved at that boundary; it does not combine or reorder the -five semantic deliverables. No checkpoint may claim -the strengthened theorem from bare `buildNormalizationCandidate` success. -Checked WF, raw/view identities, telescope/result/view-terminal equations, -constructor-pair order, per-position shape records, dependent-list alignment, -normalization equality, post-family WF, view telescopes, and terminal typing -remain generic consequences and must not return as final package premises. Do -not use erasure equality, unchecked `zip`, whole-Pi injectivity, a -caller-selected view, or a normalization oracle. Ix Pin A is complete: -the local ix `jcb/ix-formalization2` snapshot -`1f73f5c016907eadb8ed0dc86ac65b07eb24a145` pins Lean4Lean -`5e5bb767b3491d21a71908d4c58bcbaa007283bb`, builds the complete `IxTcVerify` -target, and reconciles the exact sorry and root-axiom audits. The complete -post-L4L-01E order is defined only by §13; the track labels below are -work-package references, not competing milestones. The independent 22-entry metatheory, -checker, projection, and trust work remains release work rather than evidence -that the inductive producer track is stalled. - -**Baselines.** The current formalization source is the L4L-01U merge checkpoint -`7f864b459e4a6062b468d6e5416688feac0f9f99`, with parents -`da45b536220a3eff5ed78cf2f5afcf5e7491c40f` -(`feat: derive family validation staging`) and -`ef849dfbd94a` (`upstream/master`). This roadmap-only ledger child records that -immutable source hash without changing the formalization. The source follows -roadmap decomposition checkpoint -`f82ee77f7181`, generation-readiness source -`bbb45e0e950724cdbbd405d75e304e2020cecf82`, and its ledger child -`c4fd62b23a89500154b113d849d183afbf84907f`. -The earlier structural checkpoint derives exact checked family and -constructor shapes in Theory, types the inserted family constant once, derives -every checked constructor result target, recovers candidate view telescopes -from their exact terminals, and removes all fixture-supplied `viewTel` and -`rightType` fields. The analyzer-provenance checkpoint replaces fixture -normalization equalities with exact dependent analyzer-success equations, -derives the retained normalization in Theory, reconstructs post-family -environment WF in Verify, and removes all fixture-supplied `normalization_eq` -and `typeEnv_wf` fields. The generation-readiness checkpoint derives exact raw/check -family identity, normalized constructor pairing and order, raw -telescope/results, view terminals, and the complete dependent constructor list -from analysis plus minimal stored-spine/count shapes. That checkpoint -adds the complete executable hierarchy gate, retains it with exact ordinary -producer provenance, derives checked WF and every dependent shape record from -that one gate plus exact analysis and analyzer-owned view WF, and migrates all -three fixtures away from hand-built checked WF or per-position shape evidence. -It also pins missing- and extra-constructor rejection. Fixtures no longer name -normalized pairs or provide any component equation. The executable gate, -strengthened producer, and exact-success theorem have exactly the accepted -`propext`/`Classical.choice`/`Quot.sound` closure; semantic derivations inherit -only the already recorded checked-semantic closure. L4L-01A adds the staged -semantic-input owner and migrates all three positives without changing that -trust boundary or extracting its `Nonempty` result. L4L-01B interprets the -exact singleton family-validation run and derives the post-family stage from -the entry context, eliminating every independently verified post-family -fixture context while leaving constructor interpretation for L4L-01C/L4L-01D. -No new axiom or normalization oracle was added. On the v4.31 merge, the -154-job default Lake build, default Nix build, all six current-host flake -checks, all-system no-build flake evaluation, exact 22-entry sorry frontier, -29-declaration custom-axiom inventory, formatter, CLI replay, and whitespace -checks pass. Local `master` and -`origin/master` remain fixed at the prior candidate-context-provenance -checkpoint, `1fb7d6ef9042c5a80b2de9320c88ac0f3ce404cb`; only local -`jcb/induct` and `origin/jcb/induct` are published by this work. The live -digama `upstream/master` tip `ef849dfbd94a` is the merge's second parent and -was not modified by this branch. The published -development checkpoint contains a green Stage-3 -generalized one-family port, two checked-analysis slices, E1 environment alignment, and a -completed bounded I2 recursive-Pi slice, plus the first explicit -normalization/definitional-equality boundary, its paired checked-block -slice, complete mixed-artifact preservation, the identity-normalization -public artifact switch, and one traced normalized Theory transaction with -identity and non-identity preservation fixtures, a normalized Verify -transaction trace, six actual-metadata Verify replays, and the first verified -WHNF-to-Theory normalization-certificate producer instantiated on both alias -cases. The executable side now also has the first generic candidate-view -traversal: `AddInductive.normalizeCandidateExpr` runs the ordinary checker -full check and WHNF at every inspected node, descends through Pi domains and -bodies under the exact annotation-consumed local declarations used by the -kernel, and retains every full checker context/input/result in a positionally -indexed trace with exact check, WHNF, and binder-domain `isDefEq` run -equalities. Raw binder syntax is preserved. A structural certificate records -whether `outParam`, `semiOutParam`, `optParam`, or `autoParam` was peeled, and -its executable result is checked against Lean's actual -`Expr.consumeTypeAnnotations` before the body context is extended. -Because that helper is an opaque partial definition with no usable equation -theorem, `CandidateTypeAnnotations` deliberately does not claim a -propositional equality to it. The producer rejects a runtime disagreement as -an implementation-consistency failure; Verify derives semantic authority only -from the structural peeling trace and the exact successful raw-to-consumed -`isDefEq` execution. This separates a useful executable cross-check from the -proof boundary and avoids a new axiom, native evaluator, or opaque-function -equation. -`buildNormalizationCandidate` stages family -normalization before raw family insertion and constructor normalization in -the post-family environment. `CandidateWhnfStep.innerRun` recovers the -state-bearing recursive execution erased by `M.run`, and -`WhnfRun.ofCandidateStep` converts a step to the existing Verify certificate -once strict translations are supplied. Candidate families and constructors -also retain exact full `checkType` observations, with the parallel -`CheckTypeRun.ofCandidateStep` adapter. The AliasFormer family WHNF plus its -family and post-family constructor full checks now use these adapters. -The trace tree itself is now recursively context- and source-indexed, so a Pi -child cannot be forged for a different raw domain, instantiated body, local -context, or fresh binder identifier. -`CandidateNodeRun` pairs each retained full check with its retained WHNF in one -verified context. `CandidateNodeRun.exists_ofCandidate` now obtains the -checker-returned inferred-type and WHNF-result translations directly from the -two verified executions once the matching context and root source translation -are known. `CandidateExprRun` recursively interprets those pairs into -`DefEqEvidence`, including Pi congruence under the exact raw free-variable -context and explicit type transport when a checker-inferred type is merely -definitionally equal to the structural sort; `source_tr` and `view_tr` prove -that both semantic endpoints translate the context/source-indexed kernel -syntax. AliasFormer's actual terminal trace now feeds this interpreter and -supplies its normalization and generation evidence. The current development -checkpoint constructs the verified candidate root from `VEnvs.WF`, extends -its exact `VContext`/`MLCtx` positionally at every retained Pi binder, proves -fresh-name reservation for a newly initialized checker state, and recursively -certifies arbitrary annotated-domain traces. The root full-check refinement -selects the strict source translation automatically from only the syntactic -free-variable condition; Pi result decomposition supplies child translations -and raw binder typing. At every Pi, `IsDefEqRun.ofCandidateStep` refines the -retained raw-to-consumed equality run to Theory `IsDefEqU`; -`CandidateExprRun` transports the strict body translation, typing evidence, -reconstructed-view translation, and Pi congruence between the raw, -annotation-consumed, and normalized binder contexts. -AliasFormer's actual candidate exercises that automatic root path without any -fixture-supplied Theory expression. `CandidateExprRootRun` now binds each -root trace to explicitly translated raw and exact candidate-view endpoints. -`CandidateConstructorListRun` folds constructor evidence positionally without -`zip` or truncation, and `NormalizationCandidateRun` accepts only a singleton -source-indexed family list and singleton raw Theory declaration, constructs -the corresponding `Normalization`, and assembles its `NormalizationRun`. -AliasFormer's real family and post-family constructor traces now flow through -that generic list boundary; its resulting view computes to the existing -checked alias view, and a truncated constructor view is rejected by -`normalization?` before dependent analysis or transaction construction. -The candidate boundary now continues through complete generation -certification. `CandidateExprTrace.storedSpine` requires WHNF to preserve the -raw emitted Pi spine while still permitting normalization inside binder -domains and the terminal result; `spineLength` records its exact length. -`CandidateExprRun.spineEvidence` recursively extracts raw/view binder -equality and terminal-result evidence from the same context-indexed checker -runs. `TelResultDefEqEvidence` packages those two components, supports exact -prefix replacement without forall injectivity, and preserves the induced raw -contexts. `CandidateFamilyGenerationRun`, `CandidateNormalizedCtorRun`, and -the dependent `CandidateNormalizedCtorListRun` align the extracted components -with the successful dependent analysis and forbid constructor truncation, -reordering, or evidence reuse. `GenerationCandidateRun` then assembles the -existing `GenerationRun` and `GenerationChecked.WF` certificates. -AliasFormer's actual non-identity family and constructor candidate runs now -exercise this complete generic assembler; its existing checked -`AddInductTrace`, final transaction, WF, and alignment replay consume the -result rather than a parallel hand-filled generation witness. Candidate -output remains untrusted unless this exact source-indexed run, stored-spine -condition, dependent analysis, and semantic assembly all succeed. -`AnnotatedPi.mk : ((p : outParam Prop) → AnnotatedPi) → AnnotatedPi` now closes -the missing recursive-Pi-plus-annotation vertical slice. Its exact ordinary -checker traces cover family and constructor full checks, WHNF of the retained -`outParam Prop` domain, the complete lazy-delta `isDefEq` path to `Prop`, and -the recursively extended raw/consumed binder contexts. Those runs assemble a -nonempty nested-Pi `NormalizationCandidateRun`, -`GenerationCandidateRun`, and `GenerationChecked.WF`; the resulting checked -`AddInductTrace` replays the final environment, generated recursor, and iota -rule while preserving the raw annotated binder in emitted metadata. A staged -whole-candidate negative reuses that exact metadata with a correctly typed but -opaque `outParam`; it reaches candidate traversal and is rejected at the -raw-to-consumed binder equality boundary. - -The published certified-consumer slice adds the proof-carrying boundary -needed by ix without pretending that executable metadata production is already -fully certified. Theory's `GenerationCertificate source env` couples one exact -`GenerationChecked source` with its `GenerationChecked.WF env` proof, and -`VEnv.addInductCertified` erases the proof and computes through the existing -`addInductGeneration` transaction. Its trace, atomicity, and `Ordered` -preservation theorems stay wholly in Theory. Verify's dependent -`GenerationCandidatePackage` binds the exact kernel source, source-indexed -candidate, normalization run, dependent generation result, and -`GenerationCandidateRun`; `.certificate` is the only erasure into the Theory -API, while `.addInductTrace` forces metadata replay to use the generation and -WF proof owned by that package. AliasFormer and AnnotatedPi both exercise this -public non-identity path and retain exact axiom guards. The separate -`ProducedGenerationCandidatePackage` records the stronger outer equation that -`buildNormalizationCandidate` produced the packaged candidate. AliasFormer and -AnnotatedPi now inhabit this layer with exact successful whole-call equations -in their real pre-family and post-family environments, and both Theory -certificates and Verify metadata replays project from their produced packages. -General construction for an arbitrary successful metadata call remains open. -Arbitrary-length source-indexed operational list assembly and automatic -semantic-hierarchy assembly from verified per-position inputs are complete, so -the missing work is deriving those inputs plus structural generation alignment -and the terminal package from the outer success, followed by producer breadth; -another transaction API is not needed. -The next positive outer fixture is now complete. `AddInductive.hasIndOcc` is a -transparent structural traversal, so recursion and positivity branches reduce -in exact producer theorems without a new opaque-traversal contract. AnnotatedPi -has exact equations for singleton family validation, name freshness, -recursive-occurrence detection, raw-family declaration, constructor -validation, annotation consumption, nested-Π candidate traversal, dependent -candidate-list assembly, and the complete successful whole call. Its Theory -certificate and Verify replay now project from -`annotatedPiProducedGenerationCandidatePackage`. -`VInductDecl.checked?` returns a dependent, data-bearing `Checked` -descriptor. `stage3` and the public `VEnv.addInduct` compatibility entry point -still begin with raw-normal-form acceptance analysis. Verify's -`AddInductTrace`, however, now retains the exact `GenerationChecked decl` and -its `GenerationChecked.WF` certificate and proves the same -`VEnv.addInductGeneration` transaction used by explicit views; -`VDecl.WF.induct` records that normalized transaction in environment histories. -The public identity-path preservation proof constructs the canonical -`GenerationChecked.WF` bridge and delegates to it. The public `Checked` motive, minors, -recursor, and rules now delegate to its canonical identity -`GenerationChecked`, so artifact construction has one mixed implementation -even before the transaction accepts a non-identity normalization. The -descriptor records normalized parameter and -index telescopes, result level, elimination mode, generated names, constructor -fields, and recursive arguments including Pi-binder telescopes and terminal -index spines. Its environment-free analysis rejects loose metadata, duplicate -generated names, invalid universe annotations anywhere in family or -constructor metadata, self-reference in the family telescope, malformed -result heads/spines, parameter-count errors, and -declaration/type/constructor universe-count mismatches. `Checked.WF env` adds -the semantic telescope, recursive-target, field, and result-spine obligations -over the input environment, is equivalent to the legacy `VInductDecl.WF env` -when paired with the exact analyzer result, and is what `VEnv.addInduct_WF` -converts to the normalized generation certificate. Its non-recursive-field -universe obligation now states Lean's -impredicative Prop exception explicitly: `l = .zero ∨ u ≤ l`. - -The normalization audit ruled out the tempting assumption that translated -kernel metadata is already in the syntax expected by `checked?`. Lean retains -reducible aliases in real `InductiveType.type` and constructor types: -`AliasFormer` stores the alias `TypeFamilyAlias` instead of its sort WHNF, and -`AliasRec.mk` stores `RecAlias AliasRec` instead of the direct recursive -target. The fork now has a named `Normalization source` with a -shape-preserving analysis `view`, `Normalization.checked?`, and a semantic -`Normalization.WF env` contract. The contract relates the raw and view family -types before insertion and their constructor types after insertion of the raw -family constant. `NormalizedChecked source` now retains the singleton raw -family, the normalization, the dependent checked view, and the exact analyzer -equation in one value. Structural theorems recover source/view arities and -ordered family/constructor headers; identity normalization computes back to -the legacy analyzer. `GenerationChecked` adds an executable outer-telescope -layout certificate and ordered raw/checked constructor pairs. Its additive -mixed motive/minor/recursor/rule definitions emit raw parameter, index, and -constructor-field binders while consulting the checked view for recursive -arguments and result indices. Identity specialization reduces exactly for -Nat, Eq, `IndexedVec`, and `Acc`; both alias recursors and iota rules reduce -exactly to Lean's kernel metadata, including preservation of the raw -`RecAlias AliasRec` minor binder. `VEnv.TelDefEq` now states pointwise -raw/view binder equality in the context generated by the earlier raw binders, -and constructs the corresponding Theory context equality without using the -unfinished `forall`-injectivity theorem. The strengthened -`GenerationChecked.WF` is staged: it certifies the raw family telescope and -result before family insertion, then certifies both the exact stored -constructor telescope and the raw family/field telescope emitted by artifacts -after insertion. Generic lemmas prove the raw family and every paired raw -constructor insertion-ready from that certificate. `GenerationEnv` proves the -mixed motive, every paired minor, the complete minor telescope, the recursor -type and recursor constant, each rule component, every generated iota rule, -and the ordered full rule fold well formed. The minor/rule lists have exact -length and positional lookup facts, so no proof silently relies on `zip` -truncation. Exact guards pin the mixed transport, minor, recursor, rule, and -fold roots to subsets of `[propext, Classical.choice, Quot.sound]`. -`Checked.identityGeneration` constructs the canonical identity block from any -retained analyzer witness; generic theorems show that all four public artifacts -equal the legacy identity-normal forms, and Nat, Eq, `IndexedVec`, and `Acc` -check those equalities by reduction. Both alias examples still construct the -granular certificate explicitly and retain exact `[propext, Quot.sound]` -guards. `Checked.WF.identityGeneration` supplies the ordered semantic bridge -for the compatibility path. `AddInductSuccess` and `addInduct_WF` now project -from the normalized trace/preservation theorem rather than reconstructing the -legacy `Stage3Env` transaction. `AliasFormer` and `AliasRec` execute that core -directly: their final environments preserve exact raw family and constructor -payloads, contain the kernel recursor and every generated rule, grow their -inputs, and are `Ordered`, with exact axiom guards. - -Verify now has the first checked normalization producer rather than only -hand-written Theory equality witnesses. `TypeChecker.WhnfRun` packages an -exact `Inner.whnf'` execution, its well-formed checker state, and strict -translations of the input and result; the existing checker-refinement theorem -turns that execution into an ordinary Theory definitional equality. -`TypeChecker.CheckTypeRun` similarly packages an exact full -`Inner.inferType _ false` execution and identifies the verified existential -result with named strict translations; it exposes both `HasType` and -sort-valued `IsType` consequences, including the case where the inferred type -must itself be normalized by a `WhnfRun`. -`TypeChecker.DefEqEvidence` composes reflexivity, WHNF, application, beta, -transitivity, and forall congruence without adding a normalization oracle. -`TypeChecker.TelDefEqEvidence` extends that evidence pointwise through raw -binder contexts. `VInductDecl.NormalizedCtorRun` and `GenerationRun` assemble -the declared/emitted constructor paths, exact post-family insertion state, and -complete `GenerationChecked.WF`; their interpretation roots are exactly -guarded. -`VInductDecl.NormalizationRun` stages the family comparison in the input -environment and constructor comparisons in the exact environment obtained by -inserting the raw family, and `.wf` constructs `Normalization.WF`. The -actual-metadata `AliasFormer` fixture runs WHNF on `TypeFamilyAlias`; the -`AliasRec` fixture runs WHNF on `RecAlias.{1}` and composes application, beta, -transitivity, and outer-forall congruence. `AliasFormer` also executes -`inferType (.const ``TypeFamilyAlias []) false` to obtain its family-is-a-type -premise and executes a second full check on the actual `AliasFormer.mk` type in -the exact post-family environment. That constructor check returns the retained -`TypeFamilyAlias`; the verified WHNF certificate turns it into the required -sort. `AliasRec` now likewise executes a full check on the actual raw -`RecAlias AliasRec` field in the exact post-family environment; its field -certificate uses that checked typing premise and composes the verified -`RecAlias` WHNF, application, and beta steps. Neither checked normalization -proof now borrows typing from the older hand-built generation certificate. -Both fixtures instantiate the generic -`GenerationRun` assembler to obtain complete checked -`NormalizedChecked.WF` and `GenerationChecked.WF` roots and inject those roots -into dedicated data-bearing `AddInductTrace`/`TrEnv'` replays. Every -operational, semantic, block, generation, and checked-trace boundary has an -exact axiom guard. - -The remaining parity boundary is now generalization of the outer executable -producer, not the consumer transaction. `stage3` and `VEnv.addInduct` remain -the raw-normal-form compatibility path and therefore still reject the raw -alias declarations. -`VEnv.addInductCertified`, however, accepts any source-indexed Theory -generation certificate; its proof is erased, and generic trace/atomic/WF facts -show that it is exactly the normalized transaction already proved sound. -Verify packages candidate provenance, dependent analysis, semantic assembly, -and checked metadata replay without allowing an unrelated generation witness, -and AliasFormer, AnnotatedPi, and `IndexedVec` reach the public certified -transaction through packages selected by exact whole -`buildNormalizationCandidate` calls: family validation, raw-family -declaration, constructor validation, recursive candidate traversal, and -dependent candidate-list assembly all run in the same retained contexts. What -is not yet generic is deriving such a package from every arbitrary successful -metadata call. The executable family-type, ordered-constructor, and complete -family traversals now have arbitrary-length dependent `Produced` witnesses, -and all three fixtures delegate their list equations to those generic -theorems. `GenerationCandidateRun.producedPackage` also provides the generic -outer singleton constructor once the exact semantic run exists. -`CandidateExprSemanticRootInput` and the dependent semantic input hierarchy now -invoke that retained interpreter at every exact source position. Combined with -the operational list witnesses, `.exists_ofProduced` returns the complete -source-ordered semantic hierarchy under `Nonempty`. The corresponding semantic -generation owners project every family and constructor spine from the same -value, and all three fixtures route package construction through those -projections. What remains generic is deriving the structural generation -alignment and verified inputs from the successful dependent analyzer/outer -producer itself, then returning a complete produced generation package without -fixture-supplied equations. The opaque-`outParam` whole-candidate rejection and -the reordered-`IndexedVec` view rejection remain the negative gates. The -identity API stays as a compatibility wrapper until kernel parity and -downstream migration are green. - -The bounded recursive-Pi convergence slice is coherent and green. -`recTarget?`/`recArg?` recognize a family target below a strictly positive Pi -telescope; `minorTypeRec`, `recConstRec`, `ruleCall`, `ruleRec`, and `rulesRec` -generate functional induction hypotheses and lambda-wrapped recursive calls; -and the exact `Acc.rec` type and iota RHS reduce by `rfl` to those generalized -artifacts. The semantic proof chain now closes through normalization and -list-level application of every functional induction hypothesis, -`minorAppRec_hasType`, `recRuleAppRec_hasType`, `ruleRec_WF`, and the generated -rule fold in `addInduct_WF`. `Checked.minorTypes`, `Checked.recursor`, -`Checked.generatedRules`, `VEnv.addInduct`, and `AddInductSuccess` all select -the generalized artifacts. Public `Acc` checking, transaction consequences, -`Ordered` preservation, and actual-kernel-metadata E1 replay are green. This -closes the planned recursive-Pi widening, but not L4L-07: WHNF/definitional-equality -parity, full positivity, small elimination, K behavior, and the complete -one-family differential matrix remain. - -The complete checkpoint gate was rerun on 2026-08-02 over parent `d553930a` -plus the complete `IndexedVec` semantic replay, now published at `cf3d5a47`. -The 124-job -`lake build Lean4Lean.Theory Lean4Lean.Verify`, exact 20-entry sorry audit, -focused `IndexedVecSemanticReplay` build, default `nix build`, all-system no-build -evaluation, and current-host `nix flake check` are green. The host flake check -builds the proof library, sorry frontier, downstream consumer, and all three -CLI checks. The two public semantic-package/E1 roots have exact compile-time -axiom guards. Formatter, diff, and import-boundary gates also pass. - -Two successive checkpoints move the outer family validator beyond the former -zero-parameter/immediate-sort seam. Revision `9a865ea02d4326e60d0e5fd663d6efe79c735b1c` -adds a generic, source-indexed replay theorem for any singleton candidate -family spine, computing the exact parameter expressions, index count, -terminal local context, result universe, and emitted family constant selected -by `checkInductiveTypes`. Revision -`a62736281ea419d7d0ee13d76f0e0fd9a4d9d90f` instantiates that theorem on -Lean's real universe-polymorphic `IndexedVec` family (`α : Type u`, index -`Nat`, result `Type u`). It proves the actual full `checkType`, WHNF, binder -domain `isDefEq`, fresh-local, annotation, `buildCandidateExpr`, and complete -family-validation executions. The candidate computes with spine length two, -parameter vector containing the first fresh local, index-count vector `#[1]`, -result level `u + 1`, and family constant `IndexedVec.{u}`. The proof retains -the checker-produced `mkLevelIMax'` expression instead of assuming an opaque -reduction equation. No new axiom declaration, native evaluator, or -fixture-specific normalization principle was added. The next exact slice was -the post-family `IndexedVec.nil`/`IndexedVec.cons` constructor validation and -ordered dependent-list assembly; this historical checkpoint did not yet claim -a whole executable `IndexedVec` result. - -Revision `f0d80f8ba21e44a694566ea3d6469be85a809307` adds an early -`Expr.eqv` success path to `TypeChecker.Inner.isDefEq`. The verifier transports -the strict source translation across the existing expression-equivalence -lemma and derives the same `IsDefEqU` result, while the executable run returns -without consulting or mutating `EquivManager`. Existing exact-state fixtures -now assert that stronger behavior; the old reflexivity-specific manager -simulations were deleted. Non-reflexive comparisons still traverse -`isDefEqCore` and add a successful equivalence exactly as before. This is a -sound checker simplification, not a new axiom or normalization assumption, and -it is the reusable state-stability fact needed by exact `IndexedVec.nil` and -`IndexedVec.cons` application traces. - -Five later published checkpoints close that executable boundary. Revisions -`6732659058fe770e2b768ffaeb10d147ef1f466b` and -`c40a471dce8403d236284e3e10c85e7b84281a56` certify the exact `nil` and `cons` -constructor candidates in the post-family environment; -`c739d412302da94a962fb986ff0f380962692df3` stabilizes their candidate-context -provenance; and `82f4a54cf38d1ca510cdb05fcc1c4af4c5e3737a` proves that the complete -one-parameter, one-index, two-constructor request returns the exact retained -`IndexedVec` normalization candidate. Revision -`d553930affdb3690ad43fbf9acddf68d476fe260` adds the generic recursive -identity-normalization interpreter needed to keep caller-selected Theory -endpoints through those traces. Revision -`cf3d5a47d35867e0e6ebe023c0803982e3e36cd1` instantiates identity witnesses -for the family, `nil`, and `cons`, converts identity root runs into -generation-ready spine evidence, and uses `IndexedVecSemanticReplay` to -assemble the complete `GenerationCandidatePackage`, certified Theory -transaction, and checked E1 replay. Both public roots have exact guards and the -complete checkpoint gate passes. - -The exact CI evaluation command -`nix flake check --all-systems --no-build --accept-flake-config` is also green. -Its earlier `path '*-source' is not valid` failure was reproducible: the nested -`fileset.toSource` used for `leanSrc` could be demanded during evaluation -before that store path was realized. The flake now reuses the lazy -`inputs.self.outPath`, which restores app and check evaluation on all four -declared systems. The tradeoff is broader source invalidation, so restoring a -narrow *evaluation-safe* source filter remains packaging optimization debt. -The non-fatal `system` to `stdenv.hostPlatform.system` warning remains in the -pinned Nix dependency stack. Actual Linux and Darwin builds are still supplied -by their platform CI jobs; cross-system evaluation is no longer the blocker. -Descriptor invariants, semantic compatibility and normalization witnesses, -Theory and Verify transaction APIs, and the environment-WF roots retain exact -compile-time axiom-closure guards. - -The executable-candidate checkpoint at -`bc37d436dfd6f7d6fa1ae186c0951e48677b931f` passed the same complete local -gate on 2026-08-01. It proves AliasFormer's exact successful whole producer, -constructs `aliasFormerProducedGenerationCandidatePackage`, and routes both -the certified Theory transaction and checked Verify replay through it. Exact -guards at that pre-v4.31 checkpoint exposed the additional -`Expr.hasExprMVar_eq`, `Expr.hasLevelMVar_eq`, and `Expr.hasFVar_eq` cache -contracts reached while checking closed constructor constants; L4L-01U later -proves those properties and removes their axiom declarations. No native -evaluator or assumed normalization equation was added. Only `origin/jcb/induct` moved; -both master refs and every digama/upstream ref remain unchanged. -The core E1 Verify path is no longer -vacuous: typed witnesses align kernel `ConstMap` insertions with Theory -constants and rules, and the `TrEnv'` inductive case is live. The concrete -replay layer quotes Lean's actual Nat, Eq, index-changing `IndexedVec`, and -recursive-Pi `Acc` metadata plus the actual alias definitions and metadata for -`AliasFormer` and `AliasRec`. It drives all six complete -metadata-to-normalized-Theory transactions and proves that an older -value-bearing definition remains translatable through the Nat transaction. -Every quoted kernel rule RHS is pinned to the generated Theory rule by -definitional equality. The alias replays additionally pin raw source/view -separation, exact raw binders, final environment equality, WF, alignment, and -family/constructor/recursor lookup uniqueness. - -**Ix companion.** `~/projects/ix/plans/lean4lean-upstream-gaps.md` (the file -named `lean4lea-upstream-gaps.md` in the request has a one-character typo) is -the 2026-07-29 demand-side analysis. Keep its A1-A7 and P1-P4 identifiers for -cross-repo discussion. Its fork status and M0-M5 progress are now stale, so -this later audit wins on current state and sequencing; the companion remains -authoritative for the shape of ix's consumer obligations. - -**Versioning note.** `plans/roadmap.md` is intentionally unignored and tracked -so the sole status-bearing L4L ladder travels with each checkpoint. Other files -under `/plans` remain ignored. The root-level `upstream-divergence.md` remains -the tracked per-delta ledger; it complements this roadmap rather than replacing -its milestone state. - ---- +# 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. + +**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 +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 +file's git history and the checkpoint commit messages. ## 1. Mission and exact meaning of “complete” @@ -629,10 +22,10 @@ Lean4Lean has two products: 2. `Lean4Lean/Verify/`: a proof that the executable checker over `Lean.Expr` refines Theory. -Ix is the first demanding external consumer. Its `Ix/Tc/Verify/` development -translates content-addressed `KExpr` into the same Theory and proves the Ix.Tc -checker sound there. Success therefore means more than deleting the original -three inductive sorries. +External checkers translate their own expression representations into the +same Theory and prove their checkers sound there; lean4lean's job is to make +that possible from published Theory APIs alone. Success therefore means more +than deleting the original three inductive sorries. The supported formalization is complete when all of the following hold: @@ -648,7 +41,7 @@ The supported formalization is complete when all of the following hold: - **No semantic placeholders:** `Verify.Environment.AddInduct` is inhabited and useful, `TrProj` has a justified semantics, and every currently empty or impossible verification path corresponds to a real checker execution. -- **Checker refinement:** the six remaining Level/TypeChecker proof roots are +- **Checker refinement:** the remaining Level/TypeChecker proof roots are proved, including recursor reduction, projection inference/reduction, structure eta, and unit-like comparison. - **Trust is explicit:** all final roots have an audited `#print axioms` @@ -656,777 +49,385 @@ The supported formalization is complete when all of the following hold: reachable. Any unavoidable runtime contracts (for example pointer equality or opaque C++ implementations) are narrowly stated, tested, documented, and separated from the mathematical Theory. -- **Ix is enabled:** ix pins a published revision, imports only - `Lean4Lean.Theory.*`, constructs `InductiveOracle` from checked blocks, - obtains a concrete `TrProjOK`, derives literal well-formedness from its - prelude contract, and removes the corresponding upstream sorry origins from - its executable audit manifests. `NativeOracle` remains an explicit ix trust - boundary by design, not a lean4lean proof hole. +- **Consumers are enabled:** a downstream checker can, from published + `Lean4Lean.Theory.*` APIs alone, construct inductive block certificates with + their lookup/pattern consequences, obtain a concrete projection-laws + package, and derive literal well-formedness from a prelude contract. + Consumer-side trusted oracles remain consumer trust boundaries by design, + not lean4lean proof holes. - **Upstreamability:** the fork delta is split into reviewable PRs, every - deliberate divergence is tracked, and both repositories build at each pin - boundary. + deliberate divergence is tracked, and both the fork and upstream build at + each release boundary. This definition deliberately separates **proof-complete** (no sorries or fake relations) from **trust-minimal** (no unnecessary custom axioms). Both are required for the final release; they can be reached in separate milestones. -## 2. Audited current state - -### 2.1 What has landed on the green baseline - -The old gap plan started at `0c38ab8`, where `VInductDecl.WF`, -`VEnv.addInduct`, and `VEnv.addInduct_WF` were all sorries. That is no longer -the fork's state. - -- The sorry-frontier audit and Nix CI are tracked. The audit currently accepts - exactly 22 live sorries and excludes `Experimental/`; the two v4.31 additions - are classified under L4L-02B and L4L-19B. The exact CI all-system evaluation - command is green on the L4L-01U source; - the remaining `system` deprecation warning comes from the pinned Nix stack - and is non-fatal. -- Stage 1 introduced real computational recursor/iota generation for a single, - parameter-free, non-indexed type and proved `addInduct_WF`. -- Stage 2, at `efb2a2b2`, supports any number of parameters for one - non-indexed type with direct recursive fields in a syntactically never-zero - sort. `addInduct_WF` is sorry-free for that class. -- Nat, Bool, List, Prod, and Option fixtures compare generated recursor types - and rules definitionally with the actual kernel declarations. -- The current Stage-3 development branch extends that proof to one generalized - family, including subsingleton large elimination, indexed recursive calls, - constructor-result spines, and recursive targets below Pi telescopes. Eq, - HEq, `IndexedVec`, and `Acc` compare generated recursors and/or iota rules - definitionally with Lean's kernel declarations. -- The fork also contains the `0c38ab8` kernel soundness fix and the Nix - downstream-consumer artifact work. Ix Pin A now pins the certificate-bearing - fork revision `5e5bb767` instead of upstream `8865b155`; its complete - `IxTcVerify` target and exact trust audits consume the proved normalized - generation/certificate boundary and remove the three former inductive - `sorryAx` origins. - -### 2.2 Green Stage-3/I1/E1, recursive Pi, and mixed-preservation frontier - -The Stage-3/I1 and current I2 implementation spans `Theory/Inductive.lean`, -`Theory/InductiveFixtures.lean`, `Theory/Typing/InductiveLemmas.lean`, and a -small generic environment extension in `Theory/Typing/Lemmas.lean`. E1 also -changes `Verify/Typing/Lemmas.lean`, `Verify/Environment/Basic.lean`, and -`Verify/Environment/Lemmas.lean`, and adds -`Verify/Environment/InductiveFixtures.lean`; the sorry-frontier wording is -updated. Relative to current common ancestor `8865b155`, source checkpoint -`da45b536` changes 33 files with 45,662 insertions and 66 deletions. Its direct -tree diff against the now-diverged `upstream/master` changes 68 files with -46,136 insertions and 1,097 deletions. Use per-checkpoint diffs, rather than -either accumulated total, for review sizing. - -The development branch contains: - -- parameter-and-index spines (`SpineWF`, `recPairs`, indexed motives and - minors); -- a single-family Stage-3 guard with a syntactic subsingleton/large-elimination - test; -- a dependent `VInductDecl.Checked` result and `checked?` analyzer. The public - Stage-3 Boolean is now descriptor existence rather than an independent pass; - public `addInduct` and its success/WF proofs unwrap the same checked value and - specialize it to identity normalization. Verify's `AddInductTrace` has moved - to the more general exact `GenerationChecked decl` plus - `GenerationChecked.WF` certificate; -- an explicit `Normalization source` boundary separating raw stored metadata - from the view inspected by the analyzer. `normalizationShape` fixes universe - arity, parameter count, family/constructor identities, order, and counts - while allowing expression payloads to change. `Normalization.WF env` requires - family-type defeq in the input environment and pairwise constructor-type - defeq after the raw family constant is inserted. This semantic staging is - intentionally one-family; I3 must generalize it to insertion of every family - constant in a mutual block; -- a dependent `NormalizedChecked source` boundary value built by - `Normalization.check?`, `normalizedChecked?`, or the identity compatibility - analyzer. It retains `sourceType` and its singleton equation alongside the - normalization, the exact `norm.view.Checked`, and the analyzer equation that - produced it. `Normalization.shape` exposes source/view universe arity, - parameter count, and ordered family/constructor header agreement; - `NormalizedChecked.source_anatomy` specializes that agreement to the raw - singleton family and checked singleton view. Identity normalization has a - computational Nat fixture and an `isSome` compatibility theorem. - `Checked.analyzer_eq`, `identityBlock`, and `identityGeneration` now package - any retained identity analyzer witness without re-running or choosing a - second result. The legacy `addInduct` transaction remains an identity-only - compatibility wrapper, but its semantic bridge and preservation proof now - run through this boundary and the live `Checked` artifact accessors have - moved here. The additive `GenerationCertificate`/`addInductCertified` API - accepts a semantically certified non-identity generation without exposing - Verify state or changing that compatibility behavior; -- a `GenerationChecked source` layout gate and mixed artifact layer. - `generationShape` checks raw parameter/index arity, constructor coverage, - header agreement, raw constructor parameter count, and raw/view field-count - alignment. `GenerationChecked.shape`, `rawCtors_eq`, and `viewCtors_eq` - expose those facts without downstream zipping or truncation. Mixed - parameters, indices, motives, minors, recursors, and rules retain raw binder - syntax and use only retained view descriptors for recursive classification - and result indices; no mixed helper re-runs `recArg?` on raw metadata. - Identity fixtures for Nat, Eq, `IndexedVec`, and `Acc` reduce to the existing - artifacts. Both alias cases reduce to the actual kernel recursor and rule; - the `AliasRec` fixture separately pins the raw alias as the emitted minor - binder. `VEnv.TelDefEq` records binder-by-binder raw/view equality under the - preceding raw binders and exposes raw-telescope well-formedness, universe - instantiation, and an `IsDefEqCtx` bridge. `GenerationChecked.WF` now carries - the pre-family family telescope/result and, after exact raw family insertion, - both the constructor's stored raw telescope/result and the raw - family/field telescope/result emitted in mixed artifacts. The two paths are - intentionally separate so definitionally equal constructor parameters need - not be syntactically identical. Generic guarded lemmas derive raw family and - constructor `IsType` facts from this granular contract without `forall` - injectivity. Both alias fixtures construct it at the standard Theory - closure. The mixed preservation layer now proves the motive, exact raw - constructor application under the mixed telescope, every individual minor, - the complete constructor-aligned minor telescope, the recursor type and - constant, every rule application and rule, and the complete ordered rule - fold well formed. Supporting length/lookup lemmas preserve constructor - position, and `familyApp_transport` supplies the common - insertion/weakening step. Exact compile-time guards cover every stabilized - mixed root. The public `Checked` motive/minor/recursor/rule accessors are - identity specializations of this implementation; generic compatibility - theorems recover the old identity forms, and Nat/Eq/`IndexedVec`/`Acc` - compare all four accessors by `rfl`. The additive artifact refactor is - closed. A single `VEnv.addInductGeneration` transaction now inserts the raw - family and constructors and the mixed recursor/rules; its data-bearing - `AddInductGenerationTrace` is exposed axiom-minimally through `Nonempty`, - with freshness, lookup, membership, monotonicity, atomicity, and normalized - `Ordered` preservation theorems. The raw public `addInduct` entry point is - an exact identity-normalization wrapper around that core. The proof-carrying - public `addInductCertified` entry point is an equally exact wrapper around - the same core: its certificate owns `generation` and `generation.WF env`, - but only `generation` affects computation. Generic trace, atomicity, and WF - theorems give ix a Theory-only non-identity consumer boundary. - `Checked.WF.identityGeneration` now constructs its semantic certificate - through a post-family invariant, and the legacy public success/WF - certificates delegate to the normalized trace and preservation theorem. - The redundant `Stage3Env` transaction proof has been removed; -- actual-metadata alias fixtures proving that normalization is necessary, not - hypothetical. `AliasFormer` retains a reducible alias at the family result - and `AliasRec.mk` retains one around a recursive field. Their raw declarations - fail `checked?`, their explicit views compute to accepted descriptors, and - their `Normalization.WF` proofs derive the required delta/application/beta - equalities in Theory. Exact guards pin both roots to `propext` and - `Quot.sound`. Each fixture now also constructs a `NormalizedChecked` block - and proves its combined `NormalizedChecked.WF` certificate at the same exact - axiom closure. The normalized transaction is now live and preserves raw - constants and kernel-shaped generated binders while pairing them - constructor-by-constructor with normalized analysis facts. Direct - `AliasFormer`/`AliasRec` transactions now pin exact raw payloads, kernel - recursors and iota rules, all lookup/membership consequences, monotonicity, - and final `Ordered`, while their raw `checked? = none` regressions remain. - Verify ingestion and actual-metadata replay are now complete for both aliases: - the trace consumes the same certified generation as Theory, preserves the - actual raw `ConstantInfo` payloads, and proves final equality, WF, alignment, - and lookup uniqueness. The public identity wrapper still rejects their raw - declarations, as intended. The checked producer now derives each fixed - fixture's normalization equality from an exact verified WHNF run and - compositional defeq evidence. A generic `CheckTypeRun` derives named Theory - typing consequences from exact full-check executions; `AliasFormer` uses it - for both the raw family and actual constructor premises, with the latter - staged after family insertion, while `AliasRec` uses it for the actual raw - recursive field in that same exact post-family state. Both aliases now - assemble complete checked block - and `GenerationChecked.WF` roots through the generic - `TelDefEqEvidence`/`NormalizedCtorRun`/`GenerationRun` layer, without - bootstrapping from the older hand-built generation-WF proofs. Dedicated - checked traces carry those certificates through `TrEnv'` to final - WF/alignment. `AddInductive.normalizeCandidateExpr` now supplies the first - generic executable metadata-to-candidate traversal: it uses the checker's - configured full check, WHNF, and inductive fuel; recursively exposes Pi - domains while checking bodies under structurally certified - annotation-consumed local declarations; preserves raw metadata headers; and - retains exact full-check, WHNF, and binder-equality runs at every applicable - position. - `buildNormalizationCandidate` repeats the existing family/constructor - validity checks, normalizes families in the input environment, inserts the - raw families, and only then normalizes constructor payloads. An exact - `AliasFormer` leaf regression pins this traversal to the already verified - checker WHNF run and guards its operational axiom closure. - `CandidateWhnfStep.innerRun`/`WhnfRun.ofCandidateStep` and the parallel - full-check adapters now bridge stored `M.run` equalities to state-bearing - Verify certificates once translations are provided. Every family, - constructor, Pi domain, and instantiated body retains its full check in the - exact pre-/post-family and raw-local context; the AliasFormer semantic WHNF, - family check, and constructor check all use this route. Matching verified - contexts and translations are now constructed recursively for every retained - position, and generic spine/result extraction plus dependent constructor-list - assembly produce `GenerationChecked.WF`. `GenerationCandidatePackage` - retains those exact dependent indices, erases to a Theory - `GenerationCertificate`, and builds a checked `AddInductTrace` whose - generation cannot be unrelated to the package. AliasFormer and AnnotatedPi - both run through `addInductCertified`, prove exact successful whole - `buildNormalizationCandidate` equations, inhabit the stronger - `ProducedGenerationCandidatePackage`, and route their Theory and Verify - consumers through those values. `IndexedVec` now supplies the next exact - executable result: its parameter/index family and ordered two-constructor - list reduce through the complete outer producer to the retained candidate. - The published `cf3d5a47` checkpoint carries that exact value through semantic - generation/package assembly and E1 replay. What remains is generalization - beyond the three fixture-specific successful calls; -- normalized descriptor data for parameters, indices, result universe, - elimination mode, generated names, constructors, and recursive arguments. - `RecArg` now records a possibly nonempty Pi-binder telescope, field position, - terminal index spine, and the target-family slot reserved for I3. The current - one-family analyzer populates the binder telescope and still fixes - `targetType = 0`; -- exact closed-metadata, complete universe-annotation range, family-telescope - self-reference, direct result-shape, and internal generated-name `Nodup` - checks. Their proof API includes `Checked.analysis_accepted`, - `type_closed`/`ctor_closed`, `type_levelWF`/`ctor_levelWF`, `names_nodup`, and - `direct_anatomy`, so consumers do not unfold the analyzer. Environment-relative - name freshness remains correctly enforced by the transactional `addConst` - chain and exposed by `AddInductSuccess`; -- an environment-indexed `Checked.WF env` contract over the normalized - parameter/index telescope and each constructor's field/result spine, with - `Checked.wf_of_decl`, `Checked.to_declWF`, and - `VInductDecl.wf_iff_exists_checked` proving exact compatibility with the - legacy declaration-level `WF`. The preservation theorem now obtains its - semantic premises through this descriptor contract rather than destructing - the raw declaration relation. Its field-universe condition explicitly - models Lean's impredicative Prop exception (`l = .zero ∨ u ≤ l`), which is - required by `Acc : Prop` while preserving the bound for non-Prop families; -- computed positive descriptor-shape fixtures for Nat, Eq, and `IndexedVec`, and - a computed negative matrix covering duplicate/internal generated-name - aliases, loose variables, self-reference in parameter domains, invalid - universe annotations in family and constructor fields, non-sort family - results, wrong constructor heads and parameter spines, excessive `nparams`, - family/constructor universe-count mismatches, illegal recursive-Pi domains, - changed recursive-target parameters, family occurrences in recursive target - indices, and pre-existing type, constructor, and recursor names. The three - recursive-Pi cases have exact kernel `#guard_msgs` comparisons, and every - case is rejected before any partial environment is observable; -- public generalized recursor and iota generation for direct indexed recursion - and recursive arguments below Pi telescopes: functional minor IHs, - generalized recursor types, lambda-valued recursive calls, and generalized - iota rules. Exact computational fixtures match `Acc.rec` and its rule after - universe permutation. The older direct definitions remain only as - specialization/reference code; no public `Checked` accessor or transaction - selects them; -- a closed generalized semantic chain through recursive-target transport, - `minorTypeRec`/`recTypeRec` well-formedness, recursor application, rule - binders/type, recursive-call normalization, list-level application of all - functional IHs, `minorAppRec_hasType`, `recRuleAppRec_hasType`, - `ruleRec_WF`, and the generalized generated-rule fold in `addInduct_WF`; -- Eq, HEq, and index-changing `IndexedVec` kernel-equality fixtures; -- a complete indexed environment invariant, recursor typing proof, constructor - fold, indexed iota LHS/RHS proofs, rule well-formedness proof, and final - `addInduct_WF`; -- `#guard_msgs` axiom checks proving that the checked-analysis and semantic - compatibility roots depend only on `propext` and `Quot.sound`, while the - recursive-Pi typing/preservation roots and `VEnv.addInduct_WF` depend only - on those plus `Classical.choice`; -- an `AddInductSuccess` transaction certificate plus `addInduct_le`, freshness, - type/constructor/recursor lookup, generated-rule membership, atomicity, and - early-rejection theorems for downstream consumers. The certificate now also - retains the exact `checked? = some checked` result, so ix-facing consumers - need not re-run analysis after a successful transaction; -- `AddInductConstant`, `AddInductConstants`, and `AddDefEqs` witnesses in - Verify, with fold realization, lookup, freshness, monotonicity, map-WF, and - value-preservation lemmas; -- a real `AddInduct` transaction aligning `inductInfo`, ordered `ctorInfo`s, - `recInfo`, and generated iota rules; real proofs of - `AddInduct.to_addInduct`, `AddInduct.le`, and `Aligned.addInduct`; and a live - `TrEnv'.of_value` inductive case; -- compile-time axiom-closure guards for the new Verify bridge roots. They - intentionally expose the inherited `TrProj` `sorryAx` until Track P closes - it; they do not bless it as a release axiom; -- `TrTypeExpr`, a representation-only metadata-type translation whose - `to_trExprS` theorem recovers application and pi typing premises from the - declaration's real Theory well-formedness proof; -- a replay-driven Nat fixture that quotes the actual `inductInfo`, both - `ctorInfo`s, and `recInfo` from Lean, translates them in the exact - intermediate environments, constructs `AddInduct`, executes - `TrEnv'.induct`, and checks final `WF`, alignment, and recursor lookup - uniqueness; -- an actual-metadata Eq replay with the same transaction, final-WF, - alignment, and lookup-uniqueness checks. This additionally exercises a real - index, Prop-valued elimination, and the kernel/generated recursor universe - permutation; -- an actual-metadata `IndexedVec` replay layered over the completed Nat - transaction. It exercises two constructors, a recursive field, a changing - result index, final replay equality/WF/alignment, and uniqueness of the - translated type, constructor, and recursor lookups. The source fixture uses - explicit `Nat.zero`/`Nat.succ`, so this tests the semantic dependency while - deliberately excluding notation's unrelated `OfNat`/`HAdd` instance - closure; -- an actual-metadata `Acc` replay that checks kernel constructor/recursor - counts, parameters, indices, recursive fields, rule constructor and field - count, translates each metadata declaration in its exact intermediate - environment, constructs `AddInduct`, executes `TrEnv'.induct`, and proves - final equality, WF, alignment, and lookup uniqueness. Its quoted kernel - `RecursorRule.rhs` is definitionally equal to the generalized Theory RHS, - including the lambda under the recursive Pi and the kernel universe order; -- actual-metadata `AliasFormer` and `AliasRec` replays, including the real - `DefinitionVal` prefixes for `TypeFamilyAlias` and `RecAlias`. They retain - the raw alias-bearing family/constructor payloads, translate the actual - `inductInfo`, `ctorInfo`, `recInfo`, and kernel rules in exact intermediate - environments, execute the normalized transaction, and prove final equality, - WF, alignment, and family/constructor/recursor lookup uniqueness. The - recursive-field case separately pins the raw alias-bearing minor binder; -- a candidate-produced `AnnotatedPi` replay whose actual constructor shape - combines a recursive target below a Pi with retained `outParam Prop` syntax. - It builds the complete normalization/generation certificate from exact - checker traces, executes the checked transaction, and pins the generated - recursor, iota membership/RHS, lookup uniqueness, WF, and alignment; -- explicit definitional equalities for every quoted kernel rule RHS in all six - actual-metadata replays plus the AnnotatedPi generated iota rule, rather than - only the previously highlighted `Acc` rule; -- a real dependency-free definition replayed before Nat, followed by a - concrete `TrEnv'.of_value` theorem whose proof must traverse the outer - inductive transaction and pull the old lookup through every metadata - insertion; -- a complete post-Verify-migration Lean gate on 2026-08-01: the exact 20-entry - sorry audit, `lake build Lean4Lean.Theory Lean4Lean.Verify`, formatter check, - and `git diff --check` pass; the normal current-host `nix build` also passes. - The current-host full flake check and exact all-system no-build evaluation - also pass at `5e5bb767`; representative Linux/Darwin builds remain CI jobs. - -Stage 3 remains intentionally narrow: it accepts only one type and only large -eliminators. Its structural field check recognizes direct recursion and -recursive targets beneath family-free Pi domains, and its public checked -artifact path now uses that generalized representation throughout. Its -closure and internal-name checks, metadata-wide universe-range checks, and -normalized semantic contracts are real kernel-facing checks. The explicit - normalization boundary now demonstrates how raw syntax can be related to a - checked view. Verify can replay an explicitly certified normalized generation - and now derives the two fixed alias normalization certificates plus the - recursive AnnotatedPi annotation certificate from exact ordinary-checker - executions. AliasFormer, AnnotatedPi, and `IndexedVec` have complete checked - dependent generation certificates, exact whole-call produced packages, and - use the public proof-carrying non-identity transaction; the third case - exercises a parameter, an index, and an ordered two-constructor list, and - the identity compatibility path still peels the raw syntax. No generic outer - producer yet constructs the semantic package directly from an arbitrary - successful whole metadata call. AnnotatedPi closes the nested-Π and - annotation-consumption fixture through exact constructor validation, - candidate-list assembly, and the final produced-package equation. - Constructor-parameter agreement is still - syntactic where the kernel uses definitional equality. It also lacks full - positivity, small-elimination, and K analyses. The -negative Or fixture demonstrates that small elimination is not modeled yet. -Further alias shapes, non-defeq normalization negatives, nested negativity, -mutual blocks, nested inductives, notation-heavy prelude replay, and the full -inductive environment fixture matrix remain future work. A successful default -`nix build` alone is not a release gate. - -### 2.3 Live debt outside inductive breadth - -The sorry-frontier script currently reports exactly: +## 2. Current state + +| 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 | + +### 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 +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. + +### 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: | 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/Level.lean` x2; `Verify/Environment.lean` x1; `InferType.lean` x1; `WHNF.lean` x2; `IsDefEq.lean` x2 | - -There is important non-sorry debt too: - -- The empty Verify `AddInduct` relation and both vacuous `nomatch` proofs have - been removed. Nat, Eq, `IndexedVec`, and `Acc` now supply actual-metadata - witnesses, lookup-uniqueness, `TrEnv'.wf`, and alignment tests; `Acc` also - checks the actual lambda-under-Pi rule RHS, and Nat has a pre-existing-value - preservation regression. E1 is not fully closed until the remaining I2-I4 - fixture matrix is replayed. -- The public inductive spec is a growing subset, not kernel-complete. -- `VLocalDecl` core facts, literal encodings, `ContainsLits`, - `HasPrimitives`, and `TrProj` are implementation-independent but live under - `Verify/`, forcing ix to import that layer. -- There are 29 project-specific `axiom` declarations outside - `Experimental/`: 27 in `Verify/Axioms.lean` and two pointer-equality - contracts in `PtrEq.lean`. Three cached-field equations remain from the - group known false on the older Lean pin (`lean4#8554`). Lean v4.31 repairs - the underlying cache behavior, but these equations are still unproved and - therefore remain forbidden implementation contracts. Count, classification, - and per-root reachability—not just sorry count—are release criteria. -- The fetched `logrel@upstream` branch at `e431dad8` contains a serious - experimental route to injectivity/unique typing, but the live - `Theory/Typing/Injectivity.lean` still has all three sorries. The branch's - route depends on unfinished `ShapeLogRel`/adequacy work and cannot simply be - merged as a completed proof. - -#### Current custom-axiom inventory - -This classification records the intended release treatment; it is not itself -evidence that an implementation equation is true. In particular, the ten -collection/opaque-layout equations still require validation and may move into -the forbidden class if a counterexample is found. +| 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 + `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 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 + pinned Nix stack and is non-fatal. +- The generated transitive axiom-closure report for all supported roots does + not exist yet (L4L-20A); the reachability audit is partially established, + not release-clean. + +## 3. Trust policy + +**Decision.** The axiom set of the current inductive **Theory** roots is +reasonable: only the standard logical baseline `propext`, +`Classical.choice`, `Quot.sound` (often a strict subset) and no axiom about +Lean's implementation behavior or representation. The axiom set of the +end-to-end **Verify** roots is not release-acceptable: their `sorryAx` and +collection/opaque implementation contracts are diagnostics while proofs +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 +intended release treatment, not evidence the equations are true): | Class | Count | Declarations | Release treatment | |---|---:|---|---| -| Unproved cached-field equations, known 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 | +| 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 | -| 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 and bounds actually needed, or reject | +| 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 | -**L4L-01U axiom/sorry result.** Relative to source checkpoint `da45b536`, -upstream commit `3dc52e0` proves and removes the four cached-`Expr` axioms -`hasFVar_eq`, `hasExprMVar_eq`, `hasLevelMVar_eq`, and `hasLevelParam_eq`; -`66172a2` removes the hand-declared `Expr.mkAppRangeAux.eq_def` because Lean -v4.31 generates its defining equation. The exact custom-axiom inventory is -therefore 29, down five from 34. `Level.hasParam_eq`, `Level.hasMVar_eq`, and -`Expr.looseBVarRange_eq` remain unproved; although v4.31 fixes the cached-data -bug, they remain forbidden implementation contracts and are not logical -foundations. The exact sorry frontier is 22, up two from 20: upstream adds -`NormLevel.isEquiv_wf`, mapped to L4L-02B, and the front-end theorem -`Lean4Lean.addDecl.WF`, mapped to L4L-19B. Exact guards confirm that the five -retired declarations disappeared. Existing `Expr.mkData_eq` and -`Expr.mkAppData_eq` become visible in several v4.31 Verify closures because the -new cached-field implementation routes through those already-inventoried -layout contracts; no new axiom declaration or supported-root trust category -was added. Raw count changes are acceptable only with this declaration-level -and per-root classification. - -The current reachability audit is **partially established**, not release-clean: - -- the Stage-3 proof builds; executable `#print axioms` guards pin the descriptor - analysis, closure/level/name/anatomy facts, semantic `Checked.WF` compatibility - bridges, the generic normalization-shape/source-anatomy projections, the two - concrete `Normalization.WF` witnesses and their combined paired-block - certificates, - transaction/collision facts, and `VEnv.addInduct_success` to - `propext`/`Quot.sound`, and `VEnv.addInduct_WF` to those plus - `Classical.choice`. Identity checked-block compatibility and the semantic - `Checked.WF.identityGeneration` bridge are separately pinned to the same - three-axiom Theory upper bound; their proof components reach Lean's lawful - Boolean-equality/weakening facts, while the analyzer and shape tests remain - executable definitions rather than postulated oracles. The six recursive-Pi - preservation roots are separately pinned to the same three-axiom Theory - baseline. The normalized transaction trace, atomicity, monotonicity, lookup, - and rule-membership roots are pinned to exactly `propext` and `Quot.sound`; - normalized transaction preservation, the identity-wrapper computation - theorem, and final ordered alias environments additionally reach only - `Classical.choice`. Each alias trace, raw lookup, kernel recursor lookup, and - iota-membership fixture remains at the smaller two-axiom closure; -- `Theory/` currently declares no custom axioms and imports neither - `Verify/Axioms` nor `PtrEq`, which is the required architectural boundary; -- the full generated closure report for the remaining Theory endpoints, - Verify checker roots, and ix-imported theorem set does not yet exist; -- the new E1 bridge roots have checked closures, but they inherit `sorryAx` - through the type dependency `TrConstVal → TrExprS → TrProj`; this is Track - P's projection-specification hole, not a new E1 axiom declaration; -- the five L4L-01U-retired names are absent from the source and exact guards; - their former textual uses have kernel proofs or generated v4.31 equations; -- all three remaining cached-field equations are simp lemmas and can enter a - proof without a textual reference to their names, so their absence must be - established by exact root guards rather than source search. - -Consequently, source import/name searches are useful diagnostics but are not -the release audit. Only the generated transitive axiom closure of each named -root is authoritative. - -#### Current root-level axiom snapshot - -The exact current closures below answer two different questions. The Theory -set is reasonable for this formalization: it is Lean's usual logical baseline -and contains no project-specific bridge axiom. The Verify set is reasonable -only as an explicitly guarded *transitional diagnosis*; `sorryAx` is not an -acceptable release dependency. - -The acceptance decision is deliberately stricter than “Lean compiled it”: - -- `propext`, `Classical.choice`, and `Quot.sound` are the permitted standard - logical baseline. `propext` supports equality of extensionally equivalent - propositions, choice permits classical witness selection in proofs, and - `Quot.sound` is Lean's quotient identification principle. A root may use only - the subset it actually reaches; -- no project-specific axiom is authorized for `VInductDecl.Checked`, inductive - generation/preservation, the future E2 oracle-construction theorem, or any - other Theory API exported to ix. A perceived need for one is a specification - or proof-design blocker, not a reason to extend the allowlist; -- `sorryAx` and the persistent-map contracts in the Verify rows are recorded so - their removal can be tested. They are not part of the accepted release set; -- the three cached-field equations known false on older toolchains remain - forbidden until proved for v4.31, even though the implementation bug is - fixed. Reachability, rather than declaration presence alone, is the release - criterion. - -| Root | Current transitive closure | Assessment / removal path | -|---|---|---| -| `Checked.analysis_accepted`, `names_nodup`, `type_closed`, `ctor_closed`, `type_levelWF`, `ctor_levelWF`, `direct_anatomy` | `propext`, `Quot.sound` | Accepted logical baseline; every exported structural-analysis fact is compile-time guarded. `checked?` itself is computational and declares no axiom. | -| `Checked.wf_of_decl`, `Checked.to_declWF`, `VInductDecl.wf_iff_exists_checked` | `propext`, `Quot.sound` | Accepted logical baseline; these guarded theorems show that the new environment-indexed semantic certificate adds no trust and is exactly compatible with the legacy relation. | -| `Normalization.shape`, `NormalizedChecked.source_anatomy`, `GenerationChecked.shape`, `GenerationChecked.rawCtors_eq`, `GenerationChecked.viewCtors_eq` | `propext`, `Quot.sound` | Accepted logical baseline; exact generic guards establish declaration arities, ordered family/constructor identities, raw/view layout, and complete positional constructor coverage. They do not assert expression equality or authorize a view semantically. | -| `TelDefEq.raw_onTel`, `TelDefEq.instL`, `TelDefEq.ctx`, `GenerationChecked.WF.rawFamily_isType`, `GenerationChecked.WF.rawCtor_isType` | subset of `propext`, `Quot.sound`, exactly guarded per root | Accepted logical baseline; the structural semantic contract yields raw telescope well-formedness, universe transport, definitionally equal completed contexts, and insertion-ready raw family/constructor types. No injectivity theorem, `sorryAx`, project-specific axiom, or Verify import is reachable. | -| `GenerationEnv.motive_isType`, `familyApp_transport` | `propext`, `Quot.sound` | Accepted and compile-time guarded. These roots cover the mixed motive and the common raw-family application transport without reaching choice or any project axiom. | -| `GenerationEnv.minor_isType`, `minorTypes_onTel`, `recType_isType`, `recursor_wf`, `ruleCall_hasType`, `rule_WF`, `generatedRules_WF`, `generatedRulesFold_ordered` | `propext`, `Classical.choice`, `Quot.sound` | Accepted logical baseline; every stabilized mixed minor/recursor/rule/fold boundary has an exact compile-time guard. No `sorryAx`, Verify import, or project-specific axiom reaches the complete mixed artifact preservation path. | -| `VEnv.addInductGeneration_trace`, `addInductGeneration_atomic`, and `AddInductGenerationTrace.le`/family/constructor/recursor lookup/`rule_mem` | `propext`, `Quot.sound` | Accepted and exactly guarded. The data-bearing trace is returned under `Nonempty`, so proof consumers recover the exact intermediate environments without adding `Classical.choice`; the trace is a certificate of the executable transaction, not a semantic oracle. | -| `VEnv.addInductGeneration_WF`, `addInduct_eq_addInductGeneration` | `propext`, `Classical.choice`, `Quot.sound` | Accepted and exactly guarded. Preservation consumes `GenerationChecked.WF` in insertion order and never reconstructs `Stage3Env`; the wrapper theorem pins the raw API to identity normalization. Choice is inherited from the mixed artifact/identity proof chain, not from extracting transaction states. | -| `VEnv.addInductCertified_eq_addInductGeneration` | `propext`, `Quot.sound` | Accepted and exactly guarded. The theorem is definitionally `rfl`, so it machine-checks the proof-erasure boundary: the public certified entry point computes only with `certificate.generation`, and its WF proof cannot select or alter artifacts. The reported logical closure is reached through the dependent certificate/generation types in the statement, not through computational inspection of the proof. | -| `VEnv.addInductCertified_trace`, `addInductCertified_atomic` | `propext`, `Quot.sound` | Accepted and exactly guarded. The proof-carrying public wrapper computes through `addInductGeneration`; these theorems recover the same transaction trace and atomicity result without exposing or importing Verify. The certificate's WF field is not inspected by computation. | -| `VEnv.addInductCertified_WF` | `propext`, `Classical.choice`, `Quot.sound` | Accepted and exactly guarded. The certificate carries the exact semantic premise consumed by normalized preservation, so ix does not need a separate checker-trace argument or a normalization oracle. This is the intended Theory-only non-identity transaction boundary. | -| `VDecl.WF.induct` | `propext`, `Quot.sound` | Accepted and exactly guarded. Environment histories now record the exact certified `GenerationChecked` transaction, so non-identity normalization is represented honestly rather than being forced through the identity-only public wrapper. | -| `identityChecked?_isSome` | `propext`, `Classical.choice`, `Quot.sound` | Accepted logical baseline; the identity wrapper has exactly the legacy analyzer's success behavior. The standard closure enters through the proof carried by reflexive normalization shape, including symbolic-name `BEq` lawfulness; the underlying analyzer and identity wrapper still compute and declare no oracle. Keep this exact guard so an implementation-proof dependency cannot silently grow. | -| `Checked.analyzer_eq` | `propext`, `Quot.sound` | Accepted logical baseline; any retained dependent descriptor is the unique exact analyzer result, so the identity bridge does not rerun analysis or choose a competing witness. | -| `Checked.identityBlock_generationShape`, `motiveType_eq_legacy`, `minorTypes_eq_legacy`, `recursor_eq_legacy`, `generatedRules_eq_legacy` | `propext`, `Classical.choice`, `Quot.sound` | Accepted and exactly guarded. The `Classical.choice` dependency is inherited from the already-guarded reflexive normalization-header proof; artifact construction remains computational. These roots prove that the live public accessors use the mixed generator while preserving the exact legacy identity output. | -| `aliasFormerNormalization_wf`, `aliasRecNormalization_wf`, both block-WF roots, and both generation-WF roots | `propext`, `Quot.sound` | Accepted logical baseline; exact fixture guards demonstrate that family-result and recursive-field alias normalization can be justified by existing Theory definitional equality and combined with the checked view's semantic, layout, and granular raw-binder certificates. These are evidence for the boundary design, not axioms authorizing arbitrary normalized views. | -| `AddInductive.CandidateTypeAnnotationTrace.build`, `buildCandidateTypeAnnotations`, `buildCandidateExpr`, `buildCandidateCheckType`, `buildNormalizationCandidate`, all three `CandidateExpr.*Step_valid` roots, and all three `Candidate*Step.innerRun` roots | subsets of `propext`, `Classical.choice`, `Quot.sound`, exactly guarded per root | Accepted. The executable producer retains concrete evidence: each WHNF/full-check/binder-equality node stores its actual `M.run` equality, and the `innerRun` adapters only recover erased final states. The structural annotation trace exposes the retained argument; the producer independently rejects disagreement with Lean's opaque `consumeTypeAnnotations` helper and refuses a negative `isDefEq`. The certificate intentionally stores no proposition equating its result with that opaque partial definition: the runtime agreement test is implementation validation, while semantic authority comes from the structural trace plus exact checker equality run. The standard closure is inherited from the checker/container implementation; there is no `sorryAx`, native evaluator, opaque-helper equation, normalization axiom, or project-specific axiom. | -| `TypeChecker.WhnfRun.ofCandidateStep`, `CheckTypeRun.ofCandidateStep`, `IsDefEqRun.ofCandidateStep` | `propext`, `sorryAx`, `Classical.choice`, `Quot.sound` | Transitional and exactly guarded. The adapters supply no semantic proof by themselves: callers must provide a verified context plus strict endpoint translations. `sorryAx` is inherited from the existing Verify context/translation frontier and must disappear there; the adapters add no pointer or cache axiom. | -| `candidateTypeAnnotation_fvarsIn`, `candidateTypeAnnotation_exists_translation`, `IsDefEqRun.isDefEqU` | respectively axiom-free; `propext`, `sorryAx`, `Classical.choice`, `Quot.sound`; and the exact checked semantic set | Transitional and exactly guarded. Structural recursion proves consumption cannot add free variables and extracts the retained argument's strict translation. `IsDefEqRun.isDefEqU` then refines the exact successful checker execution through the existing verified `isDefEq` theorem. The larger closure is inherited from that checker refinement; the annotation bridge declares no axiom and does not convert Lean's Boolean `Expr.equal` agreement check into an unproved propositional equality. | -| `TypeChecker.CandidateNodeRun.ofCandidate`, `CandidateNodeRun.exists_ofCandidate`, `CandidateNodeRun.evidence`, `CandidateExprRun.evidence`, `source_tr`, `view_tr` | the adapter set for direct construction; the exact checked semantic set for existential output recovery, interpretation, and endpoint translation | Transitional and exactly guarded. Recursive context/source indices tie Pi children to the exposed raw domain, exact instantiated body, actual local-context extension, and generated binder identifier. `exists_ofCandidate` derives the returned inferred/result translations from the verifier refinements once given a matching context and source translation. The interpreter consumes the paired runs, uses unique typing to transport alias-valued inferred types to structural Pi sorts, composes Pi congruence under the raw binder, and proves translations of both endpoints; it declares no oracle or axiom. The larger closure is inherited from the existing verifier refinement/context-conversion frontier. | -| `AddInductive.CandidateList.singleton` | axiom-free | Accepted structural helper. The singleton index proves the only possible family-list shape and removes any need for `head!` or a default element. | -| `AddInductive.CandidateFamilyTypeListProduced.normalize`, `CandidateConstructorListProduced.normalize`, `CandidateFamilyListProduced.normalize` | `propext`, `Classical.choice`, `Quot.sound` | Accepted operational structural glue, exactly guarded. The dependent source indices preserve length, order, and family/constructor provenance for arbitrary lists; the proofs only compose exact per-position executable results and introduce no project axiom, erasure equality, unchecked `zip`, or semantic authority. `IndexedVec` exercises the two-constructor case, while AliasFormer and AnnotatedPi exercise the singleton cases. | -| `TypeChecker.CandidateExprRootRun.evidence`, `VInductDecl.CandidateConstructorListRun.evidence`, `NormalizationCandidateRun.normalizationRun` | exactly the checked semantic set listed below | Transitional and exactly guarded. Callers name raw and exact candidate-view translations; the verified recursive run proves their equality. Constructor evidence is folded with `List.Forall₂`, and the singleton family wrapper constructs the semantic `NormalizationRun` without selecting a proof-only existential or accepting an unrelated view. The closure is inherited unchanged from the checker refinement. | -| `VInductDecl.CandidateConstructorListRun.sameHeaders`, `NormalizationCandidateRun.normalization` | respectively `propext`, `sorryAx`, `Classical.choice`, `Quot.sound`; and the same set | Transitional and exactly guarded. These roots derive header/shape preservation from the dependent run itself. They add no semantic equality and cannot truncate either list; the inherited `sorryAx` is type-level Verify debt, not a new shape axiom. | -| `TypeChecker.VState.WF.empty_of_reserves`, `candidateFreshFVarId_reserved`, `CandidateContextRun.root`, `CandidateContextRun.pushLocalDecl` | exact subsets of the transitional context set: the fresh-ID lemma uses only `propext`, `Classical.choice`, `Quot.sound`; root/context extension additionally inherit `sorryAx` plus the already recorded expression/level/container contracts | Transitional and exactly guarded. These roots construct—not assume—the precise verified root and binder contexts retained by a candidate trace. Body contexts contain the annotation-consumed domain; the separately retained exact equality run ties that domain back to raw syntax. The producer records the binder freshness equation, the candidate and checker name prefixes are proved distinct, and every empty-state restart reserves the accumulated free variables. No normalization, evaluation, or context-coherence axiom was added. `sorryAx` remains inherited from the existing `VContext`/`VState` well-formedness frontier and is therefore still release-blocking. | -| `candidateCheckTypeStep_exists_translation`, `CandidateExprRun.exists_ofCandidate`, `CandidateExprRun.exists_ofCandidateFVars` | exactly the checked semantic set (`propext`, `sorryAx`, `Classical.choice`, the two pointer implications, `Quot.sound`, and the named Expr/Level/container refinement contracts listed below) | Transitional and exactly guarded. The first theorem recovers strict source/inferred translations and typing from an exact retained full check. The recursive roots obtain all node outputs, extend the verified context with the annotation-consumed binder, refine raw-to-consumed equality, transport the body translation and typing between definitionally equal contexts, and certify an arbitrary annotated-domain trace. The `FVars` wrapper removes the last caller-chosen Theory expression. This is proof reconstruction over concrete runs, not an oracle; the former `CandidateRawBinderDomains` restriction has been removed. | -| `TypeChecker.TelDefEqEvidence.telDefEq`, `VInductDecl.NormalizedCtorRun.wf`, `GenerationRun.wf` | exactly the checked semantic set listed below | Transitional and exactly guarded. These generic roots interpret compositional checker evidence as the pointwise telescope, constructor, and complete generation certificates required by Theory. Their statements mention exact verifier-run evidence, so inheriting the verifier closure is expected; the assembler declares no axiom and does not enlarge that set. | -| `CandidateExprTrace.storedSpine`, `CandidateExprTrace.spineLength` | `propext`, `Classical.choice`, `Quot.sound` | Accepted structural/computational guards. They inspect the retained trace, require every emitted raw Pi node to remain the same outer Pi, and count exactly those nodes. They permit domain/result normalization but do not postulate Pi injectivity, normalization completeness, or semantic equality. | -| `InductiveReplayFixtures.candidateIsDefEqSelfValid` | `propext`, `Classical.choice`, `Quot.sound`, `Expr.eqv_eq`, `Level.instLawfulBEqLevel`, `Syntax.structEq_eq` | Reasonable as an exactly guarded Verify-layer reflexive execution lemma, but not an ix-facing release allowlist. It proves the ordinary checker accepts `e ≡ e`; it declares no equality or normalization axiom. The three implementation contracts are inherited from Lean expression/level/name equality and must stay confined to Verify until Track T justifies or replaces them. | -| `InductiveReplayFixtures.indexedVecFamily_candidateTrace`, `indexedVecCandidateInductiveStats_nindices`, `indexedVecCandidateInductiveStats_params` | `propext`, `sorryAx`, `Classical.choice`, `Quot.sound`, `Expr.eqv_eq`, `Expr.instantiate1_eq`, `Expr.instantiateRev_eq`, `Expr.instantiate_eq`, `Expr.looseBVarRange_eq`, `Expr.mkAppData_eq`, `Expr.mkData_eq`, `Expr.replace_eq`, `Level.hasParam_eq`, `Level.instLawfulBEqLevel`, `PersistentArray.toList'_push`, `PersistentHashMap.findAux_isSome`, `Syntax.structEq_eq`, `PersistentHashMap.WF.find?_eq`, `PersistentHashMap.WF.toList'_insert` | Transitional and exactly guarded. These roots replay the real `IndexedVec` family through two dependent binders and expose the computed one-parameter/one-index statistics. `sorryAx` and container/reference/layout equations are inherited from the existing Verify environment/context frontier; the fixture adds no axiom and gives these contracts no Theory authority. | -| `InductiveReplayFixtures.indexedVec_checkInductiveTypes` | the preceding `IndexedVec` candidate set plus `Level.hasMVar_eq` | Transitional and exactly guarded. This is the complete executable singleton-family validation, including the closedness checks. The four cached-`Expr` facts are now proved on v4.31; their proofs expose only the already listed data-layout contracts. The closure remains development evidence because every dependency is visible, but its `sorryAx` and implementation contracts are release-blocking and must not flow into the Theory certificate consumed by ix. | -| `AddInductive.observeCandidateIsDefEq_of_run`, `buildCandidateExpr_loop_of_whnf_nonForall`, `buildCandidateExpr_loop_of_whnf_forall` | `propext`, `Classical.choice`, `Quot.sound` | Accepted operational reduction seams, exactly guarded. They expose a supplied exact ordinary-checker execution and assemble one terminal or Π traversal step; they add no normalization oracle, evaluator equation, or fixture-specific axiom. | -| `TypeChecker.TelDefEqEvidence.ofTelDefEq` | `propext`, `sorryAx`, `Classical.choice`, `Quot.sound` | Transitional and exactly guarded. This constructs evidence from already proved pointwise telescope equality; its `sorryAx` is inherited through the Verify translation/context statement, not introduced by extraction. It reaches none of the pointer, expression-reflection, or container contracts used by executable checker refinement. | -| `CandidateExprIdentity.storedSpine`, `CandidateExprRun.exists_ofIdentity`, `CandidateExprRootRun.spineOfIdentity` | a subset of the checked semantic set listed below, reached transitively by both exact `IndexedVec` public-root guards | Transitional. These roots recursively interpret a syntactically identity-normalizing candidate at caller-selected Theory endpoints and recover its generation-ready stored spine from the same source-indexed run. They declare no axiom and do not assume a normalization equation; their closure is inherited from the existing verifier, translation, unique-typing, and container frontier. Add direct guards if they become independently exported audit roots. | -| `CandidateExprSemanticRootRun.exists_ofCandidate`, `.root`, `CandidateExprRootRun.semanticOfIdentity`, `CandidateConstructorSemanticListRun.roots`, `CandidateFamilySemanticRun.root`, `NormalizationCandidateSemanticRun.root`; separately `CandidateExprSemanticRootRun.spine` | the first group has exactly the checked semantic set listed below; `spine` has exactly `propext`, `sorryAx`, `Classical.choice`, and `Quot.sound` | Transitional, directly audited with `#print axioms` at `f0caf16c`. The root theorem lets the retained checker run select its Theory view from verified context/source evidence, while the dependent projections preserve exact source positions through normalization. The spine is a direct projection of that same run. Their new composite construction and generation callers are exact compile-time guarded in the next row; add individual guards here only if one becomes an independently exported audit root. None declares an axiom, assumes normalization, invokes a native evaluator, or gives the operational producer independent semantic authority. The broad closure is inherited from the existing checked-semantic translation/refinement frontier and remains release-blocking for ix-facing evidence. | -| `TypeChecker.CandidateExprSemanticRootInput.exists`, `CandidateConstructorSemanticListInput.exists`, `NormalizationCandidateSemanticInput.exists_ofProduced`, `CandidateFamilySemanticGenerationRun.run`, `CandidateSemanticNormalizedCtorListRun.run`, `GenerationCandidateSemanticRun.run`, `.package`, `.producedPackage` | exactly the checked semantic set listed below, compile-time guarded per root | Transitional and exactly guarded at `7e5f4f77`. The input hierarchy combines verified contexts and strict translations with exact operational list witnesses, then returns the complete source-ordered semantic hierarchy under `Nonempty`; the producer selects the indexed candidate but does not select its Theory view. The semantic-generation projections reuse that hierarchy's recursive runs and spines, eliminating parallel normalization/generation ownership. `Nonempty` is intentional: extracting a data-bearing run would require choice, whereas proof consumers need only semantic existence. No new axiom, normalization oracle, native evaluator, unchecked positional operation, or caller-selected endpoint is introduced. | -| `aliasFormerProducedSemanticHierarchy_exists`, `annotatedPiProducedSemanticHierarchy_exists`, `indexedVecProducedSemanticHierarchy_exists`, the three `*GenerationCandidateSemanticRun` roots, `indexedVecProducedSemanticHierarchy_constructorHeaders`, and `indexedVecReorderedView_rejected` | all positive roots have exactly the checked semantic set; reordered-view rejection has exactly `propext` | Transitional fixtures, all exactly guarded. The three positive blocks exercise terminal-alias, annotated recursive-Π, and parameter/index/two-constructor assembly. `IndexedVec` proves that the existential semantic result retains `nil`/`cons` order, while swapping those headers fails the computational normalization-shape gate before semantic or generation evidence can be attached. The v4.31 cache proofs remove the former AnnotatedPi-only axiom delta. | -| `CandidateExprRun.spineEvidence`, `CandidateExprSpineRun.evidenceAt`, `TelResultDefEqEvidence.replacePrefix`, `CandidateNormalizedCtorRun.normalizedCtorRun`, `GenerationCandidateRun.wf` | exactly the checked semantic set listed below | Transitional and exactly guarded. These generic generation-level roots recursively recover binder equality and the terminal result from the exact run, prove raw-spine length, replace a constructor's declared parameter prefix with the definitionally equal emitted family prefix in the exact induced contexts, fold a source-indexed dependent constructor list, and produce `GenerationChecked.WF`. They use neither forall injectivity nor a choice-selected candidate view and declare no axiom; the closure is inherited unchanged from checker refinement, unique typing, translation, and container contracts. | -| `Checked.type_eq`, `GenerationChecked.viewCtorType_eq`, `GenerationChecked.checkedResultTarget_hasType` | exactly `propext`, `Quot.sound` | Accepted Theory baseline and exactly guarded at `2b1d802f`. These roots expose the analyzer's exact family/constructor telescope decomposition and type a constructor's normalized result application from the retained family constant plus checked parameter/index spines. No Verify import, custom axiom, normalization oracle, or whole-Pi injectivity enters Theory. | -| `Normalization.check?_normalization`, `Normalization.generation?_normalization` | exactly `propext`, `Quot.sound` | Accepted Theory baseline and exactly guarded at `a64fe982`. These theorems invert exact successful dependent analysis to recover the normalization retained by its indexed result. They unfold the computational analyzers and introduce no Verify dependency, choice, custom axiom, or normalization oracle. | -| `GenerationCandidateRun.familyView_eq`, `CandidateNormalizedCtorRun.viewTel_eq` | exactly `propext`, `sorryAx`, `Classical.choice`, `Quot.sound` | Transitional Verify glue and exactly guarded at `2b1d802f`. Singleton normalization indices force the exact checked family view, while a known non-forall terminal plus exact checked constructor shape recovers the complete candidate view telescope. The inherited `sorryAx` is already present in the retained semantic-run types; neither theorem declares an axiom or adds semantic authority. | -| `GenerationCandidateRun.normalization_eq` | exactly `propext`, `sorryAx`, `Classical.choice`, `Quot.sound` | Transitional Verify projection and exactly guarded at `a64fe982`. The theorem consumes the exact `generation? = some generation` field and delegates normalization recovery to the Theory theorem above. The inherited `sorryAx`/choice closure comes from the dependent Verify evidence type in its statement; fixtures no longer provide the equality. | -| `NormalizationCandidateRun.sourceType_eq`, `NormalizationCandidateRun.familyViewType_eq` | exactly `propext`, `sorryAx`, `Classical.choice`, `Quot.sound` | Transitional Verify alignment and exactly guarded at `5aa9ab69`. Singleton source indices and exact dependent analysis determine the retained raw family and complete checked family view. The inherited closure comes from the dependent Verify evidence in the statements; neither theorem declares an axiom, asserts normalization, or lets a caller select a view. | -| `GenerationCandidateSemanticShapeRun.run` | exactly the checked semantic set listed below | Transitional and exactly guarded at `5aa9ab69`. Source-indexed minimal shapes retain only stored-spine success and the total binder count. Exact analysis derives every raw/view pair and the complete ordered constructor list; total length derives raw telescope/results, and checked shape derives view terminals. The projection reconstructs `GenerationCandidateSemanticRun` without `zip`, truncation, reordering, a caller-selected pair, or component premises. Its closure is exactly the existing checked semantic set, so the structural recursion and telescope decomposition add no axiom. | -| `candidateConstructorSemanticGenerationShape`, `normalizationCandidateGenerationShape`, `CandidateConstructorSemanticGenerationShapeList.ofCheck`, `produceGenerationShapeCandidate`, `produceGenerationShapeCandidate_eq_ok` | exactly `propext`, `Classical.choice`, `Quot.sound` | Accepted executable boundary and exactly guarded at `bbb45e0e`. The source-indexed Boolean covers the complete family/constructor hierarchy, checks retained emitted spines and full raw telescope lengths, and rejects missing or extra constructor positions. The strengthened producer retains the exact ordinary producer equation plus this separately successful gate. These roots make no Theory claim, declare no axiom, and cannot turn bare producer success into stored-spine evidence. | -| `NormalizationCandidateSemanticRun.generationShape`, `GenerationCandidateSemanticRun.ofGenerationShape`, `NormalizationCandidateSemanticRun.producedPackageOfGenerationShape`, `ProducedGenerationShapeCandidate.producedPackage` | exactly the already recorded checked semantic set, compile-time guarded per root | Transitional and exactly guarded at `bbb45e0e`. Exact dependent analysis and WF of the analyzer-owned view declaration derive checked WF; the successful complete Boolean expands structurally into every source-indexed family/constructor stored-spine/count record. Packaging then reuses the existing semantic owner for the same producer-selected candidate. The broader closure is inherited from verified checker/context evidence, not introduced by the shape gate; no new axiom, normalization oracle, native evaluator, unchecked positional operation, or caller-selected view is added. | -| `GenerationCandidateRun.typeEnv_wf` | exactly the checked semantic set listed below | Transitional and exactly guarded at `a64fe982`. It reconstructs the post-family environment from retained pre-family WF, the verified raw/view definitional equality, checked family typing, and the exact raw-family insertion. The broad closure is inherited from the existing checker/context evidence; fixtures no longer provide this WF judgment, and no new axiom or environment oracle is introduced. | -| `GenerationCandidateRun.familyConst_hasType`, `CandidateNormalizedCtorRun.rightType_ofChecked` | exactly the checked semantic set listed below | Transitional and exactly guarded at `2b1d802f`. The family constant is typed once in the post-family environment by combining exact insertion, candidate equality, and checked family WF. Every constructor terminal then follows from the checked result spine and telescope-context transport. Fixtures no longer supply terminal typing judgments; the broad closure is inherited from existing Verify checker/context evidence and does not reach the three Theory roots above. | -| `GenerationCandidateRun.package`, `GenerationCandidateRun.producedPackage` | `propext`, `sorryAx`, `Classical.choice`, `Quot.sound` | Transitional and exactly guarded. The first packaging root retains the already indexed source/candidate/run fields without interpreting them. The second attaches an exact successful whole-call equation for that same dependent candidate and cannot be reused for a different run, reordered list, or caller-selected view. The small closure comes from the dependent Verify evidence types in their statements; neither root introduces checker, producer, or normalization authority. | -| `GenerationCandidatePackage.certificate`, `GenerationCandidatePackage.addInductTrace` | exactly the checked semantic set listed below | Transitional and exactly guarded. Certificate erasure derives both the Theory generation and its WF proof from the same package. The metadata replay constructor likewise fixes its trace's generation/WF fields to package projections, so callers may supply insertion witnesses but cannot substitute an unrelated normalized view. The inherited Verify closure remains release-blocking and does not reach the resulting Theory API declaration. | -| `InductiveReplayFixtures.aliasFormerGenerationCandidateRun` | exactly the checked semantic set listed below | Transitional and exactly guarded. This concrete non-identity fixture supplies exact analysis, WF of the analyzer-owned view declaration, and one successful complete generation-shape gate; it no longer supplies checked WF or any per-position shape record. The generic projection derives checked WF, raw/view family identity, normalized pairing/order, all raw telescope/results and view terminals, and the dependent constructor list. Its existing `GenerationRun`, checked `AddInductTrace`, final environment, WF, and alignment replay delegate through this value, so the vertical path adds no axiom beyond the already visible Verify frontier. | -| `InductiveReplayFixtures.aliasFormerNormalizationCandidate_produced` | `propext`, `sorryAx`, `Classical.choice`, `Quot.sound`, `Expr.eqv_eq`, `Expr.looseBVarRange_eq`, `Expr.mkAppData_eq`, `Expr.mkData_eq`, `Level.instLawfulBEqLevel`, `PersistentHashMap.findAux_isSome`, `Syntax.structEq_eq`, `PersistentHashMap.WF.find?_eq`, `PersistentHashMap.WF.toList'_insert` | Transitional and exactly guarded. This is the exact successful whole `buildNormalizationCandidate` call on real AliasFormer metadata. It proves the family check, family insertion, constructor check, and source-indexed list assembly in their actual contexts; it does not assert an erasure equality or authorize a caller-selected view. The v4.31 closed-expression cache facts are proved; their implementation proof reaches the two existing data-layout contracts. | -| `InductiveReplayFixtures.aliasFormerProducedGenerationCandidatePackage` | exactly the checked semantic set | Transitional and exactly guarded. The value uses the generic strengthened outer constructor to combine the exact ordinary producer equation, complete generation-shape success, and the semantic owner. The producer equation selects the candidate but grants no Theory or shape meaning. Generic construction of the verified per-position semantic inputs and analyzer-owned view WF from an arbitrary verified outer context and exact traversals is still open. Checked WF, every per-position shape record, raw/result and view-terminal equations, normalized-pair/order, dependent-list alignment, view telescopes, terminal typing, normalization equality, and post-family WF are generic consequences and are no longer part of that gap. | -| `InductiveReplayFixtures.aliasFormerFamily_whnf`, `aliasFormerCtor_whnf` | `propext`, `sorryAx`, `Classical.choice`, `Quot.sound`, `Expr.eqv_eq`, `Level.instLawfulBEqLevel`, `PersistentHashMap.findAux_isSome`, `Syntax.structEq_eq`, `PersistentHashMap.WF.find?_eq`, `PersistentHashMap.WF.toList'_insert` | Transitional and exactly guarded. These are the pre-family alias reduction and post-family opaque-constructor `Inner.whnf'` traces. They reach no pointer-equality axiom and use no `native_decide` or newly declared reduction principle; the remaining contracts are inherited Verify/platform debt. | -| `InductiveReplayFixtures.aliasFormerFamily_candidateTrace`, `aliasFormerCtor_candidateTrace`, `aliasFormerFamily_candidate` | the exact AliasFormer operational set plus `Expr.looseBVarRange_eq` from retained full checks | Transitional and exactly guarded. These pin both positions of the real singleton family/constructor candidate list plus the erased family view. They do not certify an arbitrary translated candidate or add semantic authority to `NormalizationCandidate`. | -| `InductiveReplayFixtures.aliasFormerFamily_candidateRun_exists`, `aliasFormerFamily_candidateSource_tr`, `aliasFormerFamily_candidateView_tr` | respectively the exact checked semantic set, retained-check set, and checked semantic set | Transitional and exactly guarded. The existential fixture instantiates automatic root-context and source/output recovery on actual metadata without supplying a Theory expression. The endpoint fixtures pin the strict raw and reconstructed view translations. AliasFormer's normalization and generation evidence consume the same interpreted trace; none of these fixtures authorizes an arbitrary candidate. | -| `InductiveReplayFixtures.aliasFormerNormalizationCandidateRun`, `aliasFormerCandidateNormalization_eq` | exactly the checked semantic set | Transitional and exactly guarded. The complete source-indexed singleton list now computes the established AliasFormer view and supplies its live `NormalizationRun`; all downstream checked generation and replay roots therefore exercise the generic list boundary. `aliasFormerTruncatedView_rejected` separately uses only `propext` and proves a shorter view fails before transaction construction. | -| `InductiveReplayFixtures.recAlias_whnf` | the preceding exact set plus `Expr.mkAppData_eq`, `Expr.mkData_eq`, `Expr.replace_eq`, and `Level.hasParam_eq` | Transitional and exactly guarded. The additional contracts arise from instantiating and reducing the universe-polymorphic `RecAlias` value. The former `Expr.hasLevelParam_eq` axiom is now a theorem whose implementation proof reaches the two data-layout contracts. This is still an execution theorem, not an oracle that asserts its result. | -| `InductiveReplayFixtures.aliasFormerFamily_checkType`, `aliasFormerCtor_checkType` | `propext`, `sorryAx`, `Classical.choice`, `Quot.sound`, `Expr.eqv_eq`, `Expr.looseBVarRange_eq`, `Level.instLawfulBEqLevel`, `PersistentHashMap.findAux_isSome`, `Syntax.structEq_eq`, `PersistentHashMap.WF.find?_eq`, `PersistentHashMap.WF.toList'_insert` | Transitional and exactly guarded. These are exact operational full-check traces. The family check returns `Sort 2`; the constructor check runs after raw-family insertion and returns the retained `TypeFamilyAlias`. Both record the cache result, reach no pointer-equality contract, and introduce no evaluation axiom. | -| `InductiveReplayFixtures.aliasFormerFamily_isType_checked`, `aliasFormerCtor_isType_checked`, both `*Normalization_wf_checked`, both `*Block_wf_checked`, and both `*GenerationChecked_wf_checked` roots | `propext`, `sorryAx`, `Classical.choice`, `ptrEqConstantInfo_eq`, `ptrEqExpr_eq`, `Quot.sound`, `Expr.abstractRange_eq`, `Expr.abstract_eq`, `Expr.eqv_eq`, `Expr.hasLooseBVar_eq`, `Expr.instantiate1_eq`, `Expr.instantiateRange_eq`, `Expr.instantiateRevRange_eq`, `Expr.instantiateRev_eq`, `Expr.instantiate_eq`, `Expr.looseBVarRange_eq`, `Expr.lowerLooseBVars_eq`, `Expr.mkAppData_eq`, `Expr.mkData_eq`, `Expr.replace_eq`, `Level.hasMVar_eq`, `Level.hasParam_eq`, `Level.instLawfulBEqLevel`, `PersistentArray.toList'_push`, `PersistentHashMap.findAux_isSome`, `Syntax.structEq_eq`, `PersistentHashMap.WF.find?_eq`, `PersistentHashMap.WF.toList'_insert` | Transitional and exactly guarded. The semantic bridge correctly inherits the existing verified checker's pointer/reflection, data-layout, and container contracts; completing the paired block and generation certificates adds no dependency beyond the normalization endpoint. `sorryAx` remains on the separately tracked translation frontier. The v4.31 closure drops the generated `mkAppRangeAux` axiom and the previously reachable TreeMap contract. This is development evidence, not a release allowlist, and it must not reach Theory or ix semantic roots. | -| `InductiveReplayFixtures.aliasFormerGenerationCandidatePackage`, `aliasRecAddInductTraceChecked`, `aliasRec_trEnv'_checked` | exactly the preceding checked semantic set | Transitional and exactly guarded. The semantic package owns the generation/WF pair, and the AliasRec replay retains the established checked semantic closure. No outer producer equation is involved in these roots. | -| `InductiveReplayFixtures.aliasFormer_addInductCertified_checked`, `aliasFormerGenerationChecked_wf_checked`, `aliasFormerAddInductTraceChecked`, `aliasFormer_trEnv'_checked` | exactly the preceding checked semantic set | Transitional and exactly guarded. These concrete consumers now project from the produced package, making exact whole-call provenance visible in their axiom reports. Proof erasure still keeps those contracts out of transaction computation, and the generic Theory API remains Theory-clean; the inherited `sorryAx` and platform equations remain release-blocking for this Verify-produced value. | -| `InductiveReplayFixtures.annotatedPiCtor_candidateTrace`, `annotatedPiFamily_candidateTrace` | exact guarded operational subsets of the checked semantic set; the nested constructor root inherits `sorryAx`, `ptrEqExpr_eq`, and the existing Expr/Level/container refinement equations, while the family root uses only `propext`, `Classical.choice`, `Quot.sound`, `Expr.eqv_eq`, `Expr.looseBVarRange_eq`, `Level.hasParam_eq`, `Level.instLawfulBEqLevel`, and `Syntax.structEq_eq` | Transitional and exactly guarded. These are the exact recursive candidate traversals selected by the real constructor and family producer calls. The family profile remains narrow; the constructor profile exposes existing checker-refinement debt because it traverses annotation consumption beneath a recursive Π. Neither trace is semantic authority by itself. | -| `InductiveReplayFixtures.annotatedPiNormalizationCandidate_produced` | `propext`, `sorryAx`, `Classical.choice`, `ptrEqExpr_eq`, `Quot.sound`, `Expr.eqv_eq`, the existing instantiate/replace/loose-variable contracts, `Expr.mkAppData_eq`, `Expr.mkData_eq`, `Level.hasMVar_eq`, `Level.hasParam_eq`, `Level.instLawfulBEqLevel`, and the existing persistent-array/hash-map/syntax contracts | Transitional and exactly guarded. This is the exact successful whole `buildNormalizationCandidate` equation for AnnotatedPi, including nested Π traversal and dependent list assembly. The four former cached-`Expr` axioms are now proved; their data-layout dependencies remain visible and do not assert semantic normalization. | -| `InductiveReplayFixtures.annotatedPiProducedGenerationCandidatePackage` | exactly the checked semantic set | Transitional and exactly guarded. The record combines AnnotatedPi's exact whole operational result with its semantic-generation owner. As for AliasFormer, the producer equation selects the candidate while the retained semantic hierarchy supplies all Theory meaning; inherited `sorryAx` and platform equations remain release-blocking. | -| `InductiveReplayFixtures.annotatedPiNormalizationCandidateRun`, `annotatedPiGenerationCandidateRun`, `annotatedPiGenerationCandidatePackage`, `annotatedPi_addInductCertified`, `annotatedPiGenerationChecked_wf_checked`, `annotatedPiAddInductTraceChecked`, `annotatedPi_trEnv'_checked` | exactly the preceding checked semantic set | Transitional and exactly guarded. `AnnotatedPi` exercises the complete recursive-Pi annotation path: exact full checks, WHNF, annotation consumption, lazy-delta definitional equality, recursive candidate contexts, generation assembly, the public certified transaction, and final checked replay. The fixture adds no oracle, and the inherited `sorryAx`/platform closure remains release-blocking exactly as for the alias fixtures. | -| `InductiveReplayFixtures.indexedVecNormalizationCandidateProduced` | the exact `IndexedVec` operational set: `propext`, `sorryAx`, `Classical.choice`, `Quot.sound`, the retained Expr/Level/cache equations, and the persistent-array/hash-map/syntax contracts printed at the root | Transitional and exactly guarded. This is the complete one-parameter, one-index, ordered `nil`/`cons` outer producer equation. It selects the exact candidate but supplies no Theory meaning by itself. | -| `InductiveReplayFixtures.indexedVecSemanticProducedGenerationCandidatePackage`, `indexedVecSemantic_trEnv'_checked` | exactly the checked semantic set used by the existing produced-package replays | Transitional and exactly guarded. These roots interpret every family/constructor node at the identity endpoint, assemble the source-indexed generation package, project the proof-erased Theory certificate, and carry that same package through the final E1 replay. The former closedness cache axioms are proved on v4.31; the fixture adds no oracle or axiom, and inherited `sorryAx` and platform contracts remain release-blocking and visible in both exact guards. | -| `InductiveReplayFixtures.annotatedPiFinalEnv_iota_mem` | `propext`, `Quot.sound` | Accepted logical baseline and exactly guarded. Once the checked generation value is supplied, membership of the generated recursive-Pi iota rule in the final Theory environment does not inherit the Verify checker closure. This is the ix-relevant separation to preserve in the general producer/public path. | -| `VEnv.addInduct_success`, `addInduct_checked`, constructor/recursor collision rejection | `propext`, `Classical.choice`, `Quot.sound` | Accepted logical baseline; compile-time guarded. The success certificate carries analyzer evidence rather than postulating it. `Classical.choice` now enters because the transaction's public artifacts are identity-normalization specializations of the mixed generator. | -| `VEnv.addInduct_WF` | `propext`, `Classical.choice`, `Quot.sound` | Accepted logical baseline; compile-time guarded. | -| Recursive-Pi roots (`recTypeRec_isType`, `recConstRec_wf`, `ruleCallRec_hasType`, `minorAppRec_hasType`, `recRuleAppRec_hasType`, `ruleRec_WF`) | `propext`, `Classical.choice`, `Quot.sound` | Accepted logical baseline; every named root has an exact compile-time guard, including the final generalized iota-rule preservation theorem. No custom or Verify axiom reaches the public generalized Theory path. | -| `TrTypeExpr.to_trExprS` | `propext`, `sorryAx`, `Classical.choice`, `Quot.sound` | Transitional only. The helper itself is projection-free, but its `TrExprS` result type reaches the still-sorried `TrProj`; compile-time guarded. | -| `AddInductTrace.to_addInductGeneration`, `AddInduct.to_addInduct`, `AddInduct.le`, `Aligned.addInduct`, `TrEnv'.wf`, `TrEnv'.aligned` | `propext`, `sorryAx`, `Classical.choice`, `Quot.sound` | Transitional only. The Verify trace now proves and its public wrapper existentially exposes the exact normalized Theory transaction. The `sorryAx` is inherited because `TrExprS` has a projection constructor whose relation `TrProj` is still a sorry; P0-P2 must remove it. The stabilized roots are compile-time guarded so any closure change is reviewed. | -| `TrEnv'.of_value` | the preceding set plus `Lean.PersistentHashMap.findAux_isSome`, `Lean.PersistentHashMap.WF.find?_eq`, and `Lean.PersistentHashMap.WF.toList'_insert` | Transitional Verify/platform debt. T2 must prove or narrowly manifest the persistent-map contracts, while P removes `sorryAx`. | -| `InductiveReplayFixtures.nat_trEnv'`, `eq_trEnv'`, `indexedVec_trEnv'`, `acc_trEnv'`, `aliasFormer_trEnv'`, `aliasRec_trEnv'`, their WF/alignment roots, and `seed_after_nat_of_value` | the `TrEnv'` set plus the same three persistent-map contracts | Transitional fixture closure, compile-time guarded. The collection contracts enter while proving freshness for the concrete sequence of `SMap` insertions; the fixtures declare no axiom and must shrink with P/T2. The two aliases add no dependency beyond the existing replay closure despite exercising non-identity normalization. | - -Do not summarize this table as “four acceptable axioms.” A theorem's axiom -set includes dependencies occurring through its statement and inductive -types, not just constants named in its proof body. In particular, E1 can be -locally sorry-free while its exported roots remain transitively sorry-bearing. - -#### Axiom-set decision and release thresholds - -**Decision:** the axiom set of the current inductive **Theory** roots is -reasonable. It contains only the standard Lean logical principles -`propext`, `Classical.choice`, and `Quot.sound` (often a strict subset), and no -axiom asserting facts about the behavior or representation of Lean's -implementation. The axiom set of the current end-to-end **Verify** roots is not -release-acceptable: its `sorryAx` and collection/opaque implementation -contracts are useful diagnostics while proofs migrate, not foundations to -endorse. The checked normalization producer and the candidate-generation -assembler do not change that verdict: their design is reasonable because they -record concrete checker executions, recursively extract exact binder/result -evidence, and derive Theory equality through existing refinement theorems. -Their exact guarded closures still expose the inherited `sorryAx`, -pointer/reflection, translation, and container debt that must be discharged or -isolated before release. The `AnnotatedPi` slice confirms that verdict at the -hardest current annotation seam: retaining only the structural annotation -trace and exact `isDefEq` run is sufficient, while the opaque helper agreement -remains a runtime producer check rather than an assumed theorem. The four -cached-`Expr` properties it exercises are proved on v4.31; their proofs route -through the two already classified data-layout contracts, which remain exactly -guarded and outside the release allowlist. The automatic semantic-input, -produced-hierarchy, and semantic-generation projection roots have exactly the -same checked semantic set as the retained interpreter; their compile-time -guards show no trust growth. Returning the assembled hierarchy under -`Nonempty` is deliberate: it states semantic existence without using choice to -extract a data-bearing checker-selected view. The exact AliasFormer whole-call -proof no longer reaches three separate closedness cache axioms; it reaches -`Expr.mkData_eq` and `Expr.mkAppData_eq` through the new kernel proofs instead. -Those dependencies are exactly guarded and remain transitional layout -contracts. No new axiom or oracle was added. -The certified public path sharpens this separation: its generic Theory -transaction theorems use only the accepted logical baseline, while concrete -AliasFormer/AnnotatedPi/`IndexedVec` certificate values retain the exact -transitional Verify closure that produced their semantic proofs. Proof erasure prevents -that closure from influencing transaction computation, but does not erase it -from the axiom report of a concrete proof-carrying value. The optional -`ProducedGenerationCandidatePackage` adds only an exact executable producer -equation; it grants no semantic authority without the enclosed checked -package. All three concrete certificates and replays intentionally project -from their produced values; their exact guards therefore retain the -fixture-specific closedness/cache equations reached by ordinary checker -execution. The generic Theory `GenerationCertificate` and transaction -theorems retain their smaller accepted logical closure. -This distinction is part of the formalization's specification. +**Per-root closures.** Exact `#guard_msgs`/`#print axioms` guards in the +source are the authoritative per-root record; this roadmap does not mirror +them. Two standing facts frame that record: generic Theory transaction and +inductive roots close over the standard baseline only, while concrete Verify +packages, candidate/semantic runs, and replay fixtures inherit the +transitional closure (`sorryAx` via `TrProj`, pointer/reflection, layout, and +container contracts) — exactly guarded, release-blocking, and kept out of +Theory. The separation to preserve: once a checked generation value is +supplied, Theory-level consequences (for example iota-rule membership in the +final environment) close at `propext`/`Quot.sound` without inheriting the +Verify closure. Do not summarize any of this as “four acceptable axioms”: a +theorem's axiom set includes dependencies through its statement and inductive +types, so a proof can be locally sorry-free while its exported roots remain +transitively sorry-bearing. Only the generated transitive closure of each +named root is authoritative for release (L4L-20A). | Boundary | Allowed during development | Required at its release gate | |---|---|---| | Computational `Checked` analysis, normalization shape, and generation | No axiom declaration; evaluation and equality fixtures must compute | Same; no oracle or opaque semantic bridge in acceptance/generation | -| Theory normalization validity, preservation, patterns, projection semantics, and ix-facing Theory API | Any subset of `propext`, `Classical.choice`, `Quot.sound`; exact closure guarded per exported root | Same subset policy; zero `sorryAx`, zero project-specific axiom, and no import path to `Verify/Axioms` or `PtrEq` | -| Verify's mathematical refinement roots | Transitional bridges may remain only when named, classified, and exposed by an exact guard | Standard logical baseline only, unless the theorem is explicitly a platform-refinement theorem rather than a mathematical soundness theorem | -| Version-pinned platform adapter | A narrowly stated candidate contract with an owner, pinned Lean revision, removal issue, and tests | Only reviewed manifest entries; expected upper bound is the two pointer-equality implications and possibly lawful level `BEq`. These must not reach Theory or ix's semantic theorem roots | +| Theory normalization validity, preservation, patterns, projection semantics, and consumer-facing Theory API | Any subset of `propext`, `Classical.choice`, `Quot.sound`; exact closure guarded per exported root | Same subset policy; zero `sorryAx`, zero project-specific axiom, and no import path to `Verify/Axioms` or `PtrEq` | +| Verify's mathematical refinement roots | Transitional bridges may remain only when named, classified, and exposed by an exact guard | Standard logical baseline only, unless the theorem is explicitly a platform-refinement theorem | +| Version-pinned platform adapter | A narrowly stated candidate contract with an owner, pinned Lean revision, removal issue, and tests | Only reviewed manifest entries; expected upper bound is the two pointer-equality implications and possibly lawful level `BEq`; never reachable from Theory or a consumer-facing semantic root | | Fixtures and differential tests | May expose transitional dependencies to diagnose their path | They do not justify an axiom; release fixtures must have the closure required by the root they certify | -Audit computation and proof closure separately. For example, -`normalizationShape`, `checked?`, and `identityChecked?` are executable -definitions with no normalization oracle, while a theorem or dependent value -carrying the proof `normalizationShape source source = true` may report the -standard logical closure used by Lean's generic `BEq` lawfulness proof. That -is acceptable under the Theory threshold; it is not permission to replace the -Boolean test or semantic `Normalization.WF` evidence with an axiom. - -Apply the following rules mechanically: - -1. Treat the accepted logical baseline as a **set upper bound**, not a demand - that every theorem use all three axioms. Keep exact `#guard_msgs` checks for - today's named roots so either growth or unexpected shrinkage receives - review. -2. Reject `sorryAx` from every release root. A proof whose statement reaches a - sorried relation is not release-clean merely because its proof body contains - no `sorry`. -3. Reject every known-false cache equation from every supported root and ban - project-specific axioms from the global simp set. Removing `[simp]` is only - containment; the declaration must still be proved, narrowed, or made - unreachable. -4. Require an explicit design decision before expanding the logical baseline - or platform manifest. Proof difficulty, convenience, or pre-existence in - `Verify/Axioms.lean` is not sufficient justification. -5. Keep ix's `NativeOracle` in ix's own named consumer boundary. It does not - authorize a corresponding lean4lean Theory axiom, an assumed - `InductiveOracle`, or an opaque projection relation. -6. Treat a normalization view as untrusted data until it has both computed - shape coherence and an environment-indexed `Normalization.WF` proof. - Verify must derive that proof from translated checker/defeq behavior, and ix - must derive it from its ordinary Theory typing/defeq world. Neither consumer - may assume a normalization oracle or add a project-specific reduction axiom. - -For the I2 normalization migration, apply that policy to a fixed root set -rather than auditing whichever helper happens to be convenient: - -1. The executable roots `normalizationShape`, `Normalization.check?`, - `generationShape`, and the mixed motive/minor/recursor/rule constructors - must continue to compute without an oracle. Their kernel-equality fixtures - are computational tests, not substitutes for semantic preservation. -2. Guard the component preservation roots - `GenerationEnv.motive_isType`, `minor_isType`, `minorTypes_onTel`, the - completed `recType_isType`/`recursor_wf` pair, `ruleCall_hasType`, - `rule_WF`, `generatedRules_WF`, and the complete generated-rule fold. - Record the exact closure of each; - the permitted set is a subset of - `{propext, Classical.choice, Quot.sound}`, not permission to acquire all - three. -3. Guard the block-level theorem that turns `GenerationChecked.WF` into - well-formed raw constants, a mixed recursor, and mixed rules. Then guard the - normalized `addInduct_success`, lookup/membership/atomicity consequences, - and `addInduct_WF` separately. A clean component proof does not certify a - wrapper whose statement or result type reaches a forbidden axiom. -4. Keep identity-normalization compatibility roots separate from the general - normalization roots. The identity wrapper must reduce to the legacy result; - the general path must consume explicit `Normalization.WF` evidence and may - not infer semantic validity from shape coherence. -5. Before closing the I2 artifact or transaction checkbox, run both the exact - guards and a generated transitive closure report for the public roots. - Reject `sorryAx`, every `Verify/Axioms` or `PtrEq` dependency, and every - project-specific declaration even when it enters only through a theorem's - type. -6. Apply the same audit to the eventual E2 theorem consumed by ix. Its Theory - closure must meet the standard upper bound. Verify's actual-metadata trace - may expose named transitional platform debt during development, but it - cannot be the release proof of the ix-facing semantic theorem until that - debt has been removed or isolated outside the theorem's closure. - -### 2.4 Ix demand surface, re-audited - -Ix has advanced beyond the original “construct the first oracle” framing. -Its E2b milestone now constructs `InductiveOracle` for a staged, closed -singleton-enumeration fragment and its next local critical path is E3-S, -which composes that fragment with the production environment driver. This does -not complete lean4lean's handoff: L4L-11 widens the construction from that -deliberately small fragment to the full safe single/mutual/nested block class -established by L4L-07 through L4L-10B. The fork should strengthen the shared -Theory certificate and lookup/pattern consequences, not duplicate ix's -address, catalog, ingress, or driver proofs. - -The current ix working tree contains about 55,449 lines under -`Ix/Tc/Verify/` and 1,192 root entries across its two audit manifests. It -imports these lean4lean modules: - -```text -Theory.VLevel -Theory.VEnv -Theory.Typing.Env -Theory.Typing.Lemmas -Theory.Typing.Pattern -Verify.Typing.Expr -Verify.Typing.Lemmas -Verify.VLCtx -``` - -The ix obligations and their lean4lean owners are: - -| Ix boundary | Lean4Lean deliverable | -|---|---| -| `InductiveOracle` | full inductive spec/generation, the Theory-only `GenerationCertificate`/`addInductCertified` consumer boundary, environment alignment, lookup/monotonicity lemmas, and block-local pattern facts; ix must construct certificates from its ordinary semantic world rather than import Verify checker state | -| upstream sorry origins `VInductDecl.WF`, `VEnv.addInduct`, `addInduct_WF` | already removed on the fork baseline; publish and pin to shrink ix's audit, then broaden the spec enough to construct the oracle | -| abstract `RawProjRel` + `TrProjOK` | Theory-level projection relation and its lift/inst/WF/uniqueness/transport package | -| `literalWF`/`hlit` assumptions | Theory-level primitive/prelude readiness implies typing of `trLiteral` | -| ix recursor-pattern soundness | generated rules in `SimplePattern.iota` form plus `Params`-shaped soundness and non-overlap facts | -| `forallE_inv_stratified` and `sort_inv` sorry origins | live metatheory track, not permanently deferred | -| `NativeOracle` | remains an explicit consumer oracle; lean4lean documents and proves stability of the `.extra` extension point | - -### 2.5 Retired milestone vocabulary - -The companion's M0-M5 labels and this roadmap's former C0-C8 labels are -historical only. They mixed infrastructure, proof breadth, consumer handoffs, -and release work at incompatible scales, which made “M0 complete” ambiguous. -Section 13's L4L-00 through L4L-20C ladder supersedes both status systems and is -the only source of current milestone status. - -For historical discussion: companion M0/M1 are covered by completed L4L-00; -M2 is decomposed across L4L-01A through L4L-09C; M3 across -L4L-10A/L4L-10B/L4L-11; M4 across L4L-13A through L4L-15C; and M5's -nested/upstream pieces are L4L-09A through L4L-09C and L4L-20C respectively. -The old C0-C8 mapping is recorded after the new -milestone table. None of these legacy names may be used to report current -status. - -
-Archived M0-M5 assessment before the L4L ladder - -| Companion milestone | Archived assessment (superseded) | -|---|---| -| **M0** | Partially complete: upstream remote, token-aware sorry frontier, Nix CI, and a root-level non-ignored divergence ledger exist. The coherent generalized one-family/checked-analysis slice now includes recursive-Pi `Acc`, annotation-complete recursive candidate certification, generic generation-certificate assembly, the proof-carrying public non-identity transaction, three published produced packages, generic parameter/index family validation, exact `IndexedVec` family/`nil`/`cons` candidates, a complete executable outer producer equation, generic exact identity replay, checked `IndexedVec` E1 replay, arbitrary-length source-indexed operational list assembly, generic outer produced-package construction, retained source-indexed semantic ownership, automatic produced semantic-hierarchy assembly under `Nonempty`, semantic-owned generation/package projections, generic derivation of family/constructor view telescopes and terminal typing, exact dependent analyzer provenance, derived normalization identity, reconstructed post-family WF, analyzer-determined raw/view family and constructor alignment, generic raw telescope/result and view-terminal derivation, exact dependent constructor-list reconstruction, and a complete executable generation-readiness gate that derives checked WF plus every per-position shape record when combined with exact analysis and analyzer-owned view WF. At archival, the source checkpoint was `bbb45e0e950724cdbbd405d75e304e2020cecf82`, with tracked ledger child `c4fd62b23a89500154b113d849d183afbf84907f`, on `argumentcomputer/lean4lean`'s `jcb/induct` branch. Constructing the verified semantic inputs and analyzer-owned view WF from one arbitrary verified outer context and its exact traversals, then combining them with the strengthened gate to return a complete produced package, was the immediate M0 boundary. Ix Pin A and full downstream `IxTcVerify`/trust-audit validation are complete at the recorded pair Lean4Lean `5e5bb767b3491d21a71908d4c58bcbaa007283bb` and local ix snapshot `1f73f5c016907eadb8ed0dc86ac65b07eb24a145`; actual platform builds remain assigned to Linux/Darwin CI. | -| **M1** | Complete and exceeded on committed `master`: the vertical slice now covers parameters plus Nat/Bool/List/Prod/Option, with sorry-free `addInduct_WF`. | -| **M2** | In progress: the generalized one-family slice is green for Eq, HEq, an index-changing recursive family, and recursive-Pi `Acc`. Shared `Checked` analysis covers closure, all universe annotations, generated-name uniqueness, family-telescope self-reference, direct result shape, and recursive Pi targets; `Checked.WF env` carries normalized semantic evidence including the Prop impredicativity exception. Generalized artifacts, preservation, public accessors, and the `Acc` transaction agree. Actual alias metadata established the separate raw/view `Normalization` boundary; `NormalizedChecked` packages the raw singleton and checked view, both alias cases have combined semantic certificates, and the complete mixed generator/preservation path feeds a single traced `addInductGeneration` core. Verify's generic run/evidence bridge turns exact checker executions into Theory typing, equality, and `Normalization.WF`. `CandidateExprRun.spineEvidence` extracts raw/view telescopes and terminal results under an explicit stored-spine invariant; `TelResultDefEqEvidence.replacePrefix` transports constructor evidence to the family-emitted parameter prefix; and the dependent `GenerationCandidateRun` assembler produces complete `GenerationChecked.WF` without truncation, forall injectivity, or a selected arbitrary view. Exact checked decomposition, dependent analyzer provenance, and retained semantic evidence now derive view telescopes, terminal typing, normalization identity, post-family WF, raw/view family and constructor alignment, and the complete dependent constructor list. The consolidated executable hierarchy gate additionally derives checked WF and every per-position stored-spine/count record from exact analysis and analyzer-owned view WF; fixtures provide neither class of evidence, and missing/extra constructor regressions pin cardinality. `GenerationCandidatePackage` owns the resulting assembly and erases to the Theory-only `GenerationCertificate` consumed by `addInductCertified`; semantic-owned projections attach exact strengthened whole-call provenance to that same candidate. AliasFormer, the nested recursive-Pi AnnotatedPi, and the parameter/index/two-constructor `IndexedVec` all route their consumers through this boundary, including checked E1 replay. Generic construction of the verified semantic inputs and analyzer-owned view WF from arbitrary verified outer metadata, full environment-relative WHNF/defeq integration, positivity, small elimination, K, mutual/nested blocks, and kernel-complete coverage remain absent. | -| **M3** | In progress: the core Verify `AddInduct` trace retains `GenerationChecked` and its semantic certificate; normalized alignment, monotonicity, `TrEnv'` WF, and environment-history proofs are live. Actual-metadata Nat, Eq, `IndexedVec`, `Acc`, `AliasFormer`, and `AliasRec` replays pin all kernel rule RHSs, final equality, WF/alignment, and lookup uniqueness. The `AnnotatedPi` transaction additionally replays a nonempty recursive-Pi candidate whose raw constructor retains `outParam Prop`, including the generated recursor and iota rule. Generic candidate-spine extraction, exact constructor-prefix replacement, analyzer-determined normalized pairing/order, dependent constructor-list generation assembly, generic raw/view component and terminal derivation, generic view-telescope/result-typing derivation, analyzer-derived normalization alignment, reconstructed post-family WF, candidate-derived `GenerationChecked.WF`, exact outer package construction, automatic produced semantic-hierarchy assembly, retained semantic ownership, and derivation of checked WF plus every per-position shape record from one complete hierarchy gate are live. The generic package fixes generation/WF ownership across the public certified transaction and metadata replay; AliasFormer and AnnotatedPi provide two non-identity exact strengthened-producer instances, and `IndexedVec` provides the parameter/index/two-constructor identity-normalizing instance. Generic construction of the verified semantic inputs and analyzer-owned view WF from an arbitrary verified outer context, the broader I2-I4 replay matrix, and the block-local `Params` package remain absent. | -| **M4** | Not started: `TrProj` and all seven structural laws remain sorries. | -| **M5** | Not started: nested parity and the semantic upstream PR series have not begun. | - -
- -## 3. Architecture and trust contract +Apply these rules mechanically: + +1. Treat the accepted baseline as a **set upper bound**. Keep exact + `#guard_msgs` checks for named roots so growth or unexpected shrinkage + receives review; audit computation and proof closure separately. +2. Reject `sorryAx` from every release root; a statement reaching a sorried + relation is not release-clean merely because its proof body has no sorry. +3. Reject every known-false or unproved cache equation from supported roots + and ban project-specific axioms from the global simp set; removing `[simp]` + is containment, not discharge. +4. Expanding the logical baseline or platform manifest requires an explicit + design decision; difficulty, convenience, or prior existence in + `Verify/Axioms.lean` is not justification. +5. A consumer's trusted oracle stays in the consumer; it authorizes no + lean4lean Theory axiom, assumed inductive oracle, or opaque projection + relation. +6. A normalization view is untrusted data until it has both computed shape + coherence and an environment-indexed `Normalization.WF` proof derived from + checker/defeq evidence; neither Verify nor any consumer may assume a + normalization oracle or add a reduction axiom. +7. Before closing a milestone checkbox, run both the exact guards and a + generated transitive-closure check of the public roots; the same audit + applies to every exported consumer-facing theorem. + +## 4. Architecture and trust contract These are invariants at every milestone. 1. **Theory points downward only.** `Lean4Lean/Theory/` imports no `Lean4Lean/Verify/`. Mathematical declarations mention `VExpr`, `VLevel`, - `VEnv`, and proof objects, not `Lean.Expr`, `FVarId`, `ConstMap`, or ix's - `KExpr`/addresses/catalogs. -2. **Consumer-neutral semantics.** No ix namespace, hash, address, cache, or - checker-state type enters lean4lean. Ix-specific transport stays in ix. + `VEnv`, and proof objects, not `Lean.Expr`, `FVarId`, `ConstMap`, or any + consumer's expression/address/catalog types. +2. **Consumer-neutral semantics.** No consumer-specific namespace, hash, + address, cache, or checker-state type enters lean4lean; consumer-specific + transport stays downstream. 3. **Theory-shaped APIs live in Theory.** Move literal encodings, the VExpr-only local-declaration core, primitive readiness, projection semantics, and generally useful pattern lemmas down. Leave `Lean.Expr` @@ -1438,17 +439,19 @@ These are invariants at every milestone. not assume translated recursor shapes as hypotheses. 5. **Staging is monotone and temporary.** Every Stage-N predicate is an executable, proved subset with rejection fixtures. The final public - contract covers the full safe implementation. Never replace a missing case - with `sorry`, an oracle, or an overstrong premise that real kernel output - cannot satisfy. + contract covers the full safe implementation. Extend the shared + `Checked`/`Normalization`/`GenerationChecked` contracts monotonically; do + not reintroduce parallel Boolean analyses or downstream de Bruijn + reconstruction, and never replace a missing case with `sorry`, an oracle, + or an overstrong premise that real kernel output cannot satisfy. 6. **Checked analysis and normalization have explicit roles.** The raw `VInductDecl` is the stored constant payload. `Normalization` supplies a shape-compatible analysis view, and `Normalization.WF env` justifies that view by Theory defeq at the kernel's declaration stages. `Checked` is the environment-independent result computed from the view; `Checked.WF env` supplies its semantic typing evidence. Do not fold `VEnv`, `Lean.Expr`, or - ix-specific evidence into the computational analyzer, and do not treat a - shape-compatible view as semantically valid without its WF proof. + consumer-specific evidence into the computational analyzer, and do not + treat a shape-compatible view as semantically valid without its WF proof. 7. **One accepted source/view pair, one artifact path.** A normalized block accepted by the public transaction must preserve the raw metadata payload, use the same checked view for every WHNF-sensitive decision, generate and @@ -1456,2185 +459,437 @@ These are invariants at every milestone. it in Verify. Parallel raw/view or direct/generalized generators are permitted only as short-lived proof migrations; no checkpoint may accept a case for which the public accessor returns a weaker or different - recursor/rule set. - The consumer-facing erasure is `GenerationCertificate`: it must couple the - exact generation with its WF proof, and `addInductCertified` must remain - definitionally the same computation as `addInductGeneration`. The proof may - authorize preservation but may not affect generated artifacts or transaction - control flow. -8. **Additive migrations first.** Before changing an existing Theory - signature, grep `ix:Ix/Tc/Verify/` and the upstream Verify layer. Add a new - API and compatibility theorem first, flip ix, then remove the old path. -9. **Classic-module compatibility.** Ix currently uses classic imports because - lean4lean does. Do not introduce `module` headers in reachable files without - a coordinated migration. + recursor/rule set. The consumer-facing erasure is `GenerationCertificate`: + it must couple the exact generation with its WF proof, and + `addInductCertified` must remain definitionally the same computation as + `addInductGeneration`. The proof may authorize preservation but may not + affect generated artifacts or transaction control flow. +8. **Additive migrations first.** Before changing an existing exported Theory + signature, add the new API and a compatibility theorem or re-export first; + remove the old path only after a deprecation window for downstream + consumers. +9. **Classic-module compatibility.** Do not introduce `module` headers in + reachable files without a coordinated migration; downstream consumers use + classic imports because lean4lean does. 10. **Axiom budget is checked per root.** New Theory roots may depend only on - the accepted logical baseline (`propext`, `Classical.choice`, `Quot.sound`, - usually a subset). Verify bridge contracts need a separate, named manifest. - “It was already in `Verify/Axioms.lean`” is not acceptance. -11. **Every fork divergence is tracked.** Create a tracked - `upstream-divergence.md` (or deliberately track `/plans`) with one entry per - semantic/API delta, its ix impact, test, upstream issue/PR, and removal - condition. Empty means fully upstreamed. - -## 4. Dependency spine - -The `S`/`I`/`E`/`L`/`P`/`M`/`V`/`T` labels below are stable work-package -references. They describe proof ownership and preserve detailed checklists; -they do **not** carry milestone status. Section 13 is the only execution order -and the only place where a milestone may be `queued`, `active`, or `complete`. -There is no `partially complete` milestone state: useful prerequisites for a -future milestone remain recorded in their track, but that milestone stays -queued until every exit condition passes. - -The primary execution order is deliberately serial. Letter suffixes are real -milestones, not subitems that may be completed as a batch: - -```text -published baseline - -> staged singleton semantic inputs - -> family-validation semantics and post-family staging - -> constructor-validation trace and semantics - -> generic singleton package closure - -> isolated level proof - -> singleton validation/normalization/positivity/elimination closure - -> mutual representation, validation, then generation/replay - -> nested representation, transformation, then generation/replay - -> generated-pattern core, then environment assembler - -> ix inductive-oracle handoff - -> Theory local-declaration surface, then literal/prelude readiness - -> projection API decision, semantics, and laws - -> projection checker, eta, and import closure - -> metatheory route selection and sort inversion - -> remaining injectivity and weakening inversion - -> Church-Rosser proof, then extension contract - -> recursor reduction, environment/checker closure, and zero-sorry gate - -> axiom retirement, differential corpus, and upstream release -``` - -No later milestone begins until the active one is complete. Read-only design -reconnaissance for a later milestone is allowed when it changes the active -design, but implementation and publication stay serial. This prevents several -half-migrated public artifact paths from being live simultaneously and gives -each checkpoint one auditable claim. Projection semantics intentionally waits -for the full inductive/structure descriptor even though preliminary design -work could be done earlier. - -## 5. Track S — stabilize and publish the work already done - -### S0 — make the active indexed port green (completed by L4L-00) - -- **Status: complete in the development branch on 2026-07-30.** The exact Theory and - Verify build gate passes; keep the following as the regression checklist. -- [x] Finish the `Stage2Env` to `Stage3Env` conversion from line ~2000 onward in - `InductiveLemmas.lean`. -- [x] Update every old helper application to the indexed signatures: motives now - take `ty`, minors take both `ty` and constructor lists, recursive positions - carry index spines, and result typing consumes `SpineWF`. -- [x] Reprove the recursor type, recursor constant, constructor fold, iota LHS/RHS, - rule WF, and final `addInduct_WF` in that order. Do not patch from the bottom; - each generated component should have a named typing lemma used by the next. -- [x] Rename residual Stage-2 declarations/comments only after the proof compiles, - to keep review mechanical. -- [x] Restore an executable `#print axioms`/`#guard_msgs` check for - `VEnv.addInduct_WF`; it currently accepts exactly `propext`, - `Classical.choice`, and `Quot.sound`. -- [x] Finish the exact gates in §13. The sorry audit, - `lake build Lean4Lean.Theory Lean4Lean.Verify`, formatter check, and - `nix flake check --accept-flake-config --print-build-logs` all pass. A - successful default `nix build` alone remains insufficient. - -### S1 — publish safe checkpoints (ongoing gate; baseline in L4L-00) - -- [x] Publish the coherent Stage-3/I1/E1/bounded-I2 checkpoint after rerunning - the full gate. Revision `472a6f0417e574aaf277fc0150284d0b733aec3a` - is published on `argumentcomputer/lean4lean` after the sorry-frontier, - Theory/Verify build, formatter, diff, and Nix-build gates passed. Generalized - recursive-Pi preservation, the public artifact switch, `Acc` transaction and - replay, the additive paired normalization boundary/alias certificates, - and exact axiom guards are green. At that checkpoint, the broader - cross-system evaluation gate in §13 was still outstanding. The public transaction - remains the coherent raw-normal-form subset; do not checkpoint midway - through the later raw/view artifact or transaction switch. Keep - `efb2a2b2` as the recoverable Stage-2 checkpoint and never publish an - intermediate red or semantically split state. -- [x] Publish the candidate-context-provenance checkpoint after the same local - source and default-Nix gates. Revision - `1fb7d6ef9042c5a80b2de9320c88ac0f3ce404cb` context/source-indexes every - recursive candidate trace, derives checker-output translations from verified - executions, and transports alias-valued inferred types to structural Pi - sorts without adding an axiom. It remains the fixed `master` baseline; at - that checkpoint, the broader cross-system evaluation gate was outstanding. -- [x] Publish the recursive-normalization-candidates checkpoint only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Revision - `9fde4c6b6c34cdb5b7c71aebfff25ac75a269a56` constructs exact verified root - and Pi-binder contexts, proves binder freshness and empty-state name - reservation, recovers the root Theory translation from the retained full - check, and recursively certifies raw-domain traces. The actual AliasFormer - metadata exercises the automatic-root path, and every new semantic root has - an exact axiom guard. The exact sorry-frontier, full Theory/Verify build, - formatter, diff, Theory import-boundary, and default-Nix gates passed on - 2026-07-31. `master`, `origin/master`, and the digama upstream were not - moved; the cross-system evaluation gate was then outstanding. -- [x] Publish the annotated-normalization-binders checkpoint only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Revision - `b2839120ee3c743fd621154096346c7319141f14` preserves raw annotation syntax, - structurally certifies all four `consumeTypeAnnotations` paths, retains an - exact successful ordinary-checker equality run, refines it to Theory - equality, and transports recursive body evidence across the raw, consumed, - and normalized binder contexts. The former raw-domain restriction is gone; - fixtures cover all four positive gadgets and one exact non-defeq rejection. - The exact sorry-frontier, full Theory/Verify build, formatter, diff, Theory - import-boundary, fixture-target, and default-Nix gates passed on 2026-07-31. - `master`, `origin/master`, and the digama upstream were not moved; the - cross-system evaluation gate was then outstanding. -- [x] Publish the singleton-normalization-candidates checkpoint only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Revision - `a84aa19c3e243f9b35bd5baa988c16a0cce39093` adds exact root endpoint - certificates, source-indexed constructor-list runs, and a singleton family - assembler that constructs Theory `Normalization` and `NormalizationRun` - without `head!`, unchecked `zip`, or a caller-selected unrelated view. - AliasFormer's real pre-family and post-family candidate positions now drive - its live normalization, dependent checked analysis still succeeds, and a - truncated constructor view is rejected before transaction construction. - The exact 20-entry sorry frontier, full Theory/Verify build, formatter, diff, - Theory import-boundary, fixture-target, and default-Nix gates passed on - 2026-07-31. `master`, `origin/master`, and the digama upstream were not - moved; the cross-system evaluation gate was then outstanding. -- [x] Publish the candidate-generation-certificates checkpoint only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Revision - `c2b1c4fb5f0f992391301c1486e076f13a3af1b3` extracts the exact raw/view - telescope and terminal-result evidence from stored-spine candidate runs, - transports declared constructor parameter prefixes to the emitted family - prefix in exact induced contexts, folds a dependent source-indexed - constructor list, and assembles generic `GenerationChecked.WF`. - AliasFormer's real non-identity family/constructor candidates now supply its - existing checked end-to-end transaction through this generic assembler. - The exact 20-entry sorry frontier, full Theory/Verify build, formatter, diff, - Theory import-boundary, fixture target, exact axiom guards, and default - `nix build` gate passed on 2026-07-31. `master`, `origin/master`, and the - digama upstream were not moved; the cross-system evaluation gate was then - outstanding. -- [x] Publish the annotated recursive-Pi replay checkpoint only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Revision - `a1d8943a7b831b050fb8bc0689db2a186850a7f1` adds - `AnnotatedPi.mk : ((p : outParam Prop) → AnnotatedPi) → AnnotatedPi`, proves - the exact ordinary-checker full-check, WHNF, and complete lazy-delta - raw-to-consumed equality traces, recursively certifies the nested candidate, - and assembles `NormalizationCandidateRun`, `GenerationCandidateRun`, and - `GenerationChecked.WF`. Its checked `AddInductTrace`/`TrEnv'` replay pins the - final environment, generated recursor, and iota rule while retaining raw - annotation syntax. The annotation producer's opaque-helper agreement is - recorded as runtime validation rather than a semantic proof field; no new - axiom, oracle, native evaluator, or opaque equation was added. Six exact - root guards pin the inherited transitional Verify closure and the smaller - `[propext, Quot.sound]` iota-membership closure. The exact 20-entry sorry - frontier, full Theory/Verify build, formatter, diff, Theory import boundary, - fixture target, and default `nix build` gate passed on 2026-08-01. `master`, - `origin/master`, and the digama upstream were not moved; the cross-system - evaluation gate was then outstanding. -- [x] Publish the certified non-identity consumer checkpoint only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch at - `6a7788245831b24ae690cfb83659e892c2065be8`. The complete local gate, - including the current-host full flake checks, is green, and remote-ref - verification confirms only `origin/jcb/induct` moved. - This checkpoint adds the Theory `GenerationCertificate` and - `addInductCertified` API, its trace/atomic/WF theorems, the dependent Verify - candidate package and checked replay constructor, the AliasFormer and - AnnotatedPi public transaction fixtures, and the opaque-`outParam` - whole-candidate rejection. Exact guards demonstrate the clean generic - Theory closure and the retained concrete Verify closures. `master`, - `origin/master`, and every digama/upstream ref remain unchanged. -- [x] Publish the executable-candidate producer checkpoint only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch at - `bc37d436dfd6f7d6fa1ae186c0951e48677b931f`. AliasFormer now proves the - exact successful `buildNormalizationCandidate` equation across family - validation, raw-family insertion, constructor validation, and dependent - candidate-list assembly. The resulting - `ProducedGenerationCandidatePackage` supplies both its proof-erased Theory - certificate and checked Verify replay. The exact 20-entry sorry frontier, - focused and full Theory/Verify builds, formatter, diff and import-boundary - audits, default `nix build`, and all six current-host flake checks passed on - 2026-08-01. Exact guards record the three existing expression-cache - contracts added by the outer execution proof. `master`, `origin/master`, and - every digama/upstream ref remain unchanged; `--all-systems` was still the - pre-ix/release gate at this checkpoint. -- [x] Publish the AnnotatedPi outer-validation checkpoint only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch at - `5e5bb767b3491d21a71908d4c58bcbaa007283bb`. The recursive occurrence test is - now transparent and structural, and the fixture proves exact family - validation, freshness, recursion detection, raw-family declaration, and - recursive inner-Π `inferType`/`ensureType` execution. This is progress toward, - not completion of, AnnotatedPi's whole-call produced package. The same commit - restores CI all-system evaluation by replacing the nested unrealized - `fileset.toSource` with `inputs.self.outPath`; the narrower source filter is a - follow-up optimization. The 119-target source build, exact 20-sorry audit, - current-host full flake check, and exact - `nix flake check --all-systems --no-build --accept-flake-config` gate pass. - `master`, `origin/master`, and every digama/upstream ref remain unchanged. -- [x] Publish exact AnnotatedPi constructor validation and positivity on - `argumentcomputer/lean4lean`'s `jcb/induct` branch at - `33b99f4e462eaa02b78aba061dcac37bd64d84c4`. The checkpoint validates the - complete annotated recursive-Π constructor in the real post-family - environment and keeps both master refs and digama/upstream unchanged. -- [x] Complete AnnotatedPi's exact recursive candidate traversal, dependent - family/constructor list assembly, successful whole - `buildNormalizationCandidate` equation, and - `ProducedGenerationCandidatePackage`; published only on `jcb/induct` at - `a3ff9921cc7ef23ebbc808b4dcbab6a119378507` after the full Lean/Nix - checkpoint gate. -- [x] Publish generic singleton family validation through arbitrary - parameter/index candidate spines only on `argumentcomputer/lean4lean`'s - `jcb/induct` branch at - `9a865ea02d4326e60d0e5fd663d6efe79c735b1c`. The candidate trace now exposes - its root WHNF, terminal context/result, positional parameter locals, index - count, and exact emitted `InductiveStats`; the executable - `checkInductiveTypes` loop is replayed from these source-indexed facts rather - than a zero-parameter fixture theorem. Exact core axiom guards remain within - the permitted logical baseline. -- [x] Publish the first real parameter/index family instance only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch at - `a62736281ea419d7d0ee13d76f0e0fd9a4d9d90f`. The new - `IndexedVecCandidate` module proves exact full-check, WHNF, fresh-local, - reflexive domain-equality, recursive candidate, and complete family-validator - executions for `IndexedVec.{u} (α : Type u) : Nat → Type u`, including the - computed parameter/index statistics. The focused module build, 120-job full - Theory/Verify build, exact 20-sorry audit, formatter/diff gates, default Nix - build, and all six current-host flake checks pass on 2026-08-02. Exact guards - record the existing Verify implementation contracts and inherited `sorryAx`; - no axiom was declared. `master`, `origin/master`, and every digama/upstream - ref remain unchanged. The ordered `nil`/`cons` package is deliberately the - next checkpoint, not part of this claim. -- [x] Publish the verified syntactic-equivalence fast path only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch at - `f0d80f8ba21e44a694566ea3d6469be85a809307`. Reflexive `isDefEq` calls now - return before `isDefEqCore` and preserve the incoming checker state; - `TypeChecker.Inner.isDefEq.WF` proves soundness by transporting the strict - translation across `Expr.eqv`. Exact AnnotatedPi, AliasRec, and IndexedVec - fixtures were updated and their obsolete equivalence-manager simulations - removed. The exact 20-sorry audit, focused and 120-job full Lean builds, - formatter/diff/import-boundary gates, default Nix build, all-system flake - evaluation, and all six current-host flake checks pass on 2026-08-02. No - axiom was added; `master`, `origin/master`, and every digama/upstream ref - remain unchanged. -- [x] Publish the `IndexedVec` constructor and outer-producer series only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Revisions `67326590` and - `c40a471d` certify `nil` and the dependent recursive `cons` candidate in the - exact post-family environment; `c739d412` stabilizes candidate-context - provenance; and `82f4a54c` proves the complete one-parameter, one-index, - ordered two-constructor `buildNormalizationCandidate` result. Revision - `d553930a` adds generic exact identity replay at caller-selected Theory - endpoints. At that checkpoint local, Git, and `origin/jcb/induct` agreed at - `d553930a`; both master refs and every digama/upstream ref remained unchanged. -- [x] Complete the `IndexedVec` semantic package from that exact executable - result and publish it at `cf3d5a47d35867e0e6ebe023c0803982e3e36cd1`. - Recursive identity for the family, `nil`, - and `cons` supplies the family/constructor `GenerationCandidateRun`; the - resulting `ProducedGenerationCandidatePackage` drives both the certified - Theory transaction and checked E1 replay. Exact guards pin the public package - and `TrEnv'` roots to the existing transitional Verify closure. -- [x] Run formatter/diff/import-boundary gates, describe, and publish the - `IndexedVec` semantic replay checkpoint without moving either master or any - digama/upstream ref. The semantic commit is `cf3d5a47`; local, Git, and - `origin/jcb/induct` agree at its ledger-only follow-up `d35a2f6c`. -- [x] Generalize exact executable list assembly and publish it only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Commit - `c9e4ae2d26f28e0adb0c21ffde0e11b42bb691c2` adds arbitrary-length dependent - family-type, constructor, and complete-family `Produced` witnesses, routes - AliasFormer and AnnotatedPi through the singleton instances, and routes - `IndexedVec` through the ordered two-constructor instance. The three generic - `.normalize` theorems are guarded at exactly - `[propext, Classical.choice, Quot.sound]`. Focused and full Lake builds, the - exact 20-sorry audit, all Nix gates, formatter, diff, and import-boundary - checks pass. Local, Git, and `origin/jcb/induct` agree at ledger child - `9ff6be1cac7a3b604b1209d11e0380a858d49574`; neither master nor any - digama/upstream ref moved. -- [x] Generalize the outer produced-package construction and publish it only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Commit - `a7d101b5e16f1258c6f5c2a7ea08e55f45eb17f1` adds - `GenerationCandidateRun.producedPackage`, requires one exact - source/candidate-indexed semantic run plus the matching whole-call producer - equation, and migrates AliasFormer, AnnotatedPi, and `IndexedVec`. Its exact - inherited `[propext, sorryAx, Classical.choice, Quot.sound]` closure is - guarded. Focused and full Lake builds, the exact 20-sorry audit, all Nix - gates, formatter, diff, and import-boundary checks pass. Local, Git, and - `origin/jcb/induct` agree at ledger child - `80f9dce41d0798bbb38d41c5abf9a21e25f74bc1`; neither master nor any - digama/upstream ref moved. -- [x] Retain one source-indexed semantic hierarchy for normalization and - generation and publish it only on `argumentcomputer/lean4lean`'s - `jcb/induct` branch. Commit - `f0caf16c5788d094fdbf1e990884c0c061d6fc75` adds - `CandidateExprSemanticRootRun`, its automatic existential root constructor, - and dependent constructor-list/family/singleton-normalization ownership; - AliasFormer, AnnotatedPi, and `IndexedVec` all project their existing - normalization and generation evidence from it. Focused and full Lake builds, - the exact sorry-frontier check, default Nix build, all six current-host flake - checks, whitespace checks, and a direct axiom audit pass. Local, Git, and - `origin/jcb/induct` agree at ledger child - `ea14f31ee172bef30b94c8b5f111bc109965f00d`; neither master nor any - digama/upstream ref moved. -- [x] Assemble the produced semantic hierarchy and publish it only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Commit - `e3cf22d293b081ba11be63e910d0d1e1510a042f` adds - `CandidateExprSemanticRootInput`, dependent constructor/family/normalization - inputs, and `NormalizationCandidateSemanticInput.exists_ofProduced`. - Together they pair the arbitrary-length operational list witnesses with the - exact verified contexts and strict translations at the same source-indexed - candidate and return `Nonempty ProducedNormalizationCandidateSemanticRun`. - The retained checker selects each Theory view; the operational result does - not. Semantic-owned family/constructor generation structures and their - compatibility/package projections remove parallel roots and spines. - AliasFormer and `IndexedVec` exercise the complete path. Neither master nor - any digama/upstream ref moved. -- [x] Harden semantic ownership and publish it only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Commit - `7e5f4f7715cf71be8d09a583f0ec0d8f7aa02e72` migrates AnnotatedPi's remaining - hierarchy and generation/package path, adds exact compile-time guards for - the generic semantic inputs and projections plus all three fixture roots, - proves automatic `IndexedVec` hierarchy assembly retains `nil`/`cons` order, - and rejects the swapped view at `normalization?`. The exact 20-sorry audit, - focused 118-job semantic replay, 157-job default Lake build, 124-job Nix - proof build, default Nix build, all six current-host flake checks, all-system - no-build evaluation, formatter, diff, and Theory import-boundary checks pass. - Local, Git, and `origin/jcb/induct` agree at ledger child - `1093311b9c4e74f3d1750676429acc5d112724fa`; neither master nor any - digama/upstream ref moved. -- [x] Derive structural generation evidence and publish it only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Commit - `2b1d802fc6796e7317ec1d24708a3ebdda416655` adds exact checked - family/constructor shape theorems, derives the family terminal sort and every - constructor result-target typing judgment, recovers view telescopes from - exact non-forall terminals, and removes fixture-owned `viewTel`/`rightType` - fields across AliasFormer, AnnotatedPi, and `IndexedVec`. The exact 20-sorry - audit, focused direct compiles, 124-job Theory/Verify build, 157-job default - Lake build, 124-job Nix proof check, default Nix build, all six current-host - flake checks, all-system no-build evaluation, formatter, diff, and Theory - import-boundary checks pass. Local, Git, and `origin/jcb/induct` agree at - tracked ledger child `0270843dccd2e0599a48b40aa31d4fe6eb8c94af`; - neither master nor any digama/upstream ref moved. -- [x] Derive generation analyzer provenance and publish it only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Commit - `a64fe982bc2a7f1c6c34ec82565ec5fe1c26350b` replaces each semantic - generation fixture's bare normalization equality with the exact successful - dependent `generation?` equation. Theory derives the retained normalization - from successful `check?`/`generation?`; Verify reconstructs post-family - environment WF from retained semantic evidence and exact raw-family - insertion. AliasFormer, AnnotatedPi, and `IndexedVec` now omit both - `normalization_eq` and `typeEnv_wf`. Exact guards pin the two Theory roots and - two Verify derivations. The exact 20-sorry audit, focused direct compiles, - 124-job Theory/Verify build, 157-job default Lake build, default Nix build, - all six current-host flake checks, all-system no-build evaluation, formatter, - diff, and Theory import-boundary checks pass. Local, Git, and - `origin/jcb/induct` agree at tracked ledger child - `4b66e50e3df95baab3f93a97867c4e31dc6ed21d`; - neither master nor any digama/upstream ref moved. -- [x] Derive generation shape alignment and publish it only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Commit - `5aa9ab69fce1c7dab3f4ca357f6ed8f349fd9397` introduces the reduced - `GenerationCandidateSemanticShapeRun` boundary. Exact dependent analysis - determines raw/check family identity, normalized constructor pairing and - source order, while total stored-spine counts determine raw - telescope/results and exact checked shape determines view terminals. The - dependent recursive assembler reconstructs the full constructor run list - without caller-selected pairs, `zip`, truncation, or reordering. AliasFormer, - AnnotatedPi, and the two-constructor `IndexedVec` fixture now provide no - component equations or normalized-pair alignment. Exact guards pin both - singleton alignment roots to the small inherited Verify set and the public - shape projection to the unchanged checked semantic set. The exact 20-sorry - audit, focused direct compiles, 124-job Theory/Verify build, 157-job default - Lake build, default Nix build, all six current-host flake checks, all-system - no-build evaluation, formatter, diff, whitespace, and Theory import-boundary - checks pass. Local, Git, and `origin/jcb/induct` agree at tracked ledger child - `fda0016632e3b64d14e0628dbccd230338c531c0`; neither master nor any - digama/upstream ref moved. -- [x] Consolidate generation readiness and publish it only on - `argumentcomputer/lean4lean`'s `jcb/induct` branch. Commit - `bbb45e0e950724cdbbd405d75e304e2020cecf82` adds one executable Boolean gate - over the full singleton family/constructor hierarchy and couples its success - to the exact ordinary producer equation in - `ProducedGenerationShapeCandidate`. The gate checks emitted-spine - preservation, full raw telescope lengths, and constructor-list cardinality; - the `IndexedVec` regressions reject both missing and extra raw constructors. - Exact dependent analysis and WF of the analyzer-owned view declaration - derive checked WF and every source-indexed family/constructor shape record. - AliasFormer, AnnotatedPi, and `IndexedVec` now supply neither checked WF nor - per-position generation-shape structures. Bare producer success remains - operational provenance only and is not promoted to Theory meaning or - stored-spine authority. Exact guards pin the pure executable roots to - `propext`/`Classical.choice`/`Quot.sound`; semantic package roots inherit only - the existing checked-semantic closure. The exact 20-sorry audit, focused - direct compiles, 124-job Theory/Verify build, 157-job default Lake build, - 124-job Nix proof check, default Nix build, all six current-host flake checks, - all-system no-build evaluation, formatter, whitespace, and Theory - import-boundary checks pass. The tracked ledger child is - `c4fd62b23a89500154b113d849d183afbf84907f`; neither master nor any - digama/upstream ref moved. -- [x] Update the sorry-frontier comments to describe the current Stage-3 - generalized one-family proof. -- [x] Create the root-level, non-ignored divergence ledger and record the - current development delta from upstream `0c38ab8`; the tracked ledger is now - refreshed against source parent `bbb45e0e` for this checkpoint. -- [x] Run ix Pin A against a green certificate-bearing `jcb/induct` checkpoint, - build the complete `IxTcVerify` target, and reconcile its audits. The local ix - `jcb/ix-formalization2` snapshot - `1f73f5c016907eadb8ed0dc86ac65b07eb24a145` pins Lean4Lean - `5e5bb767b3491d21a71908d4c58bcbaa007283bb`; the exact local sorry frontier and - completed/statement root audits pass, and the former `VInductDecl.WF`, - `VEnv.addInduct`, and `VEnv.addInduct_WF` direct `sorryAx` origins are gone. - The full `InductiveOracle` handoff remains L4L-11, after the - L4L-08A–L4L-09C breadth and L4L-10A/L4L-10B pattern package. - -## 6. Track I — kernel-complete inductives - -The present generalized one-family generator is a valuable vertical slice, -not the final data model. The shared checked analysis and semantic layer now -exist: -`VInductDecl.Checked` exposes normalized type/index telescopes, result sort, -recursive-argument descriptions, elimination mode, names, constructors, -motives, minors, recursor, and generated rules. `checked?`, `stage3`, -`addInduct`, the preservation proof, fixtures, and Verify alignment all consume -that result, while `Checked.WF env` gives the normalized data its -environment-relative meaning. Extend these contracts monotonically as I2-I4 -add cases; do not reintroduce parallel Boolean analyses or downstream de -Bruijn reconstruction. The alias audit adds a second invariant: raw kernel -metadata and normalized analysis syntax are distinct objects. -`NormalizedChecked` is now the one-family data boundary joining those objects -and, through `Checked.identityGeneration`, the public identity artifact input. -It is not passed directly to the general transaction: a -`GenerationCertificate` erases the normalized/checker provenance to the exact -`GenerationChecked` value plus its semantic WF proof, and -`addInductCertified` consumes that Theory-only boundary. Preserve raw constant -payloads and generated binder syntax while using the semantically justified -view for WHNF-sensitive classification. Do not silently overwrite one with the -other or let each consumer choose its own normalization. - -### I1 — finish direct indexed families (completed by L4L-00) - -- [x] Complete S0 for one type with parameters, indices, direct recursive fields, - never-zero or syntactically subsingleton elimination, and generated Eq/HEq - recursors. -- [x] Add `addInduct_le`, generated-constant lookup lemmas, generated-rule - membership lemmas, name-freshness consequences, and failure/atomicity lemmas. - Ix's oracle needs these consequences directly; it should not unfold a large - `foldlM` proof. These are exposed through `VEnv.AddInductSuccess` and - convenience theorems, with a dedicated axiom-closure guard. -- [x] Add `IndexedVec` as a nontrivial indexed fixture whose recursive - occurrence changes indices; compare its recursor and both iota rules exactly - with the kernel. - -### I2 — complete one-family kernel behavior (L4L-01A–L4L-07) - -**Status: the direct-indexed and bounded recursive-Pi slices are green through -checked analysis, generalized artifacts, preservation, the public transaction, -and actual-metadata E1 replay. The normalization/defeq representation decision -is made; the paired raw/view checked-block data boundary, structural -projections, identity compatibility, and first semantic block fixtures are -green. The raw-syntax-preserving mixed artifact implementation matches the -identity and two alias kernels and is proved well formed through the complete -ordered rule fold. All live `Checked` artifact accessors are now canonical -identity specializations of that mixed implementation, with exact generic and -Nat/Eq/`IndexedVec`/`Acc` compatibility checks. The normalized Theory -transaction core, trace consequences, atomicity, and preservation theorem are -now green, as are the public semantic delegation and direct alias -transactions, normalized Verify trace, six actual-metadata replays, and first -checked full-check/WHNF-to-Theory producer. Both fixed alias cases now have -complete checked `GenerationChecked.WF` roots and checked end-to-end -`AddInductTrace`/`TrEnv'` replays. The complete `AnnotatedPi` candidate adds a -nested recursive-Pi annotation normalization/generation/replay path, including -the generated recursor and iota rule. A dependent Verify package and -proof-erased Theory certificate now provide public non-identity transaction -wiring for both AliasFormer and AnnotatedPi. `IndexedVec` now extends exact -outer execution to a parameter, an index, and two ordered constructors, and -the identity-replay bridge needed for its semantic spine is live. Published -checkpoint `cf3d5a47` completes its producer-selected semantic package, -certified Theory transaction, and checked E1 replay. One-family parity is not -complete because -generic arbitrary-constructor construction remains, alongside full positivity, small -elimination, K behavior, and the full differential matrix.** -The following order mirrors `Inductive/Add.lean` and keeps each widening -executable and proved: - -- [x] Introduce dependent `VInductDecl.Checked`/`checked?` and make descriptor - existence the public acceptance result. Route recursor/rule generation, - `VEnv.addInduct`, `addInduct_success`, `addInduct_WF`, Theory fixtures, and - Verify's `AddInductTrace` through the same checked value. -- [x] Record normalized parameters, indices, result level, elimination mode, - generated names, constructor fields, and recursive positions/index spines. - `RecArg.binders` is now populated for recursive Pi fields; retain - `targetType` so I3 mutual recursion does not force a second consumer-facing - redesign. -- [x] Check closed family/constructor metadata and internal generated-name - uniqueness computationally. Export proof-level closure/`Nodup` consequences, - add positive Nat/Eq/`IndexedVec` descriptor fixtures, and add duplicate-name - and loose-variable rejection fixtures. Keep environment-relative freshness - in the `addConst` transaction. Type-, constructor-, and recursor-collision - regressions now exercise stable rejection theorems rather than depending on - the internal fold order. -- [x] Finish the environment-independent, VExpr-normal-form portion of - `checkInductiveTypes`: declaration/type/constructor universe counts, - parameter count, raw parameter/index telescopes, sort result and result-level - well-formedness, range validity of every universe annotation, prohibition of - family self-reference in parameter/index domains, constructor parameter - spine, and direct result family/head/arity. Export the combined facts through - `Checked.analysis_accepted` and `Checked.direct_anatomy`; cover every branch - with the malformed-result/universe/telescope fixture matrix. -- [x] Add `Checked.WF env` for the environment-relative `OnTel`, constructor - field, universe-bound, and result-spine obligations. Prove both migration - directions and `decl.WF env ↔ ∃ checked, decl.checked? = some checked ∧ - checked.WF env`; make `addInduct_WF` consume this certificate. Guard all - three compatibility roots at exactly `propext` and `Quot.sound`. -- [x] Implement the one-family raw-VExpr counterparts of `isValidIndApp?` and - `isRecArg` beneath Pi telescopes. `recTarget?` requires family-free domains, - accepts only a terminal application of the current family to the declaration - parameters and family-free indices, and populates the complete binder - telescope. Computed `Acc` facts pin its field index, two binders, target type, - and terminal index spine. Exact kernel-differential fixtures cover a family - in a recursive-Pi domain, a changed fixed parameter at the recursive target, - and a family occurrence inside the recursive target's index; each also - reduces through public `checked?`/`addInduct` rejection. This is - raw-normal-form parity only; the later normalization task still owns - WHNF/defeq parity. -- [x] Define the generalized artifacts as a reviewable migration step: - `minorIH`/`minorTypeRec`, `recTypeRec`/`recConstRec`, `ruleBinders`, - `ruleCall`/`ruleIH`, and `ruleRec`/`rulesRec`. Exact fixtures prove by - reduction that the generalized constant and rule are `Acc.rec` and its - functional iota RHS (modulo the kernel universe permutation). -- [x] Finish generalized preservation. The proof now covers semantic - `RecArg.WF`, universe transport, binder/index typing, generalized minor and - recursor well-formedness, rule-binder/rule-type typing, recursive-field - application, normalization of lifted `minorIH` entries to `ruleIH`, - list-level application of every functional recursive call, - `minorAppRec_hasType`, `recRuleAppRec_hasType`, `ruleRec_WF`, and the - generalized rule fold. Exact guards keep all six exported recursive-Pi roots - at the standard Theory axiom baseline. -- [x] Collapse the migration to one public path. Make - `Checked.minorTypes`/`recursor`/`generatedRules`, `VEnv.addInduct`, - `AddInductSuccess`, and `addInduct_WF` consume the generalized artifacts. - The direct definitions remain only as specialization/reference code and are - not semantically live through a public accessor. Completion is gated by - exact public `accDecl.checked?`, `addInduct`, generated lookup/rule - membership, `Ordered`, and failure-atomicity fixtures. -- [x] Replay `Acc` through E1 using Lean's actual `inductInfo`, `ctorInfo`, and - `recInfo`; compare recursive-argument metadata, recursor universe order, and - the lambda-wrapped rule RHS. The replay proves exact transaction equality, - lookup uniqueness, final WF/alignment, and definitional equality between the - actual kernel `RecursorRule.rhs` and `ruleRec`. Generic `TrEnv'.of_value` - supplies preservation of older values for this transaction class; the - seed-before-Nat fixture exercises the same persistent-map path concretely - without duplicating it for every family. -- [x] Resolve the normalization representation decision empirically. Actual - Lean metadata is not already in analyzer normal form: `AliasFormer` retains - a reducible alias where the checker sees a result sort, and `AliasRec.mk` - retains a reducible application where positivity sees a recursive target. - Keep the raw declaration as the stored/source object and introduce a named - `Normalization source` carrying a shape-compatible analysis view. - `normalizationShape` already fixes all identities, arities, ordering, and - counts, and `Normalization.checked?` keeps analysis computational and - environment-independent. -- [x] Give the first one-family normalization witnesses semantic meaning. - `Normalization.WF env` compares the raw/view family types in the input - environment and compares constructor types pairwise after insertion of the - raw family constant. The family-result and recursive-field alias fixtures - construct those defeq derivations explicitly; both exact axiom guards are - `[propext, Quot.sound]`. This proves the boundary is compatible with Theory, - but not yet that every checker-produced normalization can be reconstructed - or that generated artifacts preserve the kernel's raw syntax. -- [x] Introduce one paired, data-bearing checked block. - `NormalizedChecked source` contains the normalization, the raw singleton - `sourceType` and source equation, `norm.view.Checked`, and its exact computed - analyzer equation. `Normalization.check?` constructs it without repeating - analysis; `normalizedChecked?` checks an explicit pair; `identityChecked?` - is the compatibility path. `Normalization.shape`, - `NormalizedChecked.source_anatomy`, `uvars_eq`, and `nparams_eq` expose - source/view arities and ordered family/constructor header agreement. - Identity Nat and both alias fixtures compute, and the alias blocks have - complete `NormalizedChecked.WF` certificates. Generic structural roots and - concrete semantic roots have exact axiom guards. At that checkpoint this - completed only the additive data boundary; the now-completed artifact - refactor below added constructor-by-constructor pairing of raw field - telescopes with normalized recursive-target/binder/index facts. - Whole-expression defeq plus matching names is not, by itself, enough to - recover raw binder positions. -- [x] Refactor artifact generation around that paired block before changing - acceptance. Family and constructor constants must be inserted with the raw - metadata payloads; recursor/minor/rule generation must retain the - kernel-observable raw binder syntax while consulting the view for result - sorts, recursive classification, target indices, and elimination facts. - **Complete:** `GenerationChecked` supplies the executable layout gate, - ordered `NormalizedCtor` pairs, raw/view coverage lemmas, and the sole live - mixed motive/minor/recursor/rule implementation. Identity generation - specializes by reduction to the current Nat/Eq/`IndexedVec`/`Acc` artifacts. - The family-result and recursive-field alias recursors and iota rules match the - actual kernel by `rfl`; `AliasRec` additionally proves that the emitted minor - telescope retains the raw `RecAlias AliasRec` field while recursion comes - from the view. Do not generate everything from the rewritten view: the alias - audit shows that would erase syntax retained by kernel metadata and recursor - types. - - The completed artifact-preservation sequence is: - - - [x] Establish the structural contract. `VEnv.TelDefEq` tracks pointwise - equality in raw predecessor contexts; `GenerationChecked.WF` separates - pre-family family evidence from post-family stored-constructor and - emitted-artifact evidence; generic guarded lemmas prove the raw family and - constructors well formed without the unfinished - `IsDefEqU.forallE_inv_stratified`. - - [x] Prove the mixed motive and all mixed minors well formed. - `GenerationEnv.motive_isType`, exact raw constructor-application transport, - recursive-argument/IH transport, `minor_isType`, and `minorTypes_onTel` - cover the full constructor list. `minorTypes_length` and positional - `minorTypesAux_getElem?` prevent silent list misalignment. - - [x] Factor `familyApp_transport`, covering the common operation of - inserting motive/minor binders below the indices and then weakening by a - top stack. The targeted - `Lean4Lean.Theory.Typing.InductiveLemmas` build is green. - - [x] Prove `GenerationEnv.recType_isType` telescope-by-telescope in the - order parameters, motive, minors, lifted indices, major premise, and final - motive application; `GenerationEnv.recursor_wf` closes the mixed recursor - constant. - - [x] Prove every mixed rule well formed. `ruleBinders_onTel`, - `ctorAppRule_hasType`, `ruleCall_hasType`, `minorApp_hasType`, - `recRuleApp_hasType`, and `rule_WF` cover the raw telescope, constructor, - recursive calls, RHS, and rule type; `generatedRules_WF` and - `generatedRulesFold_ordered` close the ordered list without a separate - direct-recursion branch. - - [x] Add exact axiom guards for the stabilized mixed component roots, - recursor, rule, and block-level fold as specified in §2.3. The motive and - family transport use `[propext, Quot.sound]`; the minor, recursor, rule, - and fold roots use the permitted - `[propext, Classical.choice, Quot.sound]` ceiling. - - [x] Make the legacy `Checked` artifact accessors identity-normalization - compatibility specializations of the mixed implementation, prove exact - Nat/Eq/`IndexedVec`/`Acc` public equalities, and confirm both alias - differentials. `Checked.analyzer_eq` gives the unique retained result, - `identityBlock`/`identityGeneration` construct the canonical bridge, and - generic `*_eq_legacy` theorems pin all four artifact forms. The old - `*Rec` functions remain only as compatibility/specification targets until - the transaction contract is migrated; no live public accessor generates - through them. -- [x] Replace the raw-only transaction with one normalized transaction and an - identity-normalization compatibility wrapper. Route `stage3` (or its - successor public predicate), `VEnv.addInduct`, `AddInductSuccess`, - atomicity/freshness/lookups, `addInduct_WF`, and generated-rule membership - through the paired checked block. The preservation theorem must consume - `Normalization.WF`, the checked view's semantic certificate, and the raw - declaration WF facts at their correct pre-/post-family environments. At a - checkpoint there must be one semantically live artifact path, not unrelated - raw and normalized transactions. - - Implement this in the following order: - - - [x] Add a single computational core, - `VEnv.addInductGeneration (gen : GenerationChecked source)`, which inserts - `gen.block.sourceType`, folds its raw constructor list (proved equal to - `gen.block.ctorPairs.map (·.raw)` by `rawCtors_eq`), inserts - `gen.recursor`, and folds `gen.generatedRules`. It does not inspect the - view again and accepts no semantic proof as an oracle. - - [x] Give that core a dependent success certificate retaining the exact - `gen`, intermediate environments, raw family/constructor lookups, recursor - lookup, every generated-rule membership fact, monotonicity, freshness, and - atomic failure behavior. State the primary lookup/rule fields using mixed - artifacts; derive legacy `recConstRec`/`rulesRec` consequences only in the - identity wrapper. `AddInductGenerationTrace` is data-bearing, while - `addInductGeneration_trace` returns `Nonempty` so proof consumers do not - acquire choice solely to unpack transaction bookkeeping. - - [x] Prove normalized preservation in transaction order. Use - `GenerationChecked.WF.rawFamily_isType` for the first insertion, its - staged `rawCtor_isType` facts for the constructor fold, promote the - certificate with `GenerationChecked.WF.toGenerationEnv`, then apply - `GenerationEnv.recursor_wf`, `generatedRules_WF`, and - `generatedRulesFold_ordered`. Do not reconstruct a `Stage3Env` or rerun - legacy recursive analysis. `addInductGeneration_WF` now follows exactly - this chain. - - [x] Redefine the current `VEnv.addInduct env source` as: obtain the exact - `Checked` result once, form `checked.identityGeneration`, and call the - normalized core. `addInduct_eq_addInductGeneration` pins that computation. - - [x] Add the semantic identity bridge - `env.Ordered → Checked.WF env → checked.identityGeneration.WF env`, then make - `AddInductSuccess`, its atomicity/freshness/lookups/rule-membership - consequences, and `addInduct_WF` delegate to the normalized trace and - preservation theorem. Delete the now-redundant legacy `Stage3Env` - transaction proof only after those public statements and exact closures - remain unchanged. `DirectFamilyEnv` captures precisely the state after the - family insertion and before any constructor lookup exists; the bridge uses - it to validate direct/functional recursive fields and exact raw constructor - results without reconstructing `Stage3Env`. - - [x] Add direct Theory transactions for `AliasFormer` and `AliasRec` using - their explicit `GenerationChecked.WF` witnesses. Check raw family and - constructor payload preservation, exact kernel recursor/rules, complete - lookup membership, monotonicity, and final `Ordered`; the raw - `checked? = none` facts must remain true to demonstrate that normalization, - rather than analyzer weakening, enables them. Both final environments now - have trace, freshness, raw lookup, kernel recursor/iota, monotonicity, and - ordering fixtures. - - [x] Complete the exact guard set. Core trace/atomicity/lookups, - normalized preservation, and identity-wrapper computation are already - guarded at the exact closures recorded in §2.3; add guards for the - identity semantic bridge, delegated public roots, and both alias - transaction roots. The identity bridge and ordered alias endpoints use - exactly `[propext, Classical.choice, Quot.sound]`; alias trace/lookups and - rule membership use exactly `[propext, Quot.sound]`. -- [ ] **L4L-01A–L4L-01E (01A–01B complete; 01U active before 01C):** complete generic Verify-side production of - normalized transactions in five separately green checkpoints. The - trace/consumer migration and six actual-metadata replays are complete. The - generic checker-to-Theory `WhnfRun`, `CheckTypeRun`, `DefEqEvidence`, and - `NormalizationRun` APIs are complete, as are both fixed alias normalization - instantiations and both complete checked `GenerationChecked.WF` roots. - AnnotatedPi additionally builds the complete nested candidate, checked - generation certificate, and transaction from exact checker traces. These - checked roots no longer bootstrap from older hand-built generation-WF - proofs. Semantic-input plumbing and family-validator/environment staging are - complete in L4L-01A/L4L-01B. L4L-01U first reconciles the live upstream and - Lean v4.31 without adding a semantic deliverable. Constructor trace - retention, constructor-validator soundness, and final package closure remain - the separate L4L-01C through L4L-01E checkpoints. Bare - `buildNormalizationCandidate` success is insufficient at every stage. The - whole-candidate non-defeq rejection is a required regression; an arbitrary - user-supplied view or assumed normalization oracle is forbidden. - - The Verify migration order is: - - - [x] Replace the trace's free `decl.Checked` field with the exact - `GenerationChecked decl` artifact and `GenerationChecked.WF` certificate - used by Theory; retain raw `ConstantInfo` payloads in every - `AddInductConstant`. - - [x] Add the first checked normalization-certificate producer. - `TypeChecker.WhnfRun` records the exact `Inner.whnf'` run, checker context, - state-WF proof, and input/output translations; its refinement theorem - yields typed Theory defeq. `DefEqEvidence` composes `refl`, `whnf`, `app`, - `beta`, `trans`, and `forallE`, while - `VInductDecl.NormalizationRun.wf` stages family and constructor evidence in - the correct environments. `AliasFormer` uses a real family-head WHNF run; - `AliasRec` uses a real `RecAlias.{1}` run plus application, beta, - transitivity, and forall congruence. Exact operational and semantic axiom - guards pin both paths. - - [x] Add the first full-check typing producer and close the fixed-alias - dependent certificates. `TypeChecker.CheckTypeRun` records exact - `Inner.inferType _ false` runs and exposes named `HasType`/`IsType` - consequences. `AliasFormer` checks the real `TypeFamilyAlias` constant, - then checks the actual constructor type in the exact post-family - environment; the latter returns the retained alias and is combined with - verified WHNF. `AliasRec` checks the actual raw `RecAlias AliasRec` field - in the exact post-family environment, then uses that checked typing premise - in the compositional WHNF/application/beta equality for its constructor. - All three operational traces record their inferred/cache result and have - exact axiom guards. - Both aliases now assemble checked - block-WF and complete `GenerationChecked.WF` roots without using their - older fixture generation-WF proofs. Generic `TelDefEqEvidence`, - `NormalizedCtorRun`, and `GenerationRun` package the pointwise binder, - declared/emitted constructor, and exact post-family evidence, so the fixed - cases exercise the same assembler intended for arbitrary metadata. Exact - guards show that these complete certificates add no dependency beyond the - checked semantic endpoint. - - [x] Feed both fixed-alias checked generation certificates through complete - data-bearing `AddInductTrace` values and `TrEnv'`. The checked traces reuse - the already audited metadata-translation witnesses, preserve the same - final environments, and derive final WF/alignment. Exact guards show that - this end-to-end wiring adds no dependency beyond the checked semantic set. - - [x] Complete candidate-list traversal and semantic certification of the - retained indexed runs at Lean's transparency and fuel boundary. Exact - whole-call package production is tracked separately below. - - - [x] Add the generic executable traversal. - `AddInductive.normalizeCandidateExpr` calls the ordinary checker `whnf` - at every node, traverses exposed Pi domains and instantiated bodies - under the kernel's structurally certified annotation-consumed local - declarations, retains the raw binder syntax plus an exact equality run, - and consumes the configured inductive fuel. Source-indexed candidate - family and constructor lists preserve metadata headers and positions by - construction. - `buildNormalizationCandidate` first repeats - `checkInductiveTypes`, computes family views in the input environment, - inserts all raw families, repeats `checkConstructors`, and computes - constructor views in that exact post-family environment. Its dependent - `NormalizationCandidate source` result prevents accidental reuse for a - different source but is not itself semantic authority. - - [x] Retain and operationally certify generic positional run data. - `CandidateExpr` records the full - `AddInductive.Context`, raw input, WHNF result, and recursive Pi - domain/body split at every node. Source-indexed dependent lists retain - exact family and constructor positions; views are reconstructed from - those traces while all names and non-expression headers come from the - indexed source. Every trace node carries - `CandidateWhnfStep.Valid`, the exact ordinary-checker run equality - obtained by dependent matching on the computation; `step_valid` - exposes it without an oracle or native evaluation. - - [x] Bridge retained steps to the existing semantic certificate boundary. - `CandidateWhnfStep.innerRun` constructively recovers the final checker - state erased by `TypeChecker.M.run`, while - `TypeChecker.WhnfRun.ofCandidateStep` combines that run with a matching - verified context and caller-supplied strict translations. The - AliasFormer family `WhnfRun` now comes from its produced candidate step - through this adapter rather than a parallel hand-filled `run_eq`. - - [x] Retain full checks at both declaration stages and every trace node. - Family traces run before raw family insertion; constructor traces run in - the exact post-family environment. Every recursive Pi domain and - instantiated body is checked in its recorded raw local context before - WHNF/traversal. `CandidateCheckTypeStep.innerRun` and - `CheckTypeRun.ofCandidateStep` mirror the WHNF adapters, while - `checkStep_valid` exposes every run. AliasFormer's family and actual - constructor `CheckTypeRun` values now use these candidate steps, - including the retained alias result after insertion. - - [x] Pin one exact operational leaf. The actual retained - `AliasFormer` family alias reduces through - `buildCandidateExpr` to a terminal trace containing the exact context, - source, and expected sort using the same verified checker WHNF run; - erasing that trace gives the expected `normalizeCandidateExpr` result. - Exact axiom guards record the inherited operational closure. This is - intentionally a leaf test rather than a second, fixture-specific - implementation of whole-expression WHNF. - - [x] Define and verify the recursive semantic interpretation boundary. - `CandidateExprTrace` is recursively context- and source-indexed at Pi - domains and exact instantiated bodies. Its body index is the literal - `Context.pushLocalDecl` update with the producer's next fresh identifier - and structurally certified consumed domain, eliminating the previous - independently supplied child context. `CandidateNodeRun.ofCandidate` - pairs the two retained - executions in one verified context, while - `CandidateNodeRun.exists_ofCandidate` extracts both output translations - from the verifier refinements rather than requiring them from the - caller. `CandidateExprRun` folds terminal nodes and Pi domain/body - children into `DefEqEvidence`, retaining raw Pi syntax while checking - the body under the kernel's consumed binder context. Its Pi case - accepts arbitrary checker-inferred types and transports them to the - structural domain/body/result sorts using unique typing, so a relevant - Pi-producing alias need not be reported syntactically as a sort. - `source_tr` retains the strict raw translation, while `view_tr` abstracts - the exact retained free variable, transports the body across the - raw/normalized domain context, and translates the reconstructed - candidate view. All construction, interpretation, and translation roots - have exact guards. AliasFormer's actual candidate trace supplies its live - `NormalizationRun` and `GenerationRun` family evidence through this path. - - [x] Construct matching verified contexts and translations automatically - for every retained position in a candidate trace. - `CandidateContextRun.root` aligns the exact executable root with a - verified `VEnvs`; `.pushLocalDecl` builds the corresponding - `VContext`/`MLCtx`, proves binder freshness and checker-name reservation, - and restarts the empty checker state soundly. The trace now retains the - exact freshness equation. `candidateCheckTypeStep_exists_translation` - recovers strict source/inferred translations and typing from the root - full check, and `CandidateExprRun.exists_ofCandidateFVars` invokes the - node interpreter recursively, deriving child translations and raw - domain/body typing from Pi decomposition. AliasFormer exercises the - automatic root path without a fixture-supplied Theory expression. Exact - guards cover every new state/context/recursive root. - - [x] Remove the explicit `CandidateRawBinderDomains` restriction and - certify annotation consumption. `CandidateTypeAnnotationTrace` mirrors - the four top-level peeling cases structurally, and - `buildCandidateTypeAnnotations` checks its result against Lean's actual - `consumeTypeAnnotations` implementation. Because that implementation is - an opaque partial definition, the retained `CandidateTypeAnnotations` - stores only the consumed expression and structural trace; the agreement - branch is executable producer validation, not a semantic proof field. - Every Pi retains an exact - successful `isDefEq domain consumed` execution before extending the - body context. `IsDefEqRun.ofCandidateStep` and `.isDefEqU` refine that - execution; strict translation of the consumed argument is extracted - from the raw application trace, so a redundant second full check is not - required. `CandidateExprRun.forallE` now transports domain typing, body - translation/equality, evidence, and the reconstructed view across the - raw, consumed, and normalized contexts. Positive executable fixtures - cover `outParam`, `semiOutParam`, `optParam`, and `autoParam`; a negative - fixture pins both the checker's `.ok false` result and the producer's - dedicated rejection. Exact axiom guards cover every new producer and - verifier root. - - [x] Convert the candidate list to the one-family Theory - `Normalization`, run its dependent checked analysis, and assemble - `NormalizationRun` from retained family and constructor runs. - `CandidateExprRootRun` ties named Theory endpoints to exact candidate - syntax; `CandidateConstructorListRun` folds exact positional evidence; - and `NormalizationCandidateRun` statically accepts only a singleton - source family and singleton raw declaration. AliasFormer's actual family - and post-family constructor candidate traces now drive its live - normalization certificate. A truncated view fails the computational - shape gate before transaction construction. Exact guards cover singleton - elimination, root evidence, list shape/evidence, normalization assembly, - the migrated fixture, and the negative. - - [x] Extract raw/view binder telescopes and terminal results from the - retained recursive runs, align them with the successful dependent - analysis, and assemble generic `GenerationChecked.WF`. - `CandidateExprTrace.storedSpine` prevents WHNF from inventing or deleting - emitted raw binders while allowing binder-domain and terminal-result - normalization. `CandidateExprRun.spineEvidence` returns exact - `TelResultDefEqEvidence` with a proved raw-spine length. - `CandidateFamilyGenerationRun` and `CandidateNormalizedCtorRun` align - that evidence with the dependent checked view; - `TelResultDefEqEvidence.replacePrefix` proves the declared/emitted - constructor bridge through exact contexts; and the dependent - `CandidateNormalizedCtorListRun` cannot truncate, reorder, or reuse a - constructor certificate. `GenerationCandidateRun.wf` produces the - existing Theory `GenerationChecked.WF`. Every extraction and assembly - boundary has an exact axiom guard and introduces no new axiom. - - [x] Route one non-identity candidate-derived generation certificate - through an existing complete checked consumer. AliasFormer's exact - pre-family and post-family candidate spines now build - `aliasFormerGenerationCandidateRun`; its former hand-filled - `GenerationRun` delegates to that generic value, so the checked - `AddInductTrace`, final environment, `TrEnv'`, WF, and alignment roots all - exercise the candidate assembler. - - [x] Add a complete positive candidate-list fixture with an annotation - inside an actual recursive Pi constructor type. `AnnotatedPi.mk` retains - `outParam Prop` in the raw recursive-function domain while the candidate - view consumes it to `Prop`. Its exact full-check, WHNF, and complete - lazy-delta `isDefEq` traces recursively construct the raw and consumed - contexts, pass `storedSpine`, extract the nonempty nested telescope and - terminal result, assemble `GenerationCandidateRun.wf`, and replay the - final environment, recursor, and iota rule through checked - `AddInductTrace`/`TrEnv'`. Exact guards cover normalization, generation, - checked generation, transaction replay, and the small Theory iota root. - - [x] Add the corresponding whole-candidate rejection for non-defeq - annotation domains. The fixture keeps the real AnnotatedPi family and - constructor metadata and gives `outParam` its correct polymorphic type as - an opaque constant. Family/constructor staging therefore reaches the - recursive candidate, but the ordinary checker cannot prove - `outParam Prop` definitionally equal to the syntactically consumed - `Prop`; `buildNormalizationCandidate` returns the dedicated binder-domain - error before any semantic package or transaction exists. Keep this with - the four leaf annotation positives, exact non-defeq leaf rejection, - truncated-view rejection, and positive AnnotatedPi transaction so the - failing phase remains unambiguous. - - [x] Add the generic proof-carrying consumer boundary and route two - non-identity packages through it. Theory's `GenerationCertificate` owns an - exact generation and `GenerationChecked.WF`; `VEnv.addInductCertified` - erases the proof and computes through `addInductGeneration`, with exact - trace, atomicity, and WF theorems. Verify's - `GenerationCandidatePackage` retains the exact kernel source, candidate, - normalization, generation, and semantic run; `.certificate` is the - ix-facing erasure, and `.addInductTrace` prevents metadata replay from - receiving an unrelated generation/WF pair. AliasFormer and AnnotatedPi - both exercise the package, public certified transaction, and checked - replay. Keep `VEnv.addInduct` as the identity compatibility wrapper until - kernel parity and downstream migration are green. - - [x] Instantiate the exact whole-call producer boundary on real positive - metadata. AliasFormer and AnnotatedPi prove - `buildNormalizationCandidate ... = .ok package.candidate` through the - exact family-declaration and constructor-check contexts, constructs - `ProducedGenerationCandidatePackage`, and routes both its public certified - transaction and checked metadata replay through that produced value. The - proof retains exact source-indexed candidate equality, not candidate - erasure equality or a hand-selected view, and exact guards expose every - inherited cache/platform dependency. - - [ ] **L4L-01A–L4L-01E (01A–01B complete; 01U active before 01C):** generalize exact produced-package construction to - arbitrary strengthened singleton metadata runs. The executable seam now - covers `IndexedVec`'s family telescope, parameter, index, and ordered - two-constructor list; generic identity replay and the concrete - identity-spine witnesses feed a complete dependent semantic package and E1 - replay. Automatic semantic hierarchy assembly is complete once exact - verified per-position inputs are supplied. L4L-01A consolidates that - repeated input assembly over two explicitly verified stages. L4L-01B - derives the post-family stage from the family validator. L4L-01U reconciles - current upstream before L4L-01C and L4L-01D retain and interpret - constructor validation. L4L-01E alone applies the already generic - generation alignment and deletes the temporary fixture view-WF proofs. - Bare outer-producer success remains insufficient. - - - [x] Abstract exact executable family-type, constructor, and complete - family-list assembly into arbitrary-length dependent `Produced` - witnesses. Route AliasFormer, AnnotatedPi, and the two-constructor - `IndexedVec` regression through their generic `.normalize` theorems, with - exact standard-baseline axiom guards. - - [x] Add the generic outer singleton constructor - `GenerationCandidateRun.producedPackage`. It requires an exact successful - `buildNormalizationCandidate` equation indexed by the same kernel source - and dependent candidate as the semantic run, so it cannot attach - executable provenance to another view or reordered list. Route - AliasFormer, AnnotatedPi, and `IndexedVec` through it and guard its exact - inherited `[propext, sorryAx, Classical.choice, Quot.sound]` closure. - - [x] Introduce generic retained semantic ownership. - `CandidateExprSemanticRootRun` owns the exact recursive run and its - checker-selected view; `.root` and `.spine` feed normalization and - generation from that same value. Source-indexed semantic constructor - lists, families, and singleton normalization candidates preserve every - position. AliasFormer, AnnotatedPi, and `IndexedVec` now use this hierarchy - instead of parallel root/run/spine records. - - [x] Combine the operational list witnesses with automatic construction - of the retained semantic family/constructor hierarchy. - `CandidateExprSemanticRootInput`, the dependent constructor and family - inputs, and `NormalizationCandidateSemanticInput.exists_ofProduced` - invoke the retained checker interpreter at every exact source position - and return `Nonempty ProducedNormalizationCandidateSemanticRun`. - `CandidateFamilySemanticGenerationRun`, - `CandidateSemanticNormalizedCtorListRun`, and - `GenerationCandidateSemanticRun` make those same roots and spines own the - generation path. Exact generic and fixture axiom guards are live; - `IndexedVec` proves exact constructor order and rejects a reordered view. - - [x] Derive view telescopes and terminal typing instead of accepting them - from fixture generation records. `Checked.type_eq` and - `GenerationChecked.viewCtorType_eq` expose exact accepted family and - constructor shape at the standard Theory axiom baseline. - `GenerationCandidateRun.familyView_eq` fixes the singleton candidate view; - family terminal sort typing follows from the checked result level; the - raw family constant is typed once in the post-family environment; and - `GenerationChecked.checkedResultTarget_hasType` plus exact telescope - context transport derives every constructor target judgment. - AliasFormer, AnnotatedPi, and `IndexedVec` now omit `viewTel` and - `rightType`; the two circular `IndexedVec` right-typing helpers are gone. - Exact guards cover all new Theory and Verify roots. - - [x] Retain exact dependent analyzer provenance and derive its immediate - semantic consequences. `GenerationCandidateRun` and - `GenerationCandidateSemanticRun` store - `normalization.generation? = some generation` instead of an unrelated - normalization equality. Theory proves successful `check?` and - `generation?` retain the analyzed normalization; Verify derives - post-family environment WF from the verified pre-family context, - raw/view equality, checked family typing, and exact insertion. - AliasFormer, AnnotatedPi, and `IndexedVec` now provide neither - `normalization_eq` nor `typeEnv_wf`, and exact axiom guards cover every - new public root. - - [x] Derive analyzer-owned component and dependent-list alignment from a - minimal semantic generation shape. `GenerationCandidateSemanticShapeRun` - retains checked WF, exact analysis, and only stored-spine/total-length - shape data. Singleton indices recover the raw family and complete checked - family view; analyzer maps recover every normalized constructor pair and - exact source order; total length determines raw telescope/results; and - exact checked shape determines view terminals. Its public `.run` - reconstructs `GenerationCandidateSemanticRun`. AliasFormer, AnnotatedPi, - and `IndexedVec` no longer select pairs or provide component equations. - - [x] Consolidate checked-WF and per-position shape derivation behind one - strengthened executable generation-readiness result. - `normalizationCandidateGenerationShape` checks the complete singleton - family and source-indexed constructor list, including stored emitted - spines and total raw telescope lengths, and rejects list mismatch in both - directions. `ProducedGenerationShapeCandidate` retains the exact ordinary - producer equation without pretending that equation proves the stronger - gate. `GenerationCandidateSemanticRun.ofGenerationShape` uses exact - dependent analysis and WF of the analyzer-owned view declaration to - derive checked WF and expand the successful Boolean into every dependent - shape record. All three fixtures use this boundary and exact axiom guards - show no trust-budget increase. - - [x] **L4L-01A:** add one source-indexed staged-input owner over explicitly - verified pre-family and post-family candidate contexts, strict family and - constructor source translations, exact insertion alignment, and the - existing dependent `Produced` traversals. Its only semantic output is - `Nonempty ProducedNormalizationCandidateSemanticRun`. Migrate all three - positives to this owner and delete their per-root - `CandidateExprSemanticRootInput` and constructor-list input definitions. - Because this output is intentionally `Nonempty`, the existing explicit - downstream semantic-run/package witnesses and one fixture-level `viewWF` - remain permitted and visibly temporary until L4L-01E; do not extract data - with `Classical.choice`. Complete at source checkpoint `7c792209`: all - three positives use the staged owner, exact constructor order is retained, - the repeated old input definitions are absent, and focused/universal gates - pass without changing the axiom frontier. - - [x] **L4L-01B:** interpret the exact singleton family-validation run from - one verified entry context. Derive the candidate view parameter/index - telescope, terminal sort typing, raw-family constant WF through the - candidate's semantic defeq, the exact raw-family insertion, and the - verified post-family candidate stage. Remove the second independently - verified stage and the three fixture-specific post-family `VEnvs.WF` - reconstructions. Do not inspect or prove constructor validity here. - Complete at source checkpoint `da45b536`: the exact singleton validator - derives parameter/index views, terminal/raw-family WF, exact insertion, - and the post-family candidate stage; none of the three positives retains - an independent post-family `VEnvs`/context; constructors remain - uninterpreted; family-phase negatives remain sharp; exact axiom guards - and universal gates pass. - - [x] **L4L-01U:** completed at source checkpoint - `7f864b459e4a6062b468d6e5416688feac0f9f99`. It merges digama - `upstream/master` through `ef849dfbd94a` into origin `jcb/induct` - without rewriting the published checkpoints or moving either master. - The source reconciles the overlapping - inductive/checker/Verify/level and replay/CI/Experimental changes, - upgrades Lean and lean4-nix to v4.31, retains the fork's Nix and ix-facing - certificate surfaces, and removes upstream's four now-proved - cached-`Expr` axioms plus the obsolete hand-declared `mkAppRangeAux` - equation. The exact inventory is 29 custom axioms and 22 non-Experimental - sorries. `NormLevel.isEquiv_wf` is assigned to L4L-02B and `addDecl.WF` - to L4L-19B; neither enlarges a supported-root allowlist. Completion - evidence includes the upstream tip as a source parent, passing - L4L-01A/L4L-01B regressions and universal Lean/Nix gates, and publication - of only origin `jcb/induct`. The isolated ix v4.31 probe - is diagnostic evidence, not an ix pin: merged Lean4Lean replay and ix - runtime modules pass, while ix-owned proof/API migration is deferred to - the next pin. Keep this checkpoint integration-only; constructor traces - belong to L4L-01C. - - [ ] **L4L-01C (active):** retain the complete successful singleton constructor - validator as dependent operational data: duplicate/closedness checks, - closed root `checkType`, parameter equalities, field `ensureType` and - universe comparisons, positivity/recursive-target traversals, and the - final family application. Prove decomposition/recomposition with the - actual `checkConstructors = .ok ()` execution. This milestone makes no - Theory WF claim and must preserve failure-phase diagnostics. - - [ ] **L4L-01D:** interpret the L4L-01C trace using the verified checker and - the retained candidate normalization. Derive every accepted view field's - `fieldsWF`, every constructor result `SpineWF`, and therefore WF of the - exact analyzer-owned view declaration. This is soundness for the - currently accepted normalization/validation subset, not the later - acceptance-breadth work of L4L-03/L4L-05. Remove all three fixture - `viewDecl_wf` proofs and guard the generic roots at their exact inherited - axiom closures. - - [ ] **L4L-01E:** combine the L4L-01A–L4L-01D owner, exact dependent - analysis, and `ProducedGenerationShapeCandidate` into an exact - `Nonempty ProducedGenerationCandidatePackage`. The theorem must retain - the successful ordinary producer equation but may not infer the - strengthened gate or Theory meaning from that equation. It must not - accept a view or view-WF premise. Raw/view pairing, component equations, - checked WF, per-position shape records, dependent-list alignment, view - telescopes, terminal typing, normalization identity, and post-family WF - remain derived. AliasFormer, AnnotatedPi, and `IndexedVec` use only this - theorem; missing/extra/reordered/truncated/non-defeq negatives remain - sharp. Mutual/nested generalization begins only after L4L-07. - - AliasFormer, AnnotatedPi, and `IndexedVec` remain the terminal-alias, - nested annotated-Π, and parameter/index/multi-constructor regressions. Do - not weaken the boundary to erasure equality or an assumed normalization - theorem; the opaque-`outParam` whole-candidate rejection must stay green - and fail before package construction. - - [x] Make `AddInduct.to_addInduct`, `.le`, `Aligned.addInduct`, - `TrEnv'.wf`, and `TrEnv'.aligned` consume the normalized Theory success - certificate instead of converting back to legacy raw artifacts. - - [x] Replay Nat, Eq, `IndexedVec`, `Acc`, `AliasFormer`, and `AliasRec` - from actual metadata. For every case pin source/view data, recursor - universes, raw binder syntax, all rule RHSs, final environment equality, - lookup uniqueness, WF, and alignment. - - [ ] **L4L-11:** export the ix-facing oracle ingredients only after the normalized - trace has exact axiom guards and no `sorryAx` beyond the separately tracked - projection relation. The API should expose generation/lookup/pattern facts, - not a normalization oracle or kernel implementation object. -- [ ] **L4L-03:** match the remaining singleton environment-sensitive behavior of - `checkInductiveTypes`/`checkConstructors`: `checkType` before declaration, - fuel- and transparency-appropriate WHNF-driven Pi/result-sort peeling, - WHNF-driven recursive-target traversal, and definitional rather than - syntactic constructor-parameter agreement. Add a positive constructor - parameter case whose domains differ syntactically but are definitionally - equal, paired with a genuinely non-defeq negative and exact kernel outcome. - Result-level equivalence across different family types belongs to I3, not - this singleton milestone. -- [ ] **L4L-04:** complete the normalization differential matrix before calling this - sub-slice done. Cover aliases at family results, parameter/index domains, - ordinary fields, direct recursive targets, and recursive targets hidden - behind a Pi-producing alias; include beta/let reduction where real metadata - can retain it, irreducible/opaque or otherwise non-defeq counterexamples, - and the checker fuel boundary. For each accepted case compare the raw - constant payloads, normalized descriptor, recursive positions, recursor - type, and every rule RHS with the kernel, then replay it through E1. Add - generic axiom guards for the paired-block preservation and transaction roots, - not only the two concrete fixture witnesses. -- [ ] **L4L-05:** complete positivity and constructor checks: nested negative occurrences, - non-recursive fields mentioning the family, dependent fields, recursive - functions, proof-valued fields, and constructor universe bounds. The last - obligation is already represented semantically in `Checked.WF`; this task - connects it to kernel acceptance and differential tests. Every rejection - branch gets a fixture whose nearest kernel analogue is also rejected; the - checker remains an underapproximation until agreement is demonstrated. -- [ ] **L4L-06A:** implement `isLargeEliminator`, `getElimLevel`, `getRecLevels`, and - `getRecLevelParams` faithfully. Make `ElimMode.small` constructible and - parameterize motive/recursor generation by it, so Or/And are accepted with - Prop-only recursors while Eq-like and never-zero families retain legitimate - large elimination. -- [ ] **L4L-06B:** add `isKTarget` data to the descriptor and reproduce the kernel's Eq-like - K flag/behavior without using K as a shortcut for invalid large elimination. - Verify the exact universe ordering rather than normalizing away meaningful - permutations. -- [ ] **L4L-06C:** cover empty and singleton-constructor families and prove exact recursor - binder ordering, minor ordering, field counts, recursive-argument metadata, - rule counts, and iota RHSs. Refactor the preservation proof one generated - component at a time; no new case may bypass `Checked` or add a proof-only - premise that real kernel metadata does not supply. -- [ ] **L4L-07:** replay every newly accepted family through E1 immediately. Theory parity - without actual `ConstantInfo` translation is insufficient for ix, because - `InductiveOracle` needs both semantic generation and environment alignment. - -The fixed positive matrix is Nat, Bool, List, Option, Prod, Unit, Empty, Or, -And, Eq, HEq, Fin, Vector, and Acc, plus the focused alias-normalization cases -listed above. For each, compare acceptance, raw stored type, type and -constructor names, parameter/index counts, field/recursive-argument metadata, -universe lists, elimination level, K flag where relevant, recursor type, rule -count, and every iota RHS with the real kernel. The paired negative matrix must -cover loose variables, duplicate/internal and pre-existing names, bad universe -levels, malformed result applications, parameter mismatch, non-defeq -normalization views, negative recursion, illegal recursive targets, and invalid -elimination. I2 exits only when both matrices, the E1 replay subset, exact axiom -guards, sorry audit, Theory/Verify build, and full flake gate are green. - -The current negative matrix already covers the closure, generated-name, -universe-annotation, self-reference, raw result-shape, parameter-count, -universe-count, transaction-collision, recursive-Pi domain, changed-target -parameter, and recursive-index-family branches. I2's remaining negative work -is therefore concentrated on rejecting semantically invalid raw/view pairs, -nested positivity beyond this one-family recursive target, constructor field -universes at the acceptance boundary, and elimination/K behavior rather than -duplicating completed cases. - -### I3 — mutual blocks (L4L-08A–L4L-08C) - -- [ ] **L4L-08A — mutual checked representation.** Replace singleton - destructuring in analysis with dependent lists over `decl.types`; represent - shared parameters, per-family indices/results, ordered constructors, and - cross-family recursive targets. Compute checked Tree/TreeList and one mutual - indexed descriptor, but do not generate or insert constants yet. -- [ ] **L4L-08B — mutual validation and normalization.** Generalize the - L4L-01C/L4L-01D validator traces and semantic interpretations to shared parameter - agreement, equal result universes, all-family staging before constructor - validation, cross-type recursive occurrences, and recursive Pi arguments. - Produce the exact mutual semantic package and sharp mismatch/reordering - negatives; no generator theorem is part of this checkpoint. -- [ ] **L4L-08C — mutual generation, preservation, and replay.** Generate one - motive and recursor per family, flatten all constructor minors in kernel - order, and route each recursive call to the correct motive/recursor. Add all - type constants before constructors, all constructors before recursors, and - all recursors before rules; prove `Ordered`, lookups, and preservation through - the chain. Tree/TreeList and the mutual indexed fixture compare every - `inductInfo`, `ctorInfo`, `recInfo`, and rule and replay through E1. No - singleton destructuring remains on the public path. - -### I4 — nested inductives (L4L-09A–L4L-09C) - -- [ ] **L4L-09A — nested representation decision.** 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 ix compatibility evidence first. 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. Pin the transformed family and auxiliary - descriptors for a rose tree through List and one nested indexed family, - including rejection differentials, but do not yet claim generated recursors - or E1 replay. -- [ ] **L4L-09C — nested generation and replay.** Generate every auxiliary - declaration, recursor, and rule; prove preservation and insertion order; and - round-trip both fixtures through real `Inductive.Add.run`, generic packaging, - and E1. The exit compares all raw metadata and rule RHSs rather than a - hand-authored declaration. - -### I5 — generated-pattern package (L4L-10A/L4L-10B, ix-critical) - -- [ ] **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. Port the - implementation-independent ix helpers `HeadConst`, `HeadConstN`, - `of_varN_matches`, `RecursorIotaPattern`, and `matches_shape` into - `Theory/Typing/Pattern.lean`. -- [ ] **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. Do not install a global `Params` instance for an open environment. - -## 7. Track E — Verify environment alignment and ix's inductive oracle - -### E1 — replace the empty `AddInduct` path (L4L-01A–L4L-01E/L4L-07/L4L-11) - -- **Status: core normalized relation/proof path, actual-metadata Nat, Eq, - index-changing `IndexedVec`, recursive-Pi `Acc`, `AliasFormer`, and - `AliasRec` replays, plus the pre-existing-value regression, are complete. - The first verified WHNF-to-normalization certificate producer is complete - and instantiated on both aliases. Automatic candidate traversal, dependent - semantic packaging, and the proof-carrying public non-identity transaction - are complete for AliasFormer and AnnotatedPi; both additionally have exact - whole-call produced packages in their real pre-/post-family environments. - Published checkpoint `cf3d5a47` extends the same complete path to - `IndexedVec`, including its parameter/index family, ordered `nil`/`cons` - candidate list, - producer-selected semantic package, certified transaction, and checked E1 - replay. Generic arbitrary-metadata whole-call package construction and the - remaining I2-I4 - breadth matrix remain.** -- [x] Introduce reusable fold witnesses for typed metadata constants and defeq - rules. `AddInductConstants` and `AddDefEqs` expose fold realization, output - lookup/rule membership, input freshness, and `VEnv.LE`; the map-side lemmas - additionally preserve `SMap.WF` and show that new metadata cannot fabricate - a value-bearing declaration. Quot's fixed four-step CPS chain remains the - small fixed-shape analogue. -- [x] Define proposition-valued `AddInduct` as the nonemptiness of an internal - data-bearing `AddInductTrace` that aligns one Stage-3 `inductInfo`, the - ordered `ctorInfo` list, one `recInfo`, and all generated iota rules with the - corresponding Theory operations. This preserves the original public - `AddInduct … : Prop` shape while the hidden trace retains intermediate - maps/environments so proofs do not reconstruct a `foldlM` execution. The - trace now carries the exact dependent `GenerationChecked decl` and - `GenerationChecked.WF` certificate and derives its raw family, constructor, - recursor, and rule payload from that single normalized artifact instead of - duplicating Stage-3 acceptance and generation fields. -- [x] Prove `AddInduct.to_addInduct`, `AddInduct.le`, and - `Aligned.addInduct`; remove both vacuous `nomatch` proofs. Complete the - formerly impossible `TrEnv'.of_value` inductive case by proving that - inductive metadata has `value? = none` and pulling old value lookups back - through every insertion. -- [x] Add compile-time closure guards for `AddInduct.to_addInduct` and - `Aligned.addInduct`. Their present `sorryAx` is inherited from the sorried - `TrProj` in `TrExprS`; E1 adds no axiom declaration. P0-P2 must make these - guards fail and then be tightened to a non-`sorryAx` closure. -- [x] Add a reusable replay/translation layer. `TrTypeExpr` separates the - structural metadata translation from typing, and `to_trExprS` obtains the - latter from the real Theory `WF` derivation. The elaborator fixture quotes - `ConstantInfo` records from Lean rather than hand-building lookalikes. -- [x] Complete the Nat vertical slice: quote `inductInfo`, both `ctorInfo`s, - and `recInfo`; prove their translations in the exact intermediate - environments; construct `AddInduct`; execute `TrEnv'.induct`; and check - `TrEnv'.wf`, `TrEnv'.aligned`, final replay equality, and recursor lookup - uniqueness. Guard the fixture's exact transitional axiom closure. -- [x] Prepend a concrete value-bearing definition and prove that - `TrEnv'.of_value` still translates it after the Nat inductive transaction. - This must force the proof through the inductive branch; a quantified or - impossible metadata-value premise is not an adequate test. The fixture does - so with the actual `defnInfo` for `ReplaySeed`, and guards the resulting - closure. -- [x] Repeat the actual-metadata transaction for Eq, including its - parameter/index telescope, Prop recursor, universe permutation, final - replay equality, `WF`, alignment, and recursor lookup uniqueness. Guard the - exact closure and require it to equal Nat's rather than merely contain no - newly declared axiom. -- [x] Repeat the actual-metadata transaction for `IndexedVec` over the actual - Nat replay, and exercise type, changing-index constructor, and recursor - lookup uniqueness. The fixture deliberately spells its indices as - `Nat.zero` and `Nat.succ n`. The notation form exposed `OfNat.ofNat`, - `instOfNatNat`, `HAdd.hAdd`, `instHAdd`, and `instAddNat` (and transitively - `Nat.add`), which tests generic prelude-definition replay rather than the - inductive transaction. Record this as a reduced dependency claim, not as - evidence that the full notation-generated prefix has been replayed. -- [x] Repeat the actual-metadata transaction for `Acc`. Check the real metadata - counts and recursive rule fields, translate the declarations in their exact - intermediate environments, prove final replay equality/WF/alignment and - lookup uniqueness, and pin the quoted kernel `RecursorRule.rhs` - definitionally to the generalized Theory rule. Guard the fixture at the same - exact transitional closure as the other E1 replay roots. -- [x] Migrate `AddInductTrace` to I2's paired raw/view generation block and - replay the family-result and recursive-field alias declarations from actual - metadata. Both replays include their actual alias definitions, exact - intermediate environments, all kernel rule RHSs, final equality/WF/alignment, - and lookup uniqueness. -- [ ] **L4L-11:** extend L4L-01E's generic automatic candidate/package - construction across I2-I4's complete fixture matrix, - keeping every dependency environment explicit and checking type, every - constructor role needed by the family, 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. Abstract witness-only tests are not sufficient. - -### E2 — expose an oracle-construction theorem for ix (L4L-11) - -Provide consumer-neutral lemmas from which ix can fill every -`InductiveOracle` field: - -- `after` and `envLE` from `addInduct`/`addInduct_le`; -- `blockWF` from `VDecl.WF.induct` and `addInduct_WF`; -- translated type/constructor/recursor lookups from E1; -- `recursorFacts` from generated rule membership and registered defeqs; -- `recursorPatterns` from I5. - -Ix remains responsible for address/catalog membership, freshness of KIds, and -the `nameOf` bridge. If any semantic oracle field cannot be produced without a -new assumption, strengthen lean4lean's checked-block API rather than weakening -the ix theorem. - -## 8. Track L — move consumer-neutral APIs into Theory - -This track can proceed independently once compatibility imports are designed. - -### L1 — Theory API extraction (L4L-12A) - -- 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 so upstream code does not break during migration. - -### L2 — prove literal/prelude readiness, not an invalid containment shortcut (L4L-12B) - -`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: - -- readiness + `ContainsLits l` gives - `VExpr.WF env U [] (VExpr.trLiteral l)` (ix's `literalWF`/`hlit`); -- direct `trLiteral` meaning agrees with the Verify translation of - `Literal.toConstructor`; -- readiness is monotone under `VEnv.LE` and is preserved by unrelated - declarations. - -Then change ix's `WhnfTheory.literalWF` field into a derived theorem from its -world/prelude contract. - -### L3 — finish the Theory-only ix import surface (L4L-15C) - -Audit the three remaining Verify imports after L1/L2 and Track P. Add Theory -equivalents for genuinely mathematical lemmas, flip ix imports, build, and -only then remove compatibility shims. The target is zero -`import Lean4Lean.Verify.*` lines under `Ix/Tc/Verify/`. - -## 9. Track P — projection semantics and structures - -The old companion recommends a recursor encoding, but 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. - -### P0 — prove the API is expressible (L4L-13A) - -- Freeze the seven current lemma statements as regression tests, then check - whether a meaningful relation can satisfy them without strengthening their - premises. In particular test 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'`. Change Verify's - `TrExprS.proj` through a compatibility wrapper. Do not encode the missing - metadata as unconstrained existential witnesses. -- Coordinate the additive API with ix's `RawProjRel`; ix can close over its - concrete `VEnv` when constructing `TrProjOK`. - -### P1 — choose and define the semantics (L4L-13B) - -Default to a recursor encoding because it reuses generated iota rules and is -consumer-neutral. Compare it against the alternative of 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; -- structure eta and zero-field/unit-like behavior, or a precise statement of - what additional Theory rule is required. - -### P2 — structural law package (L4L-14) - -Prove the seven upstream obligations—weakening, inverse weakening, -context-defeq transport, WF, uniqueness, term substitution, and universe -instantiation—and expose a bundled theorem matching ix's `TrProjOK`. Preserve -the individual compatibility theorem names for upstream Verify. - -### P3 — projection checker verification (L4L-15A) - -Use the same structure view to prove: - -- `inferProj.WF`; -- `reduceProj.WF` for constructor applications and strings; -- the projection branches of WHNF and translation congruence. - -### P4 — structure eta and unit-like comparison (L4L-15B) - -Prove the semantic theorem needed by `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 ix impact, and obtain upstream agreement -before changing `IsDefEq`. This is a metatheory change, not a local checker -lemma. - -### P5 — ix handoff (L4L-14) - -Instantiate ix's `RawProjRel`, derive `TrProjOK`, remove the `TrProj` sorry -origin from both audit manifests, and add projection-bearing end-to-end -fixtures. `RawProjRel.none` remains useful only for explicitly projection-free -worlds. - -## 10. Track M — finish the live metatheory - -These results are scheduled completion work, while still requiring -coordination with Mario because upstream has active research branches. - -### MT1 — route selection and sort inversion closure (L4L-16) - -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. Do not merge the -whole experimental branch: it changes unrelated implementation and pattern -code and still contains adequacy sorries. - -### MT2 — close remaining injectivity and weakening inversion (L4L-17) - -Building on L4L-16's completed `IsDefEqU.sort_inv`, prove the remaining public -statements: - -- `IsDefEqU.forallE_inv_stratified`; -- `IsDefEqU.sort_forallE_inv`; -- `IsDefEqU.weakN_iff` in `UniqueTyping.lean`. - -Re-run `IsDefEq.uniq`/`uniqU`, context inversion, and all downstream -`#print axioms` checks. This milestone removes ix's two remaining upstream -metatheory sorry origins. - -### MT3 — close Church-Rosser's two `.extra` cases (L4L-18A) - -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 inversion/non-overlap library, and rule RHS congruence to -prove the commuting diagrams. Keep the theorem generic in `[Params]`; concrete -environment assembly is a separate theorem. - -Consume the concrete `Params` package already closed by L4L-10B and check that -`ParRed.church_rosser`, normal-form -uniqueness, and the live Standardization/HeadReduction endpoint contain no -hidden placeholder assumptions. - -### MT4 — stabilize the `.extra` extension contract (L4L-18B) - -Document `.extra` as the supported hook for consumer-certified defeqs and add -the missing monotonicity/transport lemmas under `VEnv.LE`. State exactly what -an ix `NativeOracle` must prove (typedness, symmetry/closure as needed, pattern -compatibility) and what lean4lean does not trust automatically. - -## 11. Track V — finish Verify after the specifications exist - -### V1 — independent level-normalizer proofs (L4L-02A/L4L-02B) - -First prove `NormLevel.subsumption_eval` in L4L-02A. Ix's sorry-free level -normalizer uses a different representation but offers a proof decomposition to -port. Then prove the v4.31-added `NormLevel.isEquiv_wf` in L4L-02B from the -normalizer evaluation/subsumption facts and close its downstream list theorem. -Keeping these as two commits gives each upstream placeholder one exact removal -and prevents the small algorithmic invariant proof from being hidden inside a -larger checker patch. Neither proof has a technical dependency on inductive -APIs, but publication remains serialized after L4L-01E so §13 has one active -checkpoint at a time. - -### V2 — recursor reduction (L4L-19A) - -After I5 and E1, prove `reduceRecursor.WF` for Quot and inductive rules. The -proof must obtain the selected rule, match, checks, RHS translation, and result -typing from the generated/translated metadata—not from a global oracle. - -### V3 — projection/eta checker roots (L4L-15A/L4L-15B) - -Track P discharges `inferProj.WF`, `reduceProj.WF`, -`tryEtaStructCore.WF`, and `isDefEqUnitLike.WF`. Re-run the enclosing -`inferType`, `whnfCore`, and `isDefEq` theorems so the absence of a local sorry -also removes it from every exported root. - -### V4 — complete environment-to-checker theorem (L4L-19B) - -Build `TrEnv` for 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. - -## 12. Track T — trust closure, release engineering, and upstreaming - -### T1 — make the sorry frontier shrink to zero (L4L-19C) - -Keep the token-aware script exact. Every proof PR deletes entries; no PR may -rename/move a sorry and merely update the allowlist. At zero, invert the script -to reject every live sorry without an allowlist. - -### T2 — audit and retire custom axioms (L4L-20A) - -Treat the inventory in §2.3 as an initial declaration audit, then generate the -actual transitive closure for every supported root. At minimum the root set -contains: - -- `Checked.analysis_accepted`, its closure/level/name/anatomy consequences, - `Checked.wf_of_decl`, `Checked.to_declWF`, - `VInductDecl.wf_iff_exists_checked`, `VEnv.addInduct_success`, - `VEnv.addInduct_checked`, `VEnv.addInduct_WF`, the recursive-Pi - recursor/rule-preservation roots, and every later checked-inductive/projection - API exported to ix; -- the unique-typing, Church-Rosser, standardization, and head-reduction - endpoints used downstream; -- `TypeChecker.whnf.WF`, `inferType.WF`, `checkType.WF`, `isDefEq.WF`, the - remaining public checker operations, and the final executable-checker - soundness theorem; -- every theorem name imported by ix's audit manifests. - -Generate the report rather than hand-maintaining it. Each row must record the -root, layer (`Theory`, `Verify`, or ix), standard Lean axioms, project-specific -axioms, classification from §2.3, pinned Lean revision, and disposition. Keep -normalized output under version control or as a deterministic CI artifact so -that a dependency change produces a reviewable diff. - -The first Theory rows are already enforced locally: all exported checked -structural facts, the three semantic compatibility bridges, the success/exact -analysis/collision transaction facts, and `VEnv.addInduct_success` close over -exactly `propext` and `Quot.sound`; `VEnv.addInduct_WF` and the six -recursive-Pi preservation roots additionally reach `Classical.choice`. -Compile-time `#guard_msgs` checks pin those results. No custom axiom was added -for either `Checked`, `Checked.WF`, or generalized inductive preservation. -Generalize this mechanism into the generated multi-root report rather than -replacing the local guards. - -Use four acceptance states: - -1. **Logical baseline:** `propext`, `Classical.choice`, and `Quot.sound` (usually - a subset) are accepted where required. -2. **Platform contract:** an unavoidable runtime property may remain only when - narrowly stated, named in the platform manifest, version-pinned, covered by - differential and adversarial tests, and absent from Theory roots. -3. **Transitional bridge:** a plausible opaque/reference equation has a removal - issue and may support intermediate Verify work, but cannot silently become a - release assumption. -4. **Forbidden:** an equation known false on a supported toolchain, or not yet - proved after the relevant implementation changed, may not occur in any - supported root, even if the kernel cannot reduce the opaque/native function - far enough to derive `False` internally. - -Retire the classes in risk order: - -1. Finish the cache-equation retirement started by L4L-01U. Five declarations - are gone; remove the remaining three from reachable proofs, then prove the - corrected v4.31 contracts, make the checker execute proved structural - functions, prove sufficient reachable-input invariants, or weaken the - refinement claim honestly. Merely deleting `[simp]` reduces accidental use - but does not discharge an assumption. -2. Convert the thirteen reference equations into logical definitions with - `@[implemented_by]` only when the replacement is known extensionally - correct; otherwise use the reference implementation in the verified path. -3. Replace the five collection and five opaque/layout equations with upstream - theorems or narrowly bounded/WF lemmas. Do not assume equality on malformed - states when only constructor-reachable states are needed. -4. Decide the final platform budget explicitly. The expected candidates are the - two pointer-equality implications and, if it cannot be eliminated, - `Level.instLawfulBEqLevel`; retention is a reviewed decision, not a default. - -CI must reject a new unclassified project axiom, any project axiom in a Theory -root, any forbidden axiom in a supported root, or a retained platform contract -without its manifest entry and tests. It must also reject attaching `[simp]` to -a project-specific axiom: simplifier reachability is too implicit for a bridge -contract. T2 is complete only when the report can be regenerated from a green -build and every remaining dependency is in an accepted state. - -### T3 — differential adequacy (L4L-20B) - -Add a test harness that elaborates fixture declarations with Lean, translates -the resulting raw environment metadata, constructs the justified analysis -view, and compares it with Theory generation. Run it over the fixed fixture -matrix in CI and over ix's declaration corpus at pin time. Compare failures as -data: accepted/rejected, raw/view normalization stage, generated constants, -universe lists, field counts, recursive positions, K flag, rule count, and -every RHS. - -### T4 — upstream PR series (L4L-20C) - -Keep semantic patches reviewable and dependency ordered: - -1. level-normalizer proof and small generic lemmas; -2. Theory API extraction with compatibility re-exports; -3. Stage-1/2 inductive vertical slice and fixtures; -4. indexed/normalization/small-elimination/recursive-argument support; -5. mutual and nested support; -6. pattern package and Verify `AddInduct` alignment; -7. projection structure view, laws, and checker proofs; -8. injectivity/Church-Rosser completion; -9. remaining checker and axiom-minimization work. - -Do not rewrite the published `jcb/induct` checkpoints. L4L-01U merges current -upstream into that development line once; each later upstream PR series is -then 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 for it. Record every PR and downstream pin in the -divergence ledger. - -## 13. Milestones and gates - -This is the sole status-bearing execution ladder. Exactly one milestone may be -`active`; all earlier milestones must be `complete`, and all later milestones -remain `queued`. A milestone becomes complete only when its entire deliverable -and every applicable gate below pass on one committed checkpoint. Earlier -partial implementation counts as a prerequisite, never as partial milestone -credit. A suffixed identifier such as L4L-01A is a full checkpoint with its own -commit and gates; completing L4L-01A does not confer partial completion on -L4L-01B or permit work to skip directly to L4L-01E. L4L-01U is the mandatory -upstream-integration checkpoint inserted after L4L-01B; the physical row order -is authoritative, and L4L-01C may not start before L4L-01U is complete. - -| Milestone | Status | Exact deliverable | Completion evidence and ix result | -|---|---|---|---| -| **L4L-00 — published generation-readiness baseline** | **complete** | Stabilized fork infrastructure; one generalized source/view artifact path; proof-carrying non-identity transaction; retained semantic hierarchy; complete executable generation-shape gate; AliasFormer, AnnotatedPi, and `IndexedVec` checkpoints. | Source `bbb45e0e`, ledger child `c4fd62b2`, all gates green. Ix Pin A remains the separately recorded `5e5bb767`/`1f73f5c0` pair and has removed the three former inductive sorry origins without making an oracle claim. | -| **L4L-01A — staged semantic-input consolidation** | **complete** | Introduce one source-indexed builder over explicitly verified pre-family/post-family candidate stages, strict family/constructor translations, exact raw-family insertion alignment, and the existing dependent `Produced` traversals. Return the existing `Nonempty ProducedNormalizationCandidateSemanticRun`; make no view-WF or generation-package claim. | Source `7c792209`. AliasFormer, AnnotatedPi, and `IndexedVec` use the builder; their per-root semantic-input definitions are gone and exact constructor order is retained. Existing explicit downstream witnesses and one `viewWF` proof per positive are marked temporary until L4L-01E; no choice extractor was added; focused and universal gates pass. | -| **L4L-01B — family-validation semantics and staging** | **complete** | Interpret the exact singleton `checkInductiveTypes`/family-candidate run from one verified entry context. Derive view telescope and terminal-sort WF, raw-family constant WF through candidate defeq, exact insertion, and the verified post-family candidate stage. | Source `da45b536`. Exact singleton validation semantics derive the parameter/index view split, terminal/raw-family WF, exact insertion, and post-family candidate stage. AliasFormer, AnnotatedPi, and `IndexedVec` supply no independent post-family `VEnvs`/context; family terminal, annotation, fuel, and non-sort negatives remain phase-sharp; constructors remain uninterpreted; exact guards and universal gates pass. | -| **L4L-01U — upstream v4.31 reconciliation** | **complete** | Merge digama `upstream/master` through `ef849dfbd94a` without rewriting fork checkpoints or moving either master. Retain the v4.31 proof/API ports, upstream's five custom-axiom removals, the fork's Nix/CI and certificate surfaces, and the exact classifications of `NormLevel.isEquiv_wf` (L4L-02B) and `addDecl.WF` (L4L-19B). Add no constructor-trace work. | Source `7f864b459e4a6062b468d6e5416688feac0f9f99`. The 154-job Lake build, `nix build`, current-host six-check flake build, all-system no-build evaluation, formatter, CLI replay, exact 22-entry sorry guard, and exact 29-declaration axiom inventory pass. Root guards show no supported-root trust growth. The isolated ix v4.31 probe is diagnostic only; ix migration is deferred. The source and ledger are published on origin `jcb/induct`, and only that branch moved. | -| **L4L-01C — retained constructor-validation trace** | **active** | Add dependent operational evidence for the complete successful singleton `checkConstructors` traversal: duplicate/closedness/root-check, parameter equality, field type/universe, positivity/recursive-target, and terminal-family-application steps. Prove decomposition and recomposition with the executable result. | The trace is source ordered and exact; missing/extra/reordered and each validation-phase negative remain sharp; successful trace equivalence has only the executable baseline closure and makes no Theory-WF claim. | -| **L4L-01D — constructor-validation semantics and view WF** | queued | Interpret the L4L-01C trace with verified checker refinements and retained candidate normalization. Derive `fieldsWF`, constructor result `SpineWF`, and WF of the exact analyzer-owned view declaration for the currently accepted singleton subset. | All three fixture `viewDecl_wf` proofs are deleted; no `Checked.WF`, view, or view-WF premise is renamed or reintroduced; exact axiom guards pass; no normalization or validation breadth is widened. | -| **L4L-01E — generic singleton package closure** | queued | Combine the L4L-01A–01D owner, exact dependent analysis, and `ProducedGenerationShapeCandidate` into `Nonempty ProducedGenerationCandidatePackage`, retaining the exact ordinary producer equation without granting it shape or Theory authority. | All three positives use only the generic closure theorem; missing/extra/reordered/truncated/non-defeq regressions remain sharp; no manual semantic-input/view-WF scaffolding remains; universal gates pass. | -| **L4L-02A — level subsumption evaluation** | queued | Prove `NormLevel.subsumption_eval` with its existing statement and remove exactly that sorry-frontier entry. Keep the patch independent of inductive APIs. | Focused Level and full builds pass; the theorem's exact axiom closure is accepted; the frontier drops from 22 to 21; the change is a small upstream-ready commit. | -| **L4L-02B — level equivalence soundness** | queued | Prove the v4.31-added `NormLevel.isEquiv_wf` from the evaluator/subsumption library and close the dependent list-level soundness path without changing the executable normalizer. | Focused Level and full builds pass; exact root guards add no custom axiom; the frontier drops from 21 to 20; the change is a separate upstream-ready commit. | -| **L4L-03 — singleton environment-sensitive validation parity** | queued | Complete remaining singleton `checkInductiveTypes`/`checkConstructors` acceptance behavior: pre-declaration `checkType`, transparency/fuel-correct WHNF Pi/result peeling, WHNF recursive-target traversal, and definitional constructor-parameter agreement. | A syntactically different but definitionally equal positive and a genuinely non-defeq negative match kernel outcomes and traverse the L4L-01E package/E1 path. Result-level equality across mutual families remains excluded. | -| **L4L-04 — singleton normalization differential matrix** | queued | Cover family-result, parameter/index-domain, ordinary-field, direct-recursive, and Pi-hidden recursive aliases, including beta/let, opacity/non-defeq, and fuel boundaries. | Every case compares raw payload, normalized descriptor, recursive positions, recursor, and all rules with kernel metadata and replays through E1; generic rather than fixture-only axiom guards pass. | -| **L4L-05 — singleton positivity and constructor-validity parity** | queued | Extend acceptance/rejection to the kernel matrix for nested-negative occurrences, family mentions in nonrecursive/dependent/proof fields, recursive functions, and constructor universe bounds. | Each branch has the nearest-kernel differential; all accepted cases use L4L-01E and replay through E1; no proof-only premise or oracle broadens acceptance. This is breadth/completeness, distinct from L4L-01D soundness. | -| **L4L-06A — elimination mode and recursor levels** | queued | Implement `isLargeEliminator`, `getElimLevel`, `getRecLevels`, and `getRecLevelParams`; make `ElimMode.small` constructible and drive motive/recursor generation. | Or/And have exact Prop-only recursors; Eq-like and never-zero families retain legitimate large elimination; level parameter order matches kernel metadata and all rules. | -| **L4L-06B — K-target parity** | queued | Add `isKTarget` data and generation behavior without using K to bypass invalid elimination. | Eq-like positive and non-K negative fixtures match the kernel flag, recursor, universe order, and rules; L4L-06A regressions stay green. | -| **L4L-06C — empty and singleton edge shapes** | queued | Cover empty families and zero-/one-constructor behavior, including recursor/minor/rule edge cases. | Unit/Empty and focused edge fixtures match binder/minor ordering, field counts, recursive metadata, rule count, and every RHS; preservation uses the common checked path. | -| **L4L-07 — complete one-family parity** | queued | Integrate L4L-01A through L4L-06C into the fixed I2 positive/negative matrix, remove obsolete singleton staging seams, and replay every accepted family through E1. | Nat, Bool, List, Option, Prod, Unit, Empty, Or, And, Eq, HEq, Fin, Vector, Acc, and normalization cases match all recorded kernel fields. Only one public artifact path is live; all fixture/default/Nix gates pass; L4L-11 remains queued. | -| **L4L-08A — mutual checked representation** | queued | Generalize checked analysis to dependent lists of families with shared parameters, per-family indices/results/constructors, and cross-family recursive targets. | Tree/TreeList and a mutual indexed descriptor compute with exact source order; no generation or environment insertion is claimed. | -| **L4L-08B — mutual validation and normalization** | queued | Generalize validator traces, semantic interpretation, all-family staging, normalization, and package construction to mutual blocks. | Shared-parameter/result-universe positives and mismatch/reorder negatives match kernel phases; both fixtures obtain exact semantic packages; no generated recursor claim is made. | -| **L4L-08C — mutual generation and replay** | queued | Generate/preserve all motives, flattened minors, per-family recursors, and rules; insert types, constructors, recursors, and rules in kernel order. | Both mutual fixtures round-trip actual metadata, every RHS, `Ordered`, lookups, and E1 alignment; no singleton destructuring remains public. | -| **L4L-09A — nested representation decision** | queued | Audit `numNested`/flattened auxiliary metadata and commit an additive representation or proved pre-flattening relation with executable probes and ix compatibility evidence. | The design is sufficient for real rose-tree and nested-indexed metadata; no acceptance behavior or public field is changed without demonstrated need. | -| **L4L-09B — nested transformation and positivity** | queued | Model the chosen nested transformation, auxiliary descriptors, and validation/positivity obligations. | Rose-tree/List and nested-indexed transformed descriptors plus nearest negatives match kernel acceptance; recursor generation is not yet claimed. | -| **L4L-09C — nested generation and replay** | queued | Generate/preserve auxiliary declarations, recursors, and rules and replay the nested packages. | Both fixtures round-trip real `Inductive.Add.run` output through generic packaging and E1, comparing every metadata field and RHS. | -| **L4L-10A — generated iota pattern core** | queued | Express generated LHSs as `SimplePattern.iota`; prove inversion, recovery, distinctness/nonintersection, and uniqueness obligations; port consumer-neutral shape helpers. | 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 assembler** | queued | Prove `pat_wf` and assemble block-local `Params` for generated rules plus separately certified extensions. | The assembler is generic over certified extensions, has no global open-environment instance, and exposes exactly the helpers ix and Church–Rosser consume. | -| **L4L-11 — inductive oracle handoff** | queued | Generalize E1 replay to the complete I2-I4 matrix and a notation-heavy prelude environment; expose E2's consumer-neutral after/LE/WF/lookup/rule/pattern theorem; adapt ix's existing staged E2b construction to the advertised full block class. | Lean4Lean and ix are green at one recorded Pin B pair; ix constructs `InductiveOracle` from ordinary semantic world/certified block evidence for that class and removes the superseded assumed block interface where possible. No Verify state or normalization oracle crosses the Theory boundary. | -| **L4L-12A — Theory API extraction** | queued | Move VExpr-only local-declaration and literal syntax/readiness interfaces into Theory modules with compatibility re-exports; keep `FVarId`, `Lean.Expr`, and traversal in Verify. | Lean4Lean and ix build through compatibility names; no semantic assumption is removed yet; import-direction and exact axiom gates pass. | -| **L4L-12B — literal and prelude readiness** | queued | Define the exact Ordered/type/rule readiness predicate and prove literal WF, Verify-translation agreement, monotonicity, and preservation. | Ix derives and removes `literalWF`/`hlit` assumptions; notation-heavy fixtures pass; no invalid name-containment shortcut is used. | -| **L4L-13A — projection expressibility decision** | queued | Freeze seven obligations, test the current `TrProj` signature, and commit the minimal env-indexed structure-view API if required. | Real parameterized/dependent/universe fixtures demonstrate representability; missing metadata is not hidden in unconstrained existentials; ix API compatibility is recorded. | -| **L4L-13B — projection semantics** | queued | Choose recursor- or projection-constant semantics and define one faithful relation for field types, constructor reduction, congruence, lift/substitution/levels, and eta requirements. | 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 and Ix Pin C** | queued | Prove weakening, inverse weakening, context transport, WF, uniqueness, term substitution, and universe instantiation; bundle them as ix's `TrProjOK` and preserve compatibility theorem names. | Ix instantiates concrete `RawProjRel`/`TrProjOK`, projection fixtures pass, and the `TrProj` sorry origin is removed from both ix audit manifests at a recorded Pin C pair. | -| **L4L-15A — projection checker verification** | queued | Prove `inferProj.WF`, `reduceProj.WF`, and projection WHNF/congruence branches from the L4L-13B view and L4L-14 laws. | 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** | queued | Derive `tryEtaStructCore.WF` and `isDefEqUnitLike.WF`, or complete an approved metatheory change if a primitive eta rule is truly necessary. | Both roots are sorry-free and audited; any Theory-rule change has subject-reduction/injectivity/confluence and ix impact evidence. | -| **L4L-15C — Theory-only ix imports** | queued | Migrate remaining consumer-neutral lemmas and remove Verify imports from ix after L4L-12B/L4L-15B. | `rg '^import Lean4Lean.Verify' Ix/Tc/Verify` is empty; compatibility shims are removed only after both repos build. | -| **L4L-16 — metatheory route selection and sort inversion** | queued | Timebox and compare the logrel and stratified routes; enumerate all assumptions; select one route; and close the existing public `IsDefEqU.sort_inv` theorem on a focused committed checkpoint without importing the unfinished experimental branch wholesale. | The public sorry is removed with an exact accepted axiom closure; only the necessary proof and generic lemmas are merged; the chosen and discarded routes are documented with concrete remaining obligations. | -| **L4L-17 — remaining injectivity and weakening inversion** | queued | Building on L4L-16's `sort_inv`, close `forallE_inv_stratified`, `sort_forallE_inv`, and `weakN_iff`, then re-audit unique typing and context inversion. | Ix removes its two remaining Lean4Lean metatheory sorry origins at a recorded Pin D pair; affected Theory and checker roots have exact accepted closures. | -| **L4L-18A — Church–Rosser `.extra` cases** | queued | Prove both generic `NormalEq.parRed` commuting cases using L4L-10B inversion/nonoverlap and RHS congruence. | Church–Rosser, normal-form uniqueness, and live standardization/head-reduction endpoints contain no placeholder; extension-policy work remains queued. | -| **L4L-18B — extension contract** | queued | Stabilize `.extra` monotonicity/transport under `VEnv.LE` and state the exact consumer `NativeOracle` typedness/closure/pattern contract. | Generic lemmas and ix boundary build; no external defeq is trusted automatically or smuggled through generated `Params`. | -| **L4L-19A — recursor reduction verification** | queued | Prove `reduceRecursor.WF` for Quot and certified inductive rules from selected rule/match/check/RHS metadata. | Quot, singleton, mutual, and nested recursor reductions pass without a global oracle; enclosing WHNF roots have exact guards. | -| **L4L-19B — environment-to-checker closure** | queued | Prove remaining nonprojection checker refinements and full `TrEnv` over ordinary declarations, Quot, all supported inductives, literals, structures, and extension defeqs; close the executable-checker theorem. | The complete environment corpus and final checker root build with exact closures; only the mechanical zero-sorry policy switch remains. | -| **L4L-19C — zero-sorry gate** | queued | Remove every remaining supported Theory/Verify sorry and invert the frontier script to reject any new one. | Token-aware frontier is zero, no allowlist remains, full gates pass, and ix audits shrink accordingly. | -| **L4L-20A — axiom reachability and retirement** | queued | Generate transitive root manifests, classify every dependency, and eliminate all forbidden/transitional project/platform contracts. | No project axiom reaches Theory; every retained platform contract is explicitly accepted and tested; both repos' audits agree. | -| **L4L-20B — complete differential corpus** | queued | Automate actual Lean metadata translation/comparison across the fixed inductive, projection, prelude, extension, and ix declaration corpus, including failures as data. | CI compares acceptance phase, metadata, generated constants, universes, recursive positions, flags, rules, and every RHS; all supported cases pass. | -| **L4L-20C — upstream series and release** | queued | Submit dependency-ordered semantic PRs, publish coherent Lean4Lean/ix final pins, and resolve every divergence-ledger entry. | Both repos are green at final pins; each fork delta is upstreamed or has an owner, issue, and removal condition; final release artifacts and manifests are reproducible. | + the accepted logical baseline (usually a subset). Verify bridge contracts + need a separate, named manifest. “It was already in `Verify/Axioms.lean`” + is not acceptance. +11. **Every fork divergence is tracked.** `upstream-divergence.md` carries one + entry per semantic/API delta, its downstream impact, test, upstream + issue/PR, and removal condition. Empty means fully upstreamed. + +## 5. Milestone ladder + +This is the sole status-bearing execution ladder and the only milestone +naming scheme. Exactly one milestone may be active; every later milestone is +queued, and no later milestone begins until the active one is complete. A +milestone completes only when its entire deliverable and every applicable §6 +gate pass on one committed checkpoint; completed milestones are then removed +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. + +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 +inversion/non-overlap library, and rule RHS congruence to prove the +commuting diagrams, keeping the theorem generic in `[Params]`. +*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) + +**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. +*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 +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. +*Exit:* the complete environment corpus and final checker root build with +exact closures; only the mechanical zero-sorry policy switch remains. + +**L4L-19C — zero-sorry gate.** Remove every remaining supported Theory/Verify +sorry. Keep the audit allowlist exact throughout: every proof PR deletes +entries, and no PR may rename/move a sorry and merely update the allowlist. +At zero, reduce the allowlist to the deliberately kernel-rejected fixture +recoveries so any sorried declaration fails outright. +*Exit:* the proof-debt frontier is zero, only fixture-recovery entries +remain, and full gates pass. + +### Trust closure and release (L4L-20A–L4L-20C) + +**L4L-20A — axiom reachability and retirement.** Generate the actual +transitive closure for every supported root rather than hand-maintaining §3. +The root set contains at minimum the exported +checked-inductive/transaction/preservation roots and the consumer-facing +checked-inductive/projection API; the unique-typing, Church-Rosser, +standardization, and head-reduction endpoints; and the public checker +operations with the final executable-checker soundness theorem. Each row +records the root, layer, standard axioms, project axioms, §3 classification, +pinned Lean revision, and disposition; keep normalized output under version +control or as a deterministic CI artifact so a dependency change produces a +reviewable diff, generalizing the existing local `#guard_msgs` mechanism. + +Acceptance states: (1) logical baseline; (2) platform contract — narrowly +stated, manifested, version-pinned, tested, absent from Theory roots; +(3) transitional bridge — named, classified, with a removal issue, never a +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 +`@[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 +two pointer-equality implications, possibly lawful level `BEq`). CI must +reject a new unclassified project axiom, any project axiom in a Theory root, +any forbidden axiom in a supported root, a retained platform contract without +manifest entry and tests, and `[simp]` on any project-specific axiom. +*Exit:* the report regenerates from a green build with every dependency in +an accepted state; no project axiom reaches Theory. + +**L4L-20B — complete differential corpus.** Automate a harness that +elaborates fixture declarations with Lean, translates the resulting raw +environment metadata, constructs the justified analysis view, and compares it +with Theory generation, across the fixed inductive, projection, prelude, and +extension corpus. Compare failures as data: accepted/rejected, raw/view +normalization stage, generated constants, universe lists, field counts, +recursive positions, K flag, rule count, and every RHS. +*Exit:* CI compares acceptance phase, metadata, generated constants, +universes, recursive positions, flags, rules, and every RHS; all supported +cases pass. + +**L4L-20C — upstream series and release.** Submit dependency-ordered semantic +PRs: (1) level-normalizer proofs and small generic lemmas; (2) Theory API +extraction with compatibility re-exports; (3) the staged inductive vertical +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 +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 +or has an owner, issue, and removal condition; release artifacts and +manifests are reproducible. + +## 6. Gates and process Every milestone must pass all applicable gates: ```text -perl .github/scripts/check_sorry_frontier.pl -nix develop --command lake build Lean4Lean.Theory Lean4Lean.Verify -nix develop --command lake build -nix build -nix flake check --all-systems --no-build --accept-flake-config +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 -- --check . +nix fmt --accept-flake-config -- --check flake.nix git diff --check ``` +The dev-branch fileset flake does not support eval-only checking +(`nix flake check --no-build` fails with "path '…-source' is not valid", as +documented at the `leanSrc` definition), so the flake gate builds for real; +non-Linux systems stay declared but ungated, matching dev CI. + The flake is authoritative: milestone evidence must use the pinned Nix -toolchain and dependencies. Elan or a host `lake` invocation may be used only -as a non-authoritative diagnostic and never substitutes for either Nix-wrapped -Lake build, `nix build`, or the flake checks above. +toolchain and dependencies. The Lake commands above run directly from the +already active `nix develop` shell; from outside that shell, +`nix develop --command lake ...` is equivalent. Elan or another host `lake` +never substitutes for the pinned-shell Lake builds, `nix build`, or the flake +checks above. Additionally: - all new fixtures build in a default proof target; - new theorem roots have checked `#print axioms` output; -- every named root satisfies the boundary-specific axiom threshold in §2.3, +- every named root satisfies the boundary-specific axiom threshold in §3, with no `sorryAx` or project-specific dependency in a Theory root; - `rg '^import Lean4Lean.Verify' Lean4Lean/Theory` is empty; - every source/view pair accepted by the public checked transaction is generated and preserved by the same artifact path; temporary direct/generalized or raw/normalized migration functions are not both semantically live at a checkpoint; -- touched existing Theory names are grepped in ix before merge; -- the kernel differential matrix is green for inductive/projection changes; -- at an ix pin, `lake update lean4lean`, full `lake build IxTcVerify`, and both - audit executables pass with shrink-only sorry-origin edits. - -The retired C0-C8 grouping maps to this ladder as follows: C0 = L4L-00; -C1 = L4L-01A through L4L-07; C2 = L4L-08A through L4L-09C; C3 = -L4L-10A/L4L-10B/L4L-11; C4 = L4L-12A/L4L-12B plus L4L-15C; C5 = -L4L-13A through L4L-15C; C6 = L4L-16 through L4L-18B; C7 = L4L-02A/L4L-02B plus -L4L-19A through L4L-19C; and C8 = L4L-20A through L4L-20C. These mappings are -historical cross-references, not alternative completion gates. - -## 14. Ix pin and migration protocol - -Pin A is complete and belongs to L4L-00. Pin B is the exit of L4L-11, Pin C -the exit of L4L-14, and Pin D the exit of L4L-17. L4L-12A/L4L-12B and -L4L-15A–L4L-15C also require ix migrations, but they shrink API/import debt -rather than create a new numbered semantic pin. L4L-20C records the final -release pair. - -L4L-01U is an upstream/toolchain integration checkpoint, not a numbered ix -pin. Its isolated v4.31 probe establishes that merged Lean4Lean modules replay -and the consumer-facing runtime modules elaborate; it does not require this -repository to port ix's own ByteArray, Batteries `RBTree`, or proof-library -APIs. Perform that migration in ix at the next authorized pin and keep its -worktree, lockfile, and branch out of Lean4Lean commits. - -For every Pin A-D: - -1. Publish a green lean4lean commit and record its full hash. -2. Set ix's lean4lean dependency to that exact fork hash (or the equivalent - upstream hash once merged), update the lockfile, and record the manifest - pair. Do not assume the preceding pin or remote still names the intended - source tree. -3. Build the complete verification target, not only `lake build ix`. -4. Inspect audit diffs. Delete disappeared sorry origins; investigate any new - axiom before allowlisting it. -5. Add the new API usage and compatibility import in ix. -6. Only after both repos are green, delete ix-side copies/assumptions and old - lean4lean shims. -7. Record the known-good revision pair and the remaining demand-ledger rows. - -The following stay in ix: `KExpr`/addresses/Blake3/collision freedom, -`KVLCtx`, K-expression substitution and universe instantiation, the `TcM` -Hoare layer, `Methods` knot, catalog/cache/world provenance, execution proofs, -and `NativeOracle`. Move proof *techniques* or VExpr-generic lemmas, not -consumer-specific state. - -## 15. Principal risks and decision points - -- **Checkpoint/pin drift.** The generalized one-family generator, - recursive-Pi proof, public transaction, `Acc` replay, paired normalization - boundary, complete mixed preservation, public artifact switch, normalized - Verify trace, checked normalization/type-check producers, complete checked - alias generation certificates, six actual-metadata replays, context-indexed - candidate provenance, existential checker-output translation recovery, - exact verified candidate root/binder contexts, and annotation-complete - recursive certification, singleton candidate-list normalization, generic - candidate-spine extraction, dependent generation assembly, and the complete - AnnotatedPi recursive-Pi annotation replay, plus the certified public - non-identity consumer boundary and exact whole-call produced packages for - both AliasFormer and AnnotatedPi, plus generic parameter/index family - validation, the exact real `IndexedVec` family/constructor candidates, its - complete outer producer equation, generic exact identity replay, complete - produced semantic package, certified transaction, and checked E1 replay are - joined by generic arbitrary-length operational list assembly, a generic - source/candidate-indexed outer produced-package constructor, automatic - source-ordered semantic hierarchy assembly under `Nonempty`, and - semantic-owned generation/package projections. Exact checked decomposition, - singleton family-view recovery, one post-family constant typing proof, and - checked constructor-result spines now derive every view telescope and - terminal typing judgment without fixture oracles. Exact analyzer success now - also determines normalization identity, and retained semantic evidence - reconstructs post-family WF; no fixture supplies either fact. Exact analysis - plus minimal stored-spine/count shapes now also determine raw/check family - identity, normalized pair identity and source order, all raw - telescope/results and view terminals, and the complete dependent constructor - list. The consolidated generation-readiness gate now checks this complete - hierarchy at runtime, rejects missing or extra raw constructors, and lets - exact dependent analysis plus analyzer-owned view WF derive checked WF and - every per-position shape record. `IndexedVec` proves the automatic hierarchy - retains both constructors in exact source order and that a swapped view fails - the computational normalization-shape gate. All three fixtures retain exact - strengthened-producer results without treating bare producer success as - semantic authority. L4L-01A additionally consolidates the staged semantic - inputs while retaining the exact source order and intentionally returning - the hierarchy only under `Nonempty`. L4L-01B derives raw-family WF, exact - insertion, and the post-family candidate stage from the singleton family - validator, so no positive supplies an independent post-family context. The - current source is the L4L-01U merge - `7f864b459e4a6062b468d6e5416688feac0f9f99`, whose parent pair and - publication evidence are recorded in §13 and this ledger child on - `jcb/induct`. The exact - 22-entry sorry-frontier check, 154-job default Lake build, default Nix build, - all six current-host flake checks, all-system no-build evaluation, formatter, - CLI replay, and whitespace checks were rerun on 2026-08-04 over that source. - Exact compile-time guards show that the new generic and fixture roots add no - axiom; their broad Verify closure remains explicitly transitional. Pin A - uses the earlier certificate-bearing `5e5bb767` checkpoint, paired with local - ix snapshot `1f73f5c0`; keep that pair and this later producer checkpoint - recoverable, require the corresponding Linux/Darwin CI builds at a pin or - release boundary, and record any replacement hash in both roadmaps. +- exported Theory names change only additively, through compatibility + re-exports and a deprecation window; +- the kernel differential matrix is green for inductive/projection changes. + +**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 +remote-ref verification is part of each publication. Keep published +checkpoints recoverable, and refresh the divergence ledger and sorry-frontier +wording with each checkpoint. + +**Downstream consumers.** Lean4Lean is an independent upstream. Downstream +projects pin published green checkpoints and are responsible for their own +migrations, audits, and pin cadence; their demand analyses, oracle +constructions, and migration protocols live in their own repositories and do +not gate this ladder. Consumer worktrees, lockfiles, and branches stay out of +lean4lean commits. What this repository guarantees to consumers: published +checkpoints pass the complete gate; exported Theory APIs are consumer-neutral +and change additively with compatibility re-exports; the trust story (exact +per-root guards, the tracked sorry frontier, the divergence ledger) travels +with every checkpoint; and consumer-facing semantic obligations are met by +strengthening the checked-block API here, never by asking a consumer to +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. - **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. -- **Analyzer/artifact drift.** This failure mode is now guarded rather than - present for the raw-normal-form subset: recursive-Pi analysis, public - `Checked` accessors, preservation, transaction output, and Verify metadata - all use the generalized artifacts. `NormalizedChecked` now pairs the raw - singleton payload and view classification; constructor-level raw field - pairing, the complete mixed generator, the public identity specialization, - and normalized Verify replay now close the artifact/transaction part of this - risk. The checked equality/type/certificate layer, generic candidate - generation assembler, and candidate-derived AliasFormer and `AnnotatedPi` - transactions are live, and the staged whole-candidate non-defeq rejection is - pinned. AliasFormer and AnnotatedPi exact whole-call results now select their - produced semantic packages. Published checkpoint `cf3d5a47` does the same - for `IndexedVec`'s parameter/index/two-constructor declaration and carries - the certificate through checked E1 replay. Automatic produced semantic - hierarchy assembly and semantic-owned package projections now close the next - ownership seam. The strengthened hierarchy gate now derives checked WF and - all structural generation alignment; constructing the verified per-position - inputs and analyzer-owned view WF from a general verified outer context and - its exact traversals remains. - Retain public `Acc` checks, - every actual-rule-RHS equality, and the - alias fixtures as regressions; older direct/raw-only definitions must remain - compatibility specifications only or be removed after migration. +- **Analyzer/artifact drift.** Guarded for the current subset: analysis, + public accessors, preservation, transaction output, and Verify metadata all + consume the same generalized artifacts. Keep the kernel-equality and alias + fixtures as regressions; older direct/raw-only definitions remain + compatibility specifications only. - **Normalization as an accidental oracle.** Shape equality alone does not - justify a rewritten declaration, and whole-type defeq alone does not identify - the raw binder positions needed by generation. Require `Normalization.WF`, - a structural raw/view pairing, and derivation from ordinary checker or - consumer defeq evidence. A runtime comparison with opaque - `consumeTypeAnnotations` is a producer consistency check, not a theorem and - not semantic authority. Never accept an arbitrary view supplied by Verify or - ix, and never repair a missing reduction theorem with a custom axiom. + justify a rewritten declaration, and whole-type defeq alone does not + identify raw binder positions. Require `Normalization.WF`, structural + raw/view pairing, and derivation from checker or consumer defeq evidence. + Runtime agreement with opaque `consumeTypeAnnotations` is a producer + consistency check, never semantic authority. Never accept an arbitrary + supplied view; never repair a missing reduction theorem with a custom + axiom. - **Raw de Bruijn scaling.** Indexed, mutual, and recursive-Pi rules multiply - lift/inst arithmetic. The shared checked descriptor is now consumed by one - generalized public path. Preserve that architecture while adding - broader WHNF/defeq witnesses, complete positivity, and mutual recursion; continue - moving normalized evidence into the descriptor and telescope lemmas rather - than duplicating index calculations. + 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, functional semantics impossible. Resolve P0 explicitly instead of - hiding metadata in an oracle or preserving a false “frozen statement” rule. + 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 ix. Require a design proof and - upstream agreement before adding it. -- **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. -- **Unsound bridge axioms.** Some current cache equations are documented false. - Zero sorries is not a soundness claim until final-root axiom reachability is - clean. -- **Fork/consumer drift.** The published `jcb/induct` development branch is - ahead of both master and ix's recorded Pin A checkpoint at `5e5bb767`. Keep - pinning coherent checkpoints and recording revision pairs; do not wait for - the final research milestone. -- **Upstream collision.** L4L-01U reconciles the 2026-08-03 - `upstream/master` tip `ef849dfbd94a` as a real merge parent, including the - overlapping inductive/checker/Verify/level files. Repeat the ancestry and - overlap check at every later milestone boundary; if upstream advances again, - insert another explicit integration checkpoint rather than hiding merge work - inside a semantic milestone. Retain this roadmap's fixtures, consumer - contracts, and trust gates when adapting overlapping upstream work. -- **Scope leakage from Experimental.** Experiments are useful sources, but no - supported root may import them. Promote a proof only after removing its - experimental sorries and giving it a stable API. - -L4L-01A and L4L-01B are complete at `7c792209` and `da45b536` -respectively. The repeated semantic-input plumbing sits behind one -source-indexed staged owner, and exact family-validation semantics derive its -post-family stage; all three positives use it and the result deliberately -stops at `Nonempty ProducedNormalizationCandidateSemanticRun`. L4L-01U -reconciled live upstream and Lean v4.31 without starting semantic constructor -work. Active milestone L4L-01C now retains the constructor-validation execution -without making a Theory-WF claim; constructor-validator semantics/view WF and -produced-package closure remain L4L-01D and L4L-01E. -`VEnv.addInductGeneration`, its exact data-bearing trace and stable -consequences, normalized preservation, environment histories, the ordered -identity bridge, delegated public success/WF roots, all six earlier -actual-metadata replays, and the `AnnotatedPi` recursive-Pi annotation replay -are green and exactly guarded. The generic candidate layer now also -extracts family/constructor telescopes and results and assembles -`GenerationChecked.WF`: `CandidateExprRun.spineEvidence` preserves exact raw -emitted binders, `TelResultDefEqEvidence.replacePrefix` handles the -declared/emitted constructor parameter bridge, and `GenerationCandidateRun` -folds the exact dependent family/constructor evidence. AliasFormer's real -candidate and AnnotatedPi's nested candidate supply complete checked generation -certificates and `AddInductTrace`/`TrEnv'` replays through this path. AliasFormer -now additionally proves the exact whole executable call and supplies both -consumers from `aliasFormerProducedGenerationCandidatePackage`. -AnnotatedPi additionally pins the generated recursor and iota rule while -retaining the raw annotation syntax. AliasRec remains the -compositional constructor-normalization specification until its candidate -list is migrated; neither fixed alias is authority for arbitrary metadata. -The published `IndexedVec` result selects the exact parameter/index family and -ordered `nil`/`cons` traces. Its recursive identity witnesses and -`spineOfIdentity` bridge assemble their `GenerationCandidateRun`, produced -package, certified transaction, and checked E1 replay without a second -executable producer implementation. - -The executable candidate producer and the exact AliasFormer, AnnotatedPi, and -`IndexedVec` operational proofs are the base for L4L-01A through L4L-01E. -`AddInductive.normalizeCandidateExpr` traverses arbitrary metadata with the -same configured checker full check, WHNF, and inductive fuel, including Pi -domains and bodies under the exact annotation-consumed local declarations -used by the kernel. Each position is fully checked before WHNF. Every Pi also -retains a structural annotation path and an exact successful raw-to-consumed -`isDefEq` run before its body context is extended. The producer separately -checks runtime agreement with Lean's executable but opaque -`consumeTypeAnnotations`; the retained certificate does not treat that test as -semantic evidence. `CandidateExpr` retains the complete -checker context, source, inferred type, WHNF result, Pi-domain/body position, -and all three kinds of exact checker-run equality; dependent lists retain -source family and constructor positions. -`buildNormalizationCandidate` repeats the existing family/constructor checks, -computes families in the input environment, inserts the raw family -declarations, and computes constructors only in the resulting post-family -environment. Its source-indexed result is still untrusted. Such a candidate -becomes a Theory normalization only after exact root translations, -verified contexts, and positional list runs are supplied. The actual -`AliasFormer` and `AnnotatedPi` family and constructor metadata prove their -whole calls equal the candidates enclosed by their checked semantic packages; -`IndexedVec` encloses the corresponding exact whole candidate equality in its -semantic package and routes both consumers through it. All three retain operational regressions -against verified checker runs, with inherited axiom closures guarded. -`CandidateWhnfStep.innerRun` recovers the erased final checker state, and -`WhnfRun.ofCandidateStep` attaches the matching verified context and strict -translations; the AliasFormer family certificate now exercises this complete -adapter. `CheckTypeRun.ofCandidateStep` supplies the parallel bridge for every -retained full check, and the AliasFormer pre-family and post-family checks now -exercise it. `IsDefEqRun.ofCandidateStep` supplies the third bridge for every -consumed binder domain and refines the exact successful run to Theory -`IsDefEqU`. - -The generic semantic half is now explicit as well. Pi traces are recursively -context- and source-indexed at the raw domain and exact instantiated body; the -body index fixes the actual annotation-consumed local-context extension and -generated free variable. `candidateTypeAnnotation_exists_translation` -extracts the consumed domain's strict translation from the raw wrapper -application, and the exact `IsDefEqRun` relates their Theory endpoints. -`CandidateNodeRun.ofCandidate` pairs each retained full check and WHNF, while -`CandidateNodeRun.exists_ofCandidate` extracts both returned -translations from the verifier refinements after receiving only the matching -context and root source translation. `CandidateExprRun.evidence` folds -terminal and Pi nodes into the existing `DefEqEvidence` language, transporting -body typing and equality between raw and consumed binder contexts before -forming congruence over the raw Pi syntax. Its Pi case also uses unique typing -and explicit type transport, so checker-inferred aliases need only be -definitionally equal to the structural sorts rather than syntactically -identical to them. -`CandidateExprRun.source_tr` and `.view_tr` tie both endpoints back to kernel -syntax; the Pi case abstracts the retained free variable and transports the -body translation across the definitionally equal raw, consumed, and -normalized binder contexts. Exact guards pin the construction, -interpretation, and translation closures. `CandidateExprTrace.storedSpine` -additionally requires each raw emitted Pi to survive as the same outer Pi; -`spineEvidence` then accumulates pointwise binder equality, the terminal -result, and exact telescope length. AliasFormer's actual candidate trace now -supplies both its `NormalizationRun` and complete candidate-derived -`GenerationRun` through this interpreter. AnnotatedPi exercises the same -interpreter recursively through a raw `outParam Prop` domain, its consumed -`Prop` view, and the nested recursive target. -`CandidateExprIdentity` and `CandidateExprRun.exists_ofIdentity` now provide a -second, stricter interpretation for traces whose raw and normalized syntax are -identical at every recursive position. The current `IndexedVec` work proves -that invariant for the family and both constructors and turns the resulting -root runs into generation-ready spine evidence. - -Singleton candidate-list normalization and generation assembly are now -complete. `CandidateList.singleton` -eliminates only the source-indexed singleton shape; `CandidateExprRootRun` -relates explicitly named raw/view endpoints to the exact recursive candidate; -`CandidateConstructorListRun` folds every constructor position into -`List.Forall₂`; and `NormalizationCandidateRun` constructs both the Theory -`Normalization` and its semantic `NormalizationRun`. AliasFormer reuses one -verified pre-family root and the exact post-family verified constructor root, -its resulting view passes dependent checked analysis, and its previously -hand-assembled normalization run now delegates to this generic boundary. A -truncated constructor view is rejected by `normalization?` before transaction -construction. `CandidateFamilyGenerationRun` aligns the family components; -`CandidateNormalizedCtorRun` derives both declared and emitted constructor -paths; `CandidateNormalizedCtorListRun` preserves every source position; and -`GenerationCandidateRun.wf` produces the existing Theory certificate. Every -new structural, operational, and semantic root has an exact axiom guard. -AnnotatedPi now proves this boundary scales past AliasFormer's terminal alias: -its constructor has a nonempty emitted telescope, a recursive target below a -Pi, and an actual `outParam` binder domain. The ordinary checker full-check, -WHNF, and raw-to-consumed equality traces pass `storedSpine`, yield the nested -telescope/result evidence, assemble `GenerationCandidateRun.wf`, and replay -the final environment, recursor, and iota rule. - -The matching whole-candidate negative is now green. It reuses the actual -AnnotatedPi family/constructor metadata in an environment where `outParam` has -the correct type but is opaque. Metadata staging reaches candidate traversal; -the raw/consumed equality check then returns the dedicated binder-domain error -before any semantic package or transaction exists. Retain it with the four -leaf annotation positives, exact non-defeq leaf negative, truncated-view -rejection, and positive AnnotatedPi replay so the failure phase remains sharp. - -The dependent consumer package and public transaction are now complete. -`GenerationCandidatePackage` contains the exact source-indexed candidate, -successful normalization/dependent analysis, `GenerationCandidateRun`, and -resulting `GenerationChecked.WF`; it alone supplies both the Theory -`GenerationCertificate` and Verify `AddInductTrace`. AliasFormer proves the -terminal-alias consumer is adequate and AnnotatedPi proves the nested -recursive-Pi/annotation consumer is adequate. `addInductCertified` is the -proof-erased non-identity Theory path, while `addInduct` remains the identity -compatibility theorem. - -The first three outer producer instances are complete. AliasFormer and -AnnotatedPi explicitly reduce `checkInductiveTypes`, preserve the exact module -header while inserting the raw family, validate their constructors in the -post-family environment, and assemble dependent singleton lists. AnnotatedPi -additionally traverses a nested recursive Π and consumes an `outParam` -annotation under exact raw-to-consumed definitional equality. `IndexedVec` -extends the same path through one parameter, one index, and an ordered -dependent `nil`/`cons` list using exact recursive identity witnesses. Each -`ProducedGenerationCandidatePackage` encloses the semantic package assembled -from those same retained runs, and its Theory certificate plus Verify replay -both project from it. The proofs use exact candidate equality rather than a -coercion or erasure equality. Separate guards cover whole-call computation, -the combined produced packages, semantic certification, and the public -transactions. - -The operational ordered-list subproblem is now generalized. The -former public reduction seam, -`checkInductiveTypes_singleton_zero_of_whnf_sort`, handled only a -zero-parameter singleton whose family immediately WHNFs to a sort. The generic -`checkInductiveTypes_singleton_of_candidate` theorem now replays arbitrary -parameter/index splits from a source-indexed candidate spine, and the real -`IndexedVec` family proves the one-parameter/one-index case. The exact -post-family `nil`/`cons` candidate list, complete outer producer equation, -semantic run, produced package, and E1 replay are published. Generic dependent -`Produced` witnesses now reconstruct family-type lists, arbitrary ordered -constructor lists, and complete family lists from exact per-position results; -all three outer fixtures use them, and `IndexedVec` demonstrates a list of -length two. `GenerationCandidateSemanticRun.producedPackage` now generically -performs the final outer packaging step from the same semantic owner, and all -three fixtures use it. `CandidateExprSemanticRootInput`, the dependent semantic -constructor/family/normalization inputs, and `.exists_ofProduced` automatically -assemble the complete source-ordered hierarchy from the operational `Produced` -witnesses plus exact verified per-position contexts/translations, returning it -under `Nonempty`. Semantic family/constructor generation wrappers project from -that hierarchy rather than accepting parallel roots or spines. View telescopes -and terminal typing are now derived from exact checked shape, one family -constant typing proof, and checked constructor result spines. Exact dependent -analyzer success now derives normalization alignment, and the retained verified -context plus raw/view equality and exact insertion derive post-family WF. -`GenerationCandidateSemanticShapeRun` now additionally derives raw/check family -identity, every normalized constructor pair and its exact source order, raw -telescope/results, view terminals, and the dependent constructor list from -analysis plus minimal stored-spine/count shapes. The consolidated -generation-readiness checkpoint now checks all of those shapes once over the -complete family/constructor hierarchy, retains the gate with the exact ordinary -producer equation, and derives checked WF plus every dependent shape record -from exact analysis and analyzer-owned view WF. L4L-01A consolidated verified -per-position inputs over two verified stages; L4L-01B derived the second stage -from family validation; L4L-01U reconciled and published the live-upstream -merge; active milestone L4L-01C now -retains constructor validation; L4L-01D derives analyzer-owned view WF; and -L4L-01E combines the -result with the strengthened gate to return the complete produced package -without fixture-specific alignment. Only -Theory-level generation, lookup, -ordering, pattern, and semantic facts—not checker state or a normalization -oracle—should be exposed to ix. - -After L4L-01E, follow §13 without skipping: close the two isolated level proofs -in L4L-02A and L4L-02B; complete singleton environment-sensitive validation, -normalization, -positivity, elimination, K, and integration in L4L-03 through L4L-07; then -advance through mutual L4L-08A–08C, nested L4L-09A–09C, pattern -L4L-10A/L4L-10B, and oracle handoff L4L-11. The identity and alias kernel equalities remain the computational -regression gate, and every newly accepted family replays through E1 in its -own milestone. The completed generalized public path, `Acc` -transaction/replay, recursive-Pi kernel-rejection differentials, -environment-free universe/result/name/collision matrix, semantic `Checked.WF` -and `GenerationChecked.WF` bridges, and exact axiom closures remain regression -gates. - -The current formalization source is the L4L-01U merge -`7f864b459e4a6062b468d6e5416688feac0f9f99` of -`da45b536220a3eff5ed78cf2f5afcf5e7491c40f` and upstream -`ef849dfbd94a`; this publication ledger child records the immutable source hash -on `argumentcomputer/lean4lean`'s `jcb/induct` branch. Neither local `master` -nor `origin/master` is moved by this work. On top of automatic produced -semantic-hierarchy assembly and -semantic-owned generation/package projections, it derives exact family and -constructor shape, candidate view telescopes, family terminal typing, and all -constructor result-target typing generically. AliasFormer, AnnotatedPi, and -`IndexedVec` no longer supply `viewTel`, `rightType`, `normalization_eq`, or -`typeEnv_wf`: their exact dependent analyzer equations determine normalization -identity, and verified context/equality/insertion evidence reconstructs the -post-family environment. They also no longer supply normalized pairs, raw -telescope/results, view terminals, or dependent-list alignment: exact analysis -and minimal stored-spine/count shapes determine all of those generically. Exact -analysis and WF of the analyzer-owned view declaration now derive checked WF -and all per-position shape records from one complete executable hierarchy gate; -the fixtures no longer supply either class of evidence. Missing and extra raw -constructor lists are rejected. Exact axiom guards pin the executable roots to -the standard logical baseline and the semantic roots to the existing -transitional sets. Completed milestones L4L-01A and L4L-01B consolidate the -verified staged semantic inputs and derive the post-family stage from exact -family-validation semantics. Completed L4L-01U reconciles the current -upstream/toolchain/axiom delta without beginning constructor work. Active L4L-01C -retains the exact constructor-validation trace without making a Theory-WF -claim; the temporary fixture view-WF proofs remain until L4L-01D, and the -complete produced package is intentionally deferred to L4L-01E. No stage may infer -shape or Theory meaning from bare producer success. Ix Pin A is complete at the -recorded pair Lean4Lean `5e5bb767b3491d21a71908d4c58bcbaa007283bb` -and local ix snapshot `1f73f5c016907eadb8ed0dc86ac65b07eb24a145`. -Pin B is exactly the L4L-11 exit and therefore waits for L4L-01U and L4L-01A -through L4L-10B, including full single/mutual/nested breadth and the -generated-pattern -package. No intervening milestone may paper over a gap with a new oracle -assumption or broaden the accepted axiom budget. + 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. +- **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. +- **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 3bfd20f1..72006f13 100644 --- a/upstream-divergence.md +++ b/upstream-divergence.md @@ -4,9 +4,13 @@ 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 generation-readiness checkpoint (2026-08-03): +Audit baseline after the complete L4L-08C mutual generation/preservation/replay +checkpoint (2026-08-07): -- upstream: `0c38ab8` +- current upstream reconciliation parent: digama `upstream/master` + `ef849dfbd94a` +- historical generation-readiness comparison upstream: `0c38ab8`; the + ahead-of-upstream counts below use this older baseline - published semantic checkpoint: `cf3d5a47d35867e0e6ebe023c0803982e3e36cd1` (33 commits ahead of upstream) - first published documentation child: @@ -49,9 +53,105 @@ Audit baseline after the generation-readiness checkpoint (2026-08-03): `bbb45e0e950724cdbbd405d75e304e2020cecf82` (`feat: consolidate generation readiness`; 50 commits ahead of upstream; 3 files changed, 701 insertions, and 98 deletions) +- upstream v4.31 reconciliation checkpoint: + `7f864b459e4a6062b468d6e5416688feac0f9f99` + (`merge: reconcile upstream v4.31`; second parent digama + `upstream/master` `ef849dfbd94a`) +- retained constructor-validation checkpoint: + `097efb45018136df32c2f6e0dbbbbf7c7106c149` + (`feat: retain constructor validation traces`) +- local-committed constructor-universe semantic checkpoint: + `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. +- 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` + 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. +- local-committed analyzer-owned constructor view-WF checkpoint: + `98921daf15aa` (`proof: establish analyzer-owned constructor view WF`) +- local-committed generic singleton package checkpoint: + `ae6726cef1e1` (`proof: establish generic singleton package closure`) +- local-committed project level-normalization checkpoints: + `70c02b0e89d8` (`proof: establish level subsumption evaluation`) and + `a72979db8cd3` (`proof: establish level equivalence soundness`) +- local-committed constructor level-comparison checkpoint: + `de3d98c9fc5fd066b2ab88ec450e01402ed38357` + (`proof: verify constructor level comparison`). Publication to the fork's + `jcb/induct` 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. +- 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 + `0c6b178cc1bd` (`proof: cover empty and singleton generation edges`) and + `df58a3a00087` (`proof: close empty and singleton edge parity`). +- remote development L4L-07 checkpoints at `jcb/formalization`: + `bb39cb2ace0c` (`verify: add singleton parity matrix`), + `cc132cddb874` (`verify: add singleton rejection and replay inventories`), + 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. +- 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 + block-wide recursive-target ordinals. The L4L-08B closure adds + executable block validation/normalization, all-family staging, exact mutual + semantic certificates, phase-local negatives, and recursive-Pi target + traces. L4L-08C then lands block generation and its typing chain in + `12040b3e`, `3d97ac16`, `6311fa69`, `48882b9c`, and `67d65928`; complete + metadata comparison in `1d280960`; Theory/Verify environment replay in + `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. - fixed fork master: `1fb7d6ef9042c5a80b2de9320c88ac0f3ce404cb` on local and `origin/master` -- audited source checkpoint: `bbb45e0e` builds on the exact arbitrary-length +- current audited semantic checkpoint: 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 + parity matrix, alongside five normalization cases and a consolidated + 32-case rejection matrix. The fixed rows compare ordinary-producer + acceptance and all stored family/constructor/recursor/rule metadata, + including exact translated universe order and every iota RHS. All 14 fixed + families and the five normalization cases then replay actual `ConstantInfo` + through proof-carrying environment transactions to final `Aligned` and + `Ordered` outputs. Fin and Vector carry their exact aligned dependency + slices. The umbrella exposes `SingletonParityReplay` as the sole L4L-07 + artifact path. On top, `CheckedBlock` analyzes arbitrary nonempty family + lists through `CheckedFamilies source params ordinal types`, so exact source + order and target-family numbering are indices of the representation rather + than unchecked parallel data. `ValidatedBlock.WF` and + `ValidationCertificate` pair that structure with arbitrary-block + normalization, one shared semantic result universe, all-family staging, and + constructor semantics. `BlockGenerationChecked` then constructs one motive + and recursor per family, one globally flattened minor/rule inventory, and + target-family-directed recursive calls. The transaction exposes exact + all-family/all-constructor/all-recursor/rule phase boundaries and preserves + ordering, lookup, freshness, and rule membership. Tree/TreeList and + IndexedTree/IndexedTreeList execute the exact ordinary validator phases, + compute recursive targets including Pi-hidden sibling recursion, compare + every family/constructor/recursor/rule metadata field represented by Theory, + and replay the actual metadata maps through `TrEnv'.inductBlock` to final + aligned environments. The raw public `addInduct` consumes the same block + artifact; `addInductSingleton` retains the former one-family raw wrapper for + a deprecation window. Mismatch/reordering negatives still pin the nearest + kernel phases. Exact closure guards and the full completion gate are recorded + in the roadmap. +- generation-readiness source checkpoint: `bbb45e0e` builds on the exact + arbitrary-length producer witnesses and source-indexed semantic inputs that return a `Nonempty ProducedNormalizationCandidateSemanticRun`. The retained checker selects every Theory view; callers provide verified contexts and strict @@ -169,38 +269,74 @@ to the replacement. ## D005 — exact sorry-frontier enforcement - **Status:** published-fork -- **Commits:** `c8a9ef8`, with the current Stage-3 wording in `472a6f0` -- **Delta:** token-aware, declaration-attributed allowlist excluding - `Experimental/`, wired into Nix and CI. +- **Commits:** `c8a9ef8` (Perl token audit), replaced by the Lean + environment audit in dev's `0d541a4` and reconciled with the + formalization line at this checkpoint +- **Delta:** declaration-level `sorryAx` allowlist over the compiled + `Theory`/`Verify` surface (`Lean4Lean/Audit/SorryFrontier.lean`), + excluding `Experimental/`, wired into Nix and CI. - **Ix impact:** guarantees that upstream proof debt can only shrink at pin - boundaries; currently records exactly 20 supported-tree sorries. -- **Tests:** `perl .github/scripts/check_sorry_frontier.pl` and the - `sorry-frontier` flake check. + boundaries; the current exact allowlist records 19 sorried declarations + (20 `sorry` tokens) plus six deliberately kernel-rejected fixture + recoveries. +- **Tests:** `lake build Lean4Lean.Audit.SorryFrontier` and the `proofs` + flake check. - **Upstream issue/PR:** TBD. - **Removal condition:** upstream adopts an equal or stricter shrink-only gate; at zero debt, replace the allowlist with an unconditional rejection rule. ## D006 — staged computational inductive semantics -- **Status:** published-fork -- **Commits:** `71f2eae`, `06e904d`, `201c12f`, `efb2a2b`, and the generalized - single-family integration in `472a6f0` +- **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) +- **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 + `df58a3a0`, and the L4L-07 checkpoints `bb39cb2a`, `cc132cdd`, + `fefb93fe`, `9910e14e`, the L4L-08A checked representation `79e1ae4f`, the + L4L-08B validation/normalization closure, the L4L-08C implementation chain + through `aa10005d`, and this closure/audit follow-up - **Delta:** replace the three placeholder inductive declarations with real `VInductDecl.WF`, computational generation, generated recursor/iota rules, and sorry-free preservation for the accepted class. The published single-family path supports parameters, indices, index-changing recursion, recursive targets below positive Pi telescopes, raw/view normalization, - mixed raw-syntax-preserving artifacts, and a traced normalized transaction. - Acceptance is the dependent descriptor from D009. This remains an - underapproximation: full positivity, small elimination, K, mutual blocks, - nested inductives, and the complete differential matrix are not implemented. + mixed raw-syntax-preserving artifacts, exact ordinary small/large elimination + modes, independently computed K-target metadata, and a traced normalized + transaction. Zero- and one-constructor blocks use the same checked + family/constructor/recursor/rule component chain, including ordinary empty + constructor and rule folds. Acceptance is the dependent descriptor from + D009. The complete one-family checkpoint now has a 14-row fixed kernel + matrix, five focused normalization rows, and a 32-row rejection matrix. + L4L-08A additionally computes a pure checked representation for arbitrary + nonempty mutual family lists, including shared parameters, per-family + index/result/constructor data, and cross-family target ordinals. L4L-08B + adds executable block family/constructor validation, all-family staging, + arbitrary-block normalization semantics, and exact environment-indexed + 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. - **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. -- **Tests:** exact Nat, Bool, List, Prod, Option, Eq, HEq, index-changing - `IndexedVec`, and recursive-Pi `Acc` recursor/iota fixtures; the structured - rejection matrix; Theory/Verify build; full flake check; exact axiom guards - for `VEnv.addInduct_WF` and the normalized preservation roots. +- **Tests:** the integrated Nat, Bool, List, Option, Prod, Unit/`PUnit`, Empty, + Or, And, Eq, HEq, Fin, Vector, and Acc matrix; five normalization rows; + all 32 named rejection branches; exact acceptance, translated stored types + and universe order, names/counts/flags, recursor types, rule metadata, and + every iota RHS; supporting `IndexedVec`, elimination/K, and edge + differentials; exact Tree/TreeList and indexed-mutual representation, + validator execution, recursive-target matrices, semantic/generation + certificates, complete family/constructor/recursor/rule metadata, global + minor/rule order, and Theory/Verify environment replay; exact + parameter/result-universe mismatch and reordering failures at their + validation phases; Theory/Verify and default Lake builds; full Nix/flake + gate; exact axiom guards for the matrix, singleton inventories, mutual + generation/preservation roots, and replay outputs. - **Upstream issue/PR:** TBD; submit in the staged PR sequence described in the roadmap rather than as one proof mega-diff. - **Removal condition:** upstream exposes kernel-complete checked inductive @@ -208,57 +344,86 @@ to the replacement. ## D007 — consumer-facing inductive transaction API -- **Status:** published-fork -- **Commits:** the normalized core in `472a6f0` and the proof-carrying - non-identity API in `6a77882` +- **Status:** remote-development (the one-family base is published-fork; the + L4L-08C block transaction is pushed at `jcb/formalization`) +- **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` - **Delta:** `VEnv.AddInductSuccess`, `AddInductGenerationTrace`, `addInductGeneration`, `GenerationCertificate`, and `addInductCertified`, with generated type/constructor/recursor lookups, rule membership, freshness, monotonicity, atomic success/failure, and - `Ordered` preservation. The legacy `VEnv.addInduct` is an exact identity-view - compatibility wrapper; the certified API erases its proof and computes - through the same normalized transaction. + `Ordered` preservation. L4L-08C adds `BlockGenerationCertificate`, + `AddInductBlockGenerationTrace`, `addInductBlockGeneration`, and + `addInductBlockCertified`, with list-wide phase invariants and consequences. + 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. - **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. - **Tests:** identity and non-identity transaction fixtures, consumer-style - `IndexedVec`, `Acc`, AliasFormer, and AnnotatedPi transactions, collision and - atomicity fixtures, Theory/Verify and flake gates, and exact axiom guards for - the public trace/WF roots. + `IndexedVec`, `Acc`, AliasFormer, AnnotatedPi, `PUnit`, and `Empty` + transactions; raw/certified Tree/TreeList and indexed-mutual transactions; + collision and atomicity fixtures; Theory/Verify and flake gates; and exact + axiom guards for the public singleton/block trace and WF roots. - **Upstream issue/PR:** TBD; submit after or with the Stage-3 preservation PR. - **Removal condition:** equivalent stable postconditions are upstream and ix no longer imports the fork-only names. ## D008 — Verify inductive-environment alignment -- **Status:** published-fork +- **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`) - **Commits:** initial alignment in `472a6f0`, extended through `a1d8943`, - `6a77882`, and `bc37d43` + `6a77882`, `bc37d43`, `37e2ada6`, `41e1126b`, `0c6b178c`, `df58a3a0`, + `bb39cb2a`, `cc132cdd`, `fefb93fe`, the L4L-07 closure, and the L4L-08C + replay/audit checkpoints `eeae5282` and `aa10005d` - **Delta:** replace the empty `AddInduct` relation with a data-bearing trace for `inductInfo`, ordered `ctorInfo` insertion, `recInfo`, and the generated defeq fold. Fold realization, lookup, freshness, monotonicity, map-WF/value-preservation, `Aligned.addInduct`, and the formerly impossible - `TrEnv'.of_value` inductive case are live. Actual Lean metadata for Nat, Eq, - index-changing `IndexedVec`, recursive-Pi `Acc`, AliasFormer, and AliasRec is - replayed through final equality, WF, alignment, and lookup uniqueness. - AnnotatedPi adds a seventh focused replay whose raw constructor retains - `outParam Prop` beneath a recursive Pi and whose generated recursor/iota rule - is pinned. The normalized trace owns the exact generation and its semantic - certificate instead of restating artifacts. + `TrEnv'.of_value` inductive case are live. `RecursorKMatches` additionally + requires `recInfo.k` to equal the shared Theory generation decision, so a + type-correct recursor carrying the wrong reduction flag cannot align. The + sole L4L-07 replay inventory now carries actual Lean metadata transactions + for all 14 fixed families and five normalization cases through final WF, + alignment, ordering, and every rule insertion. Fin and Vector use exact + aligned dependency slices, rather than pretending to start from the empty + environment. Translation now handles stored `.mdata` type annotations by + the same semantic erasure already used by `TrExprS`, which is required by + the real `Array.size` metadata in Vector's dependency slice. The normalized + trace owns the exact generation and its semantic certificate instead of + restating artifacts; the legacy phase fixtures remain implementation inputs, + not competing public inventories. L4L-08C adds `AddInductBlockTrace` and + 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. - **Ix impact:** establishes the implementation-to-Theory environment bridge needed to translate checked inductive blocks and eventually construct - `InductiveOracle`; later I2-I4 replay fixtures plus the I5 pattern package - are still required before that oracle is constructible. -- **Tests:** `lake build Lean4Lean.Verify.Environment.InductiveFixtures`; - all actual-metadata replay roots and rule-RHS equalities; the pre-Nat value - preservation regression; full Theory/Verify and flake gates; compile-time - axiom guards for generic alignment and every concrete checked replay. + `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. +- **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 + maps; the pre-Nat value-preservation regression; full Theory/Verify, default + Lake, Nix, and flake gates; compile-time trust manifests for the fixed, + normalization, combined replay, output-ordering, and both mutual-block roots. - **Axiom note:** the guarded roots currently inherit `sorryAx` through `TrConstVal → TrExprS → TrProj`, plus the standard logical baseline. E1 - declares no new axiom. The concrete fixture additionally reaches the three - existing persistent-map contracts while proving its `SMap` insertion - freshness; Track P/T2 must remove or narrowly justify these inherited - dependencies before release. + declares no new axiom. The fixed replay inventory additionally reaches the + three existing persistent-map contracts while proving its `SMap` insertion + freshness. The normalization and combined inventories expose the already + classified pointer, expression/level, persistent-array/map, and syntax + contracts inherited from their ordinary producer evidence. The mutual replay + roots use only the already classified `TrProj` and persistent-map frontier; + fixture-local native-decision axioms have been removed from their semantic + closures. Every public root has an exact compile-time manifest; Track P/T2 + must remove or narrowly justify these inherited dependencies before release. - **Upstream issue/PR:** TBD; submit with or immediately after the staged inductive-semantics series. - **Removal condition:** upstream has a non-vacuous inductive alignment with @@ -267,8 +432,15 @@ to the replacement. ## D009 — shared checked inductive descriptor -- **Status:** published-fork -- **Commit:** introduced and integrated in `472a6f0` +- **Status:** remote-development (the base descriptor is published-fork; its + K-target, empty/singleton, complete singleton-parity, and mutual-generation + extensions are pushed at `jcb/formalization`) +- **Commit:** introduced and integrated in `472a6f0`; K-target retention is + extended through `41e1126b`, with zero-/one-constructor coverage through + `0c6b178c`, `df58a3a0`, singleton closure through `9910e14e`, and the + L4L-08A checked representation `79e1ae4f`, the L4L-08B + validation/normalization closure, the L4L-08C implementation chain through + `aa10005d`, and this closure/audit follow-up - **Delta:** add dependent `VInductDecl.Checked`, normalized constructor and recursive-argument records, and the computational `checked?` analyzer. Define public Stage-3 acceptance as descriptor existence. Route recursor/rule @@ -280,9 +452,25 @@ to the replacement. prove both compatibility directions and an iff with `VInductDecl.WF`, and make preservation consume it. `NormalizedChecked`, `GenerationChecked`, and their WF contracts retain the raw singleton block, checked view, mixed - generation layout, ordered constructor pairing, and exact analyzer result. + generation layout, ordered constructor pairing, exact K-target decision + independently of elimination mode, and exact analyzer result. + `PUnit` and `Empty` compute through this same descriptor: the former retains + one zero-field, nonrecursive constructor and one minor/rule, while the latter + retains empty constructor/minor/rule lists without a proof-only premise. Stable constructor/recursor collision rejection and identity compatibility - remain part of the public proof API. + remain part of the public proof API. L4L-08A adds `CheckedFamily`, the + ordinal- and source-list-indexed `CheckedFamilies`, `CheckedBlock`, and + `checkedBlock?`. Shared parameters occur once at block scope; each family + retains exact indices, result level, and constructor order; block-wide + recursive analysis records sibling targets in `RecArg.targetType`. L4L-08B + adds `NormalizedCheckedBlock`, `ValidatedBlock`, their computational + analyzers, block-wide WF relations, and the Theory-only + `ValidationCertificate`. L4L-08C adds `BlockGenerationChecked` and its + family/constructor semantic WF package, block-wide generated artifacts, and + `BlockGenerationCertificate`. The old `Checked`/`checked?`, + `GenerationChecked`, and certified one-family path remain available; raw + compatibility is exposed by deprecated `addInductSingleton`, while public + `stage3`/`addInduct` consume the non-singleton block descriptor. - **Ix impact:** creates the stable, consumer-neutral analysis object that E2 can use to assemble `InductiveOracle` without duplicating raw declaration or de Bruijn analysis. The semantic certificate gives ix an environment-indexed @@ -290,7 +478,14 @@ to the replacement. lets it reuse the exact checked value. Reserved recursive binder telescope and target-family fields provide the extension point for Acc-like and mutual recursion. -- **Tests:** computed descriptor-shape checks for Nat, Eq, and `IndexedVec`; +- **Tests:** computed descriptor-shape checks for Nat, Eq, `IndexedVec`, + `PUnit`, and `Empty`, plus exact K-target shapes for Eq, And, Or, Nat, + `PUnit`, and `Empty`; exact Tree/TreeList and indexed-mutual source order, + shared parameters, per-family indices/results, constructor order, + recursive field positions/indices, and target ordinals; exact mutual + normalization/checked/generation WF certificates and + parameter/result-universe/reordering phase checks; computed mutual + motive/minor/recursor/rule inventories and public raw transaction success; semantic bridge fixtures for `IndexedVec`; negative fixtures for loose data, internal/pre-existing name collisions, self-referential parameters, invalid levels, malformed results/spines, parameter counts, and universe-count @@ -298,25 +493,31 @@ to the replacement. formatter; all six current-host flake checks; and all-system no-build evaluation. - **Axiom note:** the analyzer and descriptor are computational and declare no - axiom. Compile-time guards pin every exported structural fact, the three + axiom. The new block analyzer, dependent source-order theorem, and both + mutual fixture roots have exact `propext`/`Quot.sound` manifests. + Compile-time guards pin every exported singleton structural fact, the three `Checked.WF` compatibility roots, transaction success/exact-analysis facts, and collision theorems to exactly `propext` and `Quot.sound`, a subset of the accepted Theory baseline. `addInduct_WF` retains the accepted `propext`/`Classical.choice`/`Quot.sound` closure. -- **Upstream issue/PR:** TBD; include as the architecture-first patch in the I2 - one-family-parity series. +- **Upstream issue/PR:** TBD; include as the architecture-first mutual-block + patch after the I2 one-family-parity series. - **Removal condition:** upstream generation, preservation, Verify alignment, and downstream consumers share an equivalent checked block result, and ix no longer imports the fork-only descriptor API. ## D010 — executable normalization and certified producer boundary -- **Status:** published-fork +- **Status:** remote-development (the earlier checkpoints are published-fork; + L4L-03 is pushed at `jcb/formalization`, while publication to `jcb/induct` + remains pending) - **Commits:** `1fb7d6e`, `9fde4c6`, `b283912`, `a84aa19`, `c2b1c4f`, `a1d8943`, `6a77882`, `bc37d43`, `5e5bb76`, `33b99f4`, `a3ff992`, `9a865ea`, `a627362`, `6732659`, `c40a471`, `c739d41`, `82f4a54`, `d553930`, `cf3d5a4`, `c9e4ae2`, `a7d101b`, `f0caf16`, `e3cf22d`, - `7e5f4f7`, `2b1d802`, `a64fe98`, `5aa9ab6`, and `bbb45e0` + `7e5f4f7`, `2b1d802`, `a64fe98`, `5aa9ab6`, `bbb45e0`, `7c79220`, + `da45b53`, `097efb4`, `a246c04`, `37d2dd9`, `9e40cbe`, `98921da`, + `ae6726c`, `3e6efcc`, `53d5f92`, `bb88317`, and `04a1a4f` - **Delta:** retain exact ordinary-checker full-check, WHNF, and `isDefEq` executions in source- and context-indexed candidate traces; interpret them into Theory normalization and generation certificates; assemble dependent @@ -414,48 +615,75 @@ to the replacement. the existing complete produced package for that same candidate. AliasFormer, AnnotatedPi, and `IndexedVec` all use this consolidated path; fixtures no longer provide checked WF or per-position generation-shape structures. + Constructor validation now has a parallel strengthened semantic boundary. + `checkConstructorUniverseListSemantics` replays every source-ordered + constructor telescope and accepts an ordinary field through structural + universe order, the impredicative-Prop result exception, or the normalized + comparison intersection documented in D012. Strict kernel level translation + turns that executable decision into exactly the Theory disjunction needed + later by `fieldsWF`. The additive + `StagedNormalizationCandidateUniverseInput` retains the successful audit + alongside the established semantic owner without changing + `buildNormalizationCandidate` or treating its success as semantic evidence. + AliasFormer, AnnotatedPi, and `IndexedVec` use that owner. The ordinary + validator remains unchanged, while the former normalized max/parameter gap + is now accepted only when core and verified project comparison agree. + `ConstructorViewAlignmentTrace` then aligns each validation-owned telescope + with its candidate-owned telescope at the corresponding Theory de Bruijn + positions, rather than equating their fresh-FVar identifiers. The complete + post-family semantic list run interprets the retained root type check, + parameter definitional equalities, ordinary and recursive field type checks, + positivity targets, and terminal family applications in the actual verified + post-family context. `StagedNormalizationCandidatePostFamilyInput` couples + that source-ordered result to the same produced candidate and universe audit. + AliasFormer, AnnotatedPi, and `IndexedVec` inhabit the staged owner, and the + two-constructor regression pins both source order and genuinely distinct + validator/candidate field identifiers. + `buildConstructorPreFamilySafety` and + `checkConstructorPreFamilySafety` add the strengthened D3 boundary without + changing ordinary candidate production. Their dependent traces instantiate + the analyzer-owned family parameters, retain exact ordinary-field + `checkType`/`ensureType`/annotation equality observations, omit recursive + outer-field locals, and replay family-free nested Pi binders and + recursive/result index spines in the pre-family context. Recursive fields no + longer have to form a suffix: an independent ordinary field may follow an + omitted recursive local and is reconstructed through the common D3 context. + Every later domain/result must still be syntactically independent of each + omitted FVar. The semantic trace interpretation and proved prefix-weakening + projections derive the pre-family field, binder, and spine judgments from + those exact executions. The additive + `StagedNormalizationCandidatePreFamilyInput` retains the safety trace beside + D2's owner and reconstructs its semantic result under `Nonempty` from the + exact family terminal context. AliasFormer, AnnotatedPi, and `IndexedVec` + inhabit the new produced owner; executable initial-state fixtures accept an + independent ordinary field after recursion and reject a later field that + actually depends on the omitted local. - **Ix impact:** prevents ix from receiving an unrelated hand-selected normalization or generation witness while keeping checker state out of the Theory API. This is the proof boundary needed before executable metadata can be treated as certified inductive generation. -- **Latest checkpoint:** one strengthened executable outer result now retains - the exact ordinary `buildNormalizationCandidate` equation and one complete - raw-family/constructor generation-spine check. The check is source-indexed, - rejects missing or extra constructors explicitly, and is independent of - semantic proofs. Given the retained semantic hierarchy and exact dependent - analysis, `GenerationCandidateSemanticRun.ofGenerationShape` derives checked - WF from the analyzer-owned view declaration and expands the single Boolean - into every dependent family/constructor stored-spine/count certificate. - `ProducedGenerationShapeCandidate.producedPackage` returns the complete - producer-selected semantic package for that same candidate. AliasFormer, - AnnotatedPi, and the two-constructor `IndexedVec` regression all flow through - this boundary. They supply neither checked WF nor per-position shape records; - their certified Theory transactions and checked E1 replays continue to - project from the same source-indexed packages. -- **Current gap:** construct the verified per-position semantic inputs and WF - of the analyzer-owned view declaration generically from one arbitrary - verified outer checker context, strict source translations, and the exact - successful operational traversals. Then expose the singleton theorem that - combines those semantic inputs, exact dependent analysis, and the - strengthened generation-shape result into - `Nonempty ProducedGenerationCandidatePackage` (or an equivalent dependent - result). Bare `buildNormalizationCandidate` success cannot soundly imply the - gate: WHNF may change the visible Pi spine and the ordinary producer does not - test `storedSpine`. It also cannot imply Theory WF. The generic boundary must - therefore either run the strengthened gate or require its successful result, - while verified checker executions remain the sole source of Theory meaning. - Raw/view pairing, component equations, checked WF, dependent list alignment, - and every per-position shape record must remain derived; view-telescope, - terminal-typing, normalization-equality, and post-family-WF premises must not - be reintroduced. - The outer boundary remains singleton-family; - complete the normalization differential matrix before widening it to mutual - and nested blocks. +- **Latest checkpoint:** the L4L-03 semantic source at `04a1a4f2` builds on the + generic L4L-01E package closure at `ae6726c`. Pre-declaration full checks, + WHNF Pi/result and recursive-target traversal, and the exact AnnotatedPi + producer package remain the operational authority. D3 now carries + independent ordinary fields past omitted recursive locals. `AnnotatedParam` + separately pins the ordinary constructor-parameter `isDefEq` outcome, emits + the checked parameter in the recursor, and replays the resulting kernel + metadata through the certified Theory transaction and Verify environment. + This split is deliberate: no second hand-assembled produced package is + claimed for `AnnotatedParam`. +- **Current gap:** the singleton normalization differential, omitted-local + dependency boundary, mutual result-universe equality/block staging, mutual + generation, and environment replay are closed through L4L-08C. Nested + transformation and producer packaging remain assigned to L4L-09. - **Tests:** exact positive AliasFormer, AnnotatedPi, and `IndexedVec` whole-call equations; positive semantic/transaction/replay fixtures for the first two plus the complete checkpoint semantic/transaction/E1 replay for `IndexedVec`; exact `IndexedVec` family/`nil`/`cons` candidate traces; - opaque-`outParam` whole-candidate rejection; exact axiom guards for the + opaque-`outParam` whole-candidate rejection; exact positive and genuinely + non-defeq negative `AnnotatedParam` whole-call guards; checked-parameter + recursor/iota parity plus certified transaction, metadata lookup, WF, + alignment, uniqueness, and rule replay; exact axiom guards for the semantic-input constructors, produced hierarchy, semantic-generation and reduced-shape projections, the three operational list theorems, and both outer package constructors; singleton and two-constructor list regressions; @@ -465,11 +693,21 @@ to the replacement. `typeEnv_wf`, checked-WF, per-position generation-shape, normalized-pair, `rawTel`, `rawResult`, and `viewResult` inputs; exact strengthened-producer success for all three fixtures; missing-raw and extra-raw constructor-list - rejection; exact analyzer-success replay in all three fixtures; focused - direct compiles, 157-job default Lake build, and 124-job Theory/Verify and Nix - proof builds; 20-sorry frontier check; default Nix build; all six - current-host flake checks; all-system no-build evaluation; formatter; Theory - import-boundary; and whitespace checks. + rejection; exact analyzer-success replay in all three fixtures; structural + and impredicative-Prop universe positives; normalized max/parameter + acceptance through core/project agreement; exact universe-bridge and + staged-owner axiom guards; exact post-family alignment of all AliasFormer, + AnnotatedPi, and ordered `IndexedVec` fields/results; distinct + validator/candidate + `IndexedVec` field-FVar regression; exact successful pre-family replay and + produced semantic ownership for all three fixtures; executable independent + ordinary-after-recursive acceptance and recursive-local-dependency + rejection guards; + exact generic and fixture post-family/pre-family axiom guards; focused direct + compiles, 156-job default Lake build, and + 119-job Theory/Verify and Nix proof builds; 20-sorry frontier check; default + Nix build; all six current-host flake checks; all-system no-build evaluation; + formatter; Theory import-boundary; and whitespace checks. - **Axiom note:** no normalization oracle, native evaluator, or new axiom was added. `Checked.type_eq`, `GenerationChecked.viewCtorType_eq`, and `GenerationChecked.checkedResultTarget_hasType` are exactly guarded at @@ -517,7 +755,34 @@ to the replacement. semantic generation owner, deriving checked WF, and constructing the final package inherit exactly the already recorded checked semantic closure. Exact fixture guards expose only their pre-existing checker/pointer/cache and - projection dependencies. + projection dependencies. The kernel-level structural equality/order roots + remain at exactly `propext`/`Quot.sound`; the normalized project comparison + and resulting Theory universe-disjunction root use only the standard + `propext`/`Classical.choice`/`Quot.sound` basis documented in D012. No oracle, + custom axiom, or new sorry is reachable. The additive staged projections + explicitly guard their inherited Verify closure instead of presenting it as + a smaller mathematical trust claim. The D2 staged owner and all three + fixture roots are each compile-time guarded at the same established post-family checker + closure: `propext`, `sorryAx`, `Classical.choice`, `Quot.sound`, and the + existing expression, level, pointer-equality, persistent-collection, and + syntax implementation contracts. The positional alignment and semantic-run + structures declare no axiom; no `native_decide`, new sorry, or additional + custom trust contract is reachable from these roots. + D3's independent-after-recursive acceptance and dependency rejection guards + compute without an axiom or proof premise. The trace interpretation, + weakening lemmas, staged generic + owner, and all three fixture roots are compile-time guarded at exactly the + same established Verify closure as D2: `propext`, `sorryAx`, + `Classical.choice`, `Quot.sound`, and the existing expression, level, + pointer-equality, persistent-collection, and syntax implementation + contracts. No constant-removal axiom/theorem, native evaluator, new sorry, + or new project-specific trust contract is reachable. + `AnnotatedParam`'s Theory definitional equality, complete generation WF, + certified transaction, and final iota membership are guarded exactly at + `propext`/`Quot.sound`. Its real-metadata replay trace and `TrEnv'` root add + only the existing `sorryAx`/`Classical.choice` and persistent-map contracts; + they reach no pointer, expression, level, native-evaluation, or new custom + axiom. - **Upstream issue/PR:** TBD; submit after the singleton producer interface is stable enough that the first PR does not freeze fixture-specific APIs. - **Removal condition:** upstream executable inductive ingestion returns or @@ -549,6 +814,45 @@ to the replacement. the fork removes this behavior and all candidate-replay fixtures pass against the upstream state transition instead. +## D012 — verified project universe-level comparison + +- **Status:** local-committed; publication is pending +- **Commits:** `70c02b0`, `a72979d`, and `de3d98c` +- **Delta:** prove evaluation preservation for project level normalization and + comparison without assigning a logical contract to Lean's opaque v4.31 + normalizer. `NormLevel.subsumption_eval` covers every raw normalized map by + retaining active-path membership witnesses when constants are removed. + Canonical ordered-entry equality gives `NormLevel.eval_congr`, + `isEquiv_wf`, and dependent level-list equivalence. `NormLevel.le_eval` + proves the transparent project order sound for every raw `NormLevel`, and + `geq'_wf` transports that result back through normalization. Constructor + semantic validation admits a normalized non-Prop field only when the + unchanged ordinary core `Level.geq` decision and verified project `geq'` + decision both succeed. The core half preserves the ordinary acceptance + boundary; only the proved project half supplies Theory meaning. +- **Ix impact:** removes the structural/Prop-only universe under-approximation + from the certified singleton producer while retaining the same kernel-facing + validation result and a consumer-neutral Theory inequality. +- **Tests:** generated old/new normalization differentials and exact evaluator + regressions over zero, successor, max, imax, parameters, and nested forms; + an all-pairs mvar-free core/project comparison matrix; the formerly excluded + max/parameter constructor comparison as a positive semantic-gate regression; + exact axiom guards for `NormLevel.le_eval`, `geq'_wf`, and the constructor + bridge; focused builds; 119-job Theory/Verify and 156-job default Lake + builds; exact 20-sorry audit; default Nix build; all-system no-build + evaluation; all six current-host flake checks; formatter, Theory import + boundary, and whitespace checks. +- **Axiom note:** no oracle, native evaluator, custom axiom, or new sorry was + introduced. The new comparison roots close exactly over `propext`, + `Classical.choice`, and `Quot.sound`. Lean's core `Level.geq` remains an + executable acceptance condition only and is never used as a semantic proof + premise. +- **Upstream issue/PR:** TBD; submit the generic level-normalizer proofs and + comparison bridge before the constructor-validation integration. +- **Removal condition:** upstream provides an equivalent standard-only + mvar-free level-order theorem and constructor semantic validation consumes it + without a fork-only comparator. + ## Review checklist At each publish or ix pin boundary: