diff --git a/Lean4Lean/Audit/SorryFrontier.lean b/Lean4Lean/Audit/SorryFrontier.lean index c5be36d3..f3c99065 100644 --- a/Lean4Lean/Audit/SorryFrontier.lean +++ b/Lean4Lean/Audit/SorryFrontier.lean @@ -2,8 +2,11 @@ import Lean4Lean.Theory import Lean4Lean.Theory.ConstructorValidityFixtures import Lean4Lean.Theory.Inductive import Lean4Lean.Theory.InductiveFixtures +import Lean4Lean.Theory.Literals +import Lean4Lean.Theory.LocalContext import Lean4Lean.Theory.Meta import Lean4Lean.Theory.MutualInductiveFixtures +import Lean4Lean.Theory.Projection import Lean4Lean.Theory.Quot import Lean4Lean.Theory.SingletonParity import Lean4Lean.Theory.Typing.Basic @@ -11,6 +14,7 @@ import Lean4Lean.Theory.Typing.ChurchRosser import Lean4Lean.Theory.Typing.Env import Lean4Lean.Theory.Typing.EnvLemmas import Lean4Lean.Theory.Typing.HeadReduction +import Lean4Lean.Theory.Typing.InductiveCertificate import Lean4Lean.Theory.Typing.InductiveLemmas import Lean4Lean.Theory.Typing.Injectivity import Lean4Lean.Theory.Typing.Lemmas @@ -31,6 +35,7 @@ import Lean4Lean.Verify.Environment.CandidateIdentityReplay import Lean4Lean.Verify.Environment.ConstructorValidation import Lean4Lean.Verify.Environment.ConstructorValidityMatrix import Lean4Lean.Verify.Environment.ConstructorValidityReplay +import Lean4Lean.Verify.Environment.DeepNestedReplay import Lean4Lean.Verify.Environment.Elimination import Lean4Lean.Verify.Environment.EliminationFixtures import Lean4Lean.Verify.Environment.EliminationFixturesCommon @@ -46,6 +51,7 @@ import Lean4Lean.Verify.Environment.IndexedVecConstructors import Lean4Lean.Verify.Environment.IndexedVecOuterReplay import Lean4Lean.Verify.Environment.IndexedVecSemanticReplay import Lean4Lean.Verify.Environment.InductiveFixtures +import Lean4Lean.Verify.Environment.InductiveReplayMatrix import Lean4Lean.Verify.Environment.Lemmas import Lean4Lean.Verify.Environment.MutualInductiveFixtures import Lean4Lean.Verify.Environment.Normalization @@ -126,21 +132,10 @@ private def surfacePrefixes : Array Lean.Name := #[`Lean4Lean.Theory, `Lean4Lean S (missing specification), P (stated but sorried, blocked on S), V (checker verification, blocked on S/P), R (research-grade metatheory, upstream-driven). -/ private def allowlist : Array Lean.Name := #[ - -- Tier S — missing specification - `Lean4Lean.TrProj, - -- Tier P — blocked only on Tier S - `Lean4Lean.TrProj.weak', - `Lean4Lean.TrProj.weak'_inv, - `Lean4Lean.TrProj.defeqDFC, - `Lean4Lean.TrProj.wf, - `Lean4Lean.TrProj.uniq, - `Lean4Lean.TrProj.instN, - `Lean4Lean.TrProj.instL, - -- Tier V — checker verification, blocked on Tiers S/P + -- Tier V — checker verification, blocked on Tier P -- (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, `Lean4Lean.TypeChecker.Inner.reduceProj.WF, `Lean4Lean.TypeChecker.Inner.tryEtaStructCore.WF, @@ -150,6 +145,7 @@ private def allowlist : Array Lean.Name := #[ `Lean4Lean.VEnv.IsDefEqU.forallE_inv_stratified, `Lean4Lean.VEnv.IsDefEqU.sort_forallE_inv, `Lean4Lean.VEnv.IsDefEqU.weakN_iff, + `Lean4Lean.VEnv.WF.registeredStructureHeadInversion, `Lean4Lean.VEnv.NormalEq.parRed, -- Tier F — deliberately kernel-rejected inductive fixtures. Elaborator error -- recovery admits the invalid `inductive` with `sorryAx`, so the constant diff --git a/Lean4Lean/Environment/Basic.lean b/Lean4Lean/Environment/Basic.lean index 7ed24cd0..44bfd3fb 100644 --- a/Lean4Lean/Environment/Basic.lean +++ b/Lean4Lean/Environment/Basic.lean @@ -51,6 +51,62 @@ def isNonRecStructure (env : Environment) (constName : Name) : Bool := | some (.inductInfo { isRec := false, ctors := [_], numIndices := 0, .. }) => true | _ => false +/-- A one-constructor, unindexed structure whose constructor and generated +recursor have both reached the host environment. Family metadata is staged +before either artifact is inserted; projection verification may only demand a +registered Theory view at this later boundary. + +Unlike `isNonRecStructure`, projection readiness deliberately does not inspect +`InductiveVal.isRec`: Lean emits primitive projections for recursive structures +too (including nested-recursive structures in the Lean prelude). -/ +def isProjectionReadyStructure (env : Environment) (constName : Name) : Bool := + match env.constants.find?' constName with + | some (.inductInfo { ctors := [ctor], numIndices := 0, .. }) => + match env.constants.find?' ctor, + env.constants.find?' (mkRecName constName) with + | some (.ctorInfo _), some (.recInfo _) => true + | _, _ => false + | _ => false + +theorem isProjectionReadyStructure_false_of_no_ctorInfo + {env : Environment} {name : Name} {info : InductiveVal} + (hfind : env.constants.find?' name = some (.inductInfo info)) + (hnoCtor : ∀ ctor ctorInfo, + env.constants.find?' ctor ≠ some (.ctorInfo ctorInfo)) : + env.isProjectionReadyStructure name = false := by + cases info + rename_i constant numParams numIndices all ctors numNested isRec isUnsafe isReflexive + cases constant + unfold isProjectionReadyStructure + rw [hfind] + cases numIndices with + | succ _ => rfl + | zero => + cases ctors with + | nil => rfl + | cons ctor rest => + cases rest with + | cons _ _ => rfl + | nil => + cases hctor : env.constants.find?' ctor with + | none => simp [hctor] + | some info => + cases info <;> simp_all + +theorem isProjectionReadyStructure_false_of_numIndices_ne + {env : Environment} {name : Name} {info : InductiveVal} + (hfind : env.constants.find?' name = some (.inductInfo info)) + (hindices : info.numIndices ≠ 0) : + env.isProjectionReadyStructure name = false := by + cases info + simp_all [isProjectionReadyStructure] + +theorem isProjectionReadyStructure_false_of_not_found + {env : Environment} {name : Name} + (hfind : env.constants.find?' name = none) : + env.isProjectionReadyStructure name = false := by + simp [isProjectionReadyStructure, hfind] + def checkName (env : Environment) (n : Name) (allowPrimitive := false) : Except Exception Unit := do if env.contains n then diff --git a/Lean4Lean/Inductive/ValidationTrace.lean b/Lean4Lean/Inductive/ValidationTrace.lean index 314c604a..16ede05b 100644 --- a/Lean4Lean/Inductive/ValidationTrace.lean +++ b/Lean4Lean/Inductive/ValidationTrace.lean @@ -244,6 +244,62 @@ def buildExecution (stats : InductiveStats) (ctor : Name) (argIdx : Nat) | some targetIdx => .ok (.target context source result fuel targetIdx hwhnf hoccurs hforall hvalid) +/-- The transparent decomposition succeeds on every input accepted by the +executable positivity traversal, so retained-trace construction needs no +choice principle. -/ +theorem buildExecution_ok_of_run + (success : checkPositivity.loop stats ctor argIdx source fuel context = + .ok ()) : + ∃ trace, buildExecution stats ctor argIdx context source fuel = + .ok trace := by + induction fuel generalizing context source with + | zero => + rw [checkPositivity.loop.eq_1] at success + change Except.error Exception.deepRecursion = Except.ok () at success + contradiction + | succ fuel ih => + rw [checkPositivity.loop.eq_2] at success + simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply] at success + unfold buildExecution + split + next error heq => + rw [heq] at success + simp [Except.bind] at success + next result heq => + rw [heq] at success + simp only [Except.bind] at success + split + next hoccurs => exact ⟨_, rfl⟩ + next hoccurs => + rw [hoccurs] at success + simp only [Bool.not_true, Bool.false_eq_true, if_false, + ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind, + Except.bind, Except.pure] at success + cases result <;> simp only [Expr.isForall] <;> simp only at success + case forallE name domain body binderInfo => + split + next hdomain => + rw [hdomain] at success + change Except.error _ = Except.ok () at success + contradiction + next hdomain => + rw [hdomain] at success + have tailSuccess : + checkPositivity.loop stats ctor argIdx + (body.instantiate1 context.freshExpr) fuel + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) = .ok () := success + obtain ⟨tail, htail⟩ := ih tailSuccess + rw [htail] + exact ⟨_, rfl⟩ + all_goals + split + next hvalid => + rw [hvalid] at success + change Except.error _ = Except.ok () at success + contradiction + next targetIdx hvalid => exact ⟨_, rfl⟩ + /-- An exact positivity failure, including its diagnostic payload, excludes a successful trace at precisely that source/context/fuel position. -/ theorem not_nonempty_of_error @@ -353,6 +409,28 @@ def buildExecution (stats : InductiveStats) (isUnsafe : Bool) | .error error => .error error | .ok trace => .ok (.safe rfl trace) +/-- The retained safe/unsafe branch decomposition succeeds whenever the +executable positivity branch does. -/ +theorem buildExecution_ok_of_run + (success : + (if !isUnsafe then checkPositivity stats source ctor argIdx else pure ()) + context = .ok ()) : + ∃ trace, buildExecution stats isUnsafe ctor argIdx context source = + .ok trace := by + cases isUnsafe with + | true => exact ⟨_, rfl⟩ + | false => + simp only [Bool.not_false, if_true] at success + unfold checkPositivity at success + simp only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] at success + obtain ⟨trace, htrace⟩ := + ConstructorPositivityTrace.buildExecution_ok_of_run success + unfold buildExecution + rw [htrace] + exact ⟨_, rfl⟩ + /-- Failure of the exact safe/unsafe positivity branch excludes its retained mode trace without changing the executable diagnostic. -/ theorem not_nonempty_of_error @@ -696,6 +774,149 @@ def buildExecution (stats : InductiveStats) (isUnsafe : Bool) | _ => .error <| .other "constructor source shape disagrees with isForall" +/-- The transparent telescope decomposition succeeds on every constructor +type accepted by the inner executable validator. -/ +theorem buildExecution_ok_of_run + (success : + checkConstructorType.loop stats isUnsafe familyIdx ctor source argIdx fuel + context = .ok ()) : + ∃ trace, buildExecution stats isUnsafe familyIdx ctor context source + argIdx fuel = .ok trace := by + induction fuel generalizing context source argIdx with + | zero => + rw [checkConstructorType.loop.eq_1] at success + change Except.error Exception.deepRecursion = Except.ok () at success + contradiction + | succ fuel ih => + rw [show fuel + 1 = Nat.succ fuel by omega] at success + cases source + case forallE name domain body binderInfo => + rw [checkConstructorType.loop.eq_2] at success + simp only at success + unfold buildExecution + simp only [Expr.isForall] + split + next param hparam => + rw [hparam] at success + simp only [ReaderT.bind, Bind.bind] at success + split + next error heq => + rw [heq] at success + simp [Except.bind] at success + next parameterType heq => + rw [heq] at success + simp only [Except.bind, liftTypeChecker_apply] at success + split + next error heq2 => + rw [heq2] at success + simp [Except.bind] at success + next heq2 => + rw [heq2] at success + simp only [Except.bind] at success + change Except.error _ = Except.ok () at success + contradiction + next heq2 => + rw [heq2] at success + simp only [Except.bind, if_true, ReaderT.pure, Pure.pure, + ReaderT.bind, Bind.bind, Except.pure] at success + obtain ⟨tail, htail⟩ := ih success + rw [htail] + exact ⟨_, rfl⟩ + next hparam => + rw [hparam] at success + simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply] at success + split + next error heq => + rw [heq] at success + simp [Except.bind] at success + next sortResult heq => + rw [heq] at success + simp only [Except.bind] at success + have finish : + (do + if !isUnsafe then checkPositivity stats domain ctor argIdx + withLocalDecl name binderInfo (consumeTypeAnnotations domain) + fun arg => + checkConstructorType.loop stats isUnsafe familyIdx ctor + (body.instantiate1 arg) (argIdx + 1) fuel) + context = .ok () → + (∃ positivity, + ConstructorPositivityModeTrace.buildExecution stats isUnsafe + ctor argIdx context domain = .ok positivity) ∧ + ∃ tail, + buildExecution stats isUnsafe familyIdx ctor + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) fuel = + .ok tail := by + intro restSuccess + cases isUnsafe with + | false => + simp only [Bool.not_false, if_true, + ReaderT.bind, Bind.bind] at restSuccess + cases hpos : checkPositivity stats domain ctor argIdx + context with + | error err => simp_all [Except.bind] + | ok posUnit => + cases posUnit + rw [hpos] at restSuccess + simp only [Except.bind, + withLocalDecl_apply] at restSuccess + have hpmSuccess : + (if !false then + checkPositivity stats domain ctor argIdx + else pure ()) context = .ok () := by + simpa using hpos + exact ⟨ConstructorPositivityModeTrace.buildExecution_ok_of_run + hpmSuccess, ih restSuccess⟩ + | true => + simp only [Bool.not_true, if_false, + ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind, + Except.bind, Except.pure, + withLocalDecl_apply] at restSuccess + have hpmSuccess : + (if !true then + checkPositivity stats domain ctor argIdx + else pure ()) context = .ok () := by + simp [ReaderT.pure, Pure.pure, Except.pure] + exact ⟨ConstructorPositivityModeTrace.buildExecution_ok_of_run + hpmSuccess, ih restSuccess⟩ + split + next hstruct => + rw [hstruct] at success + simp only [if_true, ReaderT.pure, Pure.pure, + ReaderT.bind, Bind.bind, Except.bind, Except.pure] at success + obtain ⟨⟨positivity, hpm⟩, tail, htail⟩ := finish success + rw [hpm, htail] + exact ⟨_, rfl⟩ + next hstruct => + rw [hstruct] at success + simp only [Bool.false_eq_true, if_false] at success + split + next hfallback => + rw [hfallback] at success + change Except.error _ = Except.ok () at success + contradiction + next hfallback => + rw [hfallback] at success + simp only [Bool.true_eq_false, Bool.not_true, if_false, + ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind, + Except.bind, Except.pure] at success + obtain ⟨⟨positivity, hpm⟩, tail, htail⟩ := finish success + rw [hpm, htail] + exact ⟨_, rfl⟩ + all_goals + unfold checkConstructorType.loop at success + simp only at success + unfold buildExecution + simp only [Expr.isForall] + split + next hvalid => + rw [hvalid] at success + change Except.error _ = Except.ok () at success + contradiction + next hvalid => exact ⟨_, rfl⟩ + /-- Erasing the inner trace also replays the public one-constructor checker, including its exact context-fuel read. -/ theorem check_run @@ -1026,6 +1247,71 @@ theorem exists_of_fold_run exact ⟨.cons seen head tail hfresh hclosed rootCheck typeTrace tailTrace⟩ +/-- The transparent list decomposition succeeds on every constructor list +accepted by the executable stateful fold. -/ +theorem buildExecution_ok_of_fold_run + (success : checkConstructorFold context.env stats isUnsafe familyIdx + seen ctors context = .ok result) : + ∃ trace, buildExecution stats isUnsafe familyIdx context seen ctors = + .ok trace := by + induction ctors generalizing seen result with + | nil => exact ⟨_, rfl⟩ + | cons head tail ih => + unfold checkConstructorFold at success + simp only at success + unfold buildExecution + split + next hfresh => + rw [hfresh] at success + change Except.error _ = Except.ok result at success + contradiction + next hfresh => + rw [hfresh] at success + simp only [Bool.false_eq_true, if_false, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] at success + split + next error heq => + rw [heq] at success + simp [liftExcept_apply, Except.bind] at success + next heq => + rw [heq] at success + simp only [liftExcept_apply, Except.bind] at success + rw [withEmptyLocalContext_apply, liftTypeChecker_apply] at success + split + next error heq2 => + rw [heq2] at success + simp [Except.bind] at success + next inferred heq2 => + rw [heq2] at success + simp only [Except.bind] at success + cases htype : checkConstructorType stats isUnsafe familyIdx + head.name head.type context with + | error err => simp_all [Except.bind] + | ok typeResult => + cases typeResult + rw [htype] at success + simp only [Except.bind, ReaderT.pure, Pure.pure, + Except.pure] at success + have htypeLoop : + checkConstructorType.loop stats isUnsafe familyIdx + head.name head.type 0 context.fuel.inductiveFuel + context = .ok () := by + unfold checkConstructorType at htype + simpa only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] using htype + obtain ⟨typeTrace, hT⟩ := + ConstructorTypeValidationTrace.buildExecution_ok_of_run + htypeLoop + rw [hT] + change checkConstructorFold context.env stats isUnsafe + familyIdx (seen.insert head.name) tail context = + .ok result at success + obtain ⟨tailTrace, htl⟩ := ih success + rw [htl] + exact ⟨_, rfl⟩ + /-- The stateful list fold's exact error value excludes a complete trace for that same source list and incoming duplicate-name accumulator. -/ theorem not_nonempty_of_fold_error @@ -1219,6 +1505,24 @@ def buildExecution (indType : InductiveType) (stats : InductiveStats) | .error error => .error error | .ok trace => .ok ⟨trace⟩ +/-- The transparent singleton decomposition succeeds on every source family +accepted by the real constructor validator. -/ +theorem buildExecution_ok_of_run + (success : checkConstructors #[indType] stats isUnsafe context = .ok ()) : + ∃ validation, buildExecution indType stats isUnsafe context = + .ok validation := by + rw [checkConstructors_singleton_eq_checkConstructorList] at success + unfold checkConstructorList at success + cases hfold : checkConstructorFold context.env stats isUnsafe 0 {} + indType.ctors context with + | error err => simp_all [Functor.map, Except.map] + | ok result => + obtain ⟨trace, htrace⟩ := + ConstructorListValidationTrace.buildExecution_ok_of_fold_run hfold + unfold buildExecution + rw [htrace] + exact ⟨_, rfl⟩ + /-- Recomposition: retained operational evidence replays the real singleton `checkConstructors` execution exactly. -/ theorem run @@ -1243,13 +1547,16 @@ theorem nonempty_of_run ConstructorListValidationTrace.exists_of_fold_run hfold exact ⟨⟨trace⟩⟩ -/-- Choose the unique-by-source operational shape supplied by a successful -run. The only nonconstructive ingredient is the project's existing baseline -`Classical.choice`; every retained equality comes from the executable run. -/ -noncomputable def of_run +/-- Choose the operational shape supplied by a successful run by replaying +the transparent decomposition. The success premise only discharges the +impossible error branch, so the retained evidence is computed by +`buildExecution` rather than selected through `Classical.choice`. -/ +def of_run (success : checkConstructors #[indType] stats isUnsafe context = .ok ()) : ConstructorValidationRun indType stats isUnsafe context := - Classical.choice (nonempty_of_run success) + match h : buildExecution indType stats isUnsafe context with + | .ok validation => validation + | .error _ => absurd (buildExecution_ok_of_run success) (by simp [h]) /-- Exact decomposition/recomposition contract for singleton constructor validation. -/ diff --git a/Lean4Lean/Tests.lean b/Lean4Lean/Tests.lean index dc420f92..540a95e5 100644 --- a/Lean4Lean/Tests.lean +++ b/Lean4Lean/Tests.lean @@ -1 +1,4 @@ import Lean4Lean.Tests.Toolchain +import Lean4Lean.Tests.LiteralReadiness +import Lean4Lean.Tests.NotationPreludeReplay +import Lean4Lean.Tests.ProjectionExpressibility diff --git a/Lean4Lean/Tests/LiteralReadiness.lean b/Lean4Lean/Tests/LiteralReadiness.lean new file mode 100644 index 00000000..fae0db67 --- /dev/null +++ b/Lean4Lean/Tests/LiteralReadiness.lean @@ -0,0 +1,99 @@ +import Lean4Lean.Theory.InductiveFixtures +import Lean4Lean.Theory.Literals +import Lean4Lean.Verify.Typing.Lemmas + +/-! # Literal readiness fixtures + +These checks pin the consumer-neutral prelude descriptors used by +`VEnv.PreludeReady` to Lean's real compiled metadata, then exercise direct and +constructor-unfolded literals with notation-heavy values. +-/ + +namespace Lean4Lean.Tests.LiteralReadiness + +open Lean + +/-! The manual Theory descriptors are exactly the declarations already +checked against the kernel by `Theory.InductiveFixtures`. -/ + +example : LiteralPrelude.boolType = InductiveFixtures.boolType := rfl +example : LiteralPrelude.natType = InductiveFixtures.natType := rfl +example : LiteralPrelude.listType = InductiveFixtures.listType := rfl + +example : LiteralPrelude.char = vconst(type_of% @Char) := rfl +example : LiteralPrelude.charOfNat = vconst(type_of% @Char.ofNat) := rfl +example : LiteralPrelude.string = vconst(type_of% @String) := rfl +example : LiteralPrelude.stringOfList = vconst(type_of% @String.ofList) := rfl + +/-! The readiness contract's recursor and iota descriptors also agree +definitionally with the kernel declarations. List's two universe parameters +use the same explicit occurrence-to-kernel permutation as the underlying +inductive adequacy fixture. -/ + +private def permC (ci : VConstant) (ls : List VLevel) : VConstant := + ⟨ci.uvars, ci.type.instL ls⟩ + +private def permE (df : VDefEq) (ls : List VLevel) : VDefEq := + ⟨df.uvars, df.lhs.instL ls, df.rhs.instL ls, df.type.instL ls⟩ + +example : LiteralPrelude.boolRec = vconst(type_of% @Bool.rec) := rfl +example : LiteralPrelude.boolIotas[0]? = + some (vdefeq(motive f t => @Bool.rec motive f t .false ≡ f)) := rfl +example : LiteralPrelude.boolIotas[1]? = + some (vdefeq(motive f t => @Bool.rec motive f t .true ≡ t)) := rfl + +example : LiteralPrelude.natRec = vconst(type_of% @Nat.rec) := rfl +example : LiteralPrelude.natIotas[0]? = + some (vdefeq(motive z s => @Nat.rec motive z s .zero ≡ z)) := rfl +example : LiteralPrelude.natIotas[1]? = + some (vdefeq(motive z s n => + @Nat.rec motive z s (.succ n) ≡ s n (@Nat.rec motive z s n))) := rfl + +example : LiteralPrelude.listRec = + permC (vconst(type_of% @List.rec)) [.param 1, .param 0] := rfl +example : LiteralPrelude.listIotas[0]? = + some (permE (vdefeq(α motive n c => @List.rec α motive n c (@List.nil α) ≡ n)) + [.param 1, .param 0]) := rfl +example : LiteralPrelude.listIotas[1]? = + some (permE (vdefeq(α motive n c hd tl => + @List.rec α motive n c (@List.cons α hd tl) ≡ + c hd tl (@List.rec α motive n c tl))) + [.param 1, .param 0]) := rfl + +section + +variable {env : VEnv} (ready : env.PreludeReady) + +example {env' : VEnv} (henv : env ≤ env') (hordered : env'.Ordered) : + env'.PreludeReady := + ready.mono henv hordered + +example {env' : VEnv} (name : Name) (ci : VConstant) (hci : ci.WF env) + (hadd : env.addConst name ci = some env') : env'.PreludeReady := + ready.addConst hci hadd + +example (df : VDefEq) (hdf : df.WF env) : + (env.addDefEq df).PreludeReady := + ready.addDefEq hdf + +example : VExpr.WF env 0 [] (VExpr.trLiteral (.natVal 1_234_567)) := + ready.trLiteral_wf _ (ready.containsLits _) + +example : VExpr.WF env 3 [] + (VExpr.trLiteral (.strVal "Lean 4: λ → ☃ — 12,345")) := + ready.trLiteral_wf _ (ready.containsLits _) + +example (h : TrExprS env [] [] + (Literal.toConstructor (.strVal "constructor ↔ direct")) w) : + w = VExpr.trLiteral (.strVal "constructor ↔ direct") ∧ + VExpr.WF env 0 [] w := + h.toConstructor_ready ready (ready.containsLits _) + +example {l : Literal} + (h : TrExprS env [] [] (Literal.toConstructor l) w) : + w = VExpr.trLiteral l := + h.toConstructor_eq + +end + +end Lean4Lean.Tests.LiteralReadiness diff --git a/Lean4Lean/Tests/NotationPreludeFixture.lean b/Lean4Lean/Tests/NotationPreludeFixture.lean new file mode 100644 index 00000000..4e1e82d6 --- /dev/null +++ b/Lean4Lean/Tests/NotationPreludeFixture.lean @@ -0,0 +1,32 @@ +/-! +# Notation-heavy prelude fixture + +Unlike the older `IndexedVec` fixture, these declarations deliberately keep +ordinary numeral, arithmetic, list, array, product, conditional, comparison, +and string notation in the source. Their compiled metadata therefore pulls +the real `OfNat`/`HAdd` and literal dependency prefix into fresh replay. +-/ + +namespace Lean4Lean.Tests.NotationPreludeFixture + +inductive NotationVec (α : Type u) : Nat → Type u where + | nil : NotationVec α 0 + | cons {n : Nat} : α → NotationVec α n → NotationVec α (n + 1) + +def sample : NotationVec Nat (1 + 1) := + .cons 37 (.cons 5 .nil) + +def notationList : List (Nat × String) := + [(0, "zero"), (1 + 1, "two"), (if 2 < 3 then 3 else 4, "three")] + +def notationArray : Array (Nat × String) := + #[(5, "five"), (2 + 4, "six")] + +/-- One root whose type and value retain the complete fixture dependency +closure for replay. -/ +def bundled : + NotationVec Nat (1 + 1) × + (List (Nat × String) × Array (Nat × String)) := + (sample, notationList, notationArray) + +end Lean4Lean.Tests.NotationPreludeFixture diff --git a/Lean4Lean/Tests/NotationPreludeReplay.lean b/Lean4Lean/Tests/NotationPreludeReplay.lean new file mode 100644 index 00000000..0ceb0f28 --- /dev/null +++ b/Lean4Lean/Tests/NotationPreludeReplay.lean @@ -0,0 +1,54 @@ +import Lean4Lean.Replay +import Lean4Lean.Tests.NotationPreludeFixture + +/-! +# Fresh notation-prelude replay + +This is an executable replay from an empty kernel environment over the real +compiled dependency closure of `bundled`. In particular, no hand-built +Theory environment or abstract existence witness stands in for the prelude +prefix selected by the stored metadata. +-/ + +namespace Lean4Lean.Tests.NotationPreludeReplay + +open Lean + +private def fixtureModule : Name := + `Lean4Lean.Tests.NotationPreludeFixture + +private def fixtureRoot : Name := + ``Lean4Lean.Tests.NotationPreludeFixture.bundled + +/-- Return the actual fresh kernel environment as well as the count so the +test can check that the notation-selected prelude prefix was really installed. +This is the same operation as `Replay.replayFromFresh` specialized to one +dependency root. -/ +private unsafe def replayNotationPrefix : + IO (Nat × Lean.Kernel.Environment) := do + Lean.withImportModules #[fixtureModule] {} (trustLevel := 0) fun env => do + let context : Lean4Lean.Replay.Context := { + newConstants := env.constants.map₁ + checkQuot := false } + Lean4Lean.Replay.replay context (.empty fixtureModule) (some fixtureRoot) + +run_cmd do + let (count, replayed) ← replayNotationPrefix + unless count = 296 do + throwError "notation-heavy fresh replay added {count} declarations; expected 296" + let required := #[ + ``OfNat.ofNat, + ``HAdd.hAdd, + ``String.ofList, + ``Char.ofNat, + ``Lean4Lean.Tests.NotationPreludeFixture.NotationVec, + ``Lean4Lean.Tests.NotationPreludeFixture.NotationVec.nil, + ``Lean4Lean.Tests.NotationPreludeFixture.NotationVec.cons, + ``Lean4Lean.Tests.NotationPreludeFixture.NotationVec.rec, + fixtureRoot] + for name in required do + unless (replayed.constants.find? name).isSome do + throwError "notation-heavy fresh replay omitted {name}" + logInfo m!"notation-heavy fresh replay OK ({count} declarations)" + +end Lean4Lean.Tests.NotationPreludeReplay diff --git a/Lean4Lean/Tests/ProjectionExpressibility.lean b/Lean4Lean/Tests/ProjectionExpressibility.lean new file mode 100644 index 00000000..349b682a --- /dev/null +++ b/Lean4Lean/Tests/ProjectionExpressibility.lean @@ -0,0 +1,1308 @@ +import Lean4Lean.Theory.Meta +import Lean4Lean.Theory.Projection +import Lean4Lean.Theory.Typing.InductiveLemmas + +/-! +# Projection expressibility fixtures + +The main fixture is simultaneously parameterized, universe-polymorphic, and +dependent: the final field type mentions the preceding projection. It is +small enough that the complete recursor encoding remains definitionally +inspectable. +-/ + +namespace Lean4Lean.Tests.ProjectionExpressibility + +open Lean4Lean VInductDecl + +universe u v + +structure DependentRecord (α : Type u) (family : α → Type v) where + key : α + value : family key + +def dependentRecordCtor : VConstVal := + ⟨vconst(type_of% @DependentRecord.mk), ``DependentRecord.mk⟩ + +def dependentRecordType : VInductiveType where + name := ``DependentRecord + uvars := 2 + type := vconst(type_of% @DependentRecord).type + ctors := [dependentRecordCtor] + +def dependentRecordDecl : VInductDecl := + ⟨2, 2, [dependentRecordType]⟩ + +example : dependentRecordDecl.checked?.isSome = true := rfl + +def dependentRecordChecked : dependentRecordDecl.Checked := + dependentRecordDecl.checked?.get (by decide) + +def dependentRecordGeneration : dependentRecordDecl.GenerationChecked := + dependentRecordChecked.identityGeneration + +def dependentRecordView : VStructureView where + source := dependentRecordDecl + generation := dependentRecordGeneration + constructor := dependentRecordGeneration.block.ctorPairs[0] + constructor_eq := rfl + raw_indices_eq := rfl + checked_indices_eq := rfl + recursive_eq := rfl + fieldSorts := [.succ (.param 0), .succ (.param 1)] + fieldSorts_length := rfl + +def dependentRecordEnv : VEnv := + (VEnv.empty.addInductGeneration dependentRecordGeneration).get (by decide) + +theorem dependentRecord_add : + VEnv.empty.addInductGeneration dependentRecordGeneration = + some dependentRecordEnv := rfl + +theorem dependentRecord_trace : + Nonempty (VEnv.AddInductGenerationTrace VEnv.empty + dependentRecordEnv dependentRecordGeneration) := + VEnv.addInductGeneration_trace dependentRecord_add + +theorem dependentRecordDecl_wf : + dependentRecordDecl.WF VEnv.empty := by + refine ⟨rfl, ?_⟩ + intro ty hty + have hty' : ty = dependentRecordType := + List.mem_singleton.1 (by simpa [dependentRecordDecl] using hty) + subst ty + refine ⟨?_, ?_⟩ + · exact ⟨⟨_, by type_tac⟩, ⟨⟨_, by type_tac⟩, trivial⟩⟩ + · intro c hc + have hc' : c = dependentRecordCtor := by + simpa [dependentRecordType] using hc + subst c + constructor + · simp [dependentRecordDecl, dependentRecordType, + dependentRecordCtor, VInductDecl.fieldsWF, + VInductDecl.ctorFields, VInductDecl.isRecField, + VInductDecl.recArg?, VInductDecl.recTarget?, + VInductDecl.recFieldIdxs, VInductDecl.sortLevel, + VExpr.dropN, VExpr.resultOf, VExpr.appHead, + VExpr.appArgs] + exact ⟨ + ⟨VLevel.succ (.param 0), by type_tac, VLevel.le_max_left⟩, + ⟨VLevel.succ (.param 1), by type_tac, VLevel.le_max_right⟩⟩ + · simp [dependentRecordDecl, dependentRecordType, + dependentRecordCtor, VInductDecl.ctorFields, + VInductDecl.recFieldIdxs, VInductDecl.sortLevel, + VExpr.dropN, VExpr.resultOf, VExpr.forallN, + VExpr.liftTelN, VExpr.appArgs] + rfl + +theorem dependentRecordGeneration_wf : + dependentRecordGeneration.WF VEnv.empty := + (dependentRecordChecked.wf_of_decl + dependentRecordDecl_wf).identityGeneration .empty + +theorem dependentRecordEnv_ordered : dependentRecordEnv.Ordered := + VEnv.addInductGeneration_WF .empty dependentRecordGeneration_wf + dependentRecord_add + +theorem dependentRecordEnv_wf : dependentRecordEnv.WF := + ⟨[.induct dependentRecordDecl], + .decl (.induct dependentRecordGeneration_wf dependentRecord_add) .empty⟩ + +theorem dependentRecord_generation_semantics : + dependentRecordView.GenerationSemantics dependentRecordEnv := by + rcases dependentRecord_trace with ⟨trace⟩ + exact .ofGenerationTrace dependentRecordGeneration_wf trace + +theorem dependentRecord_registered : + dependentRecordView.Registered dependentRecordEnv := by + rcases dependentRecord_trace with ⟨trace⟩ + refine { + family := trace.family_lookup + constructor := ?_ + recursor := trace.rec_lookup + rules := fun _ h => trace.rule_mem h } + apply trace.ctor_lookup + rw [← dependentRecordGeneration.rawCtors_eq] + exact List.mem_map.2 ⟨dependentRecordView.constructor, + by + change dependentRecordView.constructor ∈ + dependentRecordView.generation.block.ctorPairs + rw [dependentRecordView.constructor_eq] + simp, + rfl⟩ + +theorem dependentRecord_view_wf : + dependentRecordView.WF dependentRecordEnv := by + refine { + toRegistered := dependentRecord_registered + generationSemantics := dependentRecord_generation_semantics + parameters := ?_ + parameters_length := rfl + fieldTelescope := ?_ + smallFields := ?_ } + · exact ⟨⟨_, by type_tac⟩, ⟨⟨_, by type_tac⟩, trivial⟩⟩ + · exact .cons (by type_tac) (.cons (by type_tac) .nil) + · intro h + change VInductDecl.ElimMode.large = .small at h + contradiction + +/-- The checked artifact retains both parameters and exactly the two +dependent fields from the real kernel declaration. -/ +example : dependentRecordGeneration.block.rawParams = + [.sort (.succ (.param 0)), + .forallE (.bvar 0) (.sort (.succ (.param 1)))] := rfl + +example : dependentRecordView.fields = + [.bvar 1, .app (.bvar 1) (.bvar 0)] := rfl + +example : dependentRecordGeneration.elimination = .large := rfl + +private def permC (ci : VConstant) (levels : List VLevel) : VConstant := + ⟨ci.uvars, ci.type.instL levels⟩ + +example : dependentRecordGeneration.recursor = + permC (vconst(type_of% @DependentRecord.rec)) + [.param 1, .param 2, .param 0] := rfl + +def symbolicLevels : List VLevel := [.param 0, .param 1] + +/-- Parameters in the context `[family, α]`, outermost first. -/ +def symbolicParams : List VExpr := [.bvar 1, .bvar 0] + +def symbolicStructureType : VExpr := + dependentRecordView.structureType symbolicLevels symbolicParams + +example : dependentRecordView.specializedFields symbolicLevels symbolicParams = + [.bvar 1, .app (.bvar 1) (.bvar 0)] := rfl + +def keyCode : VStructureView.ProjectionCode := + (dependentRecordView.projectionCodes symbolicLevels symbolicParams)[0] + +def valueCode : VStructureView.ProjectionCode := + (dependentRecordView.projectionCodes symbolicLevels symbolicParams)[1] + +/-- Constructor reduction selects the first field for `key`. -/ +example : keyCode.minor = + .lam (.bvar 1) + (.lam (.app (.bvar 1) (.bvar 0)) (.bvar 1)) := rfl + +/-- Constructor reduction selects the second field for `value`. -/ +example : valueCode.minor = + .lam (.bvar 1) + (.lam (.app (.bvar 1) (.bvar 0)) (.bvar 0)) := rfl + +/-- The first field type is `α`. -/ +example : keyCode.typeFn = + .lam symbolicStructureType (.bvar 2) := rfl + +/-- The dependent second field type is `family (key major)`: the earlier +projection program occurs in the later motive, rather than being supplied by +an unconstrained witness. -/ +example : valueCode.typeFn = + .lam symbolicStructureType + (.app (.bvar 1) (.app keyCode.projector.lift (.bvar 0))) := rfl + +example : dependentRecordView.projectionLevels keyCode.fieldSort symbolicLevels = + [.succ (.param 0), .param 0, .param 1] := rfl + +example : dependentRecordView.projectionLevels valueCode.fieldSort symbolicLevels = + [.succ (.param 1), .param 0, .param 1] := rfl + +example : dependentRecordView.project? symbolicLevels symbolicParams 2 (.bvar 0) = + none := rfl + +/-! A fully constrained `VEnv.TrProj` witness in a universe-polymorphic +local context. -/ + +def symbolicAlphaType : VExpr := .sort (.succ (.param 0)) + +def symbolicFamilyType : VExpr := + .forallE (.bvar 0) (.sort (.succ (.param 1))) + +/-- The major binder type is written over `[family, α]`. -/ +def symbolicMajorBinderType : VExpr := + dependentRecordView.structureType symbolicLevels [.bvar 1, .bvar 0] + +def symbolicContext : List VExpr := + [symbolicMajorBinderType, symbolicFamilyType, symbolicAlphaType] + +/-- The same parameters as seen under the major binder. -/ +def symbolicMajorParams : List VExpr := [.bvar 2, .bvar 1] + +def symbolicMajor : VExpr := .bvar 0 + +theorem symbolicLevels_wf : + ∀ level ∈ symbolicLevels, level.WF 2 := by + simp [symbolicLevels, VLevel.WF] + +theorem symbolicParams_spine : + ∃ resultLevel, dependentRecordEnv.SpineWF 2 symbolicContext + (dependentRecordView.familyType.instL symbolicLevels) + symbolicMajorParams (.sort resultLevel) := by + refine ⟨.max (.succ (.param 0)) (.succ (.param 1)), + ⟨_, _, rfl, by type_tac, ?_⟩⟩ + exact ⟨_, _, rfl, by type_tac, rfl⟩ + +theorem symbolicMajor_hasType : + dependentRecordEnv.HasType 2 symbolicContext symbolicMajor + (dependentRecordView.structureType symbolicLevels symbolicMajorParams) := by + exact .bvar .zero + +def symbolicKeyCode : VStructureView.ProjectionCode := + (dependentRecordView.projectionCodes symbolicLevels symbolicMajorParams)[0] + +def symbolicValueCode : VStructureView.ProjectionCode := + (dependentRecordView.projectionCodes symbolicLevels symbolicMajorParams)[1] + +def symbolicFieldContext : List VExpr := + [.app (.bvar 3) (.bvar 0), .bvar 3, + dependentRecordView.structureType symbolicLevels symbolicMajorParams] ++ + symbolicContext + +def symbolicConstructorApp : VExpr := + dependentRecordView.projectionConstructorApp symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1)) + [.bvar 3, .app (.bvar 3) (.bvar 0)] + +def symbolicInnerStructureType : VExpr := + dependentRecordView.structureType symbolicLevels [.bvar 5, .bvar 4] + +theorem symbolicConstructor_hasType : + dependentRecordEnv.HasType 2 symbolicFieldContext symbolicConstructorApp + symbolicInnerStructureType := by + have hc := VEnv.HasType.const + (Γ := symbolicFieldContext) dependentRecord_view_wf.constructor + symbolicLevels_wf (by rfl) + have hα : dependentRecordEnv.HasType 2 symbolicFieldContext + (.bvar 5) (.sort (.succ (.param 0))) := by + type_tac + have hFamily : dependentRecordEnv.HasType 2 symbolicFieldContext + (.bvar 4) (.forallE (.bvar 5) (.sort (.succ (.param 1)))) := by + type_tac + have hKey : dependentRecordEnv.HasType 2 symbolicFieldContext + (.bvar 1) (.bvar 5) := by + type_tac + have hValue : dependentRecordEnv.HasType 2 symbolicFieldContext + (.bvar 0) (.app (.bvar 4) (.bvar 1)) := by + type_tac + have hcα := hc.app hα + have hcFamily := hcα.app hFamily + have hcKey := hcFamily.app hKey + have hcValue := hcKey.app hValue + change dependentRecordEnv.HasType 2 symbolicFieldContext + symbolicConstructorApp symbolicInnerStructureType at hcValue + exact hcValue + +private def takeLamDomains : Nat → VExpr → List VExpr + | 0, _ => [] + | n + 1, .lam A body => A :: takeLamDomains n body + | _ + 1, _ => [] + +private def dropLamBody : Nat → VExpr → VExpr + | 0, e => e + | n + 1, .lam _ body => dropLamBody n body + | _ + 1, e => e + +private def dropForallBody : Nat → VExpr → VExpr + | 0, e => e + | n + 1, .forallE _ body => dropForallBody n body + | _ + 1, e => e + +theorem symbolicStructure_isType : dependentRecordEnv.IsType 2 symbolicContext + (dependentRecordView.structureType symbolicLevels symbolicMajorParams) := by + obtain ⟨resultLevel, hspine⟩ := symbolicParams_spine + have hfamily := VEnv.HasType.const + (Γ := symbolicContext) dependentRecord_view_wf.family + symbolicLevels_wf (by rfl) + exact ⟨resultLevel, by + simpa [VStructureView.structureType] using hspine.hasType_appN hfamily⟩ + +theorem symbolicMajorBinder_isType : dependentRecordEnv.IsType 2 + [symbolicFamilyType, symbolicAlphaType] symbolicMajorBinderType := by + let resultLevel := VLevel.max (.succ (.param 0)) (.succ (.param 1)) + have hspine : dependentRecordEnv.SpineWF 2 + [symbolicFamilyType, symbolicAlphaType] + (dependentRecordView.familyType.instL symbolicLevels) + [.bvar 1, .bvar 0] (.sort resultLevel) := by + refine ⟨_, _, rfl, by type_tac, ?_⟩ + exact ⟨_, _, rfl, by type_tac, rfl⟩ + have hfamily := VEnv.HasType.const + (Γ := [symbolicFamilyType, symbolicAlphaType]) + dependentRecord_view_wf.family symbolicLevels_wf (by rfl) + exact ⟨resultLevel, by + simpa [symbolicMajorBinderType, VStructureView.structureType] using + hspine.hasType_appN hfamily⟩ + +theorem symbolicFieldContext_wf : + OnCtx symbolicFieldContext (dependentRecordEnv.IsType 2) := by + refine ⟨?_, ⟨_, by type_tac⟩⟩ + refine ⟨?_, ⟨_, by type_tac⟩⟩ + refine ⟨?_, symbolicStructure_isType⟩ + refine ⟨?_, symbolicMajorBinder_isType⟩ + refine ⟨?_, ⟨_, by type_tac⟩⟩ + exact ⟨trivial, ⟨_, by type_tac⟩⟩ + +def symbolicKeyMotive : VExpr := symbolicKeyCode.typeFn.liftN 3 + +def symbolicKeyMinor : VExpr := symbolicKeyCode.minor.liftN 3 + +def symbolicKeyRuleLevels : List VLevel := + dependentRecordView.projectionLevels symbolicKeyCode.fieldSort symbolicLevels + +def symbolicKeyRule : VDefEq := dependentRecordGeneration.generatedRules[0] + +def symbolicKeyRuleType : VExpr := + .forallE (.sort (.succ (.param 0))) + (.forallE (.forallE (.bvar 0) (.sort (.succ (.param 1)))) + (.forallE + (.forallE + (dependentRecordView.structureType symbolicLevels [.bvar 1, .bvar 0]) + (.sort (.succ (.param 0)))) + (.forallE + (.forallE (.bvar 2) + (.forallE (.app (.bvar 2) (.bvar 0)) + (.app (.bvar 2) + (.app + (.app + (.app + (.app (.const ``DependentRecord.mk symbolicLevels) + (.bvar 4)) + (.bvar 3)) + (.bvar 1)) + (.bvar 0))))) + (.forallE (.bvar 3) + (.forallE (.app (.bvar 3) (.bvar 0)) + (.app (.bvar 3) + (.app + (.app + (.app + (.app (.const ``DependentRecord.mk symbolicLevels) + (.bvar 5)) + (.bvar 4)) + (.bvar 1)) + (.bvar 0)))))))) + +theorem symbolicKeyRuleType_eq : + symbolicKeyRule.type.instL symbolicKeyRuleLevels = + symbolicKeyRuleType := rfl + +def symbolicKeyRuleArgs : List VExpr := + [.bvar 5, .bvar 4, symbolicKeyMotive, symbolicKeyMinor, + .bvar 1, .bvar 0] + +def symbolicKeyRuleResult : VExpr := + VExpr.instRev (dropForallBody 6 symbolicKeyRuleType) symbolicKeyRuleArgs + +theorem symbolicKeyRule_spine : + dependentRecordEnv.SpineWF 2 symbolicFieldContext + (symbolicKeyRule.type.instL symbolicKeyRuleLevels) + symbolicKeyRuleArgs symbolicKeyRuleResult := by + rw [symbolicKeyRuleType_eq] + unfold symbolicKeyRuleArgs symbolicKeyRuleResult + refine ⟨_, _, rfl, by type_tac, ?_⟩ + refine ⟨_, _, rfl, by type_tac, ?_⟩ + refine ⟨_, _, rfl, ?_, ?_⟩ + · have hMotiveShape : symbolicKeyMotive = + .lam + ((dependentRecordView.structureType symbolicLevels + symbolicMajorParams).liftN 3) + (.bvar 6) := rfl + rw [hMotiveShape] + obtain ⟨structureLevel, hstructure⟩ := + symbolicStructure_isType.weakN dependentRecordEnv_ordered + (Ctx.LiftN.zero + [.app (.bvar 3) (.bvar 0), .bvar 3, + dependentRecordView.structureType symbolicLevels + symbolicMajorParams]) + exact VEnv.HasType.lam (u := structureLevel) hstructure (by type_tac) + · refine ⟨_, _, rfl, ?_, ?_⟩ + · change dependentRecordEnv.HasType 2 symbolicFieldContext + symbolicKeyMinor + (.forallE (.bvar 5) + (.forallE (.app (.bvar 5) (.bvar 0)) + (.app (symbolicKeyMotive.liftN 2) + (.app + (.app + (.app + (.app (.const ``DependentRecord.mk symbolicLevels) + (.bvar 7)) + (.bvar 6)) + (.bvar 1)) + (.bvar 0))))) + have hMinorShape : symbolicKeyMinor = + .lam (.bvar 5) + (.lam (.app (.bvar 5) (.bvar 0)) (.bvar 1)) := rfl + rw [hMinorShape] + refine .lam (by type_tac) ?_ + refine .lam (by type_tac) ?_ + have hMotiveLiftShape : symbolicKeyMotive.liftN 2 = + .lam + (dependentRecordView.structureType symbolicLevels + [.bvar 7, .bvar 6]) + (.bvar 8) := rfl + rw [hMotiveLiftShape] + let innerCtor : VExpr := + .app + (.app + (.app + (.app (.const ``DependentRecord.mk symbolicLevels) (.bvar 7)) + (.bvar 6)) + (.bvar 1)) + (.bvar 0) + let innerStructure : VExpr := + dependentRecordView.structureType symbolicLevels [.bvar 7, .bvar 6] + have hkey : dependentRecordEnv.HasType 2 + ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext) + (.bvar 1) (.bvar 7) := by + type_tac + have hctor : dependentRecordEnv.HasType 2 + ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext) + innerCtor innerStructure := by + have hc := VEnv.HasType.const + (Γ := ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: + symbolicFieldContext)) + dependentRecord_view_wf.constructor symbolicLevels_wf (by rfl) + have hα : dependentRecordEnv.HasType 2 + ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext) + (.bvar 7) (.sort (.succ (.param 0))) := by + type_tac + have hFamily : dependentRecordEnv.HasType 2 + ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext) + (.bvar 6) + (.forallE (.bvar 7) (.sort (.succ (.param 1)))) := by + type_tac + have hValue : dependentRecordEnv.HasType 2 + ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext) + (.bvar 0) (.app (.bvar 6) (.bvar 1)) := by + type_tac + have hcValue := (((hc.app hα).app hFamily).app hkey).app hValue + change dependentRecordEnv.HasType 2 + ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext) + innerCtor innerStructure at hcValue + exact hcValue + have hbody : dependentRecordEnv.HasType 2 + (innerStructure :: (.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: + symbolicFieldContext) + (.bvar 8) (.sort (.succ (.param 0))) := by + dsimp [innerStructure] + type_tac + have hbetaRaw := VEnv.IsDefEq.beta hbody hctor + have hbeta : dependentRecordEnv.IsDefEq 2 + ((.app (.bvar 5) (.bvar 0)) :: .bvar 5 :: symbolicFieldContext) + (.app (.lam innerStructure (.bvar 8)) innerCtor) + (.bvar 7) (.sort (.succ (.param 0))) := by + simpa [innerCtor, innerStructure, VExpr.inst, VExpr.instVar] using hbetaRaw + exact hbeta.symm.defeq hkey + · refine ⟨_, _, rfl, by type_tac, ?_⟩ + exact ⟨_, _, rfl, by type_tac, rfl⟩ + +def symbolicKeyRuleBinders : List VExpr := + takeLamDomains 6 (symbolicKeyRule.lhs.instL symbolicKeyRuleLevels) + +def symbolicKeyRuleLhsBody : VExpr := + dropLamBody 6 (symbolicKeyRule.lhs.instL symbolicKeyRuleLevels) + +def symbolicKeyRuleRhsBody : VExpr := + dropLamBody 6 (symbolicKeyRule.rhs.instL symbolicKeyRuleLevels) + +def symbolicKeyRuleTypeBody : VExpr := + dropForallBody 6 (symbolicKeyRule.type.instL symbolicKeyRuleLevels) + +theorem symbolicKeyRule_lhs_shape : + symbolicKeyRule.lhs.instL symbolicKeyRuleLevels = + VExpr.lamN symbolicKeyRuleBinders symbolicKeyRuleLhsBody := rfl + +theorem symbolicKeyRule_rhs_shape : + symbolicKeyRule.rhs.instL symbolicKeyRuleLevels = + VExpr.lamN symbolicKeyRuleBinders symbolicKeyRuleRhsBody := rfl + +theorem symbolicKeyRule_type_shape : + symbolicKeyRule.type.instL symbolicKeyRuleLevels = + VExpr.forallN symbolicKeyRuleBinders symbolicKeyRuleTypeBody := rfl + +theorem symbolicKeyRuleBinders_length : symbolicKeyRuleBinders.length = 6 := rfl + +theorem symbolicKeyRuleArgs_length : symbolicKeyRuleArgs.length = 6 := rfl + +theorem symbolicKeyRule_registered : dependentRecordEnv.defeqs symbolicKeyRule := by + apply dependentRecord_view_wf.rules + decide + +theorem symbolicKeyRule_levels_wf : + ∀ level ∈ symbolicKeyRuleLevels, level.WF 2 := by + decide + +theorem symbolicKeyRule_levels_length : + symbolicKeyRuleLevels.length = symbolicKeyRule.uvars := by + decide + +theorem symbolicKeyRule_reduces : dependentRecordEnv.IsDefEqU 2 + symbolicFieldContext + (VExpr.instRev symbolicKeyRuleLhsBody symbolicKeyRuleArgs) + (VExpr.instRev symbolicKeyRuleRhsBody symbolicKeyRuleArgs) := by + have hextra : dependentRecordEnv.IsDefEq 2 symbolicFieldContext + (symbolicKeyRule.lhs.instL symbolicKeyRuleLevels) + (symbolicKeyRule.rhs.instL symbolicKeyRuleLevels) + (symbolicKeyRule.type.instL symbolicKeyRuleLevels) := + .extra symbolicKeyRule_registered symbolicKeyRule_levels_wf + symbolicKeyRule_levels_length + have happlied := hextra.appN_congr symbolicKeyRule_spine + have hlhsType := hextra.hasType.1 + rw [symbolicKeyRule_lhs_shape] at hlhsType + obtain ⟨hlhsTel, lhsType, hlhsBody⟩ := VEnv.HasType.lamN_wf + dependentRecordEnv_ordered symbolicFieldContext_wf hlhsType + have hlhsSpine := symbolicKeyRule_spine + rw [symbolicKeyRule_type_shape] at hlhsSpine + have hlhsRetarget := hlhsSpine.retarget + (symbolicKeyRuleArgs_length.trans symbolicKeyRuleBinders_length.symm) + lhsType + have hcollapseL := VEnv.IsDefEq.appN_lamN dependentRecordEnv_ordered + hlhsTel hlhsBody hlhsRetarget + (symbolicKeyRuleArgs_length.trans symbolicKeyRuleBinders_length.symm) + have hrhsType := hextra.hasType.2 + rw [symbolicKeyRule_rhs_shape] at hrhsType + obtain ⟨hrhsTel, rhsType, hrhsBody⟩ := VEnv.HasType.lamN_wf + dependentRecordEnv_ordered symbolicFieldContext_wf hrhsType + have hrhsSpine := symbolicKeyRule_spine + rw [symbolicKeyRule_type_shape] at hrhsSpine + have hrhsRetarget := hrhsSpine.retarget + (symbolicKeyRuleArgs_length.trans symbolicKeyRuleBinders_length.symm) + rhsType + have hcollapseR := VEnv.IsDefEq.appN_lamN dependentRecordEnv_ordered + hrhsTel hrhsBody hrhsRetarget + (symbolicKeyRuleArgs_length.trans symbolicKeyRuleBinders_length.symm) + rw [symbolicKeyRule_lhs_shape, symbolicKeyRule_rhs_shape] at happlied + exact VEnv.IsDefEqU.trans dependentRecordEnv_wf symbolicFieldContext_wf + ⟨_, hcollapseL.symm⟩ + (VEnv.IsDefEqU.trans dependentRecordEnv_wf symbolicFieldContext_wf + ⟨_, happlied⟩ ⟨_, hcollapseR⟩) + +theorem symbolicKeyProjector_hasType : + dependentRecordEnv.HasType 2 symbolicContext symbolicKeyCode.projector + (.forallE + (dependentRecordView.structureType symbolicLevels symbolicMajorParams) + (.app symbolicKeyCode.typeFn.lift (.bvar 0))) := by + obtain ⟨resultLevel, hspine⟩ := symbolicParams_spine + have hfamily := VEnv.HasType.const + (Γ := symbolicContext) dependentRecord_view_wf.family + symbolicLevels_wf (by rfl) + have hstructure : dependentRecordEnv.HasType 2 symbolicContext + (dependentRecordView.structureType symbolicLevels symbolicMajorParams) + (.sort resultLevel) := by + simpa [VStructureView.structureType] using hspine.hasType_appN hfamily + have W : Ctx.LiftN 1 0 symbolicContext + (dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) := .one + change dependentRecordEnv.HasType 2 symbolicContext (.lam _ _) + (.forallE _ _) + refine .lam hstructure ?_ + change dependentRecordEnv.HasType 2 + (dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (VExpr.appN + (.const dependentRecordView.recursorName + (dependentRecordView.projectionLevels + symbolicKeyCode.fieldSort symbolicLevels)) + (symbolicMajorParams.map (VExpr.liftN 1) ++ + [symbolicKeyCode.typeFn.lift, symbolicKeyCode.minor.lift, + .bvar 0])) + (.app symbolicKeyCode.typeFn.lift (.bvar 0)) + apply dependentRecord_view_wf.recursorProjection_hasType + dependentRecordEnv_ordered symbolicLevels symbolicLevels_wf rfl + (symbolicMajorParams.map (VExpr.liftN 1)) (by rfl) + (fieldSort := symbolicKeyCode.fieldSort) + · refine ⟨resultLevel, ?_⟩ + have hfamilyClosed : + (dependentRecordView.familyType.instL symbolicLevels).ClosedN 0 := by + simpa using + (dependentRecordEnv_ordered.closedC + dependentRecord_view_wf.family).instL + have hspine' := hspine.weakN dependentRecordEnv_ordered W + rw [hfamilyClosed.liftN_eq (Nat.zero_le _)] at hspine' + simpa [VExpr.liftN] using hspine' + · change VLevel.WF 2 (.succ (.param 0)) + decide + · rfl + · exact ⟨resultLevel, by + simpa [VExpr.liftN] using hstructure.weakN dependentRecordEnv_ordered W⟩ + · change dependentRecordEnv.HasType 2 + (dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.lam + (dependentRecordView.structureType symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1))) + (.bvar 4)) + (.forallE + (dependentRecordView.structureType symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1))) + (.sort (.succ (.param 0)))) + refine VEnv.HasType.lam (u := resultLevel) ?_ (by type_tac) + simpa [VExpr.liftN] using + hstructure.weakN dependentRecordEnv_ordered W + · change dependentRecordEnv.HasType 2 + (dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.lam (.bvar 3) + (.lam (.app (.bvar 3) (.bvar 0)) (.bvar 1))) + (.forallE (.bvar 3) + (.forallE (.app (.bvar 3) (.bvar 0)) + (.app + (.lam + (.app + (.app (.const ``DependentRecord symbolicLevels) (.bvar 5)) + (.bvar 4)) + (.bvar 6)) + (.app + (.app + (.app + (.app (.const ``DependentRecord.mk symbolicLevels) + (.bvar 5)) + (.bvar 4)) + (.bvar 1)) + (.bvar 0))))) + refine .lam (by type_tac) ?_ + refine .lam (by type_tac) ?_ + have hkey : dependentRecordEnv.HasType 2 + ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.bvar 1) (.bvar 5) := by + type_tac + apply (show dependentRecordEnv.IsDefEq 2 + ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.bvar 5) + (.app + (.lam + (.app + (.app (.const ``DependentRecord symbolicLevels) (.bvar 5)) + (.bvar 4)) + (.bvar 6)) + (.app + (.app + (.app + (.app (.const ``DependentRecord.mk symbolicLevels) (.bvar 5)) + (.bvar 4)) + (.bvar 1)) + (.bvar 0))) + (.sort (.succ (.param 0))) from ?_).defeq hkey + let S : VExpr := + .app + (.app (.const ``DependentRecord symbolicLevels) (.bvar 5)) + (.bvar 4) + let ctorApp : VExpr := + .app + (.app + (.app + (.app (.const ``DependentRecord.mk symbolicLevels) (.bvar 5)) + (.bvar 4)) + (.bvar 1)) + (.bvar 0) + have hbody : dependentRecordEnv.HasType 2 + (S :: (.app (.bvar 3) (.bvar 0)) :: .bvar 3 :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.bvar 6) (.sort (.succ (.param 0))) := by + dsimp [S] + type_tac + have hctor : dependentRecordEnv.HasType 2 + ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + ctorApp S := by + have hc := VEnv.HasType.const + (Γ := ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext)) + dependentRecord_view_wf.constructor symbolicLevels_wf (by rfl) + have hα : dependentRecordEnv.HasType 2 + ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.bvar 5) (.sort (.succ (.param 0))) := by + type_tac + have hFamily : dependentRecordEnv.HasType 2 + ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.bvar 4) + (.forallE (.bvar 5) (.sort (.succ (.param 1)))) := by + type_tac + have hKey : dependentRecordEnv.HasType 2 + ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.bvar 1) (.bvar 5) := by + type_tac + have hValue : dependentRecordEnv.HasType 2 + ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.bvar 0) (.app (.bvar 4) (.bvar 1)) := by + type_tac + have hcα := hc.app hα + have hcFamily := hcα.app hFamily + have hcKey := hcFamily.app hKey + have hcValue := hcKey.app hValue + change dependentRecordEnv.HasType 2 + ((.app (.bvar 3) (.bvar 0)) :: .bvar 3 :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + ctorApp S at hcValue + exact hcValue + have hbeta := VEnv.IsDefEq.beta hbody hctor + simpa [S, ctorApp, VExpr.inst, VExpr.instVar] using hbeta.symm + · exact .bvar .zero + +def symbolicKeyProjectorBody : VExpr := + match symbolicKeyCode.projector.liftN 3 with + | .lam _ body => body + | expression => expression + +theorem symbolicKeyProjector_lift_shape : + symbolicKeyCode.projector.liftN 3 = + .lam symbolicInnerStructureType symbolicKeyProjectorBody := by + decide + +theorem symbolicKeyProjector_beta_shape : + symbolicKeyProjectorBody.inst symbolicConstructorApp = + VExpr.instRev symbolicKeyRuleLhsBody symbolicKeyRuleArgs := by + decide + +theorem symbolicKeyRule_rhs_result_shape : + VExpr.instRev symbolicKeyRuleRhsBody symbolicKeyRuleArgs = + .app (.app symbolicKeyMinor (.bvar 1)) (.bvar 0) := by + decide + +/-- The generated key projector computes on the generated constructor by +the registered recursor iota rule. -/ +theorem symbolicKey_constructor_defeq : dependentRecordEnv.IsDefEq 2 + symbolicFieldContext + (.app (symbolicKeyCode.projector.liftN 3) symbolicConstructorApp) + (.bvar 1) (.bvar 5) := by + have W3 : Ctx.LiftN 3 0 symbolicContext symbolicFieldContext := + .zero [.app (.bvar 3) (.bvar 0), .bvar 3, + dependentRecordView.structureType symbolicLevels symbolicMajorParams] + have hprojector := symbolicKeyProjector_hasType.weakN + dependentRecordEnv_ordered W3 + rw [symbolicKeyProjector_lift_shape] at hprojector + obtain ⟨_, ⟨projectorBodyType, hprojectorBody⟩⟩ := + hprojector.lam_inv dependentRecordEnv_ordered symbolicFieldContext_wf + have hprojectorBeta := VEnv.IsDefEq.beta hprojectorBody + symbolicConstructor_hasType + rw [← symbolicKeyProjector_lift_shape, + symbolicKeyProjector_beta_shape] at hprojectorBeta + have hprojectorToRule : dependentRecordEnv.IsDefEqU 2 + symbolicFieldContext + (.app (symbolicKeyCode.projector.liftN 3) symbolicConstructorApp) + (VExpr.instRev symbolicKeyRuleLhsBody symbolicKeyRuleArgs) := + ⟨projectorBodyType.inst symbolicConstructorApp, hprojectorBeta⟩ + + have houterBody : dependentRecordEnv.HasType 2 + ((.bvar 5) :: symbolicFieldContext) + (.lam (.app (.bvar 5) (.bvar 0)) (.bvar 1)) + (.forallE (.app (.bvar 5) (.bvar 0)) (.bvar 7)) := by + refine .lam (by type_tac) (by type_tac) + have hkey : dependentRecordEnv.HasType 2 symbolicFieldContext + (.bvar 1) (.bvar 5) := by + type_tac + have houterBeta := VEnv.IsDefEq.beta houterBody hkey + change dependentRecordEnv.IsDefEq 2 symbolicFieldContext + (.app symbolicKeyMinor (.bvar 1)) _ _ at houterBeta + have hvalue : dependentRecordEnv.HasType 2 symbolicFieldContext + (.bvar 0) (.app (.bvar 4) (.bvar 1)) := by + type_tac + have houterApplied := VEnv.IsDefEq.appDF houterBeta hvalue + have hinnerBody : dependentRecordEnv.HasType 2 + ((.app (.bvar 4) (.bvar 1)) :: symbolicFieldContext) + (.bvar 2) (.bvar 6) := by + type_tac + have hinnerBeta := VEnv.IsDefEq.beta hinnerBody hvalue + have hminorToKey := houterApplied.trans hinnerBeta + rw [← symbolicKeyRule_rhs_result_shape] at hminorToKey + have hresult := VEnv.IsDefEqU.trans dependentRecordEnv_wf + symbolicFieldContext_wf hprojectorToRule + (VEnv.IsDefEqU.trans dependentRecordEnv_wf symbolicFieldContext_wf + symbolicKeyRule_reduces ⟨_, hminorToKey⟩) + exact hresult.of_r dependentRecordEnv_wf symbolicFieldContext_wf hkey + +def symbolicValueTypeFnBody : VExpr := + .app (.bvar 5) + (.app (symbolicKeyCode.projector.liftN 4) (.bvar 0)) + +theorem symbolicValueTypeFn_lift_shape : + symbolicValueCode.typeFn.lift.liftN 2 = + .lam symbolicInnerStructureType symbolicValueTypeFnBody := by + decide + +theorem symbolicValueTypeFn_beta_shape : + symbolicValueTypeFnBody.inst symbolicConstructorApp = + .app (.bvar 4) + (.app (symbolicKeyCode.projector.liftN 3) + symbolicConstructorApp) := by + decide + +theorem symbolicValueTypeFnBody_hasType : dependentRecordEnv.HasType 2 + (symbolicInnerStructureType :: symbolicFieldContext) + symbolicValueTypeFnBody (.sort (.succ (.param 1))) := by + have W4 : Ctx.LiftN 4 0 symbolicContext + (symbolicInnerStructureType :: symbolicFieldContext) := + .zero [symbolicInnerStructureType, + .app (.bvar 3) (.bvar 0), .bvar 3, + dependentRecordView.structureType symbolicLevels symbolicMajorParams] + have hkeyProjector := symbolicKeyProjector_hasType.weakN + dependentRecordEnv_ordered W4 + have hkeyAtMajor := hkeyProjector.app (VEnv.HasType.bvar (.zero)) + change dependentRecordEnv.HasType 2 + (symbolicInnerStructureType :: symbolicFieldContext) _ + (.app + (.lam + (dependentRecordView.structureType symbolicLevels + [.bvar 6, .bvar 5]) + (.bvar 7)) + (.bvar 0)) at hkeyAtMajor + have hkeyBetaRaw : dependentRecordEnv.IsDefEq 2 + (symbolicInnerStructureType :: symbolicFieldContext) + (.app + (.lam + (dependentRecordView.structureType symbolicLevels + [.bvar 6, .bvar 5]) + (.bvar 7)) + (.bvar 0)) + ((VExpr.bvar 7).inst (.bvar 0)) + ((VExpr.sort (.succ (.param 0))).inst (.bvar 0)) := by + apply VEnv.IsDefEq.beta + · type_tac + · exact .bvar .zero + have hkeyBeta : dependentRecordEnv.IsDefEq 2 + (symbolicInnerStructureType :: symbolicFieldContext) + (.app + (.lam + (dependentRecordView.structureType symbolicLevels + [.bvar 6, .bvar 5]) + (.bvar 7)) + (.bvar 0)) + (.bvar 6) (.sort (.succ (.param 0))) := by + simpa [VExpr.inst, VExpr.instVar] using hkeyBetaRaw + have hkeyAtMajor' := hkeyBeta.defeq hkeyAtMajor + have hfamily : dependentRecordEnv.HasType 2 + (symbolicInnerStructureType :: symbolicFieldContext) + (.bvar 5) + (.forallE (.bvar 6) (.sort (.succ (.param 1)))) := by + type_tac + exact hfamily.app hkeyAtMajor' + +theorem symbolicValueProjector_hasType : + dependentRecordEnv.HasType 2 symbolicContext symbolicValueCode.projector + (.forallE + (dependentRecordView.structureType symbolicLevels symbolicMajorParams) + (.app symbolicValueCode.typeFn.lift (.bvar 0))) := by + obtain ⟨resultLevel, hspine⟩ := symbolicParams_spine + have hfamily := VEnv.HasType.const + (Γ := symbolicContext) dependentRecord_view_wf.family + symbolicLevels_wf (by rfl) + have hstructure : dependentRecordEnv.HasType 2 symbolicContext + (dependentRecordView.structureType symbolicLevels symbolicMajorParams) + (.sort resultLevel) := by + simpa [VStructureView.structureType] using hspine.hasType_appN hfamily + have W : Ctx.LiftN 1 0 symbolicContext + (dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) := .one + change dependentRecordEnv.HasType 2 symbolicContext (.lam _ _) + (.forallE _ _) + refine .lam hstructure ?_ + change dependentRecordEnv.HasType 2 + (dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (VExpr.appN + (.const dependentRecordView.recursorName + (dependentRecordView.projectionLevels + symbolicValueCode.fieldSort symbolicLevels)) + (symbolicMajorParams.map (VExpr.liftN 1) ++ + [symbolicValueCode.typeFn.lift, symbolicValueCode.minor.lift, + .bvar 0])) + (.app symbolicValueCode.typeFn.lift (.bvar 0)) + apply dependentRecord_view_wf.recursorProjection_hasType + dependentRecordEnv_ordered symbolicLevels symbolicLevels_wf rfl + (symbolicMajorParams.map (VExpr.liftN 1)) (by rfl) + (fieldSort := symbolicValueCode.fieldSort) + · refine ⟨resultLevel, ?_⟩ + have hfamilyClosed : + (dependentRecordView.familyType.instL symbolicLevels).ClosedN 0 := by + simpa using + (dependentRecordEnv_ordered.closedC + dependentRecord_view_wf.family).instL + have hspine' := hspine.weakN dependentRecordEnv_ordered W + rw [hfamilyClosed.liftN_eq (Nat.zero_le _)] at hspine' + simpa [VExpr.liftN] using hspine' + · change VLevel.WF 2 (.succ (.param 1)) + decide + · rfl + · exact ⟨resultLevel, by + simpa [VExpr.liftN] using hstructure.weakN dependentRecordEnv_ordered W⟩ + · change dependentRecordEnv.HasType 2 + (dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + symbolicValueCode.typeFn.lift + (.forallE + (dependentRecordView.structureType symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1))) + (.sort (.succ (.param 1)))) + change dependentRecordEnv.HasType 2 + (dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.lam + (dependentRecordView.structureType symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1))) + (.app (.bvar 3) + (.app (symbolicKeyCode.projector.lift.liftN 1 1) (.bvar 0)))) + (.forallE + (dependentRecordView.structureType symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1))) + (.sort (.succ (.param 1)))) + refine VEnv.HasType.lam (u := resultLevel) ?_ ?_ + · simpa [VExpr.liftN] using + hstructure.weakN dependentRecordEnv_ordered W + · have Wbody : Ctx.LiftN 1 0 + (dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (dependentRecordView.structureType symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1)) :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) := .one + have hkeyProjector := + (symbolicKeyProjector_hasType.weakN dependentRecordEnv_ordered W).weakN + dependentRecordEnv_ordered Wbody + have hkeyAtMajor := hkeyProjector.app (VEnv.HasType.bvar (.zero)) + have hkeyTypeFn : symbolicKeyCode.typeFn = + .lam + (dependentRecordView.structureType symbolicLevels symbolicMajorParams) + (.bvar 3) := rfl + rw [hkeyTypeFn] at hkeyAtMajor + change dependentRecordEnv.HasType 2 + (dependentRecordView.structureType symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1)) :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + _ + (.app + (.lam + (dependentRecordView.structureType symbolicLevels + [.bvar 4, .bvar 3]) + (.bvar 5)) + (.bvar 0)) at hkeyAtMajor + have hkeyBetaRaw : dependentRecordEnv.IsDefEq 2 + (dependentRecordView.structureType symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1)) :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.app + (.lam + (dependentRecordView.structureType symbolicLevels + [.bvar 4, .bvar 3]) + (.bvar 5)) + (.bvar 0)) + ((VExpr.bvar 5).inst (.bvar 0)) + ((VExpr.sort (.succ (.param 0))).inst (.bvar 0)) := by + apply VEnv.IsDefEq.beta + · type_tac + · exact .bvar .zero + have hkeyBeta : dependentRecordEnv.IsDefEq 2 + (dependentRecordView.structureType symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1)) :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.app + (.lam + (dependentRecordView.structureType symbolicLevels + [.bvar 4, .bvar 3]) + (.bvar 5)) + (.bvar 0)) + (.bvar 4) (.sort (.succ (.param 0))) := by + simpa [VExpr.inst, VExpr.instVar] using hkeyBetaRaw + have hkeyAtMajor' := hkeyBeta.defeq hkeyAtMajor + have hprojectorLift : + VExpr.liftN 1 (VExpr.liftN 1 symbolicKeyCode.projector) = + symbolicKeyCode.projector.lift.liftN 1 1 := rfl + rw [hprojectorLift] at hkeyAtMajor' + have hfamilyAtMajor : dependentRecordEnv.HasType 2 + (dependentRecordView.structureType symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1)) :: + dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.bvar 3) + (.forallE (.bvar 4) (.sort (.succ (.param 1)))) := by + type_tac + exact hfamilyAtMajor.app hkeyAtMajor' + · change dependentRecordEnv.HasType 2 + (dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.lam (.bvar 3) + (.lam (.app (.bvar 3) (.bvar 0)) (.bvar 0))) + (dependentRecordView.projectionMinorType symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1)) + (dependentRecordView.specializedFields symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1))) + symbolicValueCode.typeFn.lift) + have hfields : dependentRecordView.specializedFields symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1)) = + [.bvar 3, .app (.bvar 3) (.bvar 0)] := rfl + rw [hfields] + change dependentRecordEnv.HasType 2 + (dependentRecordView.structureType symbolicLevels symbolicMajorParams :: + symbolicContext) + (.lam (.bvar 3) + (.lam (.app (.bvar 3) (.bvar 0)) (.bvar 0))) + (.forallE (.bvar 3) + (.forallE (.app (.bvar 3) (.bvar 0)) + (.app (symbolicValueCode.typeFn.lift.liftN 2) + (dependentRecordView.projectionConstructorApp symbolicLevels + (symbolicMajorParams.map (VExpr.liftN 1)) + [.bvar 3, .app (.bvar 3) (.bvar 0)])))) + refine .lam (by type_tac) ?_ + refine .lam (by type_tac) ?_ + have htargetBeta := VEnv.IsDefEq.beta + symbolicValueTypeFnBody_hasType symbolicConstructor_hasType + rw [← symbolicValueTypeFn_lift_shape, + symbolicValueTypeFn_beta_shape] at htargetBeta + have hfamily : dependentRecordEnv.HasType 2 symbolicFieldContext + (.bvar 4) + (.forallE (.bvar 5) (.sort (.succ (.param 1)))) := by + type_tac + have htargetToNatural := htargetBeta.trans + (VEnv.IsDefEq.appDF hfamily symbolicKey_constructor_defeq) + have hvalue : dependentRecordEnv.HasType 2 symbolicFieldContext + (.bvar 0) (.app (.bvar 4) (.bvar 1)) := by + type_tac + exact htargetToNatural.defeq' hvalue + · exact .bvar .zero + +def symbolicKeyResult : VExpr := + .app symbolicKeyCode.projector symbolicMajor + +def symbolicValueResult : VExpr := + .app symbolicValueCode.projector symbolicMajor + +theorem key_representable : + dependentRecordEnv.TrProj 2 symbolicContext dependentRecordView + symbolicLevels symbolicMajorParams 0 symbolicMajor symbolicKeyResult := by + refine { + viewWF := dependentRecord_view_wf + levelsWF := symbolicLevels_wf + levels_length := rfl + params_length := rfl + paramsSpine := symbolicParams_spine + majorType := symbolicMajor_hasType + program := ⟨symbolicKeyCode, rfl, rfl, + symbolicKeyProjector_hasType⟩ } + +theorem value_representable : + dependentRecordEnv.TrProj 2 symbolicContext dependentRecordView + symbolicLevels symbolicMajorParams 1 symbolicMajor symbolicValueResult := by + refine { + viewWF := dependentRecord_view_wf + levelsWF := symbolicLevels_wf + levels_length := rfl + params_length := rfl + paramsSpine := symbolicParams_spine + majorType := symbolicMajor_hasType + program := ⟨symbolicValueCode, rfl, rfl, + symbolicValueProjector_hasType⟩ } + +/-- The one generated iota equation used by both projection programs is +actually registered in the final Theory environment. -/ +example : dependentRecordGeneration.generatedRules.length = 1 := rfl + +theorem dependentRecord_rules_registered : + ∀ rule ∈ dependentRecordGeneration.generatedRules, + dependentRecordEnv.defeqs rule := + dependentRecord_view_wf.rules + +/-! ## Frozen legacy surface + +The seven fields below preserve the exact pre-L4L-13 theorem shapes. They +are intentionally only statement data: constructing this bundle would +reintroduce the old proof obligations. In particular, `wf` permits +unrelated contexts, `uniq` permits unrelated structure names, and every +field omits the environment, universe instantiation, and parameter spine. -/ + +abbrev LegacyTrProj := + List VExpr → Name → Nat → VExpr → VExpr → Prop + +structure LegacyProjectionLaws (R : LegacyTrProj) : Prop where + weak : ∀ {n Γ Γ' s i e e'}, + Ctx.Lift' n Γ Γ' → R Γ s i e e' → + R Γ' s i (e.lift' n) (e'.lift' n) + inverseWeakening : ∀ {env U l Γ Γ' s i e e'}, + VEnv.WF env → OnCtx Γ' (env.IsType U) → Ctx.Lift' l Γ Γ' → + R Γ' s i (e.lift' l) e' → ∃ result, R Γ s i e result + contextDefEq : ∀ {env U Γ₁ Γ₂ s i e₁ e₂ result}, + VEnv.WF env → env.IsDefEqCtx U [] Γ₁ Γ₂ → + env.IsDefEqU U Γ₁ e₁ e₂ → R Γ₁ s i e₁ result → + ∃ result', R Γ₂ s i e₂ result' + wellFormed : ∀ {env U Δ Γ s i e result}, + R Δ s i e result → VExpr.WF env U Γ e → + VExpr.WF env U Γ result + unique : ∀ {env U Γ₁ Γ₂ s₁ s₂ i e₁ e₂ result₁ result₂}, + VEnv.WF env → env.IsDefEqCtx U [] Γ₁ Γ₂ → + R Γ₁ s₁ i e₁ result₁ → R Γ₂ s₂ i e₂ result₂ → + env.IsDefEqU U Γ₁ e₁ e₂ → + env.IsDefEqU U Γ₁ result₁ result₂ + termSubstitution : ∀ {Γ₀ Γ₁ Γ s i e e' e₀ A₀ k}, + Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ → R Γ₁ s i e e' → + R Γ s i (e.inst e₀ k) (e'.inst e₀ k) + universeInstantiation : ∀ {U' Γ s i e e'} {ls : List VLevel}, + (∀ level ∈ ls, level.WF U') → R Γ s i e e' → + R (Γ.map (VExpr.instL ls)) s i (e.instL ls) (e'.instL ls) + +/-! ## Zero-field behavior -/ + +universe w + +structure EmptyRecord (α : Type w) where + +def emptyRecordCtor : VConstVal := + ⟨vconst(type_of% @EmptyRecord.mk), ``EmptyRecord.mk⟩ + +def emptyRecordType : VInductiveType where + name := ``EmptyRecord + uvars := 1 + type := vconst(type_of% @EmptyRecord).type + ctors := [emptyRecordCtor] + +def emptyRecordDecl : VInductDecl := + ⟨1, 1, [emptyRecordType]⟩ + +example : emptyRecordDecl.checked?.isSome = true := rfl + +def emptyRecordChecked : emptyRecordDecl.Checked := + emptyRecordDecl.checked?.get (by decide) + +def emptyRecordGeneration : emptyRecordDecl.GenerationChecked := + emptyRecordChecked.identityGeneration + +def emptyRecordView : VStructureView where + source := emptyRecordDecl + generation := emptyRecordGeneration + constructor := emptyRecordGeneration.block.ctorPairs[0] + constructor_eq := rfl + raw_indices_eq := rfl + checked_indices_eq := rfl + recursive_eq := rfl + fieldSorts := [] + fieldSorts_length := rfl + +def emptyRecordEnv : VEnv := + (VEnv.empty.addInductGeneration emptyRecordGeneration).get (by decide) + +theorem emptyRecord_add : + VEnv.empty.addInductGeneration emptyRecordGeneration = + some emptyRecordEnv := rfl + +theorem emptyRecord_trace : + Nonempty (VEnv.AddInductGenerationTrace VEnv.empty + emptyRecordEnv emptyRecordGeneration) := + VEnv.addInductGeneration_trace emptyRecord_add + +theorem emptyRecordDecl_wf : emptyRecordDecl.WF VEnv.empty := by + refine ⟨rfl, ?_⟩ + intro ty hty + have hty' : ty = emptyRecordType := + List.mem_singleton.1 (by simpa [emptyRecordDecl] using hty) + subst ty + refine ⟨⟨⟨_, by type_tac⟩, trivial⟩, ?_⟩ + intro c hc + have hc' : c = emptyRecordCtor := by + simpa [emptyRecordType] using hc + subst c + constructor + · simp [emptyRecordDecl, emptyRecordType, emptyRecordCtor, + VInductDecl.fieldsWF, VInductDecl.ctorFields, + VExpr.dropN] + · simp [emptyRecordDecl, emptyRecordType, emptyRecordCtor, + VInductDecl.ctorFields, VInductDecl.recFieldIdxs, + VInductDecl.sortLevel, VExpr.dropN, VExpr.resultOf, + VExpr.forallN, VExpr.liftTelN, VExpr.appArgs] + rfl + +theorem emptyRecordGeneration_wf : + emptyRecordGeneration.WF VEnv.empty := + (emptyRecordChecked.wf_of_decl + emptyRecordDecl_wf).identityGeneration .empty + +theorem emptyRecord_generation_semantics : + emptyRecordView.GenerationSemantics emptyRecordEnv := by + rcases emptyRecord_trace with ⟨trace⟩ + exact .ofGenerationTrace emptyRecordGeneration_wf trace + +theorem emptyRecord_registered : emptyRecordView.Registered emptyRecordEnv := by + rcases emptyRecord_trace with ⟨trace⟩ + refine { + family := trace.family_lookup + constructor := ?_ + recursor := trace.rec_lookup + rules := fun _ h => trace.rule_mem h } + apply trace.ctor_lookup + rw [← emptyRecordGeneration.rawCtors_eq] + exact List.mem_map.2 ⟨emptyRecordView.constructor, + by + change emptyRecordView.constructor ∈ + emptyRecordView.generation.block.ctorPairs + rw [emptyRecordView.constructor_eq] + simp, + rfl⟩ + +theorem emptyRecord_view_wf : emptyRecordView.WF emptyRecordEnv := by + refine { + toRegistered := emptyRecord_registered + generationSemantics := emptyRecord_generation_semantics + parameters := ⟨⟨_, by type_tac⟩, trivial⟩ + parameters_length := rfl + fieldTelescope := .nil + smallFields := ?_ } + intro _ level hlevel + change level ∈ ([] : List VLevel) at hlevel + contradiction + +example : emptyRecordView.fields = [] := rfl + +example : emptyRecordView.projectionCodes [.param 0] [.bvar 0] = [] := rfl + +theorem emptyRecord_project_none (idx : Nat) (major : VExpr) : + emptyRecordView.project? [.param 0] [.bvar 0] idx major = none := by + simp [VStructureView.project?, show + emptyRecordView.projectionCodes [.param 0] [.bvar 0] = [] from rfl] + +/-- +info: 'Lean4Lean.Tests.ProjectionExpressibility.dependentRecord_view_wf' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms dependentRecord_view_wf + +/-- +info: 'Lean4Lean.Tests.ProjectionExpressibility.key_representable' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms key_representable + +/-- +info: 'Lean4Lean.Tests.ProjectionExpressibility.value_representable' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms value_representable + +/-- +info: 'Lean4Lean.Tests.ProjectionExpressibility.emptyRecord_project_none' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms emptyRecord_project_none + +end Lean4Lean.Tests.ProjectionExpressibility diff --git a/Lean4Lean/Theory.lean b/Lean4Lean/Theory.lean index 67c3c0f5..2a063b5c 100644 --- a/Lean4Lean/Theory.lean +++ b/Lean4Lean/Theory.lean @@ -1,5 +1,9 @@ import Lean4Lean.Theory.Typing.EnvLemmas +import Lean4Lean.Theory.Typing.InductiveCertificate import Lean4Lean.Theory.Typing.Strong import Lean4Lean.Theory.Typing.UniqueTyping import Lean4Lean.Theory.Typing.ChurchRosser import Lean4Lean.Theory.Typing.HeadReduction +import Lean4Lean.Theory.LocalContext +import Lean4Lean.Theory.Literals +import Lean4Lean.Theory.Projection diff --git a/Lean4Lean/Theory/Literals.lean b/Lean4Lean/Theory/Literals.lean new file mode 100644 index 00000000..ae8afeec --- /dev/null +++ b/Lean4Lean/Theory/Literals.lean @@ -0,0 +1,474 @@ +import Lean4Lean.Theory.Inductive +import Lean4Lean.Theory.Typing.Strong + +/-! # Theory encodings of Lean literals and primitive reflection + +This file contains only `VExpr`/`VEnv` semantics. Traversal of `Lean.Expr` +and `Literal.toConstructor` belongs to the Verify translation layer. +-/ + +namespace Lean4Lean +open Lean + +def VEnv.ContainsLits (env : VEnv) : Literal → Prop + | .natVal _ => env.contains ``Nat + | .strVal _ => env.contains ``Char.ofNat ∧ env.contains ``String.ofList + +def VExpr.bool : VExpr := .const ``Bool [] +def VExpr.boolTrue : VExpr := .const ``Bool.true [] +def VExpr.boolFalse : VExpr := .const ``Bool.false [] +def VExpr.boolLit : Bool → VExpr + | .false => .boolFalse + | .true => .boolTrue + +def VExpr.nat : VExpr := .const ``Nat [] +def VExpr.natZero : VExpr := .const ``Nat.zero [] +def VExpr.natSucc : VExpr := .const ``Nat.succ [] +def VExpr.natLit : Nat → VExpr + | 0 => .natZero + | n+1 => .app .natSucc (.natLit n) + +def VExpr.char : VExpr := .const ``Char [] +def VExpr.string : VExpr := .const ``String [] +def VExpr.stringOfList : VExpr := .const ``String.ofList [] +def VExpr.listChar : VExpr := .app (.const ``List [.zero]) .char +def VExpr.listCharNil : VExpr := .app (.const ``List.nil [.zero]) .char +def VExpr.listCharCons : VExpr := .app (.const ``List.cons [.zero]) .char +def VExpr.charOfNat : VExpr := .const ``Char.ofNat [] +def VExpr.listCharLit : List Char → VExpr + | [] => .listCharNil + | a :: as => + .app (.app .listCharCons (.app .charOfNat (.natLit a.toNat))) (.listCharLit as) + +def VExpr.trLiteral : Literal → VExpr + | .natVal n => .natLit n + | .strVal s => .app .stringOfList (.listCharLit s.toList) + +def VExpr.literalType : Literal → VExpr + | .natVal _ => .nat + | .strVal _ => .string + +/-! ## Exact prelude artifacts + +`ContainsLits` deliberately records only name occurrence. The declarations +below describe the exact Theory artifacts that make those names meaningful. +The inductive recursors and iota rules are generated by the same +consumer-neutral Theory machinery used by `VEnv.addInduct`. +-/ + +namespace LiteralPrelude + +def boolFalse : VConstVal := + { name := ``Bool.false, uvars := 0, type := .bool } + +def boolTrue : VConstVal := + { name := ``Bool.true, uvars := 0, type := .bool } + +def boolType : VInductiveType where + name := ``Bool + uvars := 0 + type := .sort (.succ .zero) + ctors := [boolFalse, boolTrue] + +def boolRec : VConstant := VInductDecl.recConst 0 ``Bool 0 boolType +def boolIotas : List VDefEq := VInductDecl.rules 0 ``Bool 0 boolType + +def natZero : VConstVal := + { name := ``Nat.zero, uvars := 0, type := .nat } + +def natSucc : VConstVal := + { name := ``Nat.succ, uvars := 0, type := .forallE .nat .nat } + +def natType : VInductiveType where + name := ``Nat + uvars := 0 + type := .sort (.succ .zero) + ctors := [natZero, natSucc] + +def natRec : VConstant := VInductDecl.recConst 0 ``Nat 0 natType +def natIotas : List VDefEq := VInductDecl.rules 0 ``Nat 0 natType + +def char : VConstant := { uvars := 0, type := .sort (.succ .zero) } +def charOfNat : VConstant := { uvars := 0, type := .forallE .nat .char } + +def listNil : VConstVal where + name := ``List.nil + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) + (.app (.const ``List [.param 0]) (.bvar 0)) + +def listCons : VConstVal where + name := ``List.cons + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) <| + .forallE (.bvar 0) <| + .forallE (.app (.const ``List [.param 0]) (.bvar 1)) + (.app (.const ``List [.param 0]) (.bvar 2)) + +def listType : VInductiveType where + name := ``List + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + ctors := [listNil, listCons] + +def listRec : VConstant := VInductDecl.recConst 1 ``List 1 listType +def listIotas : List VDefEq := VInductDecl.rules 1 ``List 1 listType + +def string : VConstant := { uvars := 0, type := .sort (.succ .zero) } +def stringOfList : VConstant := + { uvars := 0, type := .forallE .listChar .string } + +end LiteralPrelude + +/-- The exact kernel-facing prelude fragment needed to interpret Theory +literals. In contrast with `ContainsLits`, this records declaration types, +recursors, iota rules, and an ordered construction history. -/ +structure VEnv.PreludeReady (env : VEnv) : Prop where + ordered : env.Ordered + bool : env.constants ``Bool = some LiteralPrelude.boolType.toVConstant + boolFalse : env.constants ``Bool.false = + some LiteralPrelude.boolFalse.toVConstant + boolTrue : env.constants ``Bool.true = + some LiteralPrelude.boolTrue.toVConstant + boolRec : env.constants ``Bool.rec = some LiteralPrelude.boolRec + boolIotas : ∀ df ∈ LiteralPrelude.boolIotas, env.defeqs df + nat : env.constants ``Nat = some LiteralPrelude.natType.toVConstant + natZero : env.constants ``Nat.zero = + some LiteralPrelude.natZero.toVConstant + natSucc : env.constants ``Nat.succ = + some LiteralPrelude.natSucc.toVConstant + natRec : env.constants ``Nat.rec = some LiteralPrelude.natRec + natIotas : ∀ df ∈ LiteralPrelude.natIotas, env.defeqs df + char : env.constants ``Char = some LiteralPrelude.char + charOfNat : env.constants ``Char.ofNat = some LiteralPrelude.charOfNat + list : env.constants ``List = some LiteralPrelude.listType.toVConstant + listNil : env.constants ``List.nil = + some LiteralPrelude.listNil.toVConstant + listCons : env.constants ``List.cons = + some LiteralPrelude.listCons.toVConstant + listRec : env.constants ``List.rec = some LiteralPrelude.listRec + listIotas : ∀ df ∈ LiteralPrelude.listIotas, env.defeqs df + string : env.constants ``String = some LiteralPrelude.string + stringOfList : env.constants ``String.ofList = some LiteralPrelude.stringOfList + +namespace VEnv.PreludeReady + +/-- Exact prelude artifacts transport across environment inclusion. The +target ordering premise is necessary because arbitrary `VEnv.LE` growth may +append an ill-typed declaration. -/ +theorem mono {env env' : VEnv} (H : env.PreludeReady) (henv : env ≤ env') + (hordered : env'.Ordered) : env'.PreludeReady where + ordered := hordered + bool := henv.constants H.bool + boolFalse := henv.constants H.boolFalse + boolTrue := henv.constants H.boolTrue + boolRec := henv.constants H.boolRec + boolIotas := fun df hdf => henv.defeqs (H.boolIotas df hdf) + nat := henv.constants H.nat + natZero := henv.constants H.natZero + natSucc := henv.constants H.natSucc + natRec := henv.constants H.natRec + natIotas := fun df hdf => henv.defeqs (H.natIotas df hdf) + char := henv.constants H.char + charOfNat := henv.constants H.charOfNat + list := henv.constants H.list + listNil := henv.constants H.listNil + listCons := henv.constants H.listCons + listRec := henv.constants H.listRec + listIotas := fun df hdf => henv.defeqs (H.listIotas df hdf) + string := henv.constants H.string + stringOfList := henv.constants H.stringOfList + +/-- Any successful well-formed constant insertion preserves readiness. It is +necessarily unrelated to the ready prelude: all of those names are already +occupied, while `addConst` succeeds only at a fresh name. -/ +theorem addConst {env env' : VEnv} (H : env.PreludeReady) + (hci : ci.WF env) (hadd : env.addConst name ci = some env') : + env'.PreludeReady := + H.mono (VEnv.addConst_le hadd) (.const H.ordered hci hadd) + +/-- Adding a well-formed unrelated definitional equation preserves prelude +readiness. -/ +theorem addDefEq {env : VEnv} (H : env.PreludeReady) (hdf : df.WF env) : + (env.addDefEq df).PreludeReady := + H.mono VEnv.addDefEq_le (.defeq H.ordered hdf) + +/-- A ready prelude contains every name used by the direct literal encoding. -/ +theorem containsLits {env : VEnv} (H : env.PreludeReady) : + ∀ l, env.ContainsLits l + | .natVal _ => ⟨_, H.nat⟩ + | .strVal _ => ⟨⟨_, H.charOfNat⟩, ⟨_, H.stringOfList⟩⟩ + +end VEnv.PreludeReady + +def VEnv.ReflectsNatNatNat (env : VEnv) (fc : Name) (f : Nat → Nat → Nat) := + env.contains fc → + ∀ a b, env.IsDefEqU 0 [] + (.app (.app (.const fc []) (.natLit a)) (.natLit b)) (.natLit (f a b)) + +def VEnv.ReflectsNatNatBool (env : VEnv) (fc : Name) (f : Nat → Nat → Bool) := + env.contains fc → + ∀ a b, env.IsDefEqU 0 [] + (.app (.app (.const fc []) (.natLit a)) (.natLit b)) (.boolLit (f a b)) + +structure VEnv.HasPrimitives (env : VEnv) : Prop where + bool : env.contains ``Bool → env.contains ``Bool.false ∧ env.contains ``Bool.true + boolFalse : env.constants ``Bool.false = some ci → ci = { uvars := 0, type := .bool } + boolTrue : env.constants ``Bool.true = some ci → ci = { uvars := 0, type := .bool } + nat : env.contains ``Nat → env.contains ``Nat.zero ∧ env.contains ``Nat.succ + natZero : env.constants ``Nat.zero = some ci → ci = { uvars := 0, type := .nat } + natSucc : env.constants ``Nat.succ = some ci → + ci = { uvars := 0, type := .forallE .nat .nat } + natAdd : env.ReflectsNatNatNat ``Nat.add Nat.add + natSub : env.ReflectsNatNatNat ``Nat.sub Nat.sub + natMul : env.ReflectsNatNatNat ``Nat.mul Nat.mul + natPow : env.ReflectsNatNatNat ``Nat.pow Nat.pow + natGcd : env.ReflectsNatNatNat ``Nat.gcd Nat.gcd + natMod : env.ReflectsNatNatNat ``Nat.mod Nat.mod + natDiv : env.ReflectsNatNatNat ``Nat.div Nat.div + natBEq : env.ReflectsNatNatBool ``Nat.beq Nat.beq + natBLE : env.ReflectsNatNatBool ``Nat.ble Nat.ble + natLAnd : env.ReflectsNatNatNat ``Nat.land Nat.land + natLOr : env.ReflectsNatNatNat ``Nat.lor Nat.lor + natXor : env.ReflectsNatNatNat ``Nat.xor Nat.xor + natShiftLeft : env.ReflectsNatNatNat ``Nat.shiftLeft Nat.shiftLeft + natShiftRight : env.ReflectsNatNatNat ``Nat.shiftRight Nat.shiftRight + charOfNat : env.constants ``Char.ofNat = some ci → + ci = { uvars := 0, type := .forallE .nat .char } + stringOfList : env.constants ``String.ofList = some ci → + ci = { uvars := 0, type := .forallE .listChar .string } ∧ + env.HasType 0 [] .listCharNil .listChar ∧ + env.HasType 0 [] .listCharCons (.forallE .char <| .forallE .listChar .listChar) + +variable! {env env' : VEnv} (henv : env ≤ env') in +theorem VEnv.ContainsLits.mono : ∀ {l}, env.ContainsLits l → env'.ContainsLits l + | .natVal _, ⟨_, H⟩ => ⟨_, henv.constants H⟩ + | .strVal _, ⟨⟨_, H1⟩, ⟨_, H2⟩⟩ => + ⟨⟨_, henv.constants H1⟩, ⟨_, henv.constants H2⟩⟩ + +namespace VEnv.PreludeReady + +theorem boolFalse_lookup {env : VEnv} (H : env.PreludeReady) : + env.constants ``Bool.false = some { uvars := 0, type := VExpr.bool } := by + simpa [LiteralPrelude.boolFalse] using H.boolFalse + +theorem boolTrue_lookup {env : VEnv} (H : env.PreludeReady) : + env.constants ``Bool.true = some { uvars := 0, type := VExpr.bool } := by + simpa [LiteralPrelude.boolTrue] using H.boolTrue + +theorem natZero_lookup {env : VEnv} (H : env.PreludeReady) : + env.constants ``Nat.zero = some { uvars := 0, type := VExpr.nat } := by + simpa [LiteralPrelude.natZero] using H.natZero + +theorem natSucc_lookup {env : VEnv} (H : env.PreludeReady) : + env.constants ``Nat.succ = + some { uvars := 0, type := VExpr.forallE .nat .nat } := by + simpa [LiteralPrelude.natSucc] using H.natSucc + +theorem char_lookup {env : VEnv} (H : env.PreludeReady) : + env.constants ``Char = + some { uvars := 0, type := VExpr.sort (.succ .zero) } := by + simpa [LiteralPrelude.char] using H.char + +theorem charOfNat_lookup {env : VEnv} (H : env.PreludeReady) : + env.constants ``Char.ofNat = + some { uvars := 0, type := VExpr.forallE .nat .char } := by + simpa [LiteralPrelude.charOfNat] using H.charOfNat + +theorem stringOfList_lookup {env : VEnv} (H : env.PreludeReady) : + env.constants ``String.ofList = + some { uvars := 0, type := VExpr.forallE .listChar .string } := by + simpa [LiteralPrelude.stringOfList] using H.stringOfList + +theorem boolLit_hasType {env : VEnv} (H : env.PreludeReady) (b : Bool) : + env.HasType U Γ (.boolLit b) .bool := by + cases b + · exact .const H.boolFalse_lookup nofun rfl + · exact .const H.boolTrue_lookup nofun rfl + +theorem natLit_hasType {env : VEnv} (H : env.PreludeReady) (n : Nat) : + env.HasType U Γ (.natLit n) .nat := by + induction n with + | zero => exact .const H.natZero_lookup nofun rfl + | succ n ih => + simpa [VExpr.natLit, VExpr.natSucc, VExpr.nat, VExpr.instL, VExpr.inst] using + VEnv.HasType.app + (VEnv.HasType.const (ls := []) H.natSucc_lookup (by simp) rfl) ih + +theorem charOfNat_hasType {env : VEnv} (H : env.PreludeReady) : + env.HasType U Γ .charOfNat (.forallE .nat .char) := + .const H.charOfNat_lookup nofun rfl + +theorem listCharNil_hasType {env : VEnv} (H : env.PreludeReady) : + env.HasType U Γ .listCharNil .listChar := by + have hnil : env.constants ``List.nil = some { + uvars := 1 + type := VExpr.forallE (.sort (.succ (.param 0))) + (.app (.const ``List [.param 0]) (.bvar 0)) } := by + simpa [LiteralPrelude.listNil] using H.listNil + exact .app (.const hnil (by simp [VLevel.WF]) rfl) + (.const H.char_lookup nofun rfl) + +theorem listCharCons_hasType {env : VEnv} (H : env.PreludeReady) : + env.HasType U Γ .listCharCons + (.forallE .char <| .forallE .listChar .listChar) := by + have hcons : env.constants ``List.cons = some { + uvars := 1 + type := VExpr.forallE (.sort (.succ (.param 0))) <| + .forallE (.bvar 0) <| + .forallE (.app (.const ``List [.param 0]) (.bvar 1)) + (.app (.const ``List [.param 0]) (.bvar 2)) } := by + simpa [LiteralPrelude.listCons] using H.listCons + exact .app (.const hcons (by simp [VLevel.WF]) rfl) + (.const H.char_lookup nofun rfl) + +theorem listCharLit_hasType {env : VEnv} (H : env.PreludeReady) + (cs : List Char) : env.HasType U Γ (.listCharLit cs) .listChar := by + induction cs with + | nil => exact H.listCharNil_hasType + | cons c cs ih => + exact (H.listCharCons_hasType.app + (H.charOfNat_hasType.app (H.natLit_hasType c.toNat))).app ih + +theorem trLiteral_hasType {env : VEnv} (H : env.PreludeReady) (l : Literal) : + env.HasType U Γ (.trLiteral l) (.literalType l) := by + cases l with + | natVal n => simpa [VExpr.trLiteral, VExpr.literalType] using H.natLit_hasType n + | strVal s => + simpa [VExpr.trLiteral, VExpr.literalType, VExpr.stringOfList, VExpr.string, + VExpr.instL, VExpr.inst] using + VEnv.HasType.app + (VEnv.HasType.const (ls := []) H.stringOfList_lookup (by simp) rfl) + (H.listCharLit_hasType s.toList) + +/-- Exact readiness, not name occurrence alone, makes a direct literal +encoding well-formed. Pattern matching the containment witness ensures the +literal-facing premise is checked against the exact ready lookup. -/ +theorem trLiteral_wf {env : VEnv} (H : env.PreludeReady) (l : Literal) + (hcontains : env.ContainsLits l) : + VExpr.WF env U [] (.trLiteral l) := by + cases l with + | natVal n => + obtain ⟨ci, hci⟩ := hcontains + have : ci = LiteralPrelude.natType.toVConstant := by + exact (Option.some.inj (H.nat.symm.trans hci)).symm + subst ci + exact ⟨_, H.trLiteral_hasType (.natVal n)⟩ + | strVal s => + obtain ⟨⟨charOfNat, hcharOfNat⟩, ⟨stringOfList, hstringOfList⟩⟩ := hcontains + have : charOfNat = LiteralPrelude.charOfNat := by + exact (Option.some.inj (H.charOfNat.symm.trans hcharOfNat)).symm + subst charOfNat + have : stringOfList = LiteralPrelude.stringOfList := by + exact (Option.some.inj (H.stringOfList.symm.trans hstringOfList)).symm + subst stringOfList + exact ⟨_, H.trLiteral_hasType (.strVal s)⟩ + +end VEnv.PreludeReady + +@[simp] theorem VExpr.instL_boolFalse : VExpr.boolFalse.instL ls = VExpr.boolFalse := by + simp [boolFalse, instL] + +@[simp] theorem VExpr.instL_boolTrue : VExpr.boolTrue.instL ls = VExpr.boolTrue := by + simp [boolTrue, instL] + +@[simp] theorem VExpr.instL_boolLit : (VExpr.boolLit b).instL ls = VExpr.boolLit b := by + cases b <;> simp [boolLit] + +@[simp] theorem VExpr.liftN_boolLit : (VExpr.boolLit b).liftN n k = VExpr.boolLit b := by + cases b <;> rfl + +@[simp] theorem VExpr.lift'_boolLit : (VExpr.boolLit b).lift' ρ = VExpr.boolLit b := by + cases b <;> rfl + +@[simp] theorem VExpr.inst_boolLit : (VExpr.boolLit b).inst e k = VExpr.boolLit b := by + cases b <;> rfl + +@[simp] theorem VExpr.instL_natZero : VExpr.natZero.instL ls = .natZero := by + simp [natZero, instL] + +@[simp] theorem VExpr.instL_natSucc : VExpr.natSucc.instL ls = .natSucc := by + simp [natSucc, instL] + +@[simp] theorem VExpr.instL_natLit : (VExpr.natLit n).instL ls = VExpr.natLit n := by + induction n <;> simp [*, natLit, instL] + +@[simp] theorem VExpr.liftN_natLit : (VExpr.natLit a).liftN n k = VExpr.natLit a := by + induction a <;> simp [natLit, natZero, natSucc, VExpr.liftN, *] + +@[simp] theorem VExpr.lift'_natLit : (VExpr.natLit a).lift' ρ = VExpr.natLit a := by + induction a <;> simp [natLit, natZero, natSucc, VExpr.lift', *] + +@[simp] theorem VExpr.inst_natLit : (VExpr.natLit a).inst e k = VExpr.natLit a := by + induction a <;> simp [natLit, natZero, natSucc, VExpr.inst, *] + +@[simp] theorem VExpr.liftN_listCharLit : + (VExpr.listCharLit cs).liftN n k = VExpr.listCharLit cs := by + induction cs <;> + simp [listCharLit, listCharNil, listCharCons, char, charOfNat, VExpr.liftN, *] + +@[simp] theorem VExpr.lift'_listCharLit : + (VExpr.listCharLit cs).lift' ρ = VExpr.listCharLit cs := by + induction cs <;> + simp [listCharLit, listCharNil, listCharCons, char, charOfNat, VExpr.lift', *] + +@[simp] theorem VExpr.inst_listCharLit : + (VExpr.listCharLit cs).inst e k = VExpr.listCharLit cs := by + induction cs <;> + simp [listCharLit, listCharNil, listCharCons, char, charOfNat, VExpr.inst, *] + +@[simp] theorem VExpr.instL_listCharLit : + (VExpr.listCharLit cs).instL ls = VExpr.listCharLit cs := by + induction cs <;> + simp [listCharLit, listCharNil, listCharCons, char, charOfNat, + VExpr.instL, VLevel.inst, *] + +@[simp] theorem VExpr.liftN_trLiteral : + (VExpr.trLiteral l).liftN n k = VExpr.trLiteral l := by + cases l <;> simp [trLiteral, stringOfList, VExpr.liftN] + +@[simp] theorem VExpr.lift'_trLiteral : + (VExpr.trLiteral l).lift' ρ = VExpr.trLiteral l := by + cases l <;> simp [trLiteral, stringOfList, VExpr.lift'] + +@[simp] theorem VExpr.inst_trLiteral : + (VExpr.trLiteral l).inst e k = VExpr.trLiteral l := by + cases l <;> simp [trLiteral, stringOfList, VExpr.inst] + +@[simp] theorem VExpr.instL_trLiteral : + (VExpr.trLiteral l).instL ls = VExpr.trLiteral l := by + cases l <;> simp [trLiteral, stringOfList, VExpr.instL] + +theorem VEnv.HasPrimitives.nat_of_charOfNat (wf : Ordered env) + (henv : env.HasPrimitives) (H : env.contains ``Char.ofNat) : env.contains ``Nat := by + let ⟨_, H⟩ := H + have ⟨_, H⟩ := wf.constWF (henv.charOfNat H ▸ H) + let ⟨⟨_, H⟩, _⟩ := H.forallE_inv wf + let ⟨_, H, _⟩ := H.const_inv (Γ := []) wf (by trivial) + exact ⟨_, H⟩ + +/-- +info: 'Lean4Lean.VEnv.PreludeReady.mono' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.PreludeReady.mono + +/-- +info: 'Lean4Lean.VEnv.PreludeReady.addConst' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.PreludeReady.addConst + +/-- +info: 'Lean4Lean.VEnv.PreludeReady.addDefEq' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.PreludeReady.addDefEq + +/-- +info: 'Lean4Lean.VEnv.PreludeReady.trLiteral_wf' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.PreludeReady.trLiteral_wf + +end Lean4Lean diff --git a/Lean4Lean/Theory/LocalContext.lean b/Lean4Lean/Theory/LocalContext.lean new file mode 100644 index 00000000..a196f315 --- /dev/null +++ b/Lean4Lean/Theory/LocalContext.lean @@ -0,0 +1,149 @@ +import Lean4Lean.Theory.Typing.UniqueTyping + +/-! # Theory local declarations + +The implementation-independent core of a local context. `VLocalDecl` only +mentions Theory expressions; the `Lean.FVarId` bookkeeping used by the +verified Lean-expression translator remains in `Lean4Lean.Verify.VLCtx`. +-/ + +namespace Lean4Lean +open VEnv + +inductive VLocalDecl where + | vlam (type : VExpr) + | vlet (type value : VExpr) + +def VLocalDecl.depth : VLocalDecl → Nat + | .vlam .. => 1 + | .vlet .. => 0 + +def VLocalDecl.value : VLocalDecl → VExpr + | .vlam .. => .bvar 0 + | .vlet _ e => e + +def VLocalDecl.type' : VLocalDecl → VExpr + | .vlam A + | .vlet A _ => A + +def VLocalDecl.type : VLocalDecl → VExpr + | .vlam A => A.lift + | .vlet A _ => A + +def VLocalDecl.lift' : VLocalDecl → Lift → VLocalDecl + | .vlam A, n => .vlam (A.lift' n) + | .vlet A e, n => .vlet (A.lift' n) (e.lift' n) + +def VLocalDecl.liftN : VLocalDecl → Nat → Nat → VLocalDecl + | .vlam A, n, k => .vlam (A.liftN n k) + | .vlet A e, n, k => .vlet (A.liftN n k) (e.liftN n k) + +def VLocalDecl.inst : VLocalDecl → VExpr → (k : Nat := 0) → VLocalDecl + | .vlam A, e₀, k => .vlam (A.inst e₀ k) + | .vlet A e, e₀, k => .vlet (A.inst e₀ k) (e.inst e₀ k) + +def VLocalDecl.instL : VLocalDecl → List VLevel → VLocalDecl + | .vlam A, ls => .vlam (A.instL ls) + | .vlet A e, ls => .vlet (A.instL ls) (e.instL ls) + +def VLocalDecl.WF (env : VEnv) (U : Nat) (Γ : List VExpr) : VLocalDecl → Prop + | .vlam type => env.IsType U Γ type + | .vlet type value => env.HasType U Γ value type + +def VLocalDecl.ClosedN : VLocalDecl → (k : Nat := 0) → Prop + | .vlam A, k => A.ClosedN k + | .vlet A e, k => A.ClosedN k ∧ e.ClosedN k + +variable! (env : VEnv) (U : Nat) (Γ : List VExpr) in +inductive VLocalDecl.IsDefEq : VLocalDecl → VLocalDecl → Prop + | vlam : env.IsDefEq U Γ type₁ type₂ (.sort u) → + VLocalDecl.IsDefEq (.vlam type₁) (.vlam type₂) + | vlet : + env.IsDefEq U Γ value₁ value₂ type₁ → env.IsDefEq U Γ type₁ type₂ (.sort u) → + VLocalDecl.IsDefEq (.vlet type₁ value₁) (.vlet type₂ value₂) + +theorem VLocalDecl.lift'_consN_skipN {d : VLocalDecl} : + d.lift' (.consN (.skipN .refl n) k) = d.liftN n k := by + cases d <;> simp [VLocalDecl.lift', VLocalDecl.liftN, VExpr.lift'_consN_skipN] + +nonrec theorem VLocalDecl.WF.weakN (henv : env.Ordered) (W : Ctx.LiftN n k Γ Γ') : + ∀ {d}, WF env U Γ d → WF env U Γ' (d.liftN n k) + | .vlam _, H | .vlet .., H => H.weakN henv W + +nonrec theorem VLocalDecl.WF.instN (henv : env.Ordered) (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) + (h₀ : env.HasType U Γ₀ e₀ A₀) : ∀ {d}, WF env U Γ₁ d → WF env U Γ (d.inst e₀ k) + | .vlam _, H | .vlet .., H => H.instN henv W h₀ + +nonrec theorem VLocalDecl.WF.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U') : + ∀ {d}, WF env ls.length Γ d → WF env U' (Γ.map (·.instL ls)) (d.instL ls) + | .vlam _, H | .vlet .., H => H.instL hls + +@[simp] theorem VLocalDecl.lift'_depth {d : VLocalDecl} : (d.lift' n).depth = d.depth := by + cases d <;> rfl + +theorem VLocalDecl.lift'_comp {d : VLocalDecl} : + d.lift' (.comp l₁ l₂) = (d.lift' l₁).lift' l₂ := by + cases d <;> simp [VLocalDecl.lift', VExpr.lift'_comp] + +variable! (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U)) + (W : Ctx.Lift' n Γ Γ') in +theorem VLocalDecl.weak'_iff : + VLocalDecl.WF env U Γ' (d.lift' n) ↔ VLocalDecl.WF env U Γ d := + match d with + | .vlam .. => IsType.weak'_iff henv hΓ' W + | .vlet .. => HasType.weak'_iff henv hΓ' W + +variable! (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U)) + (W : Ctx.LiftN n k Γ Γ') in +theorem VLocalDecl.weakN_iff : + VLocalDecl.WF env U Γ' (d.liftN n k) ↔ VLocalDecl.WF env U Γ d := + match d with + | .vlam .. => IsType.weakN_iff henv hΓ' W + | .vlet .. => HasType.weakN_iff henv hΓ' W + +variable! (henv : Ordered env) (hΓ : OnCtx Γ (IsType env U)) in +theorem VLocalDecl.IsDefEq.refl : + ∀ {d}, VLocalDecl.WF env U Γ d → VLocalDecl.IsDefEq env U Γ d d + | .vlam _, ⟨_, h1⟩ => .vlam h1 + | .vlet .., h1 => let ⟨_, h2⟩ := h1.isType henv hΓ; .vlet h1 h2 + +theorem VLocalDecl.IsDefEq.wf : + VLocalDecl.IsDefEq env U Γ d₁ d₂ → VLocalDecl.WF env U Γ d₁ + | .vlam h3 => ⟨_, h3.hasType.1⟩ + | .vlet h3 _ => h3.hasType.1 + +theorem VLocalDecl.IsDefEq.mono (henv : env ≤ env') : + VLocalDecl.IsDefEq env U Γ d₁ d₂ → VLocalDecl.IsDefEq env' U Γ d₁ d₂ + | .vlam h => .vlam (h.mono henv) + | .vlet h₁ h₂ => .vlet (h₁.mono henv) (h₂.mono henv) + +theorem VLocalDecl.IsDefEq.symm : + VLocalDecl.IsDefEq env U Γ d₁ d₂ → VLocalDecl.IsDefEq env U Γ d₂ d₁ + | .vlam h1 => .vlam h1.symm + | .vlet h1 h2 => .vlet (h2.defeqDF h1.symm) h2.symm + +theorem VLocalDecl.IsDefEq.defeqDFC (henv : Ordered env) + (hΓ : IsDefEqCtx env U Γ₀ Γ₁ Γ₂) : + VLocalDecl.IsDefEq env U Γ₁ d₁ d₂ → VLocalDecl.IsDefEq env U Γ₂ d₁ d₂ + | .vlam h1 => .vlam (h1.defeqDFC henv hΓ) + | .vlet h1 h2 => .vlet (h1.defeqDFC henv hΓ) (h2.defeqDFC henv hΓ) + +/-- +info: 'Lean4Lean.VLocalDecl.WF.weakN' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VLocalDecl.WF.weakN + +/-- +info: 'Lean4Lean.VLocalDecl.weakN_iff' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms VLocalDecl.weakN_iff + +/-- +info: 'Lean4Lean.VLocalDecl.IsDefEq.defeqDFC' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VLocalDecl.IsDefEq.defeqDFC + +end Lean4Lean diff --git a/Lean4Lean/Theory/NestedInductive.lean b/Lean4Lean/Theory/NestedInductive.lean new file mode 100644 index 00000000..b8d6a386 --- /dev/null +++ b/Lean4Lean/Theory/NestedInductive.lean @@ -0,0 +1,526 @@ +import Lean4Lean.Theory.Inductive + +/-! +# Nested-inductive flattening (L4L-09B) + +The Theory mirror of the kernel's `ElimNestedInductive` transformation, +following the committed L4L-09A design +(`Lean4Lean/Verify/Environment/NestedRepresentation.lean`): the stored +payload of a nested declaration is the source `VInductDecl`, and nested +support flows through an additive artifact coupling + +1. the flattened mutual block, an ordinary `VInductDecl` handled by the + existing arbitrary-block analyzer, and +2. one auxiliary specification per auxiliary family — the Theory analog of + the kernel's `aux2nested` map. + +`nestedElimination?` computes both from the source declaration plus the +caller-supplied metadata of the previously declared inductives that are +nested into (`NestedTargetBlock`). Keeping the target metadata an explicit +input keeps this analyzer environment-free, exactly like `checked?`; +`NestedTargetBlock.WF` separately ties the supplied copy to a Theory +environment. + +The transformation mirrors the kernel phase for phase: + +- An application `I Ds is` is a nested occurrence when `I` is a family of a + supplied target block, the spine covers at least `I`'s parameters, and + the parametric arguments `Ds` mention a family of the growing flattened + block. Parametric arguments that also mention a constructor-local binder + reject the declaration (the kernel's "parameters cannot contain local + variables"), and matched occurrences are rewritten without descending + into the emitted replacement, exactly like `Expr.replace`. +- One auxiliary family is created per family of `I`'s block, in `all` + order, with `I`'s family and constructor types level-instantiated at the + occurrence's levels and parameter-instantiated at `Ds`; auxiliary + constructor bodies are queued and flattened by the same loop until the + block is stable. +- Auxiliary names are canonical: `(`_nested` ++ familyName).appendIndexAfter i` + with a global counter, matching the kernel's choice whenever the ambient + environment contains no colliding `_nested.*` constant. The L4L-09A + collision probe shows the choice is erased from all final artifacts, and + in-block collisions are rejected downstream by `blockNamesOK` exactly + where the kernel's `checkName` rejects its own collisions. + +Acceptance (`nestedStage3`) is flattening success plus generation +readiness of the flattened block through the unchanged L4L-08 machinery. +No generated recursor, rule, or environment replay is claimed at this +checkpoint; the restoration substitution over generation artifacts is +L4L-09C's obligation. +-/ + +namespace Lean4Lean + +deriving instance DecidableEq for VConstant +deriving instance DecidableEq for VDefEq +deriving instance DecidableEq for VConstVal +deriving instance DecidableEq for VInductiveType +deriving instance DecidableEq for VInductDecl + +/-- Does `e` mention, through a loose bvar, one of the `k` binders directly +below its root? `d` counts binders passed inside `e` itself. -/ +def VExpr.hasLooseBelow (k : Nat) : VExpr → (d : Nat := 0) → Bool + | .bvar i, d => d ≤ i && i - d < k + | .sort _, _ | .const .., _ => false + | .app e1 e2, d => e1.hasLooseBelow k d || e2.hasLooseBelow k d + | .lam e1 e2, d | .forallE e1 e2, d => + e1.hasLooseBelow k d || e2.hasLooseBelow k (d+1) + +/-- Lower every loose bvar of `e` by `n`. Total; meaningful only when no +loose bvar lies below `n`, which callers establish with `hasLooseBelow`. -/ +def VExpr.lowerN (n : Nat) : VExpr → (d : Nat := 0) → VExpr + | .bvar i, d => if i < d then .bvar i else .bvar (i - n) + | .sort l, _ => .sort l + | .const c ls, _ => .const c ls + | .app e1 e2, d => .app (e1.lowerN n d) (e2.lowerN n d) + | .lam e1 e2, d => .lam (e1.lowerN n d) (e2.lowerN n (d+1)) + | .forallE e1 e2, d => .forallE (e1.lowerN n d) (e2.lowerN n (d+1)) + +namespace VInductDecl + +/-- Simultaneous outermost-first parameter substitution: the first list +element replaces the outermost of the `args.length` innermost loose bvars. +The same shape as `instantiateRev` on the implementation side. -/ +def instRevParams : VExpr → List VExpr → VExpr + | C, [] => C + | C, e :: es => instRevParams (C.inst e es.length) es + +/-- Substitute the leading `np`-binder telescope of `ty` simultaneously at +`args` (outermost parameter first), mirroring the kernel's +`instantiateForallParams`. Fails when `ty` exposes fewer than `np` +binders. -/ +def instTelescope (np : Nat) (ty : VExpr) (args : List VExpr) : + Option VExpr := do + guard (args.length == np) + guard ((VExpr.telN np ty).length == np) + return instRevParams (VExpr.dropN np ty) args + +/-- One previously declared mutual block that nested occurrences may point +into. `families` is the complete block in `all` order, in that block's own +universe parameters; a copy is supplied so the analyzer stays +environment-free, and `NestedTargetBlock.WF` ties the copy to an +environment. -/ +structure NestedTargetBlock where + nparams : Nat + families : List VInductiveType + +/-- The supplied target copy agrees with the environment's stored +constants. -/ +structure NestedTargetBlock.WF (env : VEnv) (block : NestedTargetBlock) : + Prop where + families : ∀ f ∈ block.families, + env.constants f.name = some f.toVConstVal.toVConstant + ctors : ∀ f ∈ block.families, ∀ c ∈ f.ctors, + env.constants c.name = some c.toVConstant + +def NestedTargetsWF (env : VEnv) (targets : List NestedTargetBlock) : Prop := + ∀ t ∈ targets, t.WF env + +/-- One auxiliary family created by nested elimination: the Theory analog +of one `aux2nested` binding. `values` are the parametric arguments `Ds`, +open over the block parameters (innermost bvar = last parameter), in +declaration level-world. -/ +structure NestedAuxSpec where + aux : Name + target : Name + levels : List VLevel + values : List VExpr + deriving DecidableEq + +/-- The nested occurrence this auxiliary family abbreviates: `I Ds`. -/ +def NestedAuxSpec.value (spec : NestedAuxSpec) : VExpr := + (VExpr.const spec.target spec.levels).appN spec.values + +/-- The flattening result: the flattened mutual block plus one auxiliary +specification per auxiliary family, in flattened family order. When the +source contains no nested occurrence, `flat` is the source itself and +`specs` is empty. -/ +structure NestedElimination (source : VInductDecl) where + flat : VInductDecl + specs : List NestedAuxSpec + +namespace ElimNested + +/-- Growing flattening state. `types` extends the source families with the +auxiliary families; `specs` aligns with `types.drop ntypes`. -/ +structure State where + types : Array VInductiveType + specs : Array NestedAuxSpec + nextIdx : Nat := 1 + +variable (targets : List NestedTargetBlock) (uvars np : Nat) + +/-- The target block owning family `c`, ignoring names that are currently +part of the flattened block itself (the kernel only recognizes previously +*declared* inductives). -/ +def findTarget? (st : State) (c : Name) : Option NestedTargetBlock := + if st.types.any (·.name == c) then none + else targets.find? fun t => t.families.any (·.name == c) + +/-- Register the auxiliary families for one first-seen nested occurrence +`I Ds` and return the auxiliary family name standing for `I` itself. +`doms` is the discovering constructor's parameter telescope, and `values` +are the parametric arguments in parameter-world. -/ +def registerAux (st : State) (block : NestedTargetBlock) (I : Name) + (ls : List VLevel) (doms values : List VExpr) : + Option (Name × State) := do + let mut st := st + let mut result := none + for J in block.families do + if J.uvars != ls.length then failure + let auxName := (`_nested ++ J.name).appendIndexAfter st.nextIdx + let auxType ← instTelescope block.nparams (J.type.instL ls) values + let mut auxCtors : List VConstVal := [] + for c in J.ctors do + let ctype ← instTelescope block.nparams (c.type.instL ls) values + auxCtors := auxCtors ++ + [⟨⟨uvars, VExpr.forallN doms ctype⟩, c.name.replacePrefix J.name auxName⟩] + let auxFamily : VInductiveType := + { name := auxName, uvars, type := VExpr.forallN doms auxType + ctors := auxCtors } + st := + { types := st.types.push auxFamily + specs := st.specs.push ⟨auxName, J.name, ls, values⟩ + nextIdx := st.nextIdx + 1 } + if J.name == I then result := some auxName + match result with + | some auxName => return (auxName, st) + | none => none + +/-- Rewrite one constructor-body subterm at binder depth `k`, mirroring +`replaceAllNested`: matched occurrences are replaced without descending +into the replacement; unmatched nodes recurse into their children. -/ +def replace (doms : List VExpr) : + VExpr → (k : Nat) → State → Option (VExpr × State) + | e@(.app f a), k, st => do + match rewrite? e k st with + | some result => result + | none => + let (f', st) ← replace doms f k st + let (a', st) ← replace doms a k st + return (.app f' a', st) + | e@(.const ..), k, st => (rewrite? e k st).getD (some (e, st)) + | .lam ty body, k, st => do + let (ty', st) ← replace doms ty k st + let (body', st) ← replace doms body (k+1) st + return (.lam ty' body', st) + | .forallE ty body, k, st => do + let (ty', st) ← replace doms ty k st + let (body', st) ← replace doms body (k+1) st + return (.forallE ty' body', st) + | e, _, st => some (e, st) + where + /-- `some (some ..)` rewrites the node, `some none` is a hard rejection, + `none` leaves the node to the structural recursion. -/ + rewrite? (e : VExpr) (k : Nat) (st : State) : + Option (Option (VExpr × State)) := do + let .const c ls := VExpr.appHead e | none + let args := e.appArgs [] + let block ← findTarget? targets st c + guard (block.nparams ≤ args.length) + guard (0 < block.nparams) + let ds := args.take block.nparams + let names := st.types.toList.map (·.name) + guard (ds.any (·.hasAnyConst names)) + -- the kernel's "nested inductive datatypes parameters cannot contain + -- local variables" rejection + if ds.any (·.hasLooseBelow k) then return none + let values := ds.map (·.lowerN k) + let key := (VExpr.const c ls).appN values + let rest := args.drop block.nparams + let recover (auxName : Name) (st : State) : VExpr × State := + ((VExpr.const auxName (VLevel.params uvars)).appN + (VExpr.bvarRevRange k np ++ rest), st) + match st.specs.find? (·.value == key) with + | some spec => return some (recover spec.aux st) + | none => + match registerAux uvars st block c ls doms values with + | some (auxName, st) => return some (recover auxName st) + | none => return none + +/-- Flatten every constructor of every block family, including the queued +auxiliary families, until the block is stable. `fuel` mirrors the +kernel's `inductiveFuel` bound on the same loop. -/ +def run (fuel : Nat) (i : Nat) (st : State) : Option State := + match fuel with + | 0 => none + | fuel+1 => + if h : i < st.types.size then + let ty := st.types[i] + let step := ty.ctors.foldlM (init := ([], st)) fun (acc, st) c => do + let doms := VExpr.telN np c.type + guard (doms.length == np) + let (body, st) ← replace targets uvars np doms (VExpr.dropN np c.type) 0 st + return (acc ++ [{ c with type := VExpr.forallN doms body }], st) + match step with + | some (ctors, st) => + run fuel (i+1) { st with types := st.types.set! i { ty with ctors } } + | none => none + else some st + +end ElimNested + +/-- Flatten one source declaration against the supplied target blocks. +Returns the flattened block plus the auxiliary specifications; the +identity result (`flat = source`, no specs) is returned when nothing is +nested. -/ +def nestedElimination? (targets : List NestedTargetBlock) + (source : VInductDecl) (fuel : Nat := 1000) : + Option (NestedElimination source) := do + let st ← ElimNested.run targets source.uvars source.nparams fuel 0 + { types := source.types.toArray, specs := #[] } + return { flat := { source with types := st.types.toList } + specs := st.specs.toList } + +/-- The number of auxiliary families, matching the stored +`InductiveVal.numNested` of an accepted nested declaration. -/ +def NestedElimination.numNested {source : VInductDecl} + (elim : NestedElimination source) : Nat := + elim.specs.length + +/-- A flattened declaration accepted by the unchanged arbitrary-block +machinery: the complete L4L-09B validation gate. Positivity, name, level, +anatomy, and generation-shape checking of the flattened block reuse the +L4L-08 analyzers verbatim. -/ +structure NestedBlockChecked (source : VInductDecl) where + elim : NestedElimination source + generation : BlockGenerationChecked elim.flat + +def nestedBlockChecked? (targets : List NestedTargetBlock) + (source : VInductDecl) (fuel : Nat := 1000) : + Option (NestedBlockChecked source) := do + let elim ← nestedElimination? targets source fuel + let generation ← elim.flat.identityBlockGeneration? + return ⟨elim, generation⟩ + +/-- Structural acceptance for a nested declaration. -/ +def nestedStage3 (targets : List NestedTargetBlock) + (source : VInductDecl) (fuel : Nat := 1000) : Bool := + (nestedBlockChecked? targets source fuel).isSome + +/-! ## Restoration (L4L-09C) + +The restoration substitution σ maps the flattened block's generation +artifacts back to the stored metadata surface: auxiliary family constants +become their nested values, auxiliary constructor constants become the +target block's constructors applied to the instantiated value's own +arguments, and auxiliary recursor constants are renamed onto the main +family's `appendIndexAfter` inventory. On an application spine headed by +an auxiliary family or constructor, the first `nparams` spine arguments +are consumed by the value instantiation, mirroring +`ElimNestedInductive.Result.restoreNested`; generated artifacts always +apply auxiliary constants to at least the block parameters (the kernel +asserts exactly this), so the identity fallback on an under-applied +auxiliary head is unreachable from real artifacts and merely keeps σ +total. -/ + +/-- One σ replacement entry. `value` is already in the level world of the +artifact being restored (`instL`-spliced by the caller for recursor-world +artifacts). -/ +structure RestoreEntry where + aux : Name + np : Nat + value : VExpr + deriving DecidableEq + +def findRestoreCtor (entries : List RestoreEntry) (c : Name) : + Option (RestoreEntry × Name) := + entries.findSome? fun entry => + if entry.aux.isPrefixOf c && c != entry.aux then + some (entry, c.replacePrefix entry.aux .anonymous) + else none + +/-- σ on one expression, bottom-up: a replacement fires at the innermost +spine node where an auxiliary head has collected exactly its block-parameter +count, and enclosing applications extend the already-restored value. On +generated artifacts — where auxiliary constants are always applied to at +least the block parameters and never occur inside another auxiliary spine's +arguments — this coincides with `restoreNested`'s top-down +replace-without-descending pass. `recMap` renames auxiliary recursor +constants and is consulted before the constructor-prefix case, exactly like +`restoreNested`'s `auxRec` map. -/ +def restoreExpr (entries : List RestoreEntry) (recMap : List (Name × Name)) : + VExpr → VExpr + | .bvar i => .bvar i + | .sort l => .sort l + | .lam ty body => .lam (restoreExpr entries recMap ty) (restoreExpr entries recMap body) + | .forallE ty body => + .forallE (restoreExpr entries recMap ty) (restoreExpr entries recMap body) + | .app f a => + let e := VExpr.app (restoreExpr entries recMap f) (restoreExpr entries recMap a) + (restoreSpine e).getD e + | e@(.const ..) => (restoreSpine e).getD e + where + /-- Fire one replacement at a completed spine. The head constant is + still unrestored exactly when no inner node completed its parameter + count. -/ + restoreSpine (e : VExpr) : Option VExpr := + match VExpr.appHead e with + | .const c ls => + let args := e.appArgs [] + match recMap.find? (·.1 == c) with + | some (_, newName) => + if args.isEmpty then some (VExpr.const newName ls) else none + | none => + match entries.find? (·.aux == c) with + | some entry => + if args.length == entry.np then + some (instRevParams entry.value args) + else none + | none => + match findRestoreCtor entries c with + | some (entry, suffix) => + if args.length == entry.np then + let value := instRevParams entry.value args + match VExpr.appHead value with + | .const iname ils => + some ((VExpr.const (iname ++ suffix) ils).appN (value.appArgs [])) + | _ => none + else none + | none => none + | _ => none + +namespace NestedBlockChecked + +variable {source : VInductDecl} + +/-- The main family name owning the restored recursor inventory. -/ +def mainName (nested : NestedBlockChecked source) : Name := + match source.types with + | ty :: _ => ty.name + | [] => .anonymous + +/-- Auxiliary recursor renaming: the `i`-th auxiliary family's recursor +becomes `mainName.rec_(i+1)`, matching `mkAuxRecNameMap`. -/ +def recMap (nested : NestedBlockChecked source) : List (Name × Name) := + nested.elim.specs.mapIdx fun i spec => + (.str spec.aux "rec", ((.str nested.mainName "rec" : Name)).appendIndexAfter (i + 1)) + +/-- σ entries in declaration level-world (constructor-type restorations). -/ +def declEntries (nested : NestedBlockChecked source) : List RestoreEntry := + nested.elim.specs.map fun spec => + ⟨spec.aux, source.nparams, spec.value⟩ + +/-- σ entries spliced into recursor level-world by the elimination +offset. -/ +def recEntries (nested : NestedBlockChecked source) : List RestoreEntry := + nested.elim.specs.map fun spec => + ⟨spec.aux, source.nparams, + spec.value.instL (VLevel.params' source.uvars + (nested.generation.recUvars - source.uvars))⟩ + +/-- σ on a recursor-world artifact. -/ +def restoreRec (nested : NestedBlockChecked source) (e : VExpr) : VExpr := + restoreExpr nested.recEntries nested.recMap e + +/-- The restored recursor inventory: the flattened block's recursors with +auxiliary names renamed and every type restored. Source-family recursors +keep their `.str name "rec"` names. -/ +def recursors (nested : NestedBlockChecked source) : List VConstVal := + nested.generation.recursors.map fun r => + ⟨⟨r.uvars, nested.restoreRec r.type⟩, + ((nested.recMap.find? (·.1 == r.name)).map (·.2)).getD r.name⟩ + +/-- The restored rule inventory, in the flattened block's globally ordered +rule order. -/ +def generatedRules (nested : NestedBlockChecked source) : List VDefEq := + nested.generation.generatedRules.map fun df => + { df with + lhs := nested.restoreRec df.lhs + rhs := nested.restoreRec df.rhs + type := nested.restoreRec df.type } + +end NestedBlockChecked + +end VInductDecl + +/-- The nested transaction: the four-phase shape of +`addInductBlockGeneration` with the *source* families and constructors as +the stored payload and the *restored* recursors and rules as the generated +artifacts. No auxiliary constant enters the environment. -/ +def VEnv.addInductNested {source : VInductDecl} (env : VEnv) + (nested : source.NestedBlockChecked) : Option VEnv := do + let env ← source.blockTypeConstants.foldlM + (fun env type => env.addConst type.name type.toVConstant) env + let env ← source.blockConstructorConstants.foldlM + (fun env constructor => env.addConst constructor.name constructor.toVConstant) env + let env ← nested.recursors.foldlM + (fun env recursor => env.addConst recursor.name recursor.toVConstant) env + return nested.generatedRules.foldl VEnv.addDefEq env + +namespace VInductDecl + +/-- Chained constant well-formedness along an `addConst` fold: each +constant is well formed in the environment already holding every earlier +one. -/ +def NestedConstsWF (env : VEnv) : List VConstVal → Prop + | [] => True + | c :: cs => c.toVConstant.WF env ∧ + ∀ env', env.addConst c.name c.toVConstant = some env' → + NestedConstsWF env' cs + +/-- Chained rule well-formedness along an `addDefEq` fold. -/ +def NestedRulesWF (env : VEnv) : List VDefEq → Prop + | [] => True + | df :: dfs => df.WF env ∧ NestedRulesWF (env.addDefEq df) dfs + +/-- Semantic input to nested preservation: the four transaction phases are +well formed at their exact insertion environments. The phase environments +are determined by the deterministic constant folds, so each later field +takes the earlier folds as hypotheses; a fixture discharges them by +computation. Inhabiting this package from the flattened block's staged +semantic certificate is the σ-transport route recorded by the L4L-09A +design note; fixtures may equally inhabit it from direct checker +executions on the restored artifacts. -/ +structure NestedBlockChecked.WF {source : VInductDecl} + (nested : NestedBlockChecked source) (env : VEnv) : Prop where + types : NestedConstsWF env source.blockTypeConstants + ctors : ∀ {typeEnv}, + source.blockTypeConstants.foldlM + (fun env type => env.addConst type.name type.toVConstant) env = + some typeEnv → + NestedConstsWF typeEnv source.blockConstructorConstants + recs : ∀ {typeEnv ctorEnv}, + source.blockTypeConstants.foldlM + (fun env type => env.addConst type.name type.toVConstant) env = + some typeEnv → + source.blockConstructorConstants.foldlM + (fun env constructor => env.addConst constructor.name constructor.toVConstant) + typeEnv = some ctorEnv → + NestedConstsWF ctorEnv nested.recursors + rules : ∀ {typeEnv ctorEnv recEnv}, + source.blockTypeConstants.foldlM + (fun env type => env.addConst type.name type.toVConstant) env = + some typeEnv → + source.blockConstructorConstants.foldlM + (fun env constructor => env.addConst constructor.name constructor.toVConstant) + typeEnv = some ctorEnv → + nested.recursors.foldlM + (fun env recursor => env.addConst recursor.name recursor.toVConstant) + ctorEnv = some recEnv → + NestedRulesWF recEnv nested.generatedRules + +end VInductDecl + +/-- Exact phase boundaries of a successful nested transaction. -/ +structure VEnv.AddInductNestedTrace {source : VInductDecl} + (env env' : VEnv) (nested : source.NestedBlockChecked) where + typeEnv : VEnv + ctorEnv : VEnv + recEnv : VEnv + addTypes : + source.blockTypeConstants.foldlM + (fun env type => env.addConst type.name type.toVConstant) env = + some typeEnv + addCtors : + source.blockConstructorConstants.foldlM + (fun env constructor => env.addConst constructor.name constructor.toVConstant) + typeEnv = some ctorEnv + addRecs : + nested.recursors.foldlM + (fun env recursor => env.addConst recursor.name recursor.toVConstant) + ctorEnv = some recEnv + addRules : + nested.generatedRules.foldl VEnv.addDefEq recEnv = env' + +end Lean4Lean diff --git a/Lean4Lean/Theory/NestedInductiveFixtures.lean b/Lean4Lean/Theory/NestedInductiveFixtures.lean new file mode 100644 index 00000000..4bcbd0e6 --- /dev/null +++ b/Lean4Lean/Theory/NestedInductiveFixtures.lean @@ -0,0 +1,323 @@ +import Lean4Lean.Theory.NestedInductive + +/-! +# Nested flattening fixtures (L4L-09B) + +Executable pins for `nestedElimination?` on the two ladder fixtures — a +universe-polymorphic rose tree through `List` and a nested indexed family +through a `PVec`-style vector — plus the nearest structural rejections. +Every family, constructor, auxiliary specification, and acceptance bit is +compared against a hand-written expected descriptor. The kernel +differential for the same shapes lives in +`Lean4Lean/Verify/Environment/NestedTransformation.lean`. +-/ + +namespace Lean4Lean.NestedInductiveFixtures + +open VInductDecl + +/-! ## Target blocks + +Hand-written copies of the nested-into metadata, in each block's own +universe parameters; the Verify differential checks the same shapes +against Lean's stored metadata. -/ + +/-- `List` as a nested target: one family, one parameter. -/ +def listTarget : NestedTargetBlock where + nparams := 1 + families := + [{ name := `List + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + ctors := + [⟨⟨1, .forallE (.sort (.succ (.param 0))) + (.app (.const `List [.param 0]) (.bvar 0))⟩, `List.nil⟩, + ⟨⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const `List [.param 0]) (.bvar 1)) + (.app (.const `List [.param 0]) (.bvar 2))))⟩, `List.cons⟩] }] + +/-- A `PVec`-style indexed vector as a nested target: one parameter, one +`Nat` index, indices spelled with `Nat.zero`/`Nat.succ`. -/ +def pvecTarget : NestedTargetBlock where + nparams := 1 + families := + [{ name := `PVec + uvars := 0 + type := .forallE (.sort (.succ .zero)) + (.forallE (.const `Nat []) (.sort (.succ .zero))) + ctors := + [⟨⟨0, .forallE (.sort (.succ .zero)) + (.app (.app (.const `PVec []) (.bvar 0)) (.const `Nat.zero []))⟩, + `PVec.nil⟩, + ⟨⟨0, .forallE (.sort (.succ .zero)) + (.forallE (.bvar 0) + (.forallE (.const `Nat []) + (.forallE (.app (.app (.const `PVec []) (.bvar 2)) (.bvar 0)) + (.app (.app (.const `PVec []) (.bvar 3)) + (.app (.const `Nat.succ []) (.bvar 1))))))⟩, + `PVec.cons⟩] }] + +/-! ## Rose tree through `List` -/ + +def roseAux : Lean.Name := (`_nested ++ `List).appendIndexAfter 1 + +/-- `inductive Rose (α : Type u) | node : α → List (Rose α) → Rose α` -/ +def roseSource : VInductDecl where + uvars := 1 + nparams := 1 + types := + [{ name := `Rose + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + ctors := + [⟨⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const `List [.param 0]) + (.app (.const `Rose [.param 0]) (.bvar 1))) + (.app (.const `Rose [.param 0]) (.bvar 2))))⟩, `Rose.node⟩] }] + +/-- The expected flattened rose block: the rewritten source family plus one +auxiliary family, exactly the shapes pinned against the kernel by the +L4L-09A probes. -/ +def roseFlat : VInductDecl where + uvars := 1 + nparams := 1 + types := + [{ name := `Rose + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + ctors := + [⟨⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const roseAux [.param 0]) (.bvar 1)) + (.app (.const `Rose [.param 0]) (.bvar 2))))⟩, `Rose.node⟩] }, + { name := roseAux + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + ctors := + [⟨⟨1, .forallE (.sort (.succ (.param 0))) + (.app (.const roseAux [.param 0]) (.bvar 0))⟩, roseAux ++ `nil⟩, + ⟨⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.app (.const `Rose [.param 0]) (.bvar 0)) + (.forallE (.app (.const roseAux [.param 0]) (.bvar 1)) + (.app (.const roseAux [.param 0]) (.bvar 2))))⟩, + roseAux ++ `cons⟩] }] + +/-- The expected auxiliary specification: `List (Rose α)`, open over the +block parameter. -/ +def roseSpec : NestedAuxSpec where + aux := roseAux + target := `List + levels := [.param 0] + values := [.app (.const `Rose [.param 0]) (.bvar 0)] + +def roseElim? : Option (NestedElimination roseSource) := + nestedElimination? [listTarget] roseSource + +#guard roseElim?.isSome +#guard (roseElim?.map fun elim => elim.flat == roseFlat).getD false +#guard (roseElim?.map fun elim => elim.specs == [roseSpec]).getD false +#guard (roseElim?.map (·.numNested)).getD 0 == 1 +#guard roseFlat.stage3 +#guard nestedStage3 [listTarget] roseSource +-- acceptance behavior of the raw analyzers on the source is unchanged +#guard !roseSource.stage3 + +/-! ## Nested indexed family through `PVec` -/ + +def nvAux : Lean.Name := (`_nested ++ `PVec).appendIndexAfter 1 + +/-- `inductive NV | node : (n : Nat) → PVec NV n → NV` -/ +def nvSource : VInductDecl where + uvars := 0 + nparams := 0 + types := + [{ name := `NV + uvars := 0 + type := .sort (.succ .zero) + ctors := + [⟨⟨0, .forallE (.const `Nat []) + (.forallE (.app (.app (.const `PVec []) (.const `NV [])) + (.bvar 0)) + (.const `NV []))⟩, `NV.node⟩] }] + +/-- The expected flattened indexed block: the auxiliary family keeps the +`Nat` index, its `nil` instantiates the index at `Nat.zero`, and its +`cons` retains sibling recursion through `NV` plus the successor index. -/ +def nvFlat : VInductDecl where + uvars := 0 + nparams := 0 + types := + [{ name := `NV + uvars := 0 + type := .sort (.succ .zero) + ctors := + [⟨⟨0, .forallE (.const `Nat []) + (.forallE (.app (.const nvAux []) (.bvar 0)) + (.const `NV []))⟩, `NV.node⟩] }, + { name := nvAux + uvars := 0 + type := .forallE (.const `Nat []) (.sort (.succ .zero)) + ctors := + [⟨⟨0, .app (.const nvAux []) (.const `Nat.zero [])⟩, nvAux ++ `nil⟩, + ⟨⟨0, .forallE (.const `NV []) + (.forallE (.const `Nat []) + (.forallE (.app (.const nvAux []) (.bvar 0)) + (.app (.const nvAux []) + (.app (.const `Nat.succ []) (.bvar 1)))))⟩, + nvAux ++ `cons⟩] }] + +/-- The expected specification: the closed partial application `PVec NV`; +the index argument stays behind on each occurrence. -/ +def nvSpec : NestedAuxSpec where + aux := nvAux + target := `PVec + levels := [] + values := [.const `NV []] + +def nvElim? : Option (NestedElimination nvSource) := + nestedElimination? [pvecTarget] nvSource + +#guard nvElim?.isSome +#guard (nvElim?.map fun elim => elim.flat == nvFlat).getD false +#guard (nvElim?.map fun elim => elim.specs == [nvSpec]).getD false +#guard nvFlat.stage3 +#guard nestedStage3 [pvecTarget] nvSource +#guard !nvSource.stage3 + +/-! ## Nearest structural rejections -/ + +/-- A parametric argument mentioning a constructor-local binder: +`node : (n : Nat) → List (Loose n) → Loose` — the kernel's "parameters +cannot contain local variables" class. Flattening itself rejects. -/ +def looseSource : VInductDecl where + uvars := 0 + nparams := 0 + types := + [{ name := `Loose + uvars := 0 + type := .sort (.succ .zero) + ctors := + [⟨⟨0, .forallE (.const `Nat []) + (.forallE (.app (.const `List [.zero]) + (.app (.const `Loose []) (.bvar 0))) + (.const `Loose []))⟩, `Loose.node⟩] }] + +#guard (nestedElimination? [listTarget] looseSource).isNone +#guard !nestedStage3 [listTarget] looseSource + +/-- A well-scoped but ill-shaped parametric argument: +`node : Bad → List (Bad Nat.zero) → Bad` flattens, but the auxiliary +constructor then mentions `Bad` applied off the parameter spine, which the +unchanged block analyzer rejects. -/ +def badAppSource : VInductDecl where + uvars := 0 + nparams := 0 + types := + [{ name := `Bad + uvars := 0 + type := .sort (.succ .zero) + ctors := + [⟨⟨0, .forallE (.const `Bad []) + (.forallE (.app (.const `List [.zero]) + (.app (.const `Bad []) (.const `Nat.zero []))) + (.const `Bad []))⟩, `Bad.node⟩] }] + +#guard (nestedElimination? [listTarget] badAppSource).isSome +#guard !nestedStage3 [listTarget] badAppSource + +-- Without the `List` target metadata the occurrence is not recognized, +-- the flattened block is the source itself, and the unchanged analyzer +-- rejects the under-a-foreign-head family mention. +#guard (nestedElimination? [] roseSource).isSome +#guard ((nestedElimination? [] roseSource).map + fun elim => elim.flat == roseSource && elim.specs == []).getD false +#guard !nestedStage3 [] roseSource + +/-- A source family occupying the first canonical auxiliary name collides +with the created auxiliary family; `blockNamesOK` rejects the flattened +block exactly where the kernel's `checkName` rejects its own duplicate +insertion. -/ +def collisionSource : VInductDecl where + uvars := 1 + nparams := 1 + types := + [{ name := `Rose + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + ctors := + [⟨⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const `List [.param 0]) + (.app (.const `Rose [.param 0]) (.bvar 1))) + (.app (.const `Rose [.param 0]) (.bvar 2))))⟩, `Rose.node⟩] }, + { name := (`_nested ++ `List).appendIndexAfter 1 + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + ctors := [] }] + +#guard (nestedElimination? [listTarget] collisionSource).isSome +#guard !nestedStage3 [listTarget] collisionSource + +/-! ## Restoration pins (L4L-09C) + +Structural pins for the restored generation artifacts; the exact +comparison against Lean's stored recursor types and rule RHSs lives in the +Verify differential. -/ + +def roseNested? : Option (NestedBlockChecked roseSource) := + nestedBlockChecked? [listTarget] roseSource + +def nvNested? : Option (NestedBlockChecked nvSource) := + nestedBlockChecked? [pvecTarget] nvSource + +#guard roseNested?.isSome +#guard nvNested?.isSome + +-- the restored recursor inventory: one per source family plus one per +-- auxiliary family, on the main family's `appendIndexAfter` names +#guard (roseNested?.map fun n => n.recursors.map (·.name)).getD [] == + [`Rose.rec, ((.str `Rose "rec" : Lean.Name)).appendIndexAfter 1] +#guard (nvNested?.map fun n => n.recursors.map (·.name)).getD [] == + [`NV.rec, ((.str `NV "rec" : Lean.Name)).appendIndexAfter 1] + +def roseAuxConsts : List Lean.Name := + [roseAux, roseAux ++ `nil, roseAux ++ `cons, .str roseAux "rec"] + +def nvAuxConsts : List Lean.Name := + [nvAux, nvAux ++ `nil, nvAux ++ `cons, .str nvAux "rec"] + +/-- No auxiliary constant survives restoration in any recursor type or +rule component. -/ +def restoredClean {source : VInductDecl} (auxConsts : List Lean.Name) + (nested : NestedBlockChecked source) : Bool := + nested.recursors.all (fun r => !VExpr.hasAnyConst auxConsts r.type) && + nested.generatedRules.all fun df => + !VExpr.hasAnyConst auxConsts df.lhs && + !VExpr.hasAnyConst auxConsts df.rhs && + !VExpr.hasAnyConst auxConsts df.type + +#guard (roseNested?.map (restoredClean roseAuxConsts)).getD false +#guard (nvNested?.map (restoredClean nvAuxConsts)).getD false + +-- the globally flattened rule inventory: one node rule plus the two +-- restored `List`/`PVec` rules +#guard (roseNested?.map fun n => n.generatedRules.length).getD 0 == 3 +#guard (nvNested?.map fun n => n.generatedRules.length).getD 0 == 3 + +-- the nested transaction inserts the source payload and the restored +-- recursors, and no auxiliary constant +def roseNestedEnv? : Option VEnv := do + VEnv.empty.addInductNested (← roseNested?) + +#guard roseNestedEnv?.isSome +#guard (roseNestedEnv?.map fun env => + (env.constants `Rose).isSome && (env.constants `Rose.node).isSome && + (env.constants `Rose.rec).isSome && + (env.constants (((.str `Rose "rec" : Lean.Name)).appendIndexAfter 1)).isSome && + (env.constants roseAux).isNone && + (env.constants (roseAux ++ `cons)).isNone && + (env.constants (.str roseAux "rec")).isNone).getD false + +end Lean4Lean.NestedInductiveFixtures diff --git a/Lean4Lean/Theory/Projection.lean b/Lean4Lean/Theory/Projection.lean new file mode 100644 index 00000000..199c3f65 --- /dev/null +++ b/Lean4Lean/Theory/Projection.lean @@ -0,0 +1,2582 @@ +import Lean4Lean.Theory.Typing.InductivePatternWF + +/-! +# Structure projections + +This module is the consumer-neutral projection boundary. A projection is +not determined by a structure name and field number alone: universe +instantiations, parameters, the constructor telescope, and the generated +recursor/iota package all affect its meaning. `VStructureView` retains that +data from the same checked artifact used by inductive generation. + +Projection terms are encoded with the generated recursor. Earlier +projections occur in the motive of a dependent later projection, so one view +determines both the projected term and its dependent result type. No +projection-function name map or unconstrained metadata witness is involved. +-/ + +namespace Lean4Lean + +open VInductDecl + +/-- Instantiate an outermost-first argument list at a fixed offset. + +The `k` variables below the substituted telescope remain bound. Each +argument is lifted past them before it replaces the then-outermost variable. +This is the operation needed to specialize constructor parameters while +retaining the preceding dependent fields. -/ +def VExpr.instRevAt : VExpr → List VExpr → Nat → VExpr + | e, [], _ => e + | e, a :: as, k => instRevAt (e.inst a (k + as.length)) as k + +theorem VExpr.instRevAt_zero (e : VExpr) (args : List VExpr) : + e.instRevAt args 0 = e.instRev args := by + induction args generalizing e with + | nil => rfl + | cons arg args ih => + simp only [VExpr.instRevAt, VExpr.instRev] + simpa using ih (e := e.inst arg args.length) + +private theorem VExpr.instRevAt_closedN (args : List VExpr) + {C : VExpr} {k : Nat} (hC : C.ClosedN k) : + C.instRevAt args k = C := by + induction args generalizing C with + | nil => rfl + | cons arg args ih => + simp only [VExpr.instRevAt] + rw [hC.instN_eq (by omega)] + exact ih hC + +private theorem VExpr.instRev_forallE_projection + (A B : VExpr) (args : List VExpr) : + VExpr.instRev (.forallE A B) args = + .forallE (VExpr.instRev A args) + (VExpr.instRevAt B args 1) := by + induction args generalizing A B with + | nil => rfl + | cons arg args ih => + simp only [VExpr.instRev, VExpr.inst] + rw [ih] + congr 1 + simp only [VExpr.instRevAt] + rw [show 1 + args.length = args.length + 1 by omega] + +private theorem VExpr.instRevAt_forallE_projection + (A B : VExpr) (args : List VExpr) (k : Nat) : + VExpr.instRevAt (.forallE A B) args k = + .forallE (VExpr.instRevAt A args k) + (VExpr.instRevAt B args (k + 1)) := by + induction args generalizing A B with + | nil => rfl + | cons arg args ih => + simp only [VExpr.instRevAt, VExpr.inst] + rw [ih] + congr 1 + rw [show k + args.length + 1 = k + 1 + args.length by omega] + +private theorem VExpr.instRevAt_forallN_projection + (As : List VExpr) (B : VExpr) (args : List VExpr) (k : Nat) : + VExpr.instRevAt (VExpr.forallN As B) args k = + VExpr.forallN + (As.zipIdx k |>.map fun x => x.1.instRevAt args x.2) + (B.instRevAt args (k + As.length)) := by + induction As generalizing k with + | nil => rfl + | cons A As ih => + simp only [VExpr.forallN, VExpr.instRevAt_forallE_projection, + List.zipIdx, List.map_cons, List.length_cons] + rw [ih] + rw [show k + 1 + As.length = k + (As.length + 1) by omega] + +theorem VExpr.instRev_forallN_projection + (As : List VExpr) (B : VExpr) (args : List VExpr) : + VExpr.instRev (VExpr.forallN As B) args = + VExpr.forallN + (As.zipIdx.map fun x => x.1.instRevAt args x.2) + (B.instRevAt args As.length) := by + cases As with + | nil => simp [VExpr.forallN, VExpr.instRevAt_zero] + | cons A As => + simp only [VExpr.forallN, VExpr.instRev_forallE_projection, + List.zipIdx, List.map_cons, List.length_cons] + rw [VExpr.instRevAt_forallN_projection] + rw [VExpr.instRevAt_zero] + congr 2 + rw [Nat.add_comm] + +/-- Consume a syntactic prefix of dependent `forall` binders, instantiating +them outermost-first. -/ +def VExpr.consumeForalls? : VExpr → List VExpr → Option VExpr + | e, [] => some e + | .forallE _ body, arg :: args => consumeForalls? (body.inst arg) args + | _, _ :: _ => none + +theorem VExpr.consumeForalls?_append (e : VExpr) + (left right : List VExpr) : + e.consumeForalls? (left ++ right) = + (e.consumeForalls? left).bind fun cursor => + cursor.consumeForalls? right := by + induction left generalizing e with + | nil => rfl + | cons arg left ih => + cases e <;> simp [VExpr.consumeForalls?, ih] + +theorem VExpr.instTelN_getElem? (arg : VExpr) (fields : List VExpr) + (k i : Nat) : + (VExpr.instTelN arg fields k)[i]? = + fields[i]?.map fun field => field.inst arg (k + i) := by + induction fields generalizing k i with + | nil => simp [VExpr.instTelN] + | cons field fields ih => + cases i with + | zero => simp [VExpr.instTelN] + | succ i => + simp only [VExpr.instTelN, List.getElem?_cons_succ] + simpa only [Nat.add_assoc, Nat.add_comm, + Nat.add_left_comm] using ih (k + 1) i + +/-- Consuming `args` from a telescope exposes the next original binder with +exactly those arguments substituted. -/ +theorem VExpr.consumeForalls?_forallN_domain + (fields : List VExpr) (result : VExpr) (args : List VExpr) + (hlen : args.length < fields.length) : + ∃ field body, + fields[args.length]? = some field ∧ + VExpr.consumeForalls? (VExpr.forallN fields result) args = + some (.forallE (field.instRevAt args 0) body) := by + induction args generalizing fields result with + | nil => + cases fields with + | nil => simp at hlen + | cons field fields => + exact ⟨field, VExpr.forallN fields result, rfl, rfl⟩ + | cons arg args ih => + cases fields with + | nil => simp at hlen + | cons field fields => + have hlen' : args.length < + (VExpr.instTelN arg fields 0).length := by + simpa [VExpr.instTelN_length] using hlen + obtain ⟨field', body, hfield', hconsume⟩ := + ih (VExpr.instTelN arg fields 0) + (result.inst arg fields.length) hlen' + rw [VExpr.instTelN_getElem?] at hfield' + obtain ⟨original, horiginal, rfl⟩ := Option.map_eq_some_iff.1 hfield' + refine ⟨original, body, by simpa using horiginal, ?_⟩ + simp only [VExpr.forallN, VExpr.consumeForalls?, + VExpr.instN_forallN] + simp only [Nat.zero_add] + simpa only [VExpr.instRevAt, Nat.zero_add] using hconsume + +@[simp] theorem VExpr.instL_instRevAt (e : VExpr) (as : List VExpr) + (k : Nat) : + (e.instRevAt as k).instL ls = + (e.instL ls).instRevAt (as.map (VExpr.instL ls)) k := by + induction as generalizing e with + | nil => rfl + | cons a as ih => + simp only [VExpr.instRevAt, List.map_cons] + simpa only [VExpr.instL_instN, List.length_map] using + ih (e := e.inst a (k + as.length)) + +private theorem VExpr.instL_lamN_projection (ls : List VLevel) : + ∀ (As : List VExpr) (e : VExpr), + (VExpr.lamN As e).instL ls = + VExpr.lamN (As.map (VExpr.instL ls)) (e.instL ls) + | [], _ => rfl + | _ :: As, e => by + simp only [VExpr.lamN, VExpr.instL, List.map_cons] + rw [VExpr.instL_lamN_projection ls As e] + +private theorem VExpr.liftN_lamN_projection (n : Nat) : + ∀ (As : List VExpr) (e : VExpr) (k : Nat), + (VExpr.lamN As e).liftN n k = + VExpr.lamN (VExpr.liftTelN n As k) + (e.liftN n (k + As.length)) + | [], _, _ => rfl + | _ :: As, e, k => by + simp only [VExpr.lamN, VExpr.liftN, VExpr.liftTelN, + List.length_cons] + rw [VExpr.liftN_lamN_projection n As e (k + 1)] + rw [show k + 1 + As.length = k + (As.length + 1) by omega] + +private theorem VExpr.instN_lamN_projection (a : VExpr) : + ∀ (As : List VExpr) (e : VExpr) (k : Nat), + (VExpr.lamN As e).inst a k = + VExpr.lamN (VExpr.instTelN a As k) + (e.inst a (k + As.length)) + | [], _, _ => rfl + | _ :: As, e, k => by + simp only [VExpr.lamN, VExpr.inst, VExpr.instTelN, + List.length_cons] + rw [VExpr.instN_lamN_projection a As e (k + 1)] + rw [show k + 1 + As.length = k + (As.length + 1) by omega] + +private theorem VExpr.liftN_lift_projection (e : VExpr) (n k : Nat) : + e.lift.liftN n (k + 1) = (e.liftN n k).lift := + (VExpr.lift_liftN' e k).symm + +private theorem VExpr.liftN_liftAt_projection + (e : VExpr) (n k i : Nat) : + (e.liftN 1 i).liftN n (k + 1 + i) = + (e.liftN n (k + i)).liftN 1 i := by + symm + simpa only [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using + VExpr.liftN_liftN_comm e 1 n i (k + i) (by omega) + +private theorem VExpr.liftTelN_liftAt_projection (As : List VExpr) + (n k i : Nat) : + VExpr.liftTelN n (VExpr.liftTelN 1 As i) (k + 1 + i) = + VExpr.liftTelN 1 (VExpr.liftTelN n As (k + i)) i := by + induction As generalizing i with + | nil => rfl + | cons A As ih => + simp only [VExpr.liftTelN] + rw [VExpr.liftN_liftAt_projection A n k i] + congr 1 + simpa only [Nat.add_assoc] using ih (i + 1) + +private theorem VExpr.liftTelN_lift_projection (As : List VExpr) + (n k : Nat) : + VExpr.liftTelN n (VExpr.liftTelN 1 As 0) (k + 1) = + VExpr.liftTelN 1 (VExpr.liftTelN n As k) 0 := by + simpa using VExpr.liftTelN_liftAt_projection As n k 0 + +private theorem VExpr.instN_liftAt_projection + (e a : VExpr) (k i : Nat) : + (e.liftN 1 i).inst a (k + 1 + i) = + (e.inst a (k + i)).liftN 1 i := by + symm + simpa only [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using + VExpr.liftN_instN_lo 1 e a (k + i) i (by omega) + +private theorem VExpr.instTelN_liftAt_projection (As : List VExpr) + (a : VExpr) (k i : Nat) : + VExpr.instTelN a (VExpr.liftTelN 1 As i) (k + 1 + i) = + VExpr.liftTelN 1 (VExpr.instTelN a As (k + i)) i := by + induction As generalizing i with + | nil => rfl + | cons A As ih => + simp only [VExpr.liftTelN, VExpr.instTelN] + rw [VExpr.instN_liftAt_projection A a k i] + congr 1 + simpa only [Nat.add_assoc] using ih (i + 1) + +private theorem VExpr.instTelN_lift_projection (As : List VExpr) + (a : VExpr) (k : Nat) : + VExpr.instTelN a (VExpr.liftTelN 1 As 0) (k + 1) = + VExpr.liftTelN 1 (VExpr.instTelN a As k) 0 := by + simpa using VExpr.instTelN_liftAt_projection As a k 0 + +private theorem VExpr.instN_instRevAt_lift_projection + (e : VExpr) (args : List VExpr) (a : VExpr) (i : Nat) : + ((e.liftN 1 i).instRevAt args (i + 1)).inst a i = + e.instRevAt args i := by + induction args generalizing e with + | nil => exact VExpr.inst_liftN1 e a i + | cons arg args ih => + simp only [VExpr.instRevAt] + rw [show i + 1 + args.length = args.length + 1 + i by omega, + VExpr.instN_liftAt_projection e arg args.length i] + simpa only [Nat.add_comm] using + ih (e := e.inst arg (args.length + i)) + +private theorem VExpr.instTelN_instRevAt_lift_projection + (fields : List VExpr) (args : List VExpr) (a : VExpr) + (start : Nat) : + VExpr.instTelN a + ((VExpr.liftTelN 1 fields start).zipIdx (start + 1) |>.map + fun x => x.1.instRevAt args x.2) + start = + (fields.zipIdx start |>.map + fun x => x.1.instRevAt args x.2) := by + induction fields generalizing start with + | nil => rfl + | cons field fields ih => + simp only [VExpr.liftTelN, List.zipIdx, List.map_cons, + VExpr.instTelN] + rw [VExpr.instN_instRevAt_lift_projection] + congr 1 + simpa only [Nat.add_assoc] using ih (start + 1) + +private theorem VExpr.inst_liftN_top (e a : VExpr) (n : Nat) : + (e.liftN (n + 1)).inst a n = e.liftN n := by + rw [← VExpr.liftN'_liftN' (e := e) (n1 := n) (n2 := 1) + (k1 := 0) (k2 := n) (Nat.zero_le _) (by omega)] + exact VExpr.inst_liftN (e.liftN n) a + +private theorem VExpr.instRevAt_liftN_len (args : List VExpr) + (e : VExpr) (k : Nat) : + (e.liftN (k + args.length)).instRevAt args k = e.liftN k := by + induction args with + | nil => rfl + | cons arg args ih => + simp only [List.length_cons, VExpr.instRevAt] + rw [show k + (args.length + 1) = (k + args.length) + 1 by omega, + VExpr.inst_liftN_top] + exact ih + +private theorem VExpr.instRevAt_bvar_lt_cons (args : List VExpr) + (arg : VExpr) (k i : Nat) (hi : i < k + args.length) : + (VExpr.bvar i).instRevAt (arg :: args) k = + (VExpr.bvar i).instRevAt args k := by + simp only [VExpr.instRevAt] + congr 1 + simp [VExpr.inst, VExpr.instVar, hi] + +private theorem VExpr.map_instRevAt_bvarRevRange + (args : List VExpr) (k : Nat) : + (VExpr.bvarRevRange k args.length).map + (fun e => e.instRevAt args k) = + args.map (VExpr.liftN k) := by + induction args with + | nil => rfl + | cons arg args ih => + simp only [List.length_cons, VExpr.bvarRevRange, + List.map_cons] + congr 1 + · simp only [VExpr.instRevAt] + rw [show (VExpr.bvar (k + args.length)).inst arg + (k + args.length) = arg.liftN (k + args.length) by + simp [VExpr.inst, VExpr.instVar]] + exact VExpr.instRevAt_liftN_len args arg k + · rw [← ih] + apply List.map_congr_left + intro e he + obtain ⟨i, rfl, _, hi⟩ := VExpr.mem_bvarRevRange he + exact VExpr.instRevAt_bvar_lt_cons args arg k i (by omega) + +private theorem VExpr.instRevAt_appN_projection + (f : VExpr) (es : List VExpr) (args : List VExpr) (k : Nat) : + (VExpr.appN f es).instRevAt args k = + VExpr.appN (f.instRevAt args k) + (es.map fun e => e.instRevAt args k) := by + induction args generalizing f es with + | nil => simp [VExpr.instRevAt, List.map_id'] + | cons arg args ih => + simp only [VExpr.instRevAt, VExpr.instN_appN] + rw [ih] + simp only [List.map_map, Function.comp_def, VExpr.instRevAt] + +private theorem VExpr.map_instRevAt_closedN (args es : List VExpr) + (k : Nat) (hclosed : ∀ e ∈ es, e.ClosedN k) : + es.map (fun e => e.instRevAt args k) = es := by + induction es with + | nil => rfl + | cons e es ih => + simp only [List.map_cons] + rw [VExpr.instRevAt_closedN args (hclosed e (.head _))] + congr 1 + exact ih (fun e he => hclosed e (.tail _ he)) + +private theorem VExpr.map_instN_closedN (a : VExpr) (es : List VExpr) + (k : Nat) (hclosed : ∀ e ∈ es, e.ClosedN k) : + es.map (fun e => e.inst a k) = es := by + induction es with + | nil => rfl + | cons e es ih => + simp only [List.map_cons] + rw [(hclosed e (.head _)).instN_eq (Nat.le_refl _)] + congr 1 + exact ih (fun e he => hclosed e (.tail _ he)) + +private theorem VExpr.map_instN_liftN_top + (es : List VExpr) (a : VExpr) (n : Nat) : + (es.map (VExpr.liftN (n + 1))).map + (fun e => e.inst a n) = + es.map (VExpr.liftN n) := by + rw [List.map_map] + apply List.map_congr_left + intro e _ + exact VExpr.inst_liftN_top e a n + +private theorem VExpr.projectionMinorBody_shape + (constructorName : Name) (levels : List VLevel) + (params : List VExpr) (m : Nat) (typeFn : VExpr) : + ((VExpr.appN (.bvar m) + [VExpr.appN (.const constructorName levels) + (VExpr.bvarRevRange (m + 1) params.length ++ + VExpr.bvarRevRange 0 m)]).instRevAt params (m + 1)).inst + typeFn m = + .app (typeFn.liftN m) + (VExpr.appN (.const constructorName levels) + (params.map (VExpr.liftN m) ++ + VExpr.bvarRevRange 0 m)) := by + have hmotiveR : (VExpr.bvar m).instRevAt params (m + 1) = + .bvar m := VExpr.instRevAt_closedN params (by + exact Nat.lt_succ_self m) + have hconstR : (VExpr.const constructorName levels).instRevAt + params (m + 1) = .const constructorName levels := + VExpr.instRevAt_closedN params (by trivial) + have hfieldsR := VExpr.map_instRevAt_closedN params + (VExpr.bvarRevRange 0 m) (m + 1) + (bvarRevRange_closedN m 0 (m + 1) (by omega)) + have hmotiveI : (VExpr.bvar m).inst typeFn m = + typeFn.liftN m := by simp [VExpr.inst, VExpr.instVar] + have hconstI : (VExpr.const constructorName levels).inst typeFn m = + .const constructorName levels := by rfl + have hparamsI := VExpr.map_instN_liftN_top params typeFn m + have hfieldsI := VExpr.map_instN_closedN typeFn + (VExpr.bvarRevRange 0 m) m + (bvarRevRange_closedN m 0 m (by omega)) + rw [VExpr.instRevAt_appN_projection, hmotiveR] + simp only [List.map_singleton] + rw [VExpr.instRevAt_appN_projection, hconstR, List.map_append, + VExpr.map_instRevAt_bvarRevRange, hfieldsR] + rw [VExpr.instN_appN, hmotiveI] + simp only [List.map_singleton] + rw [VExpr.instN_appN, hconstI, List.map_append, + hparamsI, hfieldsI] + rfl + +private theorem VExpr.projectionMajorTail_shape + (familyName : Name) (levels : List VLevel) + (params : List VExpr) (typeFn : VExpr) : + (((VExpr.forallE + (VExpr.appN (.const familyName levels) + (VExpr.bvarRevRange 2 params.length)) + (.app (.appN (.bvar 2) []) (.bvar 0))).instRevAt + params 2).inst typeFn 1) = + VExpr.forallE + (VExpr.appN (.const familyName levels) + (params.map (VExpr.liftN 1))) + (.app (typeFn.liftN 2) (.bvar 0)) := by + have hconstR : (VExpr.const familyName levels).instRevAt + params 2 = .const familyName levels := + VExpr.instRevAt_closedN params (by trivial) + have hbodyR : + (VExpr.app (VExpr.appN (.bvar 2) []) (.bvar 0)).instRevAt + params 3 = + VExpr.app (VExpr.appN (.bvar 2) []) (.bvar 0) := + VExpr.instRevAt_closedN params (by + change 2 < 3 ∧ 0 < 3 + omega) + rw [VExpr.instRevAt_forallE_projection, + VExpr.instRevAt_appN_projection, hconstR, + VExpr.map_instRevAt_bvarRevRange, hbodyR] + simp only [VExpr.inst] + congr 1 + · rw [VExpr.instN_appN] + have hconstI : (VExpr.const familyName levels).inst typeFn 1 = + .const familyName levels := by rfl + rw [hconstI, VExpr.map_instN_liftN_top] + +theorem VExpr.liftN_instRevAt (e : VExpr) (as : List VExpr) + (i k n : Nat) : + (e.instRevAt as i).liftN n (k + i) = + (e.liftN n (k + i + as.length)).instRevAt + (as.map fun a => a.liftN n k) i := by + induction as generalizing e with + | nil => simp [VExpr.instRevAt] + | cons a as ih => + simp only [VExpr.instRevAt, List.map_cons] + rw [ih] + simp only [List.length_cons, List.length_map] + rw [show k + i + as.length = k + (i + as.length) by omega, + VExpr.liftN_instN_hi] + congr 3 <;> omega + +theorem VExpr.instN_instRevAt (e : VExpr) (as : List VExpr) + (i k : Nat) (a : VExpr) : + (e.instRevAt as i).inst a (k + i) = + (e.inst a (k + i + as.length)).instRevAt + (as.map fun arg => arg.inst a k) i := by + induction as generalizing e with + | nil => simp [VExpr.instRevAt] + | cons arg as ih => + simp only [VExpr.instRevAt, List.map_cons] + rw [ih] + simp only [List.length_cons, List.length_map] + rw [show k + i + as.length = k + (i + as.length) by omega, + VExpr.inst_inst_hi] + congr 3 <;> omega + +/-- A telescope whose entries have the exact retained sort levels. -/ +inductive VEnv.OnSortTel (env : VEnv) (U : Nat) : + List VExpr → List VExpr → List VLevel → Prop where + | nil : OnSortTel env U Γ [] [] + | cons : + env.HasType U Γ A (.sort u) → + OnSortTel env U (A :: Γ) As us → + OnSortTel env U Γ (A :: As) (u :: us) + +private theorem VEnv.OnTel.monoProjection {env env' : VEnv} + (henv : env ≤ env') (H : env.OnTel U Γ As) : env'.OnTel U Γ As := by + induction As generalizing Γ with + | nil => trivial + | cons _ _ ih => + exact ⟨H.1.mono henv, ih H.2⟩ + +theorem VEnv.OnSortTel.mono {env env' : VEnv} (henv : env ≤ env') + (H : env.OnSortTel U Γ As us) : env'.OnSortTel U Γ As us := by + induction H with + | nil => exact .nil + | cons hA _ ih => exact .cons (hA.mono henv) ih + +theorem VEnv.OnSortTel.instL {env : VEnv} {U U' : Nat} + (hlevels : ∀ level ∈ levels, level.WF U') : + ∀ {Γ As us}, env.OnSortTel U Γ As us → + env.OnSortTel U' (Γ.map (VExpr.instL levels)) + (As.map (VExpr.instL levels)) + (us.map (VLevel.inst levels)) + | _, [], [], .nil => .nil + | _, _ :: _, _ :: _, .cons hA hT => + .cons (hA.instL hlevels) (VEnv.OnSortTel.instL hlevels hT) + +theorem VEnv.OnSortTel.weakN {env : VEnv} (henv : env.Ordered) + {U n k : Nat} {Γ Γ' : List VExpr} (W : Ctx.LiftN n k Γ Γ') : + ∀ {As us}, env.OnSortTel U Γ As us → + env.OnSortTel U Γ' (VExpr.liftTelN n As k) us + | [], [], .nil => .nil + | _ :: _, _ :: _, .cons hA hT => + .cons (hA.weakN henv W) + (VEnv.OnSortTel.weakN henv W.succ hT) + +private theorem VEnv.OnSortTel.instN {env : VEnv} (henv : env.Ordered) + {U : Nat} {Γ₀ : List VExpr} {e₀ A₀ : VExpr} + (h₀ : env.HasType U Γ₀ e₀ A₀) : + ∀ {As : List VExpr} {us : List VLevel} {k : Nat} + {Γ Γ' : List VExpr}, + Ctx.InstN Γ₀ e₀ A₀ k Γ Γ' → + env.OnSortTel U Γ As us → + env.OnSortTel U Γ' (VExpr.instTelN e₀ As k) us + | [], [], _, _, _, _, .nil => .nil + | _ :: _, _ :: _, _, _, _, W, .cons hA hT => + .cons (hA.instN henv W h₀) + (VEnv.OnSortTel.instN henv h₀ W.succ hT) + +private theorem VExpr.instRevAt_instTelN_cons + (fields : List VExpr) (a : VExpr) (as : List VExpr) : + ((VExpr.instTelN a fields as.length).zipIdx.map fun (field, i) => + VExpr.instRevAt field as i) = + (fields.zipIdx.map fun (field, i) => + VExpr.instRevAt field (a :: as) i) := by + suffices ∀ (start k : Nat), k = as.length + start → + ((VExpr.instTelN a fields k).zipIdx start |>.map + fun (field, i) => VExpr.instRevAt field as i) = + (fields.zipIdx start |>.map fun (field, i) => + VExpr.instRevAt field (a :: as) i) by + simpa using this 0 as.length (by omega) + intro start k hk + induction fields generalizing start k with + | nil => rfl + | cons field fields ih => + simp only [VExpr.instTelN, List.zipIdx, List.map_cons, + VExpr.instRevAt] + rw [hk] + congr 1 + · congr 2 <;> omega + · exact ih (start + 1) (as.length + start + 1) (by omega) + +theorem VExpr.instRevAt_map_instL_zipIdx + (fields : List VExpr) (levels : List VLevel) + (params : List VExpr) (start : Nat := 0) : + ((fields.map (VExpr.instL levels)).zipIdx start |>.map + fun (field, i) => VExpr.instRevAt field params i) = + (fields.zipIdx start |>.map fun (field, i) => + VExpr.instRevAt (field.instL levels) params i) := by + induction fields generalizing start with + | nil => rfl + | cons field fields ih => + simp only [List.map_cons, List.zipIdx] + congr 1 + exact ih (start + 1) + +private theorem VEnv.OnSortTel.instRevParams {env : VEnv} + (henv : env.Ordered) {U : Nat} : + ∀ {Γ params args fields sorts resultLevel}, + env.SpineWF U Γ (VExpr.forallN params (.sort resultLevel)) + args (.sort resultLevel) → + args.length = params.length → + env.OnSortTel U (params.reverse ++ Γ) fields sorts → + env.OnSortTel U Γ + (fields.zipIdx.map fun (field, i) => + VExpr.instRevAt field args i) sorts + | _, [], [], fields, sorts, _, hspine, _, hfields => by + simpa [VExpr.instRevAt] using hfields + | _, [], _ :: _, _, _, _, _, hlen, _ => by simp at hlen + | Γ, param :: params, arg :: args, fields, sorts, resultLevel, + ⟨domain, codomain, hshape, harg, hrest⟩, hlen, hfields => by + change VExpr.forallE param + (VExpr.forallN params (.sort resultLevel)) = + VExpr.forallE domain codomain at hshape + injection hshape with hdomain hcodomain + subst domain + subst codomain + have hparams : args.length = params.length := by simpa using hlen + have W := Ctx.InstN.consTel (Γ₀ := Γ) (e₀ := arg) + (A₀ := param) params (.zero) + have hfields' : env.OnSortTel U + ((VExpr.instTelN arg params 0).reverse ++ Γ) + (VExpr.instTelN arg fields params.length) sorts := by + apply VEnv.OnSortTel.instN henv harg W + simpa [List.append_assoc] using hfields + have hrest' : env.SpineWF U Γ + (VExpr.forallN (VExpr.instTelN arg params 0) + (.sort resultLevel)) args (.sort resultLevel) := by + simpa [VExpr.instN_forallN, VExpr.inst] using hrest + have hout := VEnv.OnSortTel.instRevParams henv + hrest' (by simpa [VExpr.instTelN_length] using hparams) hfields' + rw [← hparams, VExpr.instRevAt_instTelN_cons] at hout + exact hout + +private theorem VEnv.OnTel.toOnCtx {env : VEnv} {U : Nat} : + ∀ {As Γ}, env.OnTel U Γ As → OnCtx Γ (env.IsType U) → + OnCtx (As.reverse ++ Γ) (env.IsType U) + | [], _, _, hΓ => by simpa using hΓ + | A :: As, Γ, ⟨hA, hAs⟩, hΓ => by + simpa [List.append_assoc] using + VEnv.OnTel.toOnCtx hAs (Γ := A :: Γ) ⟨hΓ, hA⟩ + +private theorem VEnv.OnSortTel.closedAt {env : VEnv} {U : Nat} + (henv : env.Ordered) : + ∀ {As us Γ}, env.OnSortTel U Γ As us → CtxClosed Γ → + ∀ {i : Nat} {field : VExpr}, As[i]? = some field → + field.ClosedN (Γ.length + i) + | _, _, _, .nil, _, i, _, h => by simp at h + | _ :: _, _ :: _, Γ, .cons hA hAs, hΓ, 0, _, h => by + simp only [List.getElem?_cons_zero] at h + cases h + simpa using hA.closedN henv hΓ + | A :: As, _ :: _, Γ, .cons hA hAs, hΓ, i + 1, field, h => by + simp only [List.getElem?_cons_succ] at h + have hclosed : A.ClosedN Γ.length := hA.closedN henv hΓ + simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using + VEnv.OnSortTel.closedAt henv hAs ⟨hΓ, hclosed⟩ h + +private theorem VEnv.OnTel.liftTelN_eq {env : VEnv} {U : Nat} + (henv : env.Ordered) : + ∀ {As Γ}, env.OnTel U Γ As → CtxClosed Γ → ∀ n, + VExpr.liftTelN n As Γ.length = As + | [], _, _, _, _ => rfl + | A :: As, Γ, ⟨hA, hAs⟩, hΓ, n => by + obtain ⟨_, hA⟩ := hA + have hclosed : A.ClosedN Γ.length := hA.closedN henv hΓ + simp only [VExpr.liftTelN, hclosed.liftN_eq (Nat.le_refl _)] + simpa using VEnv.OnTel.liftTelN_eq henv hAs ⟨hΓ, hclosed⟩ n + +private theorem VEnv.OnSortTel.liftTelN_eq {env : VEnv} {U : Nat} + (henv : env.Ordered) : + ∀ {As us Γ}, env.OnSortTel U Γ As us → CtxClosed Γ → ∀ n, + VExpr.liftTelN n As Γ.length = As + | [], [], _, .nil, _, _ => rfl + | A :: As, _ :: us, Γ, .cons hA hAs, hΓ, n => by + have hclosed : A.ClosedN Γ.length := hA.closedN henv hΓ + simp only [VExpr.liftTelN, hclosed.liftN_eq (Nat.le_refl _)] + simpa using VEnv.OnSortTel.liftTelN_eq henv hAs ⟨hΓ, hclosed⟩ n + +/-- The checked, generated description of a nonrecursive structure. + +`generation` supplies the exact family, constructor, recursor, and iota rule +artifacts. The shape fields restrict that general one-family artifact to the +kernel class on which `.proj` is meaningful: no indices, exactly one +constructor, and no recursive constructor arguments. `fieldSorts` records +the motive universe required by each projection; `WF` below ties every entry +to the corresponding dependent constructor field type. -/ +structure VStructureView where + source : VInductDecl + generation : source.GenerationChecked + constructor : NormalizedCtor + constructor_eq : generation.block.ctorPairs = [constructor] + raw_indices_eq : generation.block.rawIndices = [] + checked_indices_eq : generation.block.checked.indices = [] + recursive_eq : constructor.view.recursive = [] + fieldSorts : List VLevel + fieldSorts_length : + fieldSorts.length = (constructor.rawFields source.nparams).length + +namespace VStructureView + +abbrev name (view : VStructureView) : Name := + view.generation.block.sourceType.name + +abbrev constructorName (view : VStructureView) : Name := + view.constructor.raw.name + +def recursorName (view : VStructureView) : Name := + .str view.name "rec" + +abbrev uvars (view : VStructureView) : Nat := view.source.uvars + +abbrev nparams (view : VStructureView) : Nat := view.source.nparams + +abbrev familyType (view : VStructureView) : VExpr := + view.generation.block.sourceType.type + +def constructorParams (view : VStructureView) : List VExpr := + VExpr.telN view.nparams view.constructor.raw.type + +def fields (view : VStructureView) : List VExpr := + view.constructor.rawFields view.nparams + +/-- The instantiated structure type `S.{levels} params`. -/ +def structureType (view : VStructureView) + (levels : List VLevel) (params : List VExpr) : VExpr := + VExpr.appN (.const view.name levels) params + +/-- Specialize declaration universes and constructor parameters, retaining +the preceding field binders of each dependent field. -/ +def specializedFields (view : VStructureView) + (levels : List VLevel) (params : List VExpr) : List VExpr := + view.fields.zipIdx.map fun (field, i) => + VExpr.instRevAt (field.instL levels) params i + +private theorem specializedFieldsAux_liftN + (rawFields : List VExpr) (levels : List VLevel) + (params : List VExpr) (p start n k : Nat) + (hparams : params.length = p) + (hclosed : ∀ (j : Nat) (field : VExpr), + rawFields[j]? = some field → + field.ClosedN (p + start + j)) : + (rawFields.zipIdx start |>.map fun (field, i) => + VExpr.instRevAt (field.instL levels) + (params.map fun param => param.liftN n k) i) = + VExpr.liftTelN n + (rawFields.zipIdx start |>.map fun (field, i) => + VExpr.instRevAt (field.instL levels) params i) + (k + start) := by + induction rawFields generalizing start with + | nil => rfl + | cons field rawFields ih => + have hfield : (field.instL levels).ClosedN (p + start + 0) := + VExpr.ClosedN.instL (ls := levels) (hclosed 0 field (by rfl)) + have hrawLift : + (field.instL levels).liftN n + (k + start + params.length) = field.instL levels := + hfield.liftN_eq (by rw [hparams]; omega) + have hhead := VExpr.liftN_instRevAt + (field.instL levels) params start k n + rw [hrawLift] at hhead + have htail := ih (start := start + 1) + (fun j tailField htailField => by + have := hclosed (j + 1) tailField (by simpa using htailField) + simpa only [Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using this) + simp only [List.zipIdx, List.map_cons, VExpr.liftTelN] + rw [← hhead] + exact congrArg + (List.cons (VExpr.liftN n + ((field.instL levels).instRevAt params start) (k + start))) + (by simpa only [Nat.add_assoc] using htail) + +private theorem specializedFieldsAux_instN + (rawFields : List VExpr) (levels : List VLevel) + (params : List VExpr) (p start k : Nat) (a : VExpr) + (hparams : params.length = p) + (hclosed : ∀ (j : Nat) (field : VExpr), + rawFields[j]? = some field → + field.ClosedN (p + start + j)) : + (rawFields.zipIdx start |>.map fun (field, i) => + VExpr.instRevAt (field.instL levels) + (params.map fun param => param.inst a k) i) = + VExpr.instTelN a + (rawFields.zipIdx start |>.map fun (field, i) => + VExpr.instRevAt (field.instL levels) params i) + (k + start) := by + induction rawFields generalizing start with + | nil => rfl + | cons field rawFields ih => + have hfield : (field.instL levels).ClosedN (p + start + 0) := + VExpr.ClosedN.instL (ls := levels) (hclosed 0 field (by rfl)) + have hrawInst : + (field.instL levels).inst a + (k + start + params.length) = field.instL levels := + hfield.instN_eq (by rw [hparams]; omega) + have hhead := VExpr.instN_instRevAt + (field.instL levels) params start k a + rw [hrawInst] at hhead + have htail := ih (start := start + 1) + (fun j tailField htailField => by + have := hclosed (j + 1) tailField (by simpa using htailField) + simpa only [Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using this) + simp only [List.zipIdx, List.map_cons, VExpr.instTelN] + rw [← hhead] + exact congrArg + (List.cons (VExpr.inst + ((field.instL levels).instRevAt params start) a (k + start))) + (by simpa only [Nat.add_assoc] using htail) + +/-- Universe arguments supplied to the generated recursor for a projection +whose result type inhabits `Sort fieldSort`. -/ +def projectionLevels (view : VStructureView) + (fieldSort : VLevel) (levels : List VLevel) : List VLevel := + match view.generation.elimination with + | .large => fieldSort :: levels + | .small => levels + +/-- The two expressions generated for one field. `typeFn` is the dependent +field type as a function of the structure value; `projector` is a recursor +program implementing the projection. -/ +structure ProjectionCode where + fieldSort : VLevel + typeFn : VExpr + minor : VExpr + projector : VExpr + +@[ext] theorem ProjectionCode.ext {left right : ProjectionCode} + (fieldSort : left.fieldSort = right.fieldSort) + (typeFn : left.typeFn = right.typeFn) + (minor : left.minor = right.minor) + (projector : left.projector = right.projector) : left = right := by + cases left + cases right + simp_all + +def ProjectionCode.liftN (code : ProjectionCode) + (n k : Nat) : ProjectionCode where + fieldSort := code.fieldSort + typeFn := code.typeFn.liftN n k + minor := code.minor.liftN n k + projector := code.projector.liftN n k + +def ProjectionCode.instN (code : ProjectionCode) + (a : VExpr) (k : Nat) : ProjectionCode where + fieldSort := code.fieldSort + typeFn := code.typeFn.inst a k + minor := code.minor.inst a k + projector := code.projector.inst a k + +def ProjectionCode.instL (code : ProjectionCode) + (ls : List VLevel) : ProjectionCode where + fieldSort := code.fieldSort.inst ls + typeFn := code.typeFn.instL ls + minor := code.minor.instL ls + projector := code.projector.instL ls + +/-- The constructor-headed major used by a projection minor after all fields +have been introduced. -/ +def projectionConstructorApp (view : VStructureView) + (levels : List VLevel) (params fields : List VExpr) : VExpr := + VExpr.appN (.const view.constructorName levels) + (params.map (VExpr.liftN fields.length) ++ + VExpr.bvarRevRange 0 fields.length) + +/-- The one-constructor, nonrecursive minor premise expected by the generated +recursor after parameters and a projection motive have been supplied. -/ +def projectionMinorType (view : VStructureView) + (levels : List VLevel) (params fields : List VExpr) + (typeFn : VExpr) : VExpr := + VExpr.forallN fields + (.app (typeFn.liftN fields.length) + (view.projectionConstructorApp levels params fields)) + +@[simp] theorem projectionLevels_instL (view : VStructureView) + (fieldSort : VLevel) (levels ls : List VLevel) : + (view.projectionLevels fieldSort levels).map (VLevel.inst ls) = + view.projectionLevels (fieldSort.inst ls) + (levels.map (VLevel.inst ls)) := by + unfold projectionLevels + split <;> rfl + +@[simp] theorem structureType_instL (view : VStructureView) + (levels : List VLevel) (params : List VExpr) (ls : List VLevel) : + (view.structureType levels params).instL ls = + view.structureType (levels.map (VLevel.inst ls)) + (params.map (VExpr.instL ls)) := by + simp [structureType, VExpr.instL_appN, VExpr.instL, + VLevel.inst_inst, Function.comp_def] + +@[simp] theorem structureType_liftN (view : VStructureView) + (levels : List VLevel) (params : List VExpr) (n k : Nat) : + (view.structureType levels params).liftN n k = + view.structureType levels + (params.map fun param => param.liftN n k) := by + simp [structureType, VExpr.liftN_appN, VExpr.liftN] + +@[simp] theorem structureType_instN (view : VStructureView) + (levels : List VLevel) (params : List VExpr) (a : VExpr) (k : Nat) : + (view.structureType levels params).inst a k = + view.structureType levels + (params.map fun param => param.inst a k) := by + simp [structureType, VExpr.instN_appN, VExpr.inst] + +@[simp] theorem specializedFields_instL (view : VStructureView) + (levels : List VLevel) (params : List VExpr) (ls : List VLevel) : + (view.specializedFields levels params).map (VExpr.instL ls) = + view.specializedFields (levels.map (VLevel.inst ls)) + (params.map (VExpr.instL ls)) := by + simp [specializedFields, VExpr.instL_instRevAt, + VExpr.instL_instL, VLevel.inst_inst, Function.comp_def] + +private def projectionCode (view : VStructureView) + (levels : List VLevel) (params allFields : List VExpr) + (structType field : VExpr) (fieldSort : VLevel) (i : Nat) + (previous : List ProjectionCode) : ProjectionCode := + let previousAtMajor := previous.map fun code => + .app code.projector.lift (.bvar 0) + let motiveBody := VExpr.instRevAt + (field.liftN 1 i) previousAtMajor 0 + let typeFn := .lam structType motiveBody + let minor := VExpr.lamN allFields + (.bvar (allFields.length - 1 - i)) + let recursor := .const view.recursorName + (view.projectionLevels fieldSort levels) + let projector := .lam structType <| VExpr.appN recursor <| + params.map (VExpr.liftN 1) ++ + [typeFn.lift, minor.lift, .bvar 0] + { fieldSort, typeFn, minor, projector } + +private theorem projectionCode_liftN (view : VStructureView) + (levels : List VLevel) (params allFields : List VExpr) + (structType field : VExpr) (fieldSort : VLevel) (i : Nat) + (previous : List ProjectionCode) (n k : Nat) + (hprevious : previous.length = i) + (hi : i < allFields.length) : + (projectionCode view levels params allFields structType field + fieldSort i previous).liftN n k = + projectionCode view levels + (params.map fun param => param.liftN n k) + (VExpr.liftTelN n allFields k) + (structType.liftN n k) (field.liftN n (k + i)) fieldSort i + (previous.map fun code => code.liftN n k) := by + have hfieldLift : + (field.liftN 1 i).liftN n (k + 1 + i) = + (field.liftN n (k + i)).liftN 1 i := + VExpr.liftN_liftAt_projection field n k i + have hpreviousLift : + (previous.map fun code => + VExpr.app code.projector.lift (.bvar 0)).map + (fun (e : VExpr) => e.liftN n (k + 1)) = + (previous.map fun code => code.liftN n k).map fun code => + VExpr.app code.projector.lift (.bvar 0) := by + simp [ProjectionCode.liftN, VExpr.liftN, + VExpr.liftN_lift_projection, List.map_map, + Function.comp_def] + have hmotive : + ((field.liftN 1 i).instRevAt + (previous.map fun code => + VExpr.app code.projector.lift (.bvar 0)) 0).liftN n (k + 1) = + ((field.liftN n (k + i)).liftN 1 i).instRevAt + ((previous.map fun code => code.liftN n k).map fun code => + VExpr.app code.projector.lift (.bvar 0)) 0 := by + rw [VExpr.liftN_instRevAt] + rw [List.length_map, hprevious, hfieldLift, hpreviousLift] + have hminorBody : + VExpr.liftN n (.bvar (allFields.length - 1 - i)) + (k + allFields.length) = + .bvar (allFields.length - 1 - i) := by + simp only [VExpr.liftN] + rw [liftVar_lt] + omega + have hminorVar : + liftVar n (allFields.length - 1 - i) + (k + allFields.length) = allFields.length - 1 - i := by + rw [liftVar_lt] + omega + have hminorNestedVar : + liftVar n (liftVar 1 (allFields.length - 1 - i) + allFields.length) (k + 1 + allFields.length) = + liftVar 1 (allFields.length - 1 - i) allFields.length := by + have hinner : liftVar 1 (allFields.length - 1 - i) + allFields.length = allFields.length - 1 - i := + liftVar_lt (by omega) + rw [hinner, liftVar_lt (by omega)] + have hmotiveLift : + (((field.liftN 1 i).instRevAt + (previous.map fun code => + VExpr.app code.projector.lift (.bvar 0)) 0).liftN 1 1).liftN + n (k + 1 + 1) = + (((field.liftN n (k + i)).liftN 1 i).instRevAt + ((previous.map fun code => code.liftN n k).map fun code => + VExpr.app code.projector.lift (.bvar 0)) 0).liftN 1 1 := by + rw [VExpr.liftN_liftAt_projection] + exact congrArg (fun e => e.liftN 1 1) hmotive + apply ProjectionCode.ext + · rfl + · simp [projectionCode, ProjectionCode.liftN, VExpr.liftN, + hmotive] + · simp [projectionCode, ProjectionCode.liftN, + VExpr.liftN_lamN_projection, VExpr.liftTelN_length, + hminorBody] + · simp [projectionCode, ProjectionCode.liftN, VExpr.liftN, + VExpr.liftN_appN, VExpr.liftN_lamN_projection, + VExpr.liftTelN_length, VExpr.liftN_lift_projection, + VExpr.liftTelN_lift_projection, List.map_append, + List.map_map, Function.comp_def, hmotive, hmotiveLift, + hminorNestedVar] + +private theorem projectionCode_instN (view : VStructureView) + (levels : List VLevel) (params allFields : List VExpr) + (structType field : VExpr) (fieldSort : VLevel) (i : Nat) + (previous : List ProjectionCode) (a : VExpr) (k : Nat) + (hprevious : previous.length = i) + (hi : i < allFields.length) : + (projectionCode view levels params allFields structType field + fieldSort i previous).instN a k = + projectionCode view levels + (params.map fun param => param.inst a k) + (VExpr.instTelN a allFields k) + (structType.inst a k) (field.inst a (k + i)) fieldSort i + (previous.map fun code => code.instN a k) := by + have hfieldInst : + (field.liftN 1 i).inst a (k + 1 + i) = + (field.inst a (k + i)).liftN 1 i := + VExpr.instN_liftAt_projection field a k i + have hpreviousInst : + (previous.map fun code => + VExpr.app code.projector.lift (.bvar 0)).map + (fun (e : VExpr) => e.inst a (k + 1)) = + (previous.map fun code => code.instN a k).map fun code => + VExpr.app code.projector.lift (.bvar 0) := by + simp [ProjectionCode.instN, VExpr.inst, VExpr.instVar, + ← VExpr.lift_instN_lo, List.map_map, Function.comp_def] + have hmotive : + ((field.liftN 1 i).instRevAt + (previous.map fun code => + VExpr.app code.projector.lift (.bvar 0)) 0).inst a (k + 1) = + ((field.inst a (k + i)).liftN 1 i).instRevAt + ((previous.map fun code => code.instN a k).map fun code => + VExpr.app code.projector.lift (.bvar 0)) 0 := by + rw [VExpr.instN_instRevAt] + rw [List.length_map, hprevious, hfieldInst, hpreviousInst] + have hminorVar : + VExpr.instVar (allFields.length - 1 - i) a + (k + allFields.length) = + .bvar (allFields.length - 1 - i) := by + simp [VExpr.instVar, show + allFields.length - 1 - i < k + allFields.length by omega] + apply ProjectionCode.ext + · rfl + · simp [projectionCode, ProjectionCode.instN, VExpr.inst, hmotive] + · simp [projectionCode, ProjectionCode.instN, VExpr.inst, + VExpr.instN_lamN_projection, VExpr.instTelN_length, + hminorVar] + · simp [projectionCode, ProjectionCode.instN, VExpr.inst, + VExpr.instN_appN, VExpr.instN_lamN_projection, + VExpr.instTelN_length, ← VExpr.lift_instN_lo, + VExpr.instTelN_lift_projection, List.map_append, + List.map_map, Function.comp_def, hmotive, hminorVar] + +private def projectionCodes.go (view : VStructureView) + (levels : List VLevel) (params : List VExpr) + (allFields : List VExpr) (structType : VExpr) : + List VExpr → List VLevel → Nat → List ProjectionCode → + List ProjectionCode + | field :: fields, fieldSort :: fieldSorts, i, previous => + let code := projectionCode view levels params allFields structType + field fieldSort i previous + code :: projectionCodes.go view levels params allFields structType + fields fieldSorts (i + 1) (previous ++ [code]) + | _, _, _, _ => [] + +private theorem projectionCodes.go_instN (view : VStructureView) + (levels : List VLevel) (params allFields : List VExpr) + (structType : VExpr) (fields : List VExpr) + (fieldSorts : List VLevel) (i : Nat) + (previous : List ProjectionCode) (a : VExpr) (k : Nat) + (hprevious : previous.length = i) + (hfields : i + fields.length = allFields.length) : + (projectionCodes.go view levels params allFields structType + fields fieldSorts i previous).map + (fun code => code.instN a k) = + projectionCodes.go view levels + (params.map fun param => param.inst a k) + (VExpr.instTelN a allFields k) (structType.inst a k) + (VExpr.instTelN a fields (k + i)) fieldSorts i + (previous.map fun code => code.instN a k) := by + induction fields generalizing fieldSorts i previous with + | nil => + cases fieldSorts <;> simp [projectionCodes.go, VExpr.instTelN] + | cons field fields ih => + cases fieldSorts with + | nil => simp [projectionCodes.go] + | cons fieldSort fieldSorts => + have hi : i < allFields.length := by + simp only [List.length_cons] at hfields + omega + have hcode := projectionCode_instN view levels params allFields + structType field fieldSort i previous a k hprevious hi + simp only [projectionCodes.go, List.map_cons, + VExpr.instTelN] + rw [hcode] + congr 1 + have hprevious' : + (previous ++ [projectionCode view levels params allFields + structType field fieldSort i previous]).length = i + 1 := by + simp [hprevious] + have hfields' : i + 1 + fields.length = allFields.length := by + simp only [List.length_cons] at hfields + omega + simpa only [List.map_append, List.map_singleton, + hcode, Nat.add_assoc] using + ih fieldSorts (i + 1) + (previous ++ [projectionCode view levels params allFields + structType field fieldSort i previous]) + hprevious' hfields' + +private theorem projectionCode_instL (view : VStructureView) + (levels : List VLevel) (params allFields : List VExpr) + (structType field : VExpr) (fieldSort : VLevel) (i : Nat) + (previous : List ProjectionCode) (ls : List VLevel) : + (projectionCode view levels params allFields structType field + fieldSort i previous).instL ls = + projectionCode view + (levels.map (VLevel.inst ls)) + (params.map (VExpr.instL ls)) + (allFields.map (VExpr.instL ls)) + (structType.instL ls) (field.instL ls) (fieldSort.inst ls) i + (previous.map fun code => code.instL ls) := by + simp [projectionCode, ProjectionCode.instL, VExpr.instL, + VExpr.instL_instRevAt, VExpr.instL_lamN_projection, + VExpr.instL_appN, VExpr.instL_liftN, + List.map_append, List.map_map, Function.comp_def] + +private theorem projectionCodes.go_instL (view : VStructureView) + (levels : List VLevel) (params allFields : List VExpr) + (structType : VExpr) (fields : List VExpr) + (fieldSorts : List VLevel) (i : Nat) + (previous : List ProjectionCode) (ls : List VLevel) : + (projectionCodes.go view levels params allFields structType + fields fieldSorts i previous).map + (fun code => code.instL ls) = + projectionCodes.go view + (levels.map (VLevel.inst ls)) + (params.map (VExpr.instL ls)) + (allFields.map (VExpr.instL ls)) + (structType.instL ls) + (fields.map (VExpr.instL ls)) + (fieldSorts.map (VLevel.inst ls)) i + (previous.map fun code => code.instL ls) := by + induction fields generalizing fieldSorts i previous with + | nil => simp [projectionCodes.go] + | cons field fields ih => + cases fieldSorts with + | nil => simp [projectionCodes.go] + | cons fieldSort fieldSorts => + simp only [projectionCodes.go, List.map_cons, + projectionCode_instL] + congr 1 + simpa only [List.map_append, List.map_singleton, + projectionCode_instL] using + ih fieldSorts (i + 1) + (previous ++ [projectionCode view levels params allFields + structType field fieldSort i previous]) + +private theorem projectionCodes.go_liftN (view : VStructureView) + (levels : List VLevel) (params allFields : List VExpr) + (structType : VExpr) (fields : List VExpr) + (fieldSorts : List VLevel) (i : Nat) + (previous : List ProjectionCode) (n k : Nat) + (hprevious : previous.length = i) + (hfields : i + fields.length = allFields.length) : + (projectionCodes.go view levels params allFields structType + fields fieldSorts i previous).map + (fun code => code.liftN n k) = + projectionCodes.go view levels + (params.map fun param => param.liftN n k) + (VExpr.liftTelN n allFields k) (structType.liftN n k) + (VExpr.liftTelN n fields (k + i)) fieldSorts i + (previous.map fun code => code.liftN n k) := by + induction fields generalizing fieldSorts i previous with + | nil => + cases fieldSorts <;> simp [projectionCodes.go, VExpr.liftTelN] + | cons field fields ih => + cases fieldSorts with + | nil => simp [projectionCodes.go] + | cons fieldSort fieldSorts => + have hi : i < allFields.length := by + simp only [List.length_cons] at hfields + omega + have hcode := projectionCode_liftN view levels params allFields + structType field fieldSort i previous n k hprevious hi + simp only [projectionCodes.go, List.map_cons, + VExpr.liftTelN] + rw [hcode] + congr 1 + have hprevious' : + (previous ++ [projectionCode view levels params allFields + structType field fieldSort i previous]).length = i + 1 := by + simp [hprevious] + have hfields' : i + 1 + fields.length = allFields.length := by + simp only [List.length_cons] at hfields + omega + simpa only [List.map_append, List.map_singleton, + hcode, Nat.add_assoc] using + ih fieldSorts (i + 1) + (previous ++ [projectionCode view levels params allFields + structType field fieldSort i previous]) + hprevious' hfields' + +/-- All field projections, in constructor-field order. -/ +def projectionCodes (view : VStructureView) + (levels : List VLevel) (params : List VExpr) : List ProjectionCode := + let fields := view.specializedFields levels params + projectionCodes.go view levels params fields + (view.structureType levels params) fields + (view.fieldSorts.map (VLevel.inst levels)) 0 [] + +private theorem projectionCodes.go_length (view : VStructureView) + (levels : List VLevel) (params allFields : List VExpr) + (structType : VExpr) : + ∀ (fields : List VExpr) (fieldSorts : List VLevel) + (i : Nat) (previous : List ProjectionCode), + fields.length = fieldSorts.length → + (projectionCodes.go view levels params allFields structType + fields fieldSorts i previous).length = fields.length + | [], [], _, _, _ => rfl + | [], _ :: _, _, _, h => by simp at h + | _ :: _, [], _, _, h => by simp at h + | field :: fields, fieldSort :: fieldSorts, i, previous, h => by + simp only [List.length_cons] at h ⊢ + simp only [projectionCodes.go, List.length_cons] + exact congrArg Nat.succ <| + projectionCodes.go_length view levels params allFields structType + fields fieldSorts (i + 1) + (previous ++ [projectionCode view levels params allFields + structType field fieldSort i previous]) (Nat.succ.inj h) + +@[simp] theorem projectionCodes_length (view : VStructureView) + (levels : List VLevel) (params : List VExpr) : + (view.projectionCodes levels params).length = + (view.specializedFields levels params).length := by + apply projectionCodes.go_length + simp [VStructureView.specializedFields, VStructureView.fields, + view.fieldSorts_length] + +/-- Semantic arguments substituted while walking to a later dependent +projection field. -/ +def projectionArgs (view : VStructureView) (levels : List VLevel) + (params : List VExpr) (count : Nat) (major : VExpr) : List VExpr := + (view.projectionCodes levels params).take count |>.map fun code => + .app code.projector major + +@[simp] theorem projectionArgs_length (view : VStructureView) + (levels : List VLevel) (params : List VExpr) (count : Nat) + (major : VExpr) (hcount : count ≤ + (view.projectionCodes levels params).length) : + (view.projectionArgs levels params count major).length = count := by + simp only [projectionArgs, List.length_map, List.length_take] + exact Nat.min_eq_left hcount + +theorem projectionArgs_succ (view : VStructureView) + (levels : List VLevel) (params : List VExpr) (count : Nat) + (major : VExpr) {code : ProjectionCode} + (hcode : (view.projectionCodes levels params)[count]? = some code) : + view.projectionArgs levels params (count + 1) major = + view.projectionArgs levels params count major ++ + [.app code.projector major] := by + simp only [projectionArgs, List.take_add_one, hcode, Option.toList_some, + List.map_append, List.map_singleton] + +private theorem projectionCodes.go_get?_typeFn (view : VStructureView) + (levels : List VLevel) (params allFields : List VExpr) + (structType : VExpr) : + ∀ {fields : List VExpr} {fieldSorts : List VLevel} + {i : Nat} {previous : List ProjectionCode} {j : Nat} + {code : ProjectionCode}, + (projectionCodes.go view levels params allFields structType + fields fieldSorts i previous)[j]? = some code → + ∃ field, + fields[j]? = some field ∧ + code.typeFn = .lam structType + ((field.liftN 1 (i + j)).instRevAt + ((previous ++ + (projectionCodes.go view levels params allFields structType + fields fieldSorts i previous).take j).map fun prior => + .app prior.projector.lift (.bvar 0)) 0) := by + intro fields + induction fields with + | nil => + intro fieldSorts i previous j code h + cases fieldSorts <;> simp [projectionCodes.go] at h + | cons field fields ih => + intro fieldSorts i previous j code h + cases fieldSorts with + | nil => simp [projectionCodes.go] at h + | cons fieldSort fieldSorts => + let head := projectionCode view levels params allFields structType + field fieldSort i previous + cases j with + | zero => + change some head = some code at h + injection h with hcode + subst code + refine ⟨field, rfl, ?_⟩ + simp [head, projectionCode] + | succ j => + simp only [projectionCodes.go, List.getElem?_cons_succ] at h + obtain ⟨tailField, htailField, htypeFn⟩ := + ih (fieldSorts := fieldSorts) (i := i + 1) + (previous := previous ++ [head]) h + refine ⟨tailField, by simpa using htailField, ?_⟩ + have hpref : + previous ++ + (projectionCodes.go view levels params allFields structType + (field :: fields) (fieldSort :: fieldSorts) i previous).take + (j + 1) = + (previous ++ [head]) ++ + (projectionCodes.go view levels params allFields structType + fields fieldSorts (i + 1) + (previous ++ [head])).take j := by + simp [head, projectionCodes.go, List.take, + List.append_assoc] + rw [hpref] + simpa only [Nat.add_assoc, Nat.add_comm, + Nat.add_left_comm] using htypeFn + +/-- The generated type function at field `idx` is the corresponding +specialized constructor field with all earlier generated projectors +substituted at the major premise. -/ +theorem projectionCodes_get?_typeFn (view : VStructureView) + (levels : List VLevel) (params : List VExpr) {idx : Nat} + {code : ProjectionCode} + (hcode : (view.projectionCodes levels params)[idx]? = some code) : + ∃ field, + (view.specializedFields levels params)[idx]? = some field ∧ + code.typeFn = .lam (view.structureType levels params) + ((field.liftN 1 idx).instRevAt + ((view.projectionCodes levels params).take idx |>.map fun prior => + .app prior.projector.lift (.bvar 0)) 0) := by + unfold projectionCodes at hcode ⊢ + simpa using projectionCodes.go_get?_typeFn view levels params + (view.specializedFields levels params) + (view.structureType levels params) hcode + +/-- Applying a generated projection's type function to its major premise +substitutes that major into every earlier generated projector. -/ +theorem projectionCodes_get?_typeFn_beta (view : VStructureView) + (levels : List VLevel) (params : List VExpr) {idx : Nat} + {code : ProjectionCode} + (hcode : (view.projectionCodes levels params)[idx]? = some code) + (major : VExpr) : + ∃ field typeBody, + (view.specializedFields levels params)[idx]? = some field ∧ + code.typeFn = .lam (view.structureType levels params) typeBody ∧ + typeBody.inst major = + field.instRevAt + ((view.projectionCodes levels params).take idx |>.map fun prior => + .app prior.projector major) 0 := by + obtain ⟨field, hfield, htypeFn⟩ := + view.projectionCodes_get?_typeFn levels params hcode + let codes := view.projectionCodes levels params + have hidx : idx < codes.length := + (List.getElem?_eq_some_iff.1 hcode).1 + have htake : (codes.take idx).length = idx := by + simp [List.length_take, Nat.min_eq_left (Nat.le_of_lt hidx)] + have htake' : + ((view.projectionCodes levels params).take idx).length = idx := by + simpa [codes] using htake + refine ⟨field, _, hfield, htypeFn, ?_⟩ + rw [VExpr.instN_instRevAt] + rw [List.length_map, htake'] + simp only [Nat.zero_add, VExpr.inst_liftN1] + congr 1 + induction (view.projectionCodes levels params).take idx with + | nil => rfl + | cons prior previous ih => + simp only [List.map_cons] + rw [ih] + simp only [VExpr.inst, VExpr.inst_lift, VExpr.instVar_zero] + +@[simp] theorem projectionCodes_instL (view : VStructureView) + (levels : List VLevel) (params : List VExpr) (ls : List VLevel) : + (view.projectionCodes levels params).map + (fun code => code.instL ls) = + view.projectionCodes (levels.map (VLevel.inst ls)) + (params.map (VExpr.instL ls)) := by + simp [projectionCodes, projectionCodes.go_instL, + VLevel.inst_inst, List.map_map, Function.comp_def] + +/-- The dependent result type of projection `idx`, applied to `major`. -/ +def projectionType? (view : VStructureView) + (levels : List VLevel) (params : List VExpr) + (idx : Nat) (major : VExpr) : Option VExpr := do + let code ← (view.projectionCodes levels params)[idx]? + return .app code.typeFn major + +/-- The recursor encoding of projection `idx`, applied to `major`. -/ +def project? (view : VStructureView) + (levels : List VLevel) (params : List VExpr) + (idx : Nat) (major : VExpr) : Option VExpr := do + let code ← (view.projectionCodes levels params)[idx]? + return .app code.projector major + +/-- A proof-carrying boundary for the programs generated by +`projectionCodes`. Generation fixes the program syntax, while this +certificate records the remaining semantic fact needed by consumers: every +selected projector is well typed at every well-formed instantiation. + +This is intentionally separate from `VStructureView.WF`. The latter is the +certificate produced by ordinary inductive generation; accepting primitive +projection syntax is a later capability boundary and must not silently add a +structure-eta rule to Theory's definitional equality. -/ +def ProgramsWF (view : VStructureView) (env : VEnv) : Prop := + ∀ {U : Nat} {Γ : List VExpr} {levels : List VLevel} + {params : List VExpr} {idx : Nat} {code : ProjectionCode}, + OnCtx Γ (env.IsType U) → + (∀ level ∈ levels, level.WF U) → + levels.length = view.uvars → + params.length = view.nparams → + (∃ resultLevel, env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel)) → + (view.projectionCodes levels params)[idx]? = some code → + env.HasType U Γ code.projector + (.forallE (view.structureType levels params) + (.app code.typeFn.lift (.bvar 0))) + +/-- A certified projector is typed by the exact constructor-telescope domain +exposed after substituting all earlier projections. -/ +theorem ProgramsWF.projector_hasType_field + {view : VStructureView} {env : VEnv} + (self : view.ProgramsWF env) (henv : env.WF) + {U : Nat} {Γ : List VExpr} {levels : List VLevel} + {params : List VExpr} {idx : Nat} {code : ProjectionCode} + (hΓ : OnCtx Γ (env.IsType U)) + (hlevels : ∀ level ∈ levels, level.WF U) + (hlevelsLength : levels.length = view.uvars) + (hparamsLength : params.length = view.nparams) + (hparamsSpine : ∃ resultLevel, + env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel)) + (hcode : (view.projectionCodes levels params)[idx]? = some code) + {major : VExpr} + (hmajor : env.HasType U Γ major (view.structureType levels params)) : + ∃ field typeBody, + (view.specializedFields levels params)[idx]? = some field ∧ + code.typeFn = .lam (view.structureType levels params) typeBody ∧ + env.HasType U Γ (.app code.projector major) + (field.instRevAt (view.projectionArgs levels params idx major) 0) := by + obtain ⟨field, typeBody, hfield, htypeFn, htypeBody⟩ := + view.projectionCodes_get?_typeFn_beta levels params hcode major + have hprojector := self hΓ hlevels hlevelsLength hparamsLength + hparamsSpine hcode + have happ : env.HasType U Γ (.app code.projector major) + (.app code.typeFn major) := by + simpa only [VExpr.inst, VExpr.inst_lift, VExpr.instVar_zero] using + hprojector.app hmajor + rw [htypeFn] at happ + obtain ⟨sortLevel, hredexType⟩ := happ.isType henv hΓ + obtain ⟨A, B, hlam, harg⟩ := hredexType.app_inv henv hΓ + obtain ⟨⟨_, hstructType⟩, _, hbodyType⟩ := + hlam.lam_inv henv hΓ + have hfunTypeEq := hlam.uniqU henv hΓ + (hstructType.lam hbodyType) + obtain ⟨⟨_, hdomainEq⟩, _⟩ := + hfunTypeEq.forallE_inv henv hΓ + have harg' := harg.defeqU_r henv hΓ ⟨_, hdomainEq⟩ + have hbeta : env.IsDefEqU U Γ + (.app (.lam (view.structureType levels params) typeBody) major) + (typeBody.inst major) := + ⟨_, VEnv.IsDefEq.beta hbodyType harg'⟩ + have hout := happ.defeqU_r henv hΓ hbeta + rw [htypeBody] at hout + refine ⟨field, typeBody, hfield, htypeFn, ?_⟩ + simpa [projectionArgs] using hout + +/-- Exact registration of the checked structure artifact in a Theory +environment. These are concrete lookups and generated iota rules, not an +oracle supplied by a projection consumer. -/ +structure Registered (view : VStructureView) (env : VEnv) : Prop where + family : env.constants view.name = + some view.generation.block.sourceType.toVConstant + constructor : env.constants view.constructorName = + some view.constructor.raw.toVConstant + recursor : env.constants view.recursorName = + some view.generation.recursor + rules : ∀ rule ∈ view.generation.generatedRules, env.defeqs rule + +/-- The semantic fragment of `GenerationEnv` that remains monotone under an +arbitrary environment extension. Ordering is supplied by the structural-law +caller; exact constant/rule registration is carried separately by +`Registered`. -/ +structure GenerationSemantics (view : VStructureView) (env : VEnv) : Prop where + checked : view.generation.block.checked.WF env + familyTelescope : + env.TelDefEq view.uvars [] + (view.generation.block.rawParams ++ + view.generation.block.rawIndices) + (view.generation.block.checked.params ++ + view.generation.block.checked.indices) + familyResult : + env.IsDefEq view.uvars + (view.generation.block.rawParams ++ + view.generation.block.rawIndices).reverse + view.generation.block.rawResult + (.sort view.generation.block.checked.resultLevel) + (.sort (.succ view.generation.block.checked.resultLevel)) + constructor : view.constructor.WF view.generation.block env + +/-- Semantic well-formedness of one structure view in its registered +environment. The retained sort list is checked against the exact raw +dependent field telescope. -/ +structure WF (view : VStructureView) (env : VEnv) : Prop + extends VStructureView.Registered view env where + generationSemantics : VStructureView.GenerationSemantics view env + parameters : env.OnTel view.uvars [] + view.generation.block.checked.params + parameters_length : + view.generation.block.checked.params.length = view.nparams + fieldTelescope : env.OnSortTel view.uvars + view.generation.block.checked.params.reverse + view.fields view.fieldSorts + smallFields : view.generation.elimination = .small → + ∀ level ∈ view.fieldSorts, level = .zero + +theorem WF.rule_mem (self : VStructureView.WF view env) {df : VDefEq} + (h : df ∈ VInductDecl.GenerationChecked.generatedRules view.generation) : + VEnv.defeqs env df := + self.rules df h + +theorem Registered.mono {env env' : VEnv} (henv : env ≤ env') + (self : VStructureView.Registered view env) : + VStructureView.Registered view env' where + family := henv.1 self.family + constructor := henv.1 self.constructor + recursor := henv.1 self.recursor + rules := fun rule hrule => henv.2 (self.rules rule hrule) + +theorem GenerationSemantics.mono {env env' : VEnv} (henv : env ≤ env') + (self : VStructureView.GenerationSemantics view env) : + VStructureView.GenerationSemantics view env' where + checked := self.checked.mono henv + familyTelescope := self.familyTelescope.mono henv + familyResult := self.familyResult.mono henv + constructor := self.constructor.mono henv + +/-- Recover the monotone semantic fragment of a generated structure from the +ordinary generation certificate and the exact successful transaction trace. -/ +theorem GenerationSemantics.ofGenerationTrace {pre env : VEnv} + (hgen : view.generation.WF pre) + (trace : VEnv.AddInductGenerationTrace pre env view.generation) : + VStructureView.GenerationSemantics view env := by + have htypeFinal : trace.typeEnv ≤ env := by + have hctors := + (ctorFold_spec view.generation.block.sourceType.ctors + trace.addCtors).1 + have hrec := VEnv.addConst_le trace.addRec + have hrules : trace.recEnv ≤ env := by + simpa only [trace.addRules] using + (rulesFold_spec view.generation.generatedRules trace.recEnv).1 + exact hctors.trans (hrec.trans hrules) + have hpreFinal := trace.le + refine { + checked := hgen.blockWF.2.mono hpreFinal + familyTelescope := hgen.familyTel.mono hpreFinal + familyResult := hgen.familyResult.mono hpreFinal + constructor := ?_ } + have hconstructor : + view.constructor ∈ view.generation.block.ctorPairs := by + simp [view.constructor_eq] + exact (hgen.ctors trace.typeEnv trace.addType view.constructor + hconstructor).mono htypeFinal + +theorem WF.mono {env env' : VEnv} (henv : env ≤ env') + (self : VStructureView.WF view env) : VStructureView.WF view env' where + toRegistered := self.toRegistered.mono henv + generationSemantics := self.generationSemantics.mono henv + parameters := self.parameters.monoProjection henv + parameters_length := self.parameters_length + fieldTelescope := self.fieldTelescope.mono henv + smallFields := self.smallFields + +/-- Reassemble the standard generated-artifact invariant when an ordered +environment is available. -/ +theorem WF.toGenerationEnv (self : VStructureView.WF view env) + (henv : env.Ordered) : + VInductDecl.GenerationEnv view.generation env where + ord := henv + checked := self.generationSemantics.checked + familyTel := self.generationSemantics.familyTelescope + familyResult := self.generationSemantics.familyResult + ctorWF := by + intro ctor hctor + rw [view.constructor_eq] at hctor + simp only [List.mem_singleton] at hctor + subst ctor + exact self.generationSemantics.constructor + familyConst := self.family + ctorConst := by + intro ctor hctor + rw [view.constructor_eq] at hctor + simp only [List.mem_singleton] at hctor + subst ctor + exact self.constructor + +theorem WF.field_closed (self : VStructureView.WF view env) + (henv : env.Ordered) {i : Nat} {field : VExpr} + (hfield : view.fields[i]? = some field) : + field.ClosedN (view.nparams + i) := by + have hparamsCtx : OnCtx + view.generation.block.checked.params.reverse + (env.IsType view.uvars) := + by simpa using VEnv.OnTel.toOnCtx self.parameters (by trivial) + have hclosed := VEnv.OnSortTel.closedAt henv self.fieldTelescope + (VEnv.CtxWF.closed henv hparamsCtx) hfield + simpa [self.parameters_length] using hclosed + +theorem WF.specializedFields_liftN + (self : VStructureView.WF view env) (henv : env.Ordered) + (levels : List VLevel) (params : List VExpr) + (hparams : params.length = view.nparams) (n k : Nat) : + view.specializedFields levels + (params.map fun param => param.liftN n k) = + VExpr.liftTelN n (view.specializedFields levels params) k := by + simpa [specializedFields] using + specializedFieldsAux_liftN view.fields levels params view.nparams + 0 n k hparams + (fun j field hfield => by + simpa using self.field_closed henv hfield) + +theorem WF.specializedFields_instN + (self : VStructureView.WF view env) (henv : env.Ordered) + (levels : List VLevel) (params : List VExpr) + (hparams : params.length = view.nparams) (a : VExpr) (k : Nat) : + view.specializedFields levels + (params.map fun param => param.inst a k) = + VExpr.instTelN a (view.specializedFields levels params) k := by + simpa [specializedFields] using + specializedFieldsAux_instN view.fields levels params view.nparams + 0 k a hparams + (fun j field hfield => by + simpa using self.field_closed henv hfield) + +private theorem projectionLevels_length (view : VStructureView) + (fieldSort : VLevel) (levels : List VLevel) + (hlevels : levels.length = view.uvars) : + (view.projectionLevels fieldSort levels).length = + view.generation.recUvars := by + unfold projectionLevels + cases h : view.generation.elimination <;> + simp [VInductDecl.GenerationChecked.recUvars, + VInductDecl.ElimMode.recUvars, h, hlevels] + +private theorem projectionLevels_wf (view : VStructureView) + {U : Nat} (fieldSort : VLevel) (levels : List VLevel) + (hfieldSort : fieldSort.WF U) + (hlevels : ∀ level ∈ levels, level.WF U) : + ∀ level ∈ view.projectionLevels fieldSort levels, level.WF U := by + unfold projectionLevels + cases view.generation.elimination <;> simp_all + +private theorem sourceLevels_projectionLevels (view : VStructureView) + (fieldSort : VLevel) (levels : List VLevel) + (hlevels : levels.length = view.uvars) : + view.generation.sourceLevels.map + (VLevel.inst (view.projectionLevels fieldSort levels)) = levels := by + unfold VInductDecl.GenerationChecked.sourceLevels + unfold VInductDecl.ElimMode.sourceLevels projectionLevels + cases h : view.generation.elimination + · + change (VLevel.params' view.uvars 1).map + (VLevel.inst (fieldSort :: levels)) = levels + have hshift : + (VLevel.params' view.uvars 1).map + (VLevel.inst (fieldSort :: levels)) = + (VLevel.params view.uvars).map (VLevel.inst levels) := by + simp [VLevel.params', VLevel.params, List.map_map, + Function.comp_def, VLevel.inst, + List.getD_eq_getElem?_getD] + rw [hshift] + exact VLevel.inst_map_id hlevels + · + change (VLevel.params' view.uvars 0).map + (VLevel.inst levels) = levels + have hzero : VLevel.params' view.uvars 0 = + VLevel.params view.uvars := by + simp [VLevel.params', VLevel.params] + rw [hzero] + exact VLevel.inst_map_id hlevels + +private theorem motiveLevel_projectionLevels (view : VStructureView) + (fieldSort : VLevel) (levels : List VLevel) : + view.generation.motiveLevel.inst + (view.projectionLevels fieldSort levels) = + match view.generation.elimination with + | .large => fieldSort + | .small => .zero := by + unfold VInductDecl.GenerationChecked.motiveLevel + unfold VInductDecl.ElimMode.motiveLevel projectionLevels + cases view.generation.elimination <;> rfl + +private theorem WF.motiveLevel_projectionLevels + (self : VStructureView.WF view env) + (fieldSort : VLevel) (hfieldSort : fieldSort ∈ view.fieldSorts) + (levels : List VLevel) : + view.generation.motiveLevel.inst + (view.projectionLevels (fieldSort.inst levels) levels) = + fieldSort.inst levels := by + rw [VStructureView.motiveLevel_projectionLevels] + cases hmode : view.generation.elimination with + | large => rfl + | small => + rw [self.smallFields hmode fieldSort hfieldSort] + rfl + +@[simp] theorem WF.projectionCodes_liftN + (self : VStructureView.WF view env) (henv : env.Ordered) + (levels : List VLevel) (params : List VExpr) + (hparams : params.length = view.nparams) (n k : Nat) : + (view.projectionCodes levels params).map + (fun code => code.liftN n k) = + view.projectionCodes levels + (params.map fun param => param.liftN n k) := by + unfold projectionCodes + rw [self.specializedFields_liftN henv levels params hparams n k] + rw [← structureType_liftN] + apply projectionCodes.go_liftN + · rfl + · simp [VExpr.liftTelN_length] + +@[simp] theorem WF.projectionCodes_instN + (self : VStructureView.WF view env) (henv : env.Ordered) + (levels : List VLevel) (params : List VExpr) + (hparams : params.length = view.nparams) (a : VExpr) (k : Nat) : + (view.projectionCodes levels params).map + (fun code => code.instN a k) = + view.projectionCodes levels + (params.map fun param => param.inst a k) := by + unfold projectionCodes + rw [self.specializedFields_instN henv levels params hparams a k] + rw [← structureType_instN] + apply projectionCodes.go_instN + · rfl + · simp [VExpr.instTelN_length] + +end VStructureView + +namespace VEnv + +private theorem SpineWF.monoProjection {env env' : VEnv} + (henv : env ≤ env') : + ∀ {A es B}, env.SpineWF U Γ A es B → env'.SpineWF U Γ A es B + | _, [], _, h => h + | _, _ :: _, _, ⟨A₁, A₂, rfl, he, hrest⟩ => + ⟨A₁, A₂, rfl, he.mono henv, SpineWF.monoProjection henv hrest⟩ + +/-- The view-facing direction of `TelDefEq.spine_sort`: arguments checked +against the retained raw telescope also consume its definitionally equal +view telescope. -/ +theorem TelDefEq.spine_sort_view + {env : VEnv} {U : Nat} (henv : env.Ordered) : + ∀ {Γ As As' es l}, env.TelDefEq U Γ As As' → + env.SpineWF U Γ (VExpr.forallN As (.sort l)) es (.sort l) → + es.length = As.length → + env.SpineWF U Γ (VExpr.forallN As' (.sort l)) es (.sort l) + | _, [], [], [], _, _, hspine, _ => by simpa using hspine + | _, [], [], _ :: _, _, _, _, hlen => by simp at hlen + | Γ, A :: As, A' :: As', e :: es, l, ⟨⟨_, hA⟩, hT⟩, + ⟨D, C, hshape, he, hrest⟩, hlen => by + change VExpr.forallE A (VExpr.forallN As (.sort l)) = + VExpr.forallE D C at hshape + injection hshape with hD hC + subst D + subst C + have heView : env.HasType U Γ e A' := hA.defeq he + have hTinst := TelDefEq.instN henv he (.zero) hT + have hrest' : env.SpineWF U Γ + (VExpr.forallN (VExpr.instTelN e As 0) (.sort l)) + es (.sort l) := by + simpa [VExpr.instN_forallN, VExpr.inst] using hrest + have hlen' : es.length = As.length := by simpa using hlen + have hlenInst : + es.length = (VExpr.instTelN e As 0).length := by + rw [VExpr.instTelN_length] + exact hlen' + have hout := TelDefEq.spine_sort_view henv + hTinst hrest' hlenInst + refine ⟨A', VExpr.forallN As' (.sort l), rfl, heView, ?_⟩ + simpa [VExpr.instN_forallN, VExpr.inst] using hout + +/-- Parameters accepted by the structure family also consume the stored raw +constructor parameter prefix. This is the semantic bridge used by the +kernel projection checker before it traverses the constructor fields. -/ +theorem _root_.Lean4Lean.VStructureView.WF.constructorParamsSpine + (self : VStructureView.WF view env) (henv : env.Ordered) + {U : Nat} {Γ : List VExpr} (levels : List VLevel) + (hlevels : ∀ level ∈ levels, level.WF U) + (hlevelsLength : levels.length = view.uvars) + (params : List VExpr) (hparamsLength : params.length = view.nparams) + (paramsSpine : ∃ resultLevel, + env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel)) + (target : VExpr) : + env.SpineWF U Γ + (VExpr.forallN + (view.constructorParams.map (VExpr.instL levels)) + target) params (VExpr.instRev target params) := by + let S := self.toGenerationEnv henv + obtain ⟨resultLevel, hspine⟩ := paramsSpine + have hrawLength : + view.generation.block.rawParams.length = view.nparams := + view.generation.shape.1 + have hspineShape : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.rawParams.map (VExpr.instL levels)) + (view.generation.block.rawResult.instL levels)) + params (.sort resultLevel) := by + simpa [VStructureView.familyType, + VInductDecl.NormalizedChecked.rawType_eq, + view.raw_indices_eq, VExpr.instL_forallN, + VExpr.forallN] using hspine + have hparamsRaw : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.rawParams.map (VExpr.instL levels)) + (.sort .zero)) params (.sort .zero) := by + have hout := hspineShape.retarget + (by simpa [hrawLength] using hparamsLength) (.sort .zero) + rw [VExpr.instRev_closedN params (by trivial)] at hout + exact hout + have hfamilyDefEq := S.rawParams_defeq.instL hlevels + have hrawLift : VExpr.liftTelN Γ.length + (view.generation.block.rawParams.map (VExpr.instL levels)) 0 = + view.generation.block.rawParams.map (VExpr.instL levels) := by + simpa using VEnv.OnTel.liftTelN_eq henv + hfamilyDefEq.raw_onTel (by trivial) Γ.length + have hcheckedLift : VExpr.liftTelN Γ.length + (view.generation.block.checked.params.map (VExpr.instL levels)) 0 = + view.generation.block.checked.params.map (VExpr.instL levels) := by + simpa using VEnv.OnTel.liftTelN_eq henv + (hfamilyDefEq.view_onTel henv) (by trivial) Γ.length + have hfamilyDefEqΓ := hfamilyDefEq.weakN henv + (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ) + rw [hrawLift, hcheckedLift] at hfamilyDefEqΓ + simp only [List.append_nil] at hfamilyDefEqΓ + have hparamsChecked : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.checked.params.map (VExpr.instL levels)) + (.sort .zero)) params (.sort .zero) := + TelDefEq.spine_sort_view henv hfamilyDefEqΓ hparamsRaw + (by simpa [hrawLength] using hparamsLength) + have hconstructorMem : + view.constructor ∈ view.generation.block.ctorPairs := by + simp [view.constructor_eq] + have hconstructorShape := + view.generation.shape.2.2.2.2.2 view.constructor hconstructorMem + have hconstructorDefEq₀ := + ((S.ctorWF view.constructor hconstructorMem).declaredTel.take + view.nparams).instL hlevels + have hconstructorDefEq : env.TelDefEq U [] + (view.constructorParams.map (VExpr.instL levels)) + (view.generation.block.checked.params.map (VExpr.instL levels)) := by + simpa [VStructureView.constructorParams, + VInductDecl.NormalizedCtor.declaredBinders, + VInductDecl.NormalizedCtor.viewBinders, + hconstructorShape.2.2.1, self.parameters_length] using + hconstructorDefEq₀ + have hconstructorRawLift : VExpr.liftTelN Γ.length + (view.constructorParams.map (VExpr.instL levels)) 0 = + view.constructorParams.map (VExpr.instL levels) := by + simpa using VEnv.OnTel.liftTelN_eq henv + hconstructorDefEq.raw_onTel (by trivial) Γ.length + have hconstructorCheckedLift : VExpr.liftTelN Γ.length + (view.generation.block.checked.params.map (VExpr.instL levels)) 0 = + view.generation.block.checked.params.map (VExpr.instL levels) := + hcheckedLift + have hconstructorDefEqΓ := hconstructorDefEq.weakN henv + (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ) + rw [hconstructorRawLift, hconstructorCheckedLift] at hconstructorDefEqΓ + simp only [List.append_nil] at hconstructorDefEqΓ + have hout := TelDefEq.spine_sort henv hconstructorDefEqΓ hparamsChecked + (by simpa [VStructureView.constructorParams] using + hparamsLength.trans hconstructorShape.2.2.1.symm) + exact hout.retarget + (by simpa [VStructureView.constructorParams] using + hparamsLength.trans hconstructorShape.2.2.1.symm) target + +theorem _root_.Lean4Lean.VStructureView.WF.specializedFields_onSortTel + (self : VStructureView.WF view env) (henv : env.Ordered) + {U : Nat} {Γ : List VExpr} (levels : List VLevel) + (hlevels : ∀ level ∈ levels, level.WF U) + (hlevelsLength : levels.length = view.uvars) + (params : List VExpr) (hparamsLength : params.length = view.nparams) + (paramsSpine : ∃ resultLevel, + env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel)) : + env.OnSortTel U Γ (view.specializedFields levels params) + (view.fieldSorts.map (VLevel.inst levels)) := by + let S := self.toGenerationEnv henv + obtain ⟨resultLevel, hspine⟩ := paramsSpine + have hrawLength : + view.generation.block.rawParams.length = view.nparams := + view.generation.shape.1 + have hspineShape : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.rawParams.map (VExpr.instL levels)) + (view.generation.block.rawResult.instL levels)) + params (.sort resultLevel) := by + simpa [VStructureView.familyType, + VInductDecl.NormalizedChecked.rawType_eq, + view.raw_indices_eq, VExpr.instL_forallN, + VExpr.forallN] using hspine + have hparamsRaw : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.rawParams.map (VExpr.instL levels)) + (.sort resultLevel)) params (.sort resultLevel) := by + have hout := hspineShape.retarget + (by simpa [hrawLength] using hparamsLength) + (.sort resultLevel) + rw [VExpr.instRev_closedN params (by trivial)] at hout + exact hout + have hrawChecked := S.rawParams_defeq.instL hlevels + have hrawLift := VEnv.OnTel.liftTelN_eq henv + hrawChecked.raw_onTel (by trivial) Γ.length + have hcheckedLift := VEnv.OnTel.liftTelN_eq henv + (hrawChecked.view_onTel henv) (by trivial) Γ.length + have hrawLift' : VExpr.liftTelN Γ.length + (view.generation.block.rawParams.map (VExpr.instL levels)) 0 = + view.generation.block.rawParams.map (VExpr.instL levels) := by + simpa using hrawLift + have hcheckedLift' : VExpr.liftTelN Γ.length + (view.generation.block.checked.params.map (VExpr.instL levels)) 0 = + view.generation.block.checked.params.map (VExpr.instL levels) := by + simpa using hcheckedLift + have hrawCheckedΓ := hrawChecked.weakN henv + (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ) + rw [hrawLift', hcheckedLift'] at hrawCheckedΓ + simp only [List.append_nil] at hrawCheckedΓ + have hparamsChecked : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.checked.params.map + (VExpr.instL levels)) (.sort resultLevel)) + params (.sort resultLevel) := by + exact TelDefEq.spine_sort_view henv hrawCheckedΓ hparamsRaw + (by simpa [hrawLength] using hparamsLength) + have hfields := self.fieldTelescope.instL hlevels + have hcheckedParams := self.parameters.instL hlevels + have Wparams := Ctx.LiftN.consTel + (view.generation.block.checked.params.map (VExpr.instL levels)) + (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ) + rw [hcheckedLift'] at Wparams + have hcheckedCtx : OnCtx + (view.generation.block.checked.params.reverse.map + (VExpr.instL levels)) (env.IsType U) := by + simpa [List.map_reverse] using + VEnv.OnTel.toOnCtx hcheckedParams (by trivial) + have hfieldLift := VEnv.OnSortTel.liftTelN_eq henv hfields + (VEnv.CtxWF.closed henv hcheckedCtx) Γ.length + have hfieldsΓ := VEnv.OnSortTel.weakN henv + (by simpa [List.map_reverse] using Wparams) hfields + simp only [List.length_reverse, List.length_map] at hfieldLift + rw [hfieldLift] at hfieldsΓ + have hspecialized := VEnv.OnSortTel.instRevParams henv + hparamsChecked (by simpa [self.parameters_length] using hparamsLength) + (by simpa [List.map_reverse] using hfieldsΓ) + rw [VExpr.instRevAt_map_instL_zipIdx] at hspecialized + simpa [VStructureView.specializedFields] using hspecialized + +private theorem _root_.Lean4Lean.VStructureView.WF.generationParamsSpine + (self : VStructureView.WF view env) (henv : env.Ordered) + {U : Nat} {Γ : List VExpr} (levels : List VLevel) + (hlevels : ∀ level ∈ levels, level.WF U) + (hlevelsLength : levels.length = view.uvars) + (params : List VExpr) (hparamsLength : params.length = view.nparams) + (paramsSpine : ∃ resultLevel, + env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel)) + (fieldSort : VLevel) : + env.SpineWF U Γ + (VExpr.forallN + (view.generation.paramsTel.map + (VExpr.instL + (view.projectionLevels fieldSort levels))) + (.sort fieldSort)) params (.sort fieldSort) := by + let S := self.toGenerationEnv henv + obtain ⟨resultLevel, hspine⟩ := paramsSpine + have hrawLength : + view.generation.block.rawParams.length = view.nparams := + view.generation.shape.1 + have hspineShape : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.rawParams.map (VExpr.instL levels)) + (view.generation.block.rawResult.instL levels)) + params (.sort resultLevel) := by + simpa [VStructureView.familyType, + VInductDecl.NormalizedChecked.rawType_eq, + view.raw_indices_eq, VExpr.instL_forallN, + VExpr.forallN] using hspine + have hparamsRaw : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.rawParams.map (VExpr.instL levels)) + (.sort fieldSort)) params (.sort fieldSort) := by + have hout := hspineShape.retarget + (by simpa [hrawLength] using hparamsLength) (.sort fieldSort) + rw [VExpr.instRev_closedN params (by trivial)] at hout + exact hout + have hrawChecked := S.rawParams_defeq.instL hlevels + have hrawLift : VExpr.liftTelN Γ.length + (view.generation.block.rawParams.map (VExpr.instL levels)) 0 = + view.generation.block.rawParams.map (VExpr.instL levels) := by + simpa using VEnv.OnTel.liftTelN_eq henv + hrawChecked.raw_onTel (by trivial) Γ.length + have hcheckedLift : VExpr.liftTelN Γ.length + (view.generation.block.checked.params.map (VExpr.instL levels)) 0 = + view.generation.block.checked.params.map (VExpr.instL levels) := by + simpa using VEnv.OnTel.liftTelN_eq henv + (hrawChecked.view_onTel henv) (by trivial) Γ.length + have hrawCheckedΓ := hrawChecked.weakN henv + (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ) + rw [hrawLift, hcheckedLift] at hrawCheckedΓ + simp only [List.append_nil] at hrawCheckedΓ + have hparamsChecked : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.checked.params.map + (VExpr.instL levels)) (.sort fieldSort)) + params (.sort fieldSort) := + TelDefEq.spine_sort_view henv hrawCheckedΓ hparamsRaw + (by simpa [hrawLength] using hparamsLength) + have hgenerationChecked := S.generationParams_defeq.instL hlevels + have hgenerationLift : VExpr.liftTelN Γ.length + (view.generation.block.generationParams.map + (VExpr.instL levels)) 0 = + view.generation.block.generationParams.map + (VExpr.instL levels) := by + simpa using VEnv.OnTel.liftTelN_eq henv + hgenerationChecked.raw_onTel (by trivial) Γ.length + have hcheckedLift₂ : VExpr.liftTelN Γ.length + (view.generation.block.checked.params.map + (VExpr.instL levels)) 0 = + view.generation.block.checked.params.map + (VExpr.instL levels) := hcheckedLift + have hgenerationCheckedΓ := hgenerationChecked.weakN henv + (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ) + rw [hgenerationLift, hcheckedLift₂] at hgenerationCheckedΓ + simp only [List.append_nil] at hgenerationCheckedΓ + have hparamsGeneration := TelDefEq.spine_sort henv + hgenerationCheckedΓ hparamsChecked + (by simpa [S.generationParams_length] using hparamsLength) + have hsource := VStructureView.sourceLevels_projectionLevels + view fieldSort levels + hlevelsLength + have hparamsTel : + view.generation.paramsTel.map + (VExpr.instL (view.projectionLevels fieldSort levels)) = + view.generation.block.generationParams.map + (VExpr.instL levels) := by + simp [VInductDecl.GenerationChecked.paramsTel, + List.map_map, Function.comp_def, VExpr.instL_instL, hsource] + rw [hparamsTel] + exact hparamsGeneration + +theorem _root_.Lean4Lean.VStructureView.WF.recursorProjection_hasType + (self : VStructureView.WF view env) (henv : env.Ordered) + {U : Nat} {Γ : List VExpr} (levels : List VLevel) + (hlevels : ∀ level ∈ levels, level.WF U) + (hlevelsLength : levels.length = view.uvars) + (params : List VExpr) (hparamsLength : params.length = view.nparams) + (paramsSpine : ∃ resultLevel, + env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel)) + (fieldSort : VLevel) + (hfieldSort : fieldSort.WF U) + (hmotiveLevel : + view.generation.motiveLevel.inst + (view.projectionLevels fieldSort levels) = fieldSort) + (structIsType : env.IsType U Γ + (view.structureType levels params)) + {typeFn minor major : VExpr} + (typeFnType : env.HasType U Γ typeFn + (.forallE (view.structureType levels params) (.sort fieldSort))) + (minorType : env.HasType U Γ minor + (view.projectionMinorType levels params + (view.specializedFields levels params) typeFn)) + (majorType : env.HasType U Γ major + (view.structureType levels params)) : + env.HasType U Γ + (VExpr.appN (.const view.recursorName + (view.projectionLevels fieldSort levels)) + (params ++ [typeFn, minor, major])) + (.app typeFn major) := by + let gen := view.generation + let S := self.toGenerationEnv henv + let pLevels := view.projectionLevels fieldSort levels + let k := gen.block.ctorPairs.length + let ni := gen.idxTel.length + let recRest : VExpr := + VExpr.forallN gen.minorTypes <| + VExpr.forallN (VExpr.liftTelN (k + 1) gen.idxTel 0) <| + .forallE + (VExpr.appN (.const gen.block.sourceType.name gen.sourceLevels) + (VExpr.bvarRevRange (ni + k + 1) view.nparams ++ + VExpr.bvarRevRange 0 ni)) + (.app + (VExpr.appN (.bvar (ni + k + 1)) + (VExpr.bvarRevRange 1 ni)) + (.bvar 0)) + let recTail : VExpr := .forallE gen.motiveType recRest + have hrec : env.HasType U Γ + (.const view.recursorName pLevels) + ((VExpr.forallN gen.paramsTel recTail).instL pLevels) := by + have hout := VEnv.HasType.const (Γ := Γ) self.recursor + (VStructureView.projectionLevels_wf view fieldSort levels + hfieldSort hlevels) + (VStructureView.projectionLevels_length view fieldSort levels + hlevelsLength) + simpa [gen, pLevels, recTail, recRest, k, ni, + VStructureView.recursorName, + VInductDecl.GenerationChecked.recursor, + VInductDecl.GenerationChecked.recType] using hout + have hparams := self.generationParamsSpine henv levels hlevels + hlevelsLength params hparamsLength paramsSpine fieldSort + have hparamsTelLength : params.length = + (gen.paramsTel.map (VExpr.instL pLevels)).length := by + simp [gen, VInductDecl.GenerationChecked.paramsTel, + S.generationParams_length, hparamsLength] + have hparamsFull := hparams.retarget hparamsTelLength + (recTail.instL pLevels) + have hparamsFull' : env.SpineWF U Γ + ((VExpr.forallN gen.paramsTel recTail).instL pLevels) + params (VExpr.instRev (recTail.instL pLevels) params) := by + simpa [VExpr.instL_forallN] using hparamsFull + have hmotiveShape : + VExpr.instRev (recTail.instL pLevels) params = + .forallE + (.forallE (view.structureType levels params) (.sort fieldSort)) + (VExpr.instRevAt (recRest.instL pLevels) params 1) := by + change VExpr.instRev + (.forallE (gen.motiveType.instL pLevels) + (recRest.instL pLevels)) params = _ + have hconst : VExpr.instRev + (.const view.generation.block.sourceType.name levels) params = + .const view.generation.block.sourceType.name levels := + VExpr.instRev_closedN params (by trivial) + have hrange : + (VExpr.bvarRevRange 0 view.source.nparams).map + (VExpr.instRev · params) = params := by + have hparamsLength' : params.length = view.source.nparams := + hparamsLength + rw [← hparamsLength'] + exact VExpr.map_instRev_bvarRevRange params + have hrangeL : + (VExpr.bvarRevRange 0 view.source.nparams).map + (fun x => (x.instL pLevels).instRev params) = params := by + calc + _ = ((VExpr.bvarRevRange 0 view.source.nparams).map + (VExpr.instL pLevels)).map (VExpr.instRev · params) := by + rw [List.map_map] + rfl + _ = params := by + rw [VExpr.bvarRevRange_map_instL] + exact hrange + have hsort : + (VExpr.sort fieldSort).instRevAt params 1 = + .sort fieldSort := + VExpr.instRevAt_closedN params (by trivial) + rw [VExpr.instRev_forallE_projection] + congr 1 + simp [gen, pLevels, + VInductDecl.GenerationChecked.motiveType, + VInductDecl.GenerationChecked.idxTel, + view.raw_indices_eq, VExpr.forallN, VExpr.bvarRevRange, + VExpr.instL, VExpr.instL_appN, + VExpr.instRev_forallE_projection, + VExpr.instRev_appN, Function.comp_def, + hconst, hrangeL, hsort, hmotiveLevel, + VStructureView.structureType, + VStructureView.sourceLevels_projectionLevels view fieldSort levels + hlevelsLength] + rw [hmotiveShape] at hparamsFull' + have hwithMotive := hparamsFull'.snoc typeFnType + have hconstructorMem : + view.constructor ∈ view.generation.block.ctorPairs := by + simp [view.constructor_eq] + have hresultIndices : view.constructor.view.resultIndices = [] := by + apply List.length_eq_zero_iff.1 + rw [S.viewResultIndices_length hconstructorMem] + simp [view.checked_indices_eq] + have hminorShape : + ((VExpr.instRevAt (recRest.instL pLevels) params 1).inst typeFn) = + .forallE (view.projectionMinorType levels params + (view.specializedFields levels params) typeFn) + (.forallE (view.structureType levels params).lift + (.app (typeFn.liftN 2) (.bvar 0))) := by + simp [gen, pLevels, recRest, k, ni, + VInductDecl.GenerationChecked.minorTypes, + VInductDecl.GenerationChecked.minorTypesAux, + VInductDecl.GenerationChecked.minorType, + VInductDecl.GenerationChecked.idxTel, + VInductDecl.NormalizedCtor.fieldsR, + VInductDecl.NormalizedCtor.recArgsR, + VInductDecl.NormalizedCtor.resultIndicesR, + VInductDecl.ihsFromRecArgs, + VStructureView.projectionMinorType, + VStructureView.projectionConstructorApp, + view.constructor_eq, view.raw_indices_eq, + hresultIndices, view.recursive_eq, + VExpr.instL_forallN, VExpr.instL_appN, + VExpr.liftTelN_instL, + VExpr.instL_instL, VExpr.instN_forallN, + VExpr.instTelN, + VExpr.instRevAt_forallN_projection, + VExpr.instRevAt_forallE_projection, + VExpr.instN_appN, VExpr.instRev, + VExpr.instRev_appN, List.map_append, + VExpr.bvarRevRange, List.map_append, + List.map_map, Function.comp_def, + VStructureView.sourceLevels_projectionLevels view fieldSort levels + hlevelsLength, hparamsLength] + change VExpr.forallE _ _ = VExpr.forallE _ _ + congr 1 + · have hfieldTel := + VExpr.instTelN_instRevAt_lift_projection + ((view.constructor.rawFields view.source.nparams).map + (VExpr.instL levels)) params typeFn 0 + rw [VExpr.instRevAt_map_instL_zipIdx] at hfieldTel + have hfieldTel' : + VExpr.instTelN typeFn + ((VExpr.liftTelN 1 + ((view.constructor.rawFields view.source.nparams).map + (VExpr.instL levels)) 0).zipIdx 1 |>.map + fun x => x.1.instRevAt params x.2) 0 = + view.specializedFields levels params := by + simpa [VStructureView.specializedFields, + VStructureView.fields] using hfieldTel + rw [hfieldTel'] + congr 1 + have hsourceLevels := + VStructureView.sourceLevels_projectionLevels view fieldSort levels + hlevelsLength + change + (VLevel.params' view.source.uvars + view.generation.elimination.offset).map + (VLevel.inst pLevels) = levels at hsourceLevels + have hliftedLength : + (VExpr.liftTelN 1 + ((view.constructor.rawFields view.source.nparams).map + (VExpr.instL levels)) 0).length = + (view.constructor.rawFields view.source.nparams).length := by + rw [VExpr.liftTelN_length] + simp + have hspecializedLength : + (view.specializedFields levels params).length = + (view.constructor.rawFields view.source.nparams).length := by + simp [VStructureView.specializedFields, + VStructureView.fields] + simp only [VExpr.forallN, VExpr.instL, + VExpr.bvarRevRange_map_instL, + hliftedLength, hspecializedLength, hparamsLength] + rw [hsourceLevels] + have hbody := + VExpr.projectionMinorBody_shape view.constructorName levels + params (view.constructor.rawFields view.source.nparams).length + typeFn + rw [hparamsLength] at hbody + simpa only [Nat.add_comm] using hbody + · have hsourceLevels := + VStructureView.sourceLevels_projectionLevels view fieldSort levels + hlevelsLength + change + (VLevel.params' view.source.uvars + view.generation.elimination.offset).map + (VLevel.inst pLevels) = levels at hsourceLevels + simp only [VExpr.forallN, VExpr.liftTelN, List.zipIdx_nil, + List.map_nil, VExpr.instTelN, Nat.add_zero, + VExpr.instL, VExpr.instL_appN, + VExpr.bvarRevRange_map_instL, VExpr.instL] + rw [hsourceLevels] + simpa [gen, hparamsLength, VStructureView.structureType] using + (VExpr.projectionMajorTail_shape view.name levels params typeFn) + rw [hminorShape] at hwithMotive + have hwithMinor := hwithMotive.snoc minorType + have hwithMajor : env.SpineWF U Γ + ((VExpr.forallN gen.paramsTel recTail).instL pLevels) + (params ++ [typeFn, minor, major]) (.app typeFn major) := by + have majorType' : env.HasType U Γ major + ((view.structureType levels params).lift.inst minor) := by + rw [VExpr.inst_lift] + exact majorType + have hout := hwithMinor.snoc majorType' + have htypeFnMinor : + (typeFn.liftN 2).inst minor 1 = typeFn.lift := by + rw [← VExpr.liftN_liftN typeFn 1 1, + VExpr.instN_liftAt_projection, VExpr.inst_lift] + have hminorVar : VExpr.instVar 0 minor 1 = .bvar 0 := by + simp [VExpr.instVar] + have hresult : + (((typeFn.liftN 2).app (.bvar 0)).inst minor 1).inst major = + typeFn.app major := by + simp only [VExpr.inst] + rw [htypeFnMinor, VExpr.inst_lift] + rw [hminorVar] + simp only [VExpr.inst] + rw [VExpr.instVar_zero] + rw [hresult] at hout + simpa [List.append_assoc] using hout + exact hwithMajor.hasType_appN hrec + +theorem SpineWF.instNProjection {env : VEnv} {U k : Nat} + {Γ₀ Γ₁ Γ : List VExpr} {e₀ A₀ : VExpr} + (henv : env.Ordered) + (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) + (h₀ : env.HasType U Γ₀ e₀ A₀) : + ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ₁ A es B → + env.SpineWF U Γ (A.inst e₀ k) + (es.map fun e => e.inst e₀ k) (B.inst e₀ k) + | [], A, B, h => by + change A.inst e₀ k = B.inst e₀ k + exact congrArg (fun e => e.inst e₀ k) h + | _ :: es, _, _, ⟨A₁, A₂, rfl, he, hrest⟩ => + ⟨A₁.inst e₀ k, A₂.inst e₀ (k + 1), rfl, + he.instN henv W h₀, by + have := SpineWF.instNProjection henv W h₀ (es := es) hrest + rwa [VExpr.inst0_inst_hi] at this⟩ + +/-- Environment-indexed projection semantics. + +The universe and parameter spines are explicit. The major premise must have +the exact instantiated structure type, and the result is the unique program +computed by the registered view. -/ +structure TrProj (env : VEnv) (U : Nat) (Γ : List VExpr) + (view : VStructureView) (levels : List VLevel) (params : List VExpr) + (idx : Nat) (major result : VExpr) : Prop where + viewWF : VStructureView.WF view env + levelsWF : ∀ level ∈ levels, level.WF U + levels_length : levels.length = view.uvars + params_length : params.length = view.nparams + paramsSpine : ∃ resultLevel, + env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel) + majorType : env.HasType U Γ major (view.structureType levels params) + program : ∃ code : VStructureView.ProjectionCode, + (view.projectionCodes levels params)[idx]? = some code ∧ + result = .app code.projector major ∧ + env.HasType U Γ code.projector + (.forallE (view.structureType levels params) + (.app code.typeFn.lift (.bvar 0))) + +theorem TrProj.project_eq + (self : VEnv.TrProj env U Γ view levels params idx major result) : + VStructureView.project? view levels params idx major = some result := by + obtain ⟨code, hcode, rfl, -⟩ := self.program + simp [VStructureView.project?, hcode] + +theorem TrProj.type_eq + (self : VEnv.TrProj env U Γ view levels params idx major result) : + ∃ code : VStructureView.ProjectionCode, + VStructureView.projectionType? view levels params idx major = + some (VExpr.app code.typeFn major) := by + obtain ⟨code, hcode, _, -⟩ := self.program + exact ⟨code, by simp [VStructureView.projectionType?, hcode]⟩ + +/-- A fixed checked view, universe/parameter instantiation, field index, and +major determine the projection result syntactically. -/ +theorem TrProj.result_eq + (self : VEnv.TrProj env U Γ view levels params idx major result) + (other : VEnv.TrProj env U Γ view levels params idx major result') : + result = result' := + Option.some.inj (self.project_eq.symm.trans other.project_eq) + +/-- Projection evidence is stable when the registered environment is +extended without changing any existing constants or reduction rules. -/ +theorem TrProj.mono {env env' : VEnv} (henv : env ≤ env') + (self : VEnv.TrProj env U Γ view levels params idx major result) : + VEnv.TrProj env' U Γ view levels params idx major result where + viewWF := self.viewWF.mono henv + levelsWF := self.levelsWF + levels_length := self.levels_length + params_length := self.params_length + paramsSpine := self.paramsSpine.imp fun _ h => h.monoProjection henv + majorType := self.majorType.mono henv + program := self.program.imp fun code ⟨hcode, hresult, htype⟩ => + ⟨hcode, hresult, htype.mono henv⟩ + +/-- Weakening acts pointwise on the explicit parameters, major, and computed +projection program. -/ +theorem TrProj.weakN (henv : env.Ordered) + (W : Ctx.LiftN n k Γ Γ') + (self : VEnv.TrProj env U Γ view levels params idx major result) : + VEnv.TrProj env U Γ' view levels + (params.map fun param => param.liftN n k) idx + (major.liftN n k) (result.liftN n k) := by + refine { + viewWF := self.viewWF + levelsWF := self.levelsWF + levels_length := self.levels_length + params_length := by simpa using self.params_length + paramsSpine := ?_ + majorType := by simpa using self.majorType.weakN henv W + program := ?_ } + · have hfamilyClosed : (view.familyType.instL levels).ClosedN 0 := by + simpa using (henv.closedC self.viewWF.family).instL + obtain ⟨resultLevel, hspine⟩ := self.paramsSpine + refine ⟨resultLevel, ?_⟩ + have hspine' := hspine.weakN henv W + rw [hfamilyClosed.liftN_eq (Nat.zero_le _)] at hspine' + simpa [VExpr.liftN] using hspine' + · obtain ⟨code, hcode, rfl, htype⟩ := self.program + refine ⟨code.liftN n k, ?_, rfl, ?_⟩ + rw [← self.viewWF.projectionCodes_liftN henv levels params + self.params_length n k] + simp only [List.getElem?_map, hcode, Option.map_some] + simpa [VStructureView.ProjectionCode.liftN, VExpr.liftN, + VExpr.liftN_lift_projection] using htype.weakN henv W + +/-- General context lifting, derived one inserted binder at a time from +`weakN`. -/ +theorem TrProj.weak' (henv : env.Ordered) + (W : Ctx.Lift' l Γ Γ') + (self : VEnv.TrProj env U Γ view levels params idx major result) : + VEnv.TrProj env U Γ' view levels + (params.map fun param => param.lift' l) idx + (major.lift' l) (result.lift' l) := by + generalize hdepth : l.depth = depth + induction depth generalizing l Γ' with + | zero => + have hctx := W.depth_zero hdepth + subst Γ' + simpa [VExpr.lift'_depth_zero (l := l) hdepth] using self + | succ depth ih => + obtain ⟨tail, k, rfl, rfl⟩ := Lift.depth_succ hdepth + obtain ⟨Γ₁, W₁, W₂⟩ := W.of_cons_skip + have h := (ih W₁ Lift.depth_consN).weakN henv W₂ + rw [Lift.consN_skip_eq] + have hlift : ∀ e : VExpr, + e.lift' ((tail.consN k).comp + (Lift.refl.skip.consN k)) = + (e.lift' (tail.consN k)).liftN 1 k := by + intro e + rw [VExpr.lift'_comp, ← Lift.skipN_one, + VExpr.lift'_consN_skipN] + have hparams : + params.map (fun param => param.lift' ((tail.consN k).comp + (Lift.refl.skip.consN k))) = + (params.map fun param => param.lift' (tail.consN k)).map + (fun param => param.liftN 1 k) := by + rw [List.map_map] + exact List.map_congr_left fun param _ => hlift param + rw [hparams, hlift major, hlift result] + exact h + +/-- Substitution acts pointwise on the explicit parameters, major, and +computed projection program. -/ +theorem TrProj.instN (henv : env.Ordered) + (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) + (h₀ : env.HasType U Γ₀ e₀ A₀) + (self : VEnv.TrProj env U Γ₁ view levels params idx major result) : + VEnv.TrProj env U Γ view levels + (params.map fun param => param.inst e₀ k) idx + (major.inst e₀ k) (result.inst e₀ k) := by + refine { + viewWF := self.viewWF + levelsWF := self.levelsWF + levels_length := self.levels_length + params_length := by simpa using self.params_length + paramsSpine := ?_ + majorType := by simpa using self.majorType.instN henv W h₀ + program := ?_ } + · have hfamilyClosed : (view.familyType.instL levels).ClosedN 0 := by + simpa using (henv.closedC self.viewWF.family).instL + obtain ⟨resultLevel, hspine⟩ := self.paramsSpine + refine ⟨resultLevel, ?_⟩ + have hspine' := hspine.instNProjection henv W h₀ + rw [hfamilyClosed.instN_eq (Nat.zero_le _)] at hspine' + simpa [VExpr.inst] using hspine' + · obtain ⟨code, hcode, rfl, htype⟩ := self.program + refine ⟨code.instN e₀ k, ?_, rfl, ?_⟩ + rw [← self.viewWF.projectionCodes_instN henv levels params + self.params_length e₀ k] + simp only [List.getElem?_map, hcode, Option.map_some] + simpa [VStructureView.ProjectionCode.instN, VExpr.inst, + ← VExpr.lift_instN_lo] using htype.instN henv W h₀ + +/-- Transport projection evidence to a definitionally equal context and a +new major already checked against the same instantiated structure type. -/ +theorem TrProj.defeqDFC (henv : env.Ordered) + (hΓ : env.IsDefEqCtx U Γ₀ Γ₁ Γ₂) + (majorType' : env.HasType U Γ₂ major' + (view.structureType levels params)) + (self : VEnv.TrProj env U Γ₁ view levels params idx major result) : + ∃ result', VEnv.TrProj env U Γ₂ view levels params idx major' result' := by + obtain ⟨code, hcode, -, htype⟩ := self.program + refine ⟨.app code.projector major', { + viewWF := self.viewWF + levelsWF := self.levelsWF + levels_length := self.levels_length + params_length := self.params_length + paramsSpine := self.paramsSpine.imp fun _ h => h.defeqDFC henv hΓ + majorType := majorType' + program := ⟨code, hcode, rfl, + htype.defeqDFC henv hΓ⟩ }⟩ + +/-- Universe instantiation acts pointwise on the explicit structure +universes and parameters, and on the recursor program they determine. -/ +theorem TrProj.instL {ls : List VLevel} + (hls : ∀ level ∈ ls, level.WF U') + (self : VEnv.TrProj env U Γ view levels params idx major result) : + VEnv.TrProj env U' (Γ.map (VExpr.instL ls)) view + (levels.map (VLevel.inst ls)) + (params.map (VExpr.instL ls)) idx + (major.instL ls) (result.instL ls) := by + refine { + viewWF := self.viewWF + levelsWF := ?_ + levels_length := by simpa using self.levels_length + params_length := by simpa using self.params_length + paramsSpine := ?_ + majorType := by simpa using self.majorType.instL hls + program := ?_ } + · intro level hlevel + obtain ⟨sourceLevel, hsourceLevel, rfl⟩ := List.mem_map.1 hlevel + exact VLevel.WF.inst hls + · obtain ⟨resultLevel, hspine⟩ := self.paramsSpine + refine ⟨resultLevel.inst ls, ?_⟩ + simpa [VExpr.instL, VExpr.instL_instL] using hspine.instL hls + · obtain ⟨code, hcode, rfl, htype⟩ := self.program + refine ⟨code.instL ls, ?_, ?_, ?_⟩ + · rw [← VStructureView.projectionCodes_instL] + simp only [List.getElem?_map, hcode, Option.map_some] + · rfl + · simpa [VStructureView.ProjectionCode.instL, VExpr.instL, + VExpr.instL_liftN] using htype.instL hls + +/-- The registered-structure constant-head inversion boundary. + +The two conclusions are the projection-specific eliminators supplied by +constant-head injectivity: a type assigned to a syntactically weakened major +recovers an instantiation below the inserted context, and definitionally equal +majors recover the same registered view/instantiation strongly enough for the +generated projector programs to be definitionally equal. Its eventual proof +uses `IsDefEqU.weakN_iff` together with injectivity of registered inductive +heads. Keeping the boundary in Theory makes the temporary L4L-16/17 +dependency explicit instead of leaving Verify's structural laws as local +holes. -/ +structure RegisteredStructureHeadInversion (env : VEnv) : Prop where + weak'_inv : + ∀ {U : Nat} {Γ Γ' : List VExpr} {view : VStructureView} + {levels : List VLevel} {params : List VExpr} {idx : Nat} + {major result : VExpr} {lift : Lift}, + OnCtx Γ' (env.IsType U) → + Ctx.Lift' lift Γ Γ' → + env.TrProj U Γ' view levels params idx (major.lift' lift) result → + ∃ params' result', + env.TrProj U Γ view levels params' idx major result' + unique : + ∀ {U : Nat} {Γ₁ Γ₂ : List VExpr} + {view₁ view₂ : VStructureView} + {levels₁ levels₂ : List VLevel} {params₁ params₂ : List VExpr} + {idx : Nat} {major₁ major₂ result₁ result₂ : VExpr}, + env.IsDefEqCtx U [] Γ₁ Γ₂ → + env.TrProj U Γ₁ view₁ levels₁ params₁ idx major₁ result₁ → + env.TrProj U Γ₂ view₂ levels₂ params₂ idx major₂ result₂ → + env.IsDefEqU U Γ₁ major₁ major₂ → + env.IsDefEqU U Γ₁ result₁ result₂ + +/-- Public Tier-R registered-head inversion statement. L4L-16/17 discharge +the underlying constant-head theorem; projection structural laws consume only +this stable interface and therefore shed `sorryAx` automatically when it is +proved. -/ +theorem WF.registeredStructureHeadInversion + (self : VEnv.WF env) : RegisteredStructureHeadInversion env := by + sorry + +/-- +info: 'Lean4Lean.VEnv.WF.registeredStructureHeadInversion' depends on axioms: [propext, sorryAx, Quot.sound] +-/ +#guard_msgs in +#print axioms WF.registeredStructureHeadInversion + +/-- +info: 'Lean4Lean.VEnv.TrProj.result_eq' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms TrProj.result_eq + +/-- +info: 'Lean4Lean.VEnv.TrProj.mono' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms TrProj.mono + +end VEnv + +end Lean4Lean diff --git a/Lean4Lean/Theory/Typing/Env.lean b/Lean4Lean/Theory/Typing/Env.lean index de6f89cb..0e957bab 100644 --- a/Lean4Lean/Theory/Typing/Env.lean +++ b/Lean4Lean/Theory/Typing/Env.lean @@ -2,6 +2,7 @@ import Lean4Lean.Theory.Typing.Basic import Lean4Lean.Theory.VDecl import Lean4Lean.Theory.Quot import Lean4Lean.Theory.Inductive +import Lean4Lean.Theory.NestedInductive namespace Lean4Lean @@ -35,6 +36,10 @@ inductive VDecl.WF : VEnv → VDecl → VEnv → Prop where gen.WF env blockEnv → env.addInductBlockGeneration gen = some env' → VDecl.WF env (.induct decl) env' + | inductNested {nested : decl.NestedBlockChecked} : + nested.WF env → + env.addInductNested nested = some env' → + VDecl.WF env (.induct decl) env' inductive VEnv.WF' : List VDecl → VEnv → Prop where | empty : VEnv.WF' [] .empty diff --git a/Lean4Lean/Theory/Typing/EnvLemmas.lean b/Lean4Lean/Theory/Typing/EnvLemmas.lean index cedcfc16..eba779d7 100644 --- a/Lean4Lean/Theory/Typing/EnvLemmas.lean +++ b/Lean4Lean/Theory/Typing/EnvLemmas.lean @@ -2,6 +2,7 @@ import Lean4Lean.Theory.Typing.Lemmas import Lean4Lean.Theory.Typing.Env import Lean4Lean.Theory.Typing.QuotLemmas import Lean4Lean.Theory.Typing.InductiveLemmas +import Lean4Lean.Theory.Typing.NestedInductiveLemmas namespace Lean4Lean @@ -23,5 +24,6 @@ theorem VEnv.WF.ordered : WF env → Ordered env | quot h1 h2 => exact addQuot_WF ih h1 h2 | induct h1 h2 => exact addInductGeneration_WF ih h1 h2 | inductBlock h1 h2 => exact addInductBlockGeneration_WF ih h1 h2 + | inductNested h1 h2 => exact VEnv.addInductNested_WF ih h1 h2 instance : CoeOut (VEnv.WF env) env.Ordered := ⟨(·.ordered)⟩ diff --git a/Lean4Lean/Theory/Typing/InductiveCertificate.lean b/Lean4Lean/Theory/Typing/InductiveCertificate.lean new file mode 100644 index 00000000..f7ea85eb --- /dev/null +++ b/Lean4Lean/Theory/Typing/InductiveCertificate.lean @@ -0,0 +1,517 @@ +import Lean4Lean.Theory.Typing.EnvLemmas +import Lean4Lean.Theory.Typing.InductivePattern +import Lean4Lean.Theory.Typing.NestedInductiveLemmas + +/-! +# Consumer certificates for completed inductive blocks + +`BlockGenerationCertificate` is the semantic input to the block transaction. +This module packages that input with one successful transaction and a +well-formed dependency environment, then exports the stable consequences a +consumer needs. The package contains only Theory values and proofs: no +implementation metadata, checker state, or normalization execution crosses +this boundary. + +In particular, `BlockCertificate.ruleClosure` derives the closed payload +required by the generated-pattern API from the registered, well-formed iota +rules in the completed environment. A consumer therefore does not need a +second closedness assumption in order to use `IotaPat`. +-/ + +namespace Lean4Lean + +namespace VInductDecl + +/-- One successful proof-carrying block transaction over an explicit +dependency environment. -/ +structure BlockCertificate (source : VInductDecl) (before after : VEnv) where + semantic : source.BlockGenerationCertificate before + success : before.addInductBlockCertified semantic = some after + beforeWF : before.WF + +namespace BlockCertificate + +variable {source : VInductDecl} {before after : VEnv} + +/-- Package the ordinary raw `addInduct` entry point once its accepted block +descriptor and semantic proof are known. This is the compatibility bridge +for consumers that still execute `addInduct`; no second transaction is run. -/ +def ofAddInduct + (generation : source.BlockGenerationChecked) (blockEnv : VEnv) + (hidentity : source.identityBlockGeneration? = some generation) + (hwf : generation.WF before blockEnv) (hbefore : before.WF) + (hadd : before.addInduct source = some after) : + BlockCertificate source before after where + semantic := ⟨generation, blockEnv, hwf⟩ + success := by + unfold VEnv.addInduct at hadd + rw [hidentity] at hadd + exact hadd + beforeWF := hbefore + +/-- The exact generation descriptor retained by a completed block. -/ +abbrev generation (certificate : BlockCertificate source before after) : + source.BlockGenerationChecked := + certificate.semantic.generation + +/-- Recover the four exact insertion phases of the completed block. -/ +theorem trace (certificate : BlockCertificate source before after) : + Nonempty (VEnv.AddInductBlockGenerationTrace before after + certificate.generation) := + VEnv.addInductBlockCertified_trace certificate.success + +/-- The completed transaction is a genuine block declaration step. -/ +theorem declWF (certificate : BlockCertificate source before after) : + VDecl.WF before (.induct source) after := by + apply VDecl.WF.inductBlock certificate.semantic.wf + simpa only [VEnv.addInductBlockCertified_eq_addInductBlockGeneration] using + certificate.success + +/-- Extend the dependency-environment history with the certified block. -/ +theorem afterWF (certificate : BlockCertificate source before after) : + after.WF := by + rcases certificate.beforeWF with ⟨decls, hdecls⟩ + exact ⟨.induct source :: decls, hdecls.decl certificate.declWF⟩ + +/-- A completed block only grows its dependency environment. -/ +theorem envLE (certificate : BlockCertificate source before after) : + before ≤ after := by + rcases certificate.trace with ⟨trace⟩ + exact trace.le + +/-- Compatibility spelling for consumers of the historical +`addInduct_le` growth theorem. -/ +theorem addInduct_le (certificate : BlockCertificate source before after) : + before ≤ after := + certificate.envLE + +/-- Compatibility spelling for the preservation result traditionally +exported as `addInduct_WF`. -/ +theorem addInduct_WF (certificate : BlockCertificate source before after) : + after.WF := + certificate.afterWF + +/-- Recover success through the ordinary raw API when this certificate's +descriptor is the declaration's identity descriptor. -/ +theorem addInduct + (certificate : BlockCertificate source before after) + (hidentity : source.identityBlockGeneration? = + some certificate.generation) : + before.addInduct source = some after := by + unfold VEnv.addInduct + rw [hidentity] + simpa [VEnv.addInductBlockCertified] using certificate.success + +/-- Every source family has its exact stored Theory value in the completed +environment. -/ +theorem familyLookup (certificate : BlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) : + after.constants family.name = some family.toVConstant := by + rcases certificate.trace with ⟨trace⟩ + exact trace.family_lookup hfamily + +/-- Every flattened source constructor has its exact stored Theory value in +the completed environment. -/ +theorem constructorLookup + (certificate : BlockCertificate source before after) + {constructor : VConstVal} + (hconstructor : constructor ∈ source.blockConstructorConstants) : + after.constants constructor.name = some constructor.toVConstant := by + rcases certificate.trace with ⟨trace⟩ + exact trace.ctor_lookup hconstructor + +/-- Every generated family recursor has its exact Theory value in the +completed environment. -/ +theorem recursorLookup + (certificate : BlockCertificate source before after) + {recursor : VConstVal} + (hrecursor : recursor ∈ certificate.generation.recursors) : + after.constants recursor.name = some recursor.toVConstant := by + rcases certificate.trace with ⟨trace⟩ + exact trace.rec_lookup hrecursor + +/-- A source family name was fresh at the dependency boundary. -/ +theorem familyFresh (certificate : BlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) : + before.constants family.name = none := by + rcases certificate.trace with ⟨trace⟩ + exact trace.family_fresh hfamily + +/-- A flattened source constructor name was fresh at the dependency +boundary. -/ +theorem constructorFresh + (certificate : BlockCertificate source before after) + {constructor : VConstVal} + (hconstructor : constructor ∈ source.blockConstructorConstants) : + before.constants constructor.name = none := by + rcases certificate.trace with ⟨trace⟩ + exact trace.ctor_fresh hconstructor + +/-- A generated recursor name was fresh at the dependency boundary. -/ +theorem recursorFresh + (certificate : BlockCertificate source before after) + {recursor : VConstVal} + (hrecursor : recursor ∈ certificate.generation.recursors) : + before.constants recursor.name = none := by + rcases certificate.trace with ⟨trace⟩ + exact trace.rec_fresh hrecursor + +/-- Every generated rule is registered by the completed transaction. -/ +theorem ruleRegistered + (certificate : BlockCertificate source before after) + {rule : VDefEq} + (hrule : rule ∈ certificate.generation.generatedRules) : + after.defeqs rule := by + rcases certificate.trace with ⟨trace⟩ + exact trace.rule_mem hrule + +/-- Every generated rule is well formed in the completed environment. -/ +theorem ruleWF + (certificate : BlockCertificate source before after) + {rule : VDefEq} + (hrule : rule ∈ certificate.generation.generatedRules) : + rule.WF after := + certificate.afterWF.ordered.defEqWF (certificate.ruleRegistered hrule) + +/-- An exact family lookup is unique. This small eliminator is convenient +for consumers that translate their own family representation to a Theory +constant and then compare it with the certificate inventory. -/ +theorem familyLookup_unique + (certificate : BlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) + {constant : VConstant} + (hlookup : after.constants family.name = some constant) : + constant = family.toVConstant := by + exact Option.some.inj (hlookup.symm.trans (certificate.familyLookup hfamily)) + +/-- An exact constructor lookup is unique. -/ +theorem constructorLookup_unique + (certificate : BlockCertificate source before after) + {constructor : VConstVal} + (hconstructor : constructor ∈ source.blockConstructorConstants) + {constant : VConstant} + (hlookup : after.constants constructor.name = some constant) : + constant = constructor.toVConstant := by + exact Option.some.inj + (hlookup.symm.trans (certificate.constructorLookup hconstructor)) + +/-- An exact generated-recursor lookup is unique. -/ +theorem recursorLookup_unique + (certificate : BlockCertificate source before after) + {recursor : VConstVal} + (hrecursor : recursor ∈ certificate.generation.recursors) + {constant : VConstant} + (hlookup : after.constants recursor.name = some constant) : + constant = recursor.toVConstant := by + exact Option.some.inj + (hlookup.symm.trans (certificate.recursorLookup hrecursor)) + +private theorem rule_mem_generatedRules + (generation : source.BlockGenerationChecked) + {i : Nat} {constructor : NormalizedBlockCtor} + (hentry : generation.flatCtors[i]? = some constructor) : + generation.rule i constructor ∈ generation.generatedRules := by + apply List.mem_map.2 + refine ⟨(constructor, i), ?_, rfl⟩ + apply List.mem_of_getElem? (i := i) + rw [List.getElem?_zipIdx, hentry, Option.map_some, Nat.zero_add] + +private theorem closedN_lamN_body : + ∀ {binders : List VExpr} {body : VExpr} {k : Nat}, + (VExpr.lamN binders body).ClosedN k → + body.ClosedN (k + binders.length) + | [], _, _, h => by + simpa only [VExpr.lamN, List.length_nil, Nat.add_zero] using h + | _ :: binders, body, k, h => by + have hbody := closedN_lamN_body (binders := binders) + (body := body) (k := k + 1) h.2 + simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hbody + +private theorem closedN_lamN_replace : + ∀ {binders : List VExpr} {body body' : VExpr} {k : Nat}, + (VExpr.lamN binders body).ClosedN k → + body'.ClosedN (k + binders.length) → + (VExpr.lamN binders body').ClosedN k + | [], _, _, _, _, hbody' => by + simpa only [VExpr.lamN, List.length_nil, Nat.add_zero] using hbody' + | _ :: binders, body, body', k, h, hbody' => by + refine ⟨h.1, closedN_lamN_replace (binders := binders) + (body := body) (body' := body') (k := k + 1) h.2 ?_⟩ + simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hbody' + +private theorem closedN_appN_function : + ∀ {function : VExpr} {arguments : List VExpr} {k : Nat}, + (VExpr.appN function arguments).ClosedN k → function.ClosedN k + | _, [], _, h => by simpa only [VExpr.appN] using h + | function, argument :: arguments, k, h => + (closedN_appN_function (function := function.app argument) + (arguments := arguments) (k := k) h).1 + +private theorem closedN_appN_argument + {function : VExpr} {arguments : List VExpr} {k : Nat} + (hclosed : (VExpr.appN function arguments).ClosedN k) + {argument : VExpr} (hargument : argument ∈ arguments) : + argument.ClosedN k := by + induction arguments generalizing function with + | nil => simp at hargument + | cons head tail ih => + rcases List.mem_cons.1 hargument with heq | htail + · rw [heq] + exact (closedN_appN_function + (function := function.app head) (arguments := tail) + (k := k) hclosed).2 + · exact ih (function := function.app head) hclosed htail + +/-- The successful block transaction supplies the closedness bundle required +by `IotaPat`. Closedness is derived from the registered rules and the +completed environment's ordinary WF history; it is not an additional +consumer assumption. -/ +theorem ruleClosure + (certificate : BlockCertificate source before after) : + certificate.generation.RuleClosure := by + constructor + · intro i constructor hentry + have hmem := rule_mem_generatedRules certificate.generation hentry + exact (certificate.ruleWF hmem).2.closedN + certificate.afterWF.ordered trivial + · intro constructor hconstructor expression hexpression + obtain ⟨i, hentry⟩ := List.mem_iff_getElem?.1 hconstructor + have hmem := rule_mem_generatedRules certificate.generation hentry + have hlhs := (certificate.ruleWF hmem).1.closedN + certificate.afterWF.ordered trivial + rw [certificate.generation.rule_lhs i constructor] at hlhs + have hbody := closedN_lamN_body hlhs + have hexpression' : expression ∈ + certificate.generation.ruleIdx constructor ++ + [certificate.generation.ruleCtorApp constructor] := + List.mem_append.2 (.inl hexpression) + have hclosed : expression.ClosedN + (certificate.generation.ruleBinders constructor).length := by + apply closedN_appN_argument + (function := certificate.generation.recBase + (certificate.generation.ruleFieldCount constructor) + constructor.owner) + (arguments := certificate.generation.ruleIdx constructor ++ + [certificate.generation.ruleCtorApp constructor]) + · simpa only [BlockGenerationChecked.ruleLhsBody, List.length_nil, + Nat.zero_add] using hbody + · exact hexpression' + apply closedN_lamN_replace hlhs + simpa using hclosed + +/-- The exact generated pattern and payload associated with one flattened +rule entry. -/ +theorem recursorPattern + (certificate : BlockCertificate source before after) + {i : Nat} {constructor : NormalizedBlockCtor} + (hentry : certificate.generation.ruleEntry i constructor) : + certificate.generation.IotaPat certificate.ruleClosure + ((certificate.generation.rulePattern constructor).toPattern) + (certificate.generation.ruleRHS certificate.ruleClosure hentry, + certificate.generation.ruleCheck certificate.ruleClosure + (List.mem_of_getElem? hentry)) := + .mk hentry + +/-- Rule-level consumer bundle: exact global position, generated-list +membership, registration, well-formedness, and the corresponding L4L-10 +pattern all come from the same completed block. -/ +structure RecursorRuleFacts + (certificate : BlockCertificate source before after) + (i : Nat) (constructor : NormalizedBlockCtor) : Prop where + entry : certificate.generation.ruleEntry i constructor + member : certificate.generation.rule i constructor ∈ + certificate.generation.generatedRules + registered : after.defeqs (certificate.generation.rule i constructor) + wf : (certificate.generation.rule i constructor).WF after + pattern : certificate.generation.IotaPat certificate.ruleClosure + ((certificate.generation.rulePattern constructor).toPattern) + (certificate.generation.ruleRHS certificate.ruleClosure entry, + certificate.generation.ruleCheck certificate.ruleClosure + (List.mem_of_getElem? entry)) + +/-- Assemble all rule facts without a consumer-supplied semantic premise. -/ +theorem recursorRuleFacts + (certificate : BlockCertificate source before after) + {i : Nat} {constructor : NormalizedBlockCtor} + (hentry : certificate.generation.ruleEntry i constructor) : + certificate.RecursorRuleFacts i constructor := by + have hmember := rule_mem_generatedRules certificate.generation hentry + exact { + entry := hentry + member := hmember + registered := certificate.ruleRegistered hmember + wf := certificate.ruleWF hmember + pattern := certificate.recursorPattern hentry } + +end BlockCertificate + +/-! ## Completed nested transactions -/ + +/-- One successful proof-carrying nested transaction over an explicit +dependency environment. As with `BlockCertificate`, this package contains +only Theory artifacts. -/ +structure NestedBlockCertificate + (source : VInductDecl) (before after : VEnv) where + nested : source.NestedBlockChecked + semantic : nested.WF before + success : before.addInductNested nested = some after + beforeWF : before.WF + +namespace NestedBlockCertificate + +variable {source : VInductDecl} {before after : VEnv} + +/-- Recover the exact four-phase nested transaction trace. -/ +theorem trace (certificate : NestedBlockCertificate source before after) : + Nonempty (VEnv.AddInductNestedTrace before after certificate.nested) := + VEnv.addInductNested_trace certificate.success + +/-- The nested completion is a genuine inductive declaration step. -/ +theorem declWF (certificate : NestedBlockCertificate source before after) : + VDecl.WF before (.induct source) after := + .inductNested certificate.semantic certificate.success + +/-- Extend the dependency-environment history with the nested block. -/ +theorem afterWF (certificate : NestedBlockCertificate source before after) : + after.WF := by + rcases certificate.beforeWF with ⟨decls, hdecls⟩ + exact ⟨.induct source :: decls, hdecls.decl certificate.declWF⟩ + +/-- A completed nested transaction only grows its dependency environment. -/ +theorem envLE (certificate : NestedBlockCertificate source before after) : + before ≤ after := + VEnv.addInductNested_le certificate.success + +/-- Nested analogue of the public block growth result. -/ +theorem addInduct_le + (certificate : NestedBlockCertificate source before after) : + before ≤ after := + certificate.envLE + +/-- Nested analogue of the public block preservation result. -/ +theorem addInduct_WF + (certificate : NestedBlockCertificate source before after) : + after.WF := + certificate.afterWF + +/-- Every stored source family has its exact final value. -/ +theorem familyLookup (certificate : NestedBlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) : + after.constants family.name = some family.toVConstant := by + rcases certificate.trace with ⟨trace⟩ + exact trace.family_lookup hfamily + +/-- Every stored source constructor has its exact final value. -/ +theorem constructorLookup + (certificate : NestedBlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) + {constructor : VConstVal} (hconstructor : constructor ∈ family.ctors) : + after.constants constructor.name = some constructor.toVConstant := by + rcases certificate.trace with ⟨trace⟩ + exact trace.ctor_lookup hfamily hconstructor + +/-- Every restored recursor has its exact final value. -/ +theorem recursorLookup + (certificate : NestedBlockCertificate source before after) + {recursor : VConstVal} (hrecursor : recursor ∈ certificate.nested.recursors) : + after.constants recursor.name = some recursor.toVConstant := by + rcases certificate.trace with ⟨trace⟩ + exact trace.rec_lookup hrecursor + +/-- Every source family name was fresh at the dependency boundary. -/ +theorem familyFresh (certificate : NestedBlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) : + before.constants family.name = none := by + rcases certificate.trace with ⟨trace⟩ + exact trace.family_fresh hfamily + +/-- Every flattened source constructor name was fresh at the dependency +boundary. -/ +theorem constructorFresh + (certificate : NestedBlockCertificate source before after) + {constructor : VConstVal} + (hconstructor : constructor ∈ source.blockConstructorConstants) : + before.constants constructor.name = none := by + rcases certificate.trace with ⟨trace⟩ + exact trace.ctor_fresh hconstructor + +/-- Every restored recursor name was fresh at the dependency boundary. -/ +theorem recursorFresh + (certificate : NestedBlockCertificate source before after) + {recursor : VConstVal} (hrecursor : recursor ∈ certificate.nested.recursors) : + before.constants recursor.name = none := by + rcases certificate.trace with ⟨trace⟩ + exact trace.rec_fresh hrecursor + +/-- Every restored rule is registered in the completed environment. -/ +theorem ruleRegistered + (certificate : NestedBlockCertificate source before after) + {rule : VDefEq} (hrule : rule ∈ certificate.nested.generatedRules) : + after.defeqs rule := by + rcases certificate.trace with ⟨trace⟩ + exact trace.rule_mem hrule + +/-- Every registered restored rule is well formed. -/ +theorem ruleWF + (certificate : NestedBlockCertificate source before after) + {rule : VDefEq} (hrule : rule ∈ certificate.nested.generatedRules) : + rule.WF after := + certificate.afterWF.ordered.defEqWF (certificate.ruleRegistered hrule) + +/-- Exact family lookups are unique. -/ +theorem familyLookup_unique + (certificate : NestedBlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) + {constant : VConstant} + (hlookup : after.constants family.name = some constant) : + constant = family.toVConstant := + Option.some.inj (hlookup.symm.trans (certificate.familyLookup hfamily)) + +/-- Exact constructor lookups are unique. -/ +theorem constructorLookup_unique + (certificate : NestedBlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) + {constructor : VConstVal} (hconstructor : constructor ∈ family.ctors) + {constant : VConstant} + (hlookup : after.constants constructor.name = some constant) : + constant = constructor.toVConstant := + Option.some.inj + (hlookup.symm.trans (certificate.constructorLookup hfamily hconstructor)) + +/-- Exact restored-recursor lookups are unique. -/ +theorem recursorLookup_unique + (certificate : NestedBlockCertificate source before after) + {recursor : VConstVal} (hrecursor : recursor ∈ certificate.nested.recursors) + {constant : VConstant} + (hlookup : after.constants recursor.name = some constant) : + constant = recursor.toVConstant := + Option.some.inj + (hlookup.symm.trans (certificate.recursorLookup hrecursor)) + +end NestedBlockCertificate + +end VInductDecl + +end Lean4Lean + +/-! ## Exact Theory trust guards -/ + +/-- info: 'Lean4Lean.VInductDecl.BlockCertificate.afterWF' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockCertificate.afterWF + +/-- info: 'Lean4Lean.VInductDecl.BlockCertificate.ruleClosure' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockCertificate.ruleClosure + +/-- info: 'Lean4Lean.VInductDecl.BlockCertificate.recursorRuleFacts' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockCertificate.recursorRuleFacts + +/-- info: 'Lean4Lean.VInductDecl.NestedBlockCertificate.afterWF' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.NestedBlockCertificate.afterWF + +/-- info: 'Lean4Lean.VInductDecl.NestedBlockCertificate.ruleWF' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.NestedBlockCertificate.ruleWF diff --git a/Lean4Lean/Theory/Typing/InductivePattern.lean b/Lean4Lean/Theory/Typing/InductivePattern.lean new file mode 100644 index 00000000..26c19016 --- /dev/null +++ b/Lean4Lean/Theory/Typing/InductivePattern.lean @@ -0,0 +1,774 @@ +import Lean4Lean.Theory.Typing.InductiveLemmas +import Lean4Lean.Theory.Typing.Pattern + +/-! # Generated iota rules as patterns + +Every iota rule generated for a certified mutual block +(`BlockGenerationChecked.rule`) is a closed defeq between lambda telescopes +whose left body is a `SimplePattern.iota` spine: the owning family's recursor +applied to the shared parameters, all motives, all minors, and the +constructor's result indices, with a constructor-headed major premise. This +module makes that connection exact and proves the generic pattern facts the +Church–Rosser `Params` interface demands of one certified block: + +* `rulePattern` is the `SimplePattern` of one flattened constructor's rule, + and `ruleLhsBody_matches` matches the exact generated left body against it + at the rule's recursor levels. +* `IotaPat` is the block's pattern set, associating each rule's pattern with + an RHS template (the registered right tower applied to the captured common + arguments and fields) and a check list (parameter and result-index + agreement between the recursor spine and the major premise). +* `pat_simple`, `pat_uniq`, `pat_app_l`, `pat_app_l_uniq`, and + `pat_app_uniq` are exactly the `Params` obligations, specialized to + `IotaPat`; their name-freshness inputs come from the certified block's + `blockGeneratedNames` nodup bit, and the major-arity agreement between + same-recursor rules comes from the analyzer's terminal `blockTarget?` + arity equation. + +No open-environment `Params` instance is installed here; the block supplies +the facts, and soundness (`pat_wf`) plus the block-local environment +assembler belong to the pattern-soundness milestone. -/ + +namespace Lean4Lean + +open VExpr + +namespace VExpr + +@[simp] theorem bvarRevRange_length : ∀ (off m : Nat), + (bvarRevRange off m).length = m + | _, 0 => rfl + | off, m+1 => by simp [bvarRevRange, bvarRevRange_length off m] + +end VExpr + +/-- Extending a `HeadConstN` spine by an application spine. -/ +theorem HeadConstN.appN {c : Name} {ls : List VLevel} : + ∀ (as : List VExpr) {n : Nat} {f : VExpr}, HeadConstN c ls n f → + HeadConstN c ls (n + as.length) (VExpr.appN f as) + | [], _, _, h => h + | a :: as, n, f, h => by + have := HeadConstN.appN as (h.app (a := a)) + show HeadConstN c ls (n + (as.length + 1)) (VExpr.appN (f.app a) as) + rwa [(by omega : n + (as.length + 1) = n + 1 + as.length)] + +namespace VInductDecl + +/-! ## Positional facts about the checked pairings -/ + +theorem pairNormalizedFamilies_getElem? : + ∀ (raws : List VInductiveType) (views : List CheckedFamilyData) (t : Nat) + {family : NormalizedFamily}, + (pairNormalizedFamilies raws views)[t]? = some family → + raws[t]? = some family.raw ∧ views[t]? = some family.view + | raw :: raws, view :: views, 0, family => by + intro h + cases h + exact ⟨rfl, rfl⟩ + | raw :: raws, view :: views, t+1, family => by + intro h + simpa using pairNormalizedFamilies_getElem? raws views t + (by simpa [pairNormalizedFamilies] using h) + | [], _, t, _ => by intro h; simp [pairNormalizedFamilies] at h + | _ :: _, [], t, _ => by intro h; simp [pairNormalizedFamilies] at h + +theorem pairNormalizedCtors_getElem? : + ∀ (raws : List VConstVal) (views : List CheckedCtor) (t : Nat) + {ctor : NormalizedCtor}, + (pairNormalizedCtors raws views)[t]? = some ctor → + raws[t]? = some ctor.raw ∧ views[t]? = some ctor.view + | raw :: raws, view :: views, 0, ctor => by + intro h + cases h + exact ⟨rfl, rfl⟩ + | raw :: raws, view :: views, t+1, ctor => by + intro h + simpa using pairNormalizedCtors_getElem? raws views t + (by simpa [pairNormalizedCtors] using h) + | [], _, t, _ => by intro h; simp [pairNormalizedCtors] at h + | _ :: _, [], t, _ => by intro h; simp [pairNormalizedCtors] at h + +/-- The erased family-data spine reads back its exact member facts: ordinal +consecutiveness, the indexing family, the analyzer equations, and the +per-family acceptance bit. -/ +theorem CheckedFamilies.data_getElem? {source : VInductDecl} {params : List VExpr} : + ∀ {ord : Nat} {types : List VInductiveType} + (fs : CheckedFamilies source params ord types) (t : Nat) + {fd : CheckedFamilyData}, + fs.data[t]? = some fd → + ∃ type, types[t]? = some type ∧ fd.ordinal = ord + t ∧ fd.value = type ∧ + fd.indices = ctorFields (VExpr.dropN source.nparams type.type) ∧ + fd.constructors = type.ctors.map (CheckedCtor.ofBlock source) ∧ + blockFamilyCore source params (ord + t) type = true + | _, _, .nil, t, fd => by intro h; simp [CheckedFamilies.data] at h + | ord, _, .cons head tail, 0, fd => by + intro h + cases h + exact ⟨_, rfl, rfl, rfl, head.indices_eq, head.constructors_eq, head.accepted⟩ + | ord, _, .cons head tail, t+1, fd => by + intro h + obtain ⟨type, h1, h2, h3, h4, h5, h6⟩ := + CheckedFamilies.data_getElem? tail t (by simpa [CheckedFamilies.data] using h) + exact ⟨type, by simpa using h1, by omega, h3, h4, h5, + by rw [(by omega : ord + (t + 1) = ord + 1 + t)]; exact h6⟩ + +/-! ## Arity extraction from the analyzer's terminal target check -/ + +theorem blockTarget?_loop_length {U np j : Nat} {names : List Name} + {head : VExpr} {args : List VExpr} : + ∀ (headers : List FamilyHeader) (t : Nat) {target : Nat} {idxs : List VExpr}, + blockTarget?.loop U np j names head args t headers = some (target, idxs) → + t ≤ target ∧ ∃ header, headers[target - t]? = some header ∧ + args.length = np + header.indices ∧ idxs = args.drop np + | [], t, target, idxs => by intro h; simp [blockTarget?.loop] at h + | header :: headers, t, target, idxs => by + intro h + rw [blockTarget?.loop] at h + split at h + · rename_i hcond + cases h + simp only [Bool.and_eq_true, beq_iff_eq] at hcond + exact ⟨Nat.le_refl _, header, by simp, hcond.1.1.2, rfl⟩ + · obtain ⟨hle, header', h1, h2, h3⟩ := + blockTarget?_loop_length headers (t+1) h + refine ⟨Nat.le_of_succ_le hle, header', ?_, h2, h3⟩ + rw [(by omega : target - t = (target - (t+1)) + 1)] + simpa using h1 + +/-- A successful mutual target recognition pins the target's index arity to +its family header. -/ +theorem blockTarget?_length {U np j : Nat} {headers : List FamilyHeader} + {names : List Name} {B : VExpr} {target : Nat} {idxs : List VExpr} + (h : blockTarget? U np j headers names B = some (target, idxs)) : + ∃ header, headers[target]? = some header ∧ + (VExpr.appArgs B []).length = np + header.indices ∧ + idxs = (VExpr.appArgs B []).drop np := by + rw [blockTarget?] at h + obtain ⟨hle, header, h1, h2, h3⟩ := blockTarget?_loop_length headers 0 h + exact ⟨header, by simpa using h1, h2, h3⟩ + +/-- The terminal of an accepted mutual constructor shape is a successful +`blockTarget?` recognition of the owner family, past all fields. -/ +theorem blockStage3Ctor_result {U np : Nat} {headers : List FamilyHeader} + {names : List Name} {owner : Nat} : + ∀ (B : VExpr) (j : Nat), blockStage3Ctor U np headers names owner j B = true → + ∃ idxs, blockTarget? U np (j + (ctorFields B).length) headers names + (VExpr.resultOf B) = some (owner, idxs) := by + intro B + induction B with + (intro j h + simp only [blockStage3Ctor] at h + try (split at h + · rename_i target idxs heq + refine ⟨idxs, ?_⟩ + simp only [ctorFields, List.length_nil, Nat.add_zero, VExpr.resultOf] + rwa [(by simpa using h : target = owner)] at heq + · cases h)) + | forallE A rest _ ihR => + rw [Bool.and_eq_true] at h + obtain ⟨-, h2⟩ := h + obtain ⟨idxs, hidx⟩ := ihR (j+1) h2 + refine ⟨idxs, ?_⟩ + simp only [ctorFields, List.length_cons, VExpr.resultOf] + rwa [(by omega : j + ((ctorFields rest).length + 1) = j + 1 + (ctorFields rest).length)] + +/-! ## Name transport across the normalization boundary -/ + +theorem sameCtorHeaders_names : ∀ {cs cs' : List VConstVal}, + sameCtorHeaders cs cs' = true → cs.map (·.name) = cs'.map (·.name) + | [], [], _ => rfl + | c :: cs, c' :: cs', h => by + simp only [sameCtorHeaders, Bool.and_eq_true, beq_iff_eq] at h + simp only [List.map_cons, h.1.1, sameCtorHeaders_names h.2] + | [], _ :: _, h => by simp [sameCtorHeaders] at h + | _ :: _, [], h => by simp [sameCtorHeaders] at h + +theorem sameTypeHeaders_names : ∀ {tys tys' : List VInductiveType}, + sameTypeHeaders tys tys' = true → + tys.map (·.name) = tys'.map (·.name) ∧ + tys.flatMap (fun ty => ty.ctors.map (·.name)) = + tys'.flatMap (fun ty => ty.ctors.map (·.name)) + | [], [], _ => ⟨rfl, rfl⟩ + | ty :: tys, ty' :: tys', h => by + simp only [sameTypeHeaders, Bool.and_eq_true, beq_iff_eq] at h + have ih := sameTypeHeaders_names h.2 + simp only [List.map_cons, List.flatMap_cons, h.1.1.1, ih.1, ih.2, + sameCtorHeaders_names h.1.2, and_self] + | [], _ :: _, h => by simp [sameTypeHeaders] at h + | _ :: _, [], h => by simp [sameTypeHeaders] at h + +/-- The reserved generated names are unchanged by normalization: they are +computed from family and constructor identities only. -/ +theorem blockGeneratedNames_eq_of_sameTypeHeaders + {tys tys' : List VInductiveType} (h : sameTypeHeaders tys tys' = true) : + blockGeneratedNames tys = blockGeneratedNames tys' := by + obtain ⟨h1, h2⟩ := sameTypeHeaders_names h + have h3 : tys.map (fun ty => (.str ty.name "rec" : Name)) = + tys'.map (fun ty => (.str ty.name "rec" : Name)) := by + have := congrArg (List.map (fun n => (.str n "rec" : Name))) h1 + simpa [List.map_map, Function.comp_def] using this + simp only [blockGeneratedNames, h1, h2, h3] + +namespace BlockGenerationChecked + +variable {source : VInductDecl} (gen : source.BlockGenerationChecked) + +/-! ## Inventory facts from the certified block -/ + +include gen in +/-- The reserved generated names of the raw source are collision-free: the +analyzer certifies the view's inventory, and normalization retains every +identity. -/ +theorem blockGeneratedNames_nodup : + (blockGeneratedNames source.types).Nodup := by + have hshape := gen.block.normalization.shape_eq + simp only [normalizationShape, Bool.and_eq_true, beq_iff_eq] at hshape + rw [blockGeneratedNames_eq_of_sameTypeHeaders hshape.2] + have h := gen.block.checked.names_nodup + rwa [gen.block.checked.names_eq] at h + +/-! ## Named components of one generated iota rule -/ + +/-- Field count of one flattened constructor, as bound by its iota rule. -/ +def ruleFieldCount (constructor : NormalizedBlockCtor) : Nat := + (constructor.ctor.fieldsR source.uvars source.nparams gen.elimination).length + +/-- The result-index spine of one iota rule body, in the rule's binder +context. -/ +def ruleIdx (constructor : NormalizedBlockCtor) : List VExpr := + constructor.ctor.resultIndicesR source.uvars gen.elimination |>.map + fun e => e.liftN (gen.familyCount + gen.minorCount) + (gen.ruleFieldCount constructor) + +/-- The binder telescope shared by both towers of one iota rule. -/ +def ruleBinders (constructor : NormalizedBlockCtor) : List VExpr := + gen.paramsTel ++ gen.motiveTypes ++ gen.minorTypes ++ + VExpr.liftTelN (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams gen.elimination) 0 + +/-- The constructor-headed major premise of one iota rule body. -/ +def ruleCtorApp (constructor : NormalizedBlockCtor) : VExpr := + VExpr.appN (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + (gen.ruleFieldCount constructor + (gen.familyCount + gen.minorCount)) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.ruleFieldCount constructor)) + +/-- The exact left body of one generated iota rule: the owner's recursor +applied to the common arguments, the constructor's result indices, and the +constructor-headed major premise. -/ +def ruleLhsBody (constructor : NormalizedBlockCtor) : VExpr := + VExpr.appN (gen.recBase (gen.ruleFieldCount constructor) constructor.owner) + (gen.ruleIdx constructor ++ [gen.ruleCtorApp constructor]) + +/-- The generated rule's left side is exactly the shared binder telescope +over the `SimplePattern.iota` spine. -/ +theorem rule_lhs (i : Nat) (constructor : NormalizedBlockCtor) : + (gen.rule i constructor).lhs = + VExpr.lamN (gen.ruleBinders constructor) (gen.ruleLhsBody constructor) := rfl + +/-! ## The pattern of one generated iota rule -/ + +/-- The recursor constant owning one flattened constructor's iota rule. -/ +def ruleRecName (constructor : NormalizedBlockCtor) : Name := + .str (gen.familyNameAt constructor.owner) "rec" + +/-- Major-argument arity of one iota rule: shared parameters, all motives, +all minors, and the constructor's result indices. -/ +def ruleMajorArity (constructor : NormalizedBlockCtor) : Nat := + source.nparams + gen.familyCount + gen.minorCount + + (constructor.ctor.resultIndicesR source.uvars gen.elimination).length + +/-- Argument arity of one iota rule's constructor-headed major premise. -/ +def ruleArgArity (constructor : NormalizedBlockCtor) : Nat := + source.nparams + gen.ruleFieldCount constructor + +/-- The `SimplePattern` of one generated iota rule. -/ +def rulePattern (constructor : NormalizedBlockCtor) : SimplePattern := + .iota (gen.ruleRecName constructor) (gen.ruleMajorArity constructor) + constructor.ctor.raw.name (gen.ruleArgArity constructor) + +/-- The generated left body is matched by the rule's pattern, at exactly the +rule's recursor levels. -/ +theorem ruleLhsBody_matches (constructor : NormalizedBlockCtor) : + ∃ m2, ((gen.rulePattern constructor).toPattern).Matches + (gen.ruleLhsBody constructor) gen.recLevels m2 := by + rw [rulePattern, SimplePattern.toPattern_iota] + have hleft : HeadConstN (gen.ruleRecName constructor) gen.recLevels + (gen.ruleMajorArity constructor) + (VExpr.appN (gen.recBase (gen.ruleFieldCount constructor) constructor.owner) + (gen.ruleIdx constructor)) := by + have h0 : HeadConstN (gen.ruleRecName constructor) gen.recLevels 0 + (.const (gen.ruleRecName constructor) gen.recLevels) := .const + have h1 := (h0.appN (VExpr.bvarRevRange (gen.ruleFieldCount constructor) + (source.nparams + gen.familyCount + gen.minorCount))) + have h2 := h1.appN (as := gen.ruleIdx constructor) + rw [VExpr.bvarRevRange_length] at h2 + have harity : 0 + (source.nparams + gen.familyCount + gen.minorCount) + + (gen.ruleIdx constructor).length = gen.ruleMajorArity constructor := by + simp only [ruleIdx, ruleMajorArity, List.length_map]; omega + rwa [harity] at h2 + have hright : HeadConstN constructor.ctor.raw.name gen.sourceLevels + (gen.ruleArgArity constructor) (gen.ruleCtorApp constructor) := by + have h0 : HeadConstN constructor.ctor.raw.name gen.sourceLevels 0 + (.const constructor.ctor.raw.name gen.sourceLevels) := .const + have h1 := h0.appN (as := VExpr.bvarRevRange + (gen.ruleFieldCount constructor + (gen.familyCount + gen.minorCount)) + source.nparams ++ VExpr.bvarRevRange 0 (gen.ruleFieldCount constructor)) + rw [List.length_append, VExpr.bvarRevRange_length, VExpr.bvarRevRange_length] at h1 + have harity : 0 + (source.nparams + gen.ruleFieldCount constructor) = + gen.ruleArgArity constructor := by simp only [ruleArgArity]; omega + rwa [harity] at h1 + have hbody : gen.ruleLhsBody constructor = + .app (VExpr.appN (gen.recBase (gen.ruleFieldCount constructor) constructor.owner) + (gen.ruleIdx constructor)) + (gen.ruleCtorApp constructor) := by + rw [ruleLhsBody, VExpr.appN_append] + rfl + rw [hbody] + exact RecursorIotaPattern.matches_of hleft hright + +/-! ## Positional anatomy of the flattened constructors -/ + +/-- The checked spine assigns family ordinals positionally. -/ +theorem families_getElem?_ordinal {t : Nat} {family : NormalizedFamily} + (h : gen.families[t]? = some family) : family.view.ordinal = t := by + have h' : (pairNormalizedFamilies source.types + gen.block.checked.families.data)[t]? = some family := h + obtain ⟨-, hview⟩ := pairNormalizedFamilies_getElem? _ _ t h' + obtain ⟨type, -, hord, -, -, -, -⟩ := CheckedFamilies.data_getElem? _ t hview + simpa using hord + +/-- Position `t` of the paired family list is the `t`-th source family. -/ +theorem families_getElem?_raw {t : Nat} {family : NormalizedFamily} + (h : gen.families[t]? = some family) : source.types[t]? = some family.raw := + (pairNormalizedFamilies_getElem? source.types + gen.block.checked.families.data t h).1 + +/-- A family lookup names the owning recursor's family. -/ +theorem familyNameAt_eq {t : Nat} {family : NormalizedFamily} + (h : gen.families[t]? = some family) : + gen.familyNameAt t = family.raw.name := by + simp [familyNameAt, h] + +/-- One flattened constructor decomposes into its owner family lookup and +its position inside that family's pairing. -/ +theorem flatCtors_anatomy {constructor : NormalizedBlockCtor} + (hc : constructor ∈ gen.flatCtors) : + ∃ t family, gen.families[t]? = some family ∧ + constructor.owner = t ∧ + constructor.familyName = family.raw.name ∧ + constructor.familyIndices = family.view.indices ∧ + constructor.ctor ∈ family.ctorPairs := by + have hc' : constructor ∈ gen.families.flatMap (·.blockCtors) := hc + rw [List.mem_flatMap] at hc' + obtain ⟨family, hfamily, hmem⟩ := hc' + obtain ⟨t, ht⟩ := List.mem_iff_getElem?.1 hfamily + simp only [NormalizedFamily.blockCtors, List.mem_map] at hmem + obtain ⟨ctor, hctor, rfl⟩ := hmem + exact ⟨t, family, ht, gen.families_getElem?_ordinal ht, rfl, rfl, hctor⟩ + +/-! ## The analyzer's arity equation for pattern majors -/ + +/-- Every flattened constructor's checked result-index spine has exactly its +owner family's index arity: the analyzer's terminal `blockTarget?` equation +transports through the checked spine. -/ +theorem view_resultIndices_length {constructor : NormalizedBlockCtor} + (hc : constructor ∈ gen.flatCtors) : + constructor.ctor.view.resultIndices.length = + constructor.familyIndices.length := by + obtain ⟨t, family, ht, -, -, hindices, hmem⟩ := gen.flatCtors_anatomy hc + have ht' : (pairNormalizedFamilies source.types + gen.block.checked.families.data)[t]? = some family := ht + obtain ⟨-, hview⟩ := pairNormalizedFamilies_getElem? _ _ t ht' + obtain ⟨vtype, hvty, -, -, hvindices, hvctors, hvcore⟩ := + CheckedFamilies.data_getElem? _ t hview + rw [Nat.zero_add] at hvcore + obtain ⟨s, hs⟩ := List.mem_iff_getElem?.1 hmem + have hs' : (pairNormalizedCtors family.raw.ctors + family.view.constructors)[s]? = some constructor.ctor := hs + obtain ⟨-, hviewCtor⟩ := pairNormalizedCtors_getElem? _ _ s hs' + rw [hvctors, List.getElem?_map] at hviewCtor + obtain ⟨c₀, hc₀, hview_eq⟩ : ∃ c₀, vtype.ctors[s]? = some c₀ ∧ + CheckedCtor.ofBlock _ c₀ = constructor.ctor.view := by + cases h0 : vtype.ctors[s]? with + | none => rw [h0] at hviewCtor; cases hviewCtor + | some c₀ => rw [h0] at hviewCtor; exact ⟨c₀, rfl, by simpa using hviewCtor⟩ + simp only [blockFamilyCore, Bool.and_eq_true, beq_iff_eq, + List.all_eq_true] at hvcore + have hstage := (hvcore.2 c₀ (List.mem_of_getElem? hc₀)).2 + obtain ⟨idxs, htarget⟩ := blockStage3Ctor_result _ 0 hstage + obtain ⟨header, hheader, hlen, -⟩ := blockTarget?_length htarget + rw [familyHeaders, List.getElem?_map, hvty, Option.map_some] at hheader + have hri : constructor.ctor.view.resultIndices = + (VExpr.appArgs (VExpr.resultOf (VExpr.dropN + gen.block.normalization.view.nparams c₀.type)) []).drop + gen.block.normalization.view.nparams := by + rw [← hview_eq]; rfl + rw [hri, hindices, hvindices, List.length_drop, hlen] + cases hheader + show gen.block.normalization.view.nparams + + (ctorFields (VExpr.dropN gen.block.normalization.view.nparams + vtype.type)).length - + gen.block.normalization.view.nparams = + (ctorFields (VExpr.dropN gen.block.normalization.view.nparams + vtype.type)).length + omega + +/-- Pattern major arity through the owner family's index count. -/ +theorem ruleMajorArity_eq {constructor : NormalizedBlockCtor} + (hc : constructor ∈ gen.flatCtors) : + gen.ruleMajorArity constructor = + source.nparams + gen.familyCount + gen.minorCount + + constructor.familyIndices.length := by + simp only [ruleMajorArity, NormalizedCtor.resultIndicesR, List.length_map, + gen.view_resultIndices_length hc] + +/-! ## Name freshness of the generated inventory -/ + +include gen in +private theorem nodup_parts : + (source.types.map (·.name)).Nodup ∧ + (source.types.flatMap fun ty => ty.ctors.map (·.name)).Nodup ∧ + ∀ a ∈ (source.types.flatMap fun ty => ty.ctors.map (·.name)), + ∀ b ∈ source.types.map (fun ty => (.str ty.name "rec" : Name)), a ≠ b := by + have h := gen.blockGeneratedNames_nodup + rw [blockGeneratedNames, List.nodup_append] at h + obtain ⟨hAB, -, hdisj⟩ := h + rw [List.nodup_append] at hAB + exact ⟨hAB.1, hAB.2.1, fun a ha b hb => + hdisj a (List.mem_append.2 (.inr ha)) b hb⟩ + +/-- Family positions are recoverable from raw family names. -/ +theorem families_name_inj {t t' : Nat} {family family' : NormalizedFamily} + (h : gen.families[t]? = some family) (h' : gen.families[t']? = some family') + (hname : family.raw.name = family'.raw.name) : t = t' := by + have h1 := gen.families_getElem?_raw h + have h1' := gen.families_getElem?_raw h' + have hm : (source.types.map (·.name))[t]? = some family.raw.name := by + rw [List.getElem?_map, h1, Option.map_some] + have hm' : (source.types.map (·.name))[t']? = some family.raw.name := by + rw [List.getElem?_map, h1', Option.map_some, hname] + obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.1 hm + exact (List.getElem?_inj hlt gen.nodup_parts.1).1 (hm.trans hm'.symm) + +/-- Flattened positions are recoverable from raw constructor names. -/ +theorem flatCtors_name_inj {i i' : Nat} {c c' : NormalizedBlockCtor} + (h : gen.flatCtors[i]? = some c) (h' : gen.flatCtors[i']? = some c') + (hname : c.ctor.raw.name = c'.ctor.raw.name) : i = i' ∧ c = c' := by + have hnodup : ((source.blockConstructorConstants).map (·.name)).Nodup := by + rw [VInductDecl.blockConstructorConstants, List.map_flatMap] + exact gen.nodup_parts.2.1 + have hm : ((source.blockConstructorConstants).map (·.name))[i]? = + some c.ctor.raw.name := by + rw [List.getElem?_map, ← gen.flatCtors_map_raw, List.getElem?_map, h] + rfl + have hm' : ((source.blockConstructorConstants).map (·.name))[i']? = + some c.ctor.raw.name := by + rw [List.getElem?_map, ← gen.flatCtors_map_raw, List.getElem?_map, h', + hname] + rfl + obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.1 hm + have hii : i = i' := (List.getElem?_inj hlt hnodup).1 (hm.trans hm'.symm) + subst hii + exact ⟨rfl, Option.some.inj (h.symm.trans h')⟩ + +/-- No family's recursor name collides with any flattened constructor's +name. -/ +theorem recName_ne_ctorName {family : NormalizedFamily} + (hfam : family ∈ gen.families) {constructor : NormalizedBlockCtor} + (hc : constructor ∈ gen.flatCtors) : + (.str family.raw.name "rec" : Name) ≠ constructor.ctor.raw.name := by + have hmemC : constructor.ctor.raw.name ∈ + source.types.flatMap fun ty => ty.ctors.map (·.name) := by + have h1 : constructor.ctor.raw ∈ source.blockConstructorConstants := by + rw [← gen.flatCtors_map_raw] + exact List.mem_map_of_mem hc + rw [VInductDecl.blockConstructorConstants, List.mem_flatMap] at h1 + obtain ⟨ty, hty, hmem⟩ := h1 + rw [List.mem_flatMap] + exact ⟨ty, hty, List.mem_map_of_mem hmem⟩ + have hmemR : (.str family.raw.name "rec" : Name) ∈ + source.types.map (fun ty => (.str ty.name "rec" : Name)) := by + have h1 : family.raw ∈ source.types := by + rw [← gen.families_map_raw] + exact List.mem_map_of_mem hfam + exact List.mem_map_of_mem h1 + intro heq + exact gen.nodup_parts.2.2 _ hmemC _ hmemR heq.symm + +/-- Two flattened constructors with the same owning recursor name share +their owner and their family's index telescope. -/ +theorem ruleRecName_inj {c c' : NormalizedBlockCtor} + (hc : c ∈ gen.flatCtors) (hc' : c' ∈ gen.flatCtors) + (h : gen.ruleRecName c = gen.ruleRecName c') : + c.owner = c'.owner ∧ c.familyIndices = c'.familyIndices := by + obtain ⟨t, family, ht, ho, -, hi, -⟩ := gen.flatCtors_anatomy hc + obtain ⟨t', family', ht', ho', -, hi', -⟩ := gen.flatCtors_anatomy hc' + rw [ruleRecName, ruleRecName, ho, ho', gen.familyNameAt_eq ht, + gen.familyNameAt_eq ht'] at h + have hnames : family.raw.name = family'.raw.name := by + injection h with h1 h2 + have ht2 : t = t' := gen.families_name_inj ht ht' hnames + subst ht2 + cases Option.some.inj (ht.symm.trans ht') + exact ⟨ho.trans ho'.symm, hi.trans hi'.symm⟩ + +/-- Rule distinctness: distinct flattened positions carry distinct +patterns. -/ +theorem rulePattern_inj {i i' : Nat} {c c' : NormalizedBlockCtor} + (h : gen.flatCtors[i]? = some c) (h' : gen.flatCtors[i']? = some c') + (heq : gen.rulePattern c = gen.rulePattern c') : i = i' ∧ c = c' := by + injection heq with h1 h2 h3 h4 + exact gen.flatCtors_name_inj h h' h3 + +/-! ## Rule payloads: RHS templates and agreement checks -/ + +/-- Closedness inputs for one certified block's rule payloads: the towers a +rule's RHS template and checks embed as fixed template constants. Concrete +fixtures discharge this bundle by `decide`; the pattern-soundness milestone +derives it from the staged environment's rule well-formedness. -/ +structure RuleClosure : Prop where + rhs_closed : ∀ ⦃i : Nat⦄ ⦃constructor : NormalizedBlockCtor⦄, + gen.flatCtors[i]? = some constructor → + ((gen.rule i constructor).rhs).ClosedN 0 + idxTower_closed : ∀ ⦃constructor : NormalizedBlockCtor⦄, + constructor ∈ gen.flatCtors → ∀ e ∈ gen.ruleIdx constructor, + (VExpr.lamN (gen.ruleBinders constructor) e).ClosedN 0 + +/-- The template capture list shared by every payload tower: the recursor +side's parameters, motives, and minors, then the major premise's fields. -/ +def captureArgs (constructor : NormalizedBlockCtor) : + List (((gen.rulePattern constructor).toPattern).RHS) := + ((Pattern.varNPaths (.const (gen.ruleRecName constructor)) + (gen.ruleMajorArity constructor)).take + (source.nparams + gen.familyCount + gen.minorCount)).map + (fun path => .var (.inl path)) ++ + ((Pattern.varNPaths (.const constructor.ctor.raw.name) + (gen.ruleArgArity constructor)).drop source.nparams).map + (fun path => .var (.inr path)) + +/-- The RHS template of one rule: the registered right tower applied to the +captured common arguments and fields. -/ +def ruleRHS (hcl : gen.RuleClosure) {i : Nat} {constructor : NormalizedBlockCtor} + (h : gen.flatCtors[i]? = some constructor) : + ((gen.rulePattern constructor).toPattern).RHS := + Pattern.RHS.appN (.fixed ((gen.rule i constructor).rhs) (hcl.rhs_closed h)) + (gen.captureArgs constructor) + +/-- The check list of one rule: the major premise's parameters must agree +with the recursor side's parameters, and the recursor side's index arguments +must agree with the constructor's computed result indices (as fixed index +towers applied to the captures). -/ +def ruleCheck (hcl : gen.RuleClosure) {constructor : NormalizedBlockCtor} + (hc : constructor ∈ gen.flatCtors) : + ((gen.rulePattern constructor).toPattern).Check := + let recPaths := Pattern.varNPaths (.const (gen.ruleRecName constructor)) + (gen.ruleMajorArity constructor) + let ctorPaths := Pattern.varNPaths (.const constructor.ctor.raw.name) + (gen.ruleArgArity constructor) + let common := source.nparams + gen.familyCount + gen.minorCount + let idxChecks := + ((gen.ruleIdx constructor).attach.zip (recPaths.drop common)).foldr + (fun ep rest => + .defeq (.var (.inl ep.2)) + (Pattern.RHS.appN + (.fixed (VExpr.lamN (gen.ruleBinders constructor) ep.1.1) + (hcl.idxTower_closed hc ep.1.1 ep.1.2)) + (gen.captureArgs constructor)) rest) + .true + ((ctorPaths.take source.nparams).zip (recPaths.take source.nparams)).foldr + (fun pr rest => .defeq (.var (.inr pr.1)) (.var (.inl pr.2)) rest) + idxChecks + +/-- Position `i` of the certified block's flattened constructor list. -/ +abbrev ruleEntry (i : Nat) (constructor : NormalizedBlockCtor) : Prop := + gen.flatCtors[i]? = some constructor + +/-- A decidable sufficient condition for `RuleClosure`, discharging concrete +fixtures by evaluation. -/ +theorem RuleClosure.of_all + (h1 : gen.flatCtors.zipIdx.all (fun ic => + decide (((gen.rule ic.2 ic.1).rhs).ClosedN 0)) = true) + (h2 : gen.flatCtors.all (fun c => (gen.ruleIdx c).all fun e => + decide ((VExpr.lamN (gen.ruleBinders c) e).ClosedN 0)) = true) : + gen.RuleClosure := by + constructor + · intro i constructor h + have hmem : (constructor, i) ∈ gen.flatCtors.zipIdx := by + apply List.mem_of_getElem? (i := i) + rw [List.getElem?_zipIdx, h, Option.map_some, Nat.zero_add] + exact of_decide_eq_true (List.all_eq_true.1 h1 _ hmem) + · intro constructor hc e he + exact of_decide_eq_true (List.all_eq_true.1 (List.all_eq_true.1 h2 _ hc) _ he) + +/-- The pattern set of one certified block: each flattened constructor's +rule pattern with its template and checks. -/ +inductive IotaPat (hcl : gen.RuleClosure) : + (p : Pattern) → p.RHS × p.Check → Prop where + | mk {i : Nat} {constructor : NormalizedBlockCtor} + (h : gen.ruleEntry i constructor) : + IotaPat hcl ((gen.rulePattern constructor).toPattern) + (gen.ruleRHS hcl h, gen.ruleCheck hcl (List.mem_of_getElem? h)) + +/-! ## The `Params` obligations for one certified block -/ + +/-- `Params.pat_simple` for the block's pattern set. -/ +theorem IotaPat.pat_simple {hcl : gen.RuleClosure} {p : Pattern} + {r : p.RHS × p.Check} (H : gen.IotaPat hcl p r) : + ∃ sp : SimplePattern, p = sp.toPattern := by + cases H with | mk h => exact ⟨_, rfl⟩ + +/-- Rule recovery: a pattern in the block's set determines its flattened +rule position and constructor. -/ +theorem IotaPat.recover {hcl : gen.RuleClosure} {p : Pattern} + {r : p.RHS × p.Check} (H : gen.IotaPat hcl p r) : + ∃ (i : Nat) (constructor : NormalizedBlockCtor), + gen.flatCtors[i]? = some constructor ∧ + p = (gen.rulePattern constructor).toPattern ∧ + ∀ (i' : Nat) (constructor' : NormalizedBlockCtor), + gen.flatCtors[i']? = some constructor' → + (gen.rulePattern constructor').toPattern = p → + i' = i ∧ constructor' = constructor := by + cases H with | @mk i constructor h => + refine ⟨i, constructor, h, rfl, ?_⟩ + intro i' constructor' h' heq + have := RecursorIotaPattern.inj heq + exact gen.flatCtors_name_inj h' h this.2.2.1 + +/-- `Params.pat_uniq` for the block's pattern set. -/ +theorem IotaPat.pat_uniq {hcl : gen.RuleClosure} {p₁ p₂ p₃ p₄ : Pattern} + {r : p₁.RHS × p₁.Check} {r' : p₂.RHS × p₂.Check} + (H1 : gen.IotaPat hcl p₁ r) (H2 : gen.IotaPat hcl p₂ r') + (H3 : Subpattern p₃ p₁) (H4 : p₂.inter p₃ = some p₄) : + p₁ = p₂ ∧ p₂ = p₃ ∧ r ≍ r' := by + cases H1 with | @mk i c h => + cases H2 with | @mk i' c' h' => + rcases RecursorIotaPattern.subpattern_inv H3 with rfl | ⟨j, hj, rfl⟩ | ⟨j, hj, rfl⟩ + · obtain ⟨hR, hM, hC, hN, rfl⟩ := RecursorIotaPattern.inter_some H4 + obtain ⟨rfl, rfl⟩ := gen.flatCtors_name_inj h' h hC + exact ⟨rfl, rfl, HEq.rfl⟩ + · obtain ⟨hb, hj'⟩ := RecursorIotaPattern.inter_varN_const_some H4 + obtain ⟨-, hIdx⟩ := gen.ruleRecName_inj (List.mem_of_getElem? h) + (List.mem_of_getElem? h') hb + have hM : gen.ruleMajorArity c' = gen.ruleMajorArity c := by + rw [gen.ruleMajorArity_eq (List.mem_of_getElem? h'), + gen.ruleMajorArity_eq (List.mem_of_getElem? h), hIdx] + omega + · obtain ⟨hb, -⟩ := RecursorIotaPattern.inter_varN_const_some H4 + obtain ⟨t', family', ht', ho', -, -, -⟩ := + gen.flatCtors_anatomy (List.mem_of_getElem? h') + have hrec : gen.ruleRecName c' = (.str family'.raw.name "rec" : Name) := by + rw [ruleRecName, ho', gen.familyNameAt_eq ht'] + refine absurd ?_ (gen.recName_ne_ctorName (List.mem_of_getElem? ht') + (List.mem_of_getElem? h)) + rw [← hrec, hb] + +/-- `Params.pat_app_l` for the block's pattern set. -/ +theorem IotaPat.pat_app_l {hcl : gen.RuleClosure} {p : Pattern} + {r : p.RHS × p.Check} {p₁ p₂ p₃ p₄ : Pattern} + (H : gen.IotaPat hcl p r) (h : Subpattern (.app p₁ p₂) p) : + ¬Subpattern (.app p₃ p₄) p₁ := by + cases H with | @mk i c hi => + obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h + intro hsub + obtain ⟨j', hj', heq'⟩ := hsub.varN_const_le + cases j' <;> exact absurd heq' (by simp [Pattern.varN]) + +/-- `Params.pat_app_l_uniq` for the block's pattern set. -/ +theorem IotaPat.pat_app_l_uniq {hcl : gen.RuleClosure} {p p' : Pattern} + {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check} {p₁ p₂ p₁' p₂' p₃ : Pattern} + (H : gen.IotaPat hcl p r) (H' : gen.IotaPat hcl p' r') + (h : Subpattern (.app p₁ p₂) p) (h' : Subpattern (.app p₁' p₂') p') + (h₃ : Subpattern (.var p₃) p₁) : p₁'.inter p₃ = none := by + cases H with | @mk i c hi => + cases H' with | @mk i' c' hi' => + obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h + obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h' + obtain ⟨j, hj, heq⟩ := h₃.varN_const_le + cases j with + | zero => exact absurd heq (by simp [Pattern.varN]) + | succ j'' => + rw [show Pattern.varN (.const (gen.ruleRecName c)) (j'' + 1) = + .var (Pattern.varN (.const (gen.ruleRecName c)) j'') from rfl] at heq + injection heq with heq' + subst heq' + by_cases hname : gen.ruleRecName c' = gen.ruleRecName c + · obtain ⟨-, hIdx⟩ := gen.ruleRecName_inj (List.mem_of_getElem? hi') + (List.mem_of_getElem? hi) hname + have hM : gen.ruleMajorArity c' = gen.ruleMajorArity c := by + rw [gen.ruleMajorArity_eq (List.mem_of_getElem? hi'), + gen.ruleMajorArity_eq (List.mem_of_getElem? hi), hIdx] + rw [hname] + exact Pattern.varN_const_inter_of_ne_arity (by omega) _ _ + · exact Pattern.varN_const_inter_of_ne_name hname _ _ + +/-- `Params.pat_app_uniq` for the block's pattern set. -/ +theorem IotaPat.pat_app_uniq {hcl : gen.RuleClosure} {p p' : Pattern} + {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check} + {p₁ p₂ p₁' p₂' p₃ p₃' : Pattern} + (H : gen.IotaPat hcl p r) (H' : gen.IotaPat hcl p' r') + (h : Subpattern (.app p₁ p₂) p) (h' : Subpattern (.app p₁' p₂') p') + (h₃ : Subpattern p₃ p₁) (h₃' : Subpattern p₃' p₂') : p₃.inter p₃' = none := by + cases H with | @mk i c hi => + cases H' with | @mk i' c' hi' => + obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h + obtain ⟨-, rfl⟩ := RecursorIotaPattern.app_subpattern h' + obtain ⟨j, hj, rfl⟩ := h₃.varN_const_le + obtain ⟨j', hj', rfl⟩ := h₃'.varN_const_le + refine Pattern.varN_const_inter_of_ne_name ?_ _ _ + obtain ⟨t, family, ht, ho, -, -, -⟩ := + gen.flatCtors_anatomy (List.mem_of_getElem? hi) + have hrec : gen.ruleRecName c = (.str family.raw.name "rec" : Name) := by + rw [ruleRecName, ho, gen.familyNameAt_eq ht] + rw [hrec] + exact gen.recName_ne_ctorName (List.mem_of_getElem? ht) + (List.mem_of_getElem? hi') + +/-! ## Axiom closures of the generic pattern facts -/ + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.ruleLhsBody_matches' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms ruleLhsBody_matches + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.view_resultIndices_length' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms view_resultIndices_length + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.rulePattern_inj' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms rulePattern_inj + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_simple' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms IotaPat.pat_simple + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.recover' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms IotaPat.recover + +/-- +info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_uniq' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms IotaPat.pat_uniq + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_app_l' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms IotaPat.pat_app_l + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_app_l_uniq' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms IotaPat.pat_app_l_uniq + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_app_uniq' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms IotaPat.pat_app_uniq + +end BlockGenerationChecked + +end VInductDecl + +end Lean4Lean diff --git a/Lean4Lean/Theory/Typing/InductivePatternEnv.lean b/Lean4Lean/Theory/Typing/InductivePatternEnv.lean new file mode 100644 index 00000000..d5c34712 --- /dev/null +++ b/Lean4Lean/Theory/Typing/InductivePatternEnv.lean @@ -0,0 +1,239 @@ +import Lean4Lean.Theory.Typing.InductivePatternWF + +/-! # The block-local pattern environment assembler + +`assembleEnv` builds an environment whose defeq set consists of exactly one +certified block's generated iota rules plus separately certified extension +rules over a defeq-free constant base. The exposed helpers are the ones +Church–Rosser instantiation and downstream consumers need: + +* `assembleEnv_defeqs` inverts the assembled defeq set exactly: a registered + defeq is a generated rule, an extension, or a base defeq — nothing else. +* `assembleEnv_WF` preserves ordering through the block phases and the + extension fold, given the block's semantic package and each extension's + well-formedness. +* `AssembledPat` is the union pattern set. The block half carries the full + L4L-10A obligations and `pat_wf`; the extension half carries each + certificate's own pattern payload, with `CertifiedExtension.covers` + recording the spine-level coverage equation that `extra_pat` demands of + it. No open-environment `Params` instance is installed. -/ + +namespace Lean4Lean + +namespace VInductDecl + +/-- One separately certified extension rule for an assembled environment: +its registered defeq, a simple pattern, the pattern payload, and the exact +spine-level coverage equation (every universe instantiation of the defeq's +left side matches the pattern, and its right side is the applied +template). Check obligations (`Check.OK`) are discharged by the consumer at +instantiation time. -/ +structure CertifiedExtension where + df : VDefEq + pat : SimplePattern + rhs : (pat.toPattern).RHS + check : (pat.toPattern).Check + covers : ∀ (ls : List VLevel), ls.length = df.uvars → + ∃ m1 m2, (pat.toPattern).Matches (df.lhs.instL ls) m1 m2 ∧ + df.rhs.instL ls = rhs.apply m1 m2 + +namespace BlockGenerationChecked + +variable {source : VInductDecl} (gen : source.BlockGenerationChecked) + +/-- The assembled block-local environment: dependency constants from the +base, the block's four insertion phases, and the certified extension +defeqs. -/ +def assembleEnv (base : VEnv) (exts : List CertifiedExtension) : + Option VEnv := do + let env ← base.addInductBlockGeneration gen + return exts.foldl (fun env ext => env.addDefEq ext.df) env + +/-! ## Defeq-set inversion -/ + +private theorem addConst_defeqs {env env' : VEnv} {n : Name} {ci : VConstant} + (h : env.addConst n ci = some env') {df : VDefEq} : + env'.defeqs df ↔ env.defeqs df := by + unfold VEnv.addConst at h + split at h + · cases h + · cases h + exact Iff.rfl + +private theorem foldlM_addConst_defeqs {α : Type _} (name : α → Name) + (ci : α → VConstant) : + ∀ (xs : List α) {env env' : VEnv}, + xs.foldlM (fun env x => env.addConst (name x) (ci x)) env = some env' → + ∀ {df : VDefEq}, (env'.defeqs df ↔ env.defeqs df) + | [], env, env', h, df => by cases h; exact Iff.rfl + | x :: xs, env, env', h, df => by + rw [List.foldlM_cons] at h + rcases Option.bind_eq_some_iff.1 h with ⟨envx, hx, hrest⟩ + exact (foldlM_addConst_defeqs name ci xs hrest).trans (addConst_defeqs hx) + +private theorem foldl_addDefEq_defeqs : + ∀ (dfs : List VDefEq) (env : VEnv) (df : VDefEq), + ((dfs.foldl VEnv.addDefEq env).defeqs df ↔ df ∈ dfs ∨ env.defeqs df) + | [], env, df => by simp + | d :: dfs, env, df => by + rw [List.foldl_cons, foldl_addDefEq_defeqs dfs (env.addDefEq d) df] + show _ ∨ (df = d ∨ _) ↔ _ + rw [List.mem_cons] + constructor + · rintro (h | h | h) + · exact .inl (.inr h) + · exact .inl (.inl h) + · exact .inr h + · rintro ((h | h) | h) + · exact .inr (.inl h) + · exact .inl h + · exact .inr (.inr h) + +/-- Registered defeqs of a completed block transaction are exactly the +generated rules over the base's. -/ +theorem addInductBlockGeneration_defeqs {base env₁ : VEnv} + (hadd : base.addInductBlockGeneration gen = some env₁) (df : VDefEq) : + env₁.defeqs df ↔ df ∈ gen.generatedRules ∨ base.defeqs df := by + rcases VEnv.addInductBlockGeneration_trace hadd with ⟨H⟩ + rw [← H.addRules, foldl_addDefEq_defeqs] + refine or_congr Iff.rfl ?_ + exact ((foldlM_addConst_defeqs _ _ _ H.addRecs).trans + ((foldlM_addConst_defeqs _ _ _ H.addCtors).trans + (foldlM_addConst_defeqs _ _ _ H.addTypes))) + +/-- The assembled defeq set, inverted exactly. -/ +theorem assembleEnv_defeqs {base env' : VEnv} + {exts : List CertifiedExtension} + (hadd : gen.assembleEnv base exts = some env') (df : VDefEq) : + env'.defeqs df ↔ + df ∈ gen.generatedRules ∨ (∃ ext ∈ exts, df = ext.df) ∨ + base.defeqs df := by + unfold assembleEnv at hadd + rcases Option.bind_eq_some_iff.1 hadd with ⟨env₁, h₁, h₂⟩ + cases Option.some.inj h₂ + have hfold : ∀ (es : List CertifiedExtension) (env : VEnv), + ((es.foldl (fun env ext => env.addDefEq ext.df) env).defeqs df ↔ + (∃ ext ∈ es, df = ext.df) ∨ env.defeqs df) := by + intro es + induction es with + | nil => intro env; simp + | cons e es ih => + intro env + rw [List.foldl_cons, ih (env.addDefEq e.df)] + show _ ∨ (df = e.df ∨ _) ↔ _ + constructor + · rintro (⟨ext, hm, rfl⟩ | rfl | hbase) + · exact .inl ⟨ext, .tail _ hm, rfl⟩ + · exact .inl ⟨e, .head _, rfl⟩ + · exact .inr hbase + · rintro (⟨ext, hm, rfl⟩ | hbase) + · rcases List.mem_cons.1 hm with rfl | hm + · exact .inr (.inl rfl) + · exact .inl ⟨ext, hm, rfl⟩ + · exact .inr (.inr hbase) + rw [hfold, gen.addInductBlockGeneration_defeqs h₁] + constructor + · rintro (h | h | h) + · exact .inr (.inl h) + · exact .inl h + · exact .inr (.inr h) + · rintro (h | h | h) + · exact .inr (.inl h) + · exact .inl h + · exact .inr (.inr h) + +/-- A defeq-free base makes the assembled defeq set exactly the generated +rules plus the certified extensions. -/ +theorem assembleEnv_defeq_cases {base env' : VEnv} + {exts : List CertifiedExtension} + (hadd : gen.assembleEnv base exts = some env') + (hbase : ∀ df, ¬base.defeqs df) {df : VDefEq} + (hdf : env'.defeqs df) : + df ∈ gen.generatedRules ∨ ∃ ext ∈ exts, df = ext.df := by + rcases (gen.assembleEnv_defeqs hadd df).1 hdf with h | h | h + · exact .inl h + · exact .inr h + · exact absurd h (hbase df) + +/-! ## Ordering -/ + +/-- The assembled environment is ordered: the block transaction preserves +ordering through its four phases, and each certified extension is well +formed over the post-block environment. -/ +theorem assembleEnv_WF {base : VEnv} (henv : base.Ordered) + {blockEnv : VEnv} (hgen : gen.WF base blockEnv) + {exts : List CertifiedExtension} {env₁ : VEnv} + (hadd₁ : base.addInductBlockGeneration gen = some env₁) + (hexts : ∀ ext ∈ exts, ext.df.WF env₁) : + ∃ env', gen.assembleEnv base exts = some env' ∧ env'.Ordered := by + refine ⟨exts.foldl (fun env ext => env.addDefEq ext.df) env₁, ?_, ?_⟩ + · unfold assembleEnv + rw [hadd₁] + rfl + · have hord₁ : env₁.Ordered := + VEnv.addInductBlockGeneration_WF henv hgen hadd₁ + have hmap : exts.foldl (fun env ext => env.addDefEq ext.df) env₁ = + (exts.map (·.df)).foldl VEnv.addDefEq env₁ := by + rw [List.foldl_map] + rw [hmap] + exact VInductDecl.rulesFold_WF _ hord₁ + (fun df hdf => by + rcases List.mem_map.1 hdf with ⟨ext, hm, rfl⟩ + exact hexts ext hm) + +/-! ## The union pattern set -/ + +/-- The assembled pattern set: the block's iota patterns with their L4L-10A +payloads, plus each certified extension's pattern payload. -/ +inductive AssembledPat (hcl : gen.RuleClosure) + (exts : List CertifiedExtension) : + (p : Pattern) → p.RHS × p.Check → Prop where + | rule {p : Pattern} {r : p.RHS × p.Check} : + gen.IotaPat hcl p r → AssembledPat hcl exts p r + | ext (ext : CertifiedExtension) (hmem : ext ∈ exts) : + AssembledPat hcl exts (ext.pat.toPattern) (ext.rhs, ext.check) + +/-- `Params.pat_simple` for the assembled set. -/ +theorem AssembledPat.pat_simple {hcl : gen.RuleClosure} + {exts : List CertifiedExtension} {p : Pattern} {r : p.RHS × p.Check} + (H : gen.AssembledPat hcl exts p r) : + ∃ sp : SimplePattern, p = sp.toPattern := by + cases H with + | rule h => exact h.pat_simple + | ext ext hmem => exact ⟨ext.pat, rfl⟩ + +/-- Extension defeqs of the assembled set satisfy the spine-level +`extra_pat` equation through their certificates. -/ +theorem AssembledPat.ext_covers {hcl : gen.RuleClosure} + {exts : List CertifiedExtension} {ext : CertifiedExtension} + (hmem : ext ∈ exts) {ls : List VLevel} (hls : ls.length = ext.df.uvars) : + ∃ p r m1 m2, gen.AssembledPat hcl exts p r ∧ + p.Matches (ext.df.lhs.instL ls) m1 m2 ∧ + ext.df.rhs.instL ls = r.1.apply m1 m2 := by + obtain ⟨m1, m2, hmatch, hrhs⟩ := ext.covers ls hls + exact ⟨ext.pat.toPattern, (ext.rhs, ext.check), m1, m2, + .ext ext hmem, hmatch, hrhs⟩ + +end BlockGenerationChecked + +end VInductDecl + +end Lean4Lean + +/-! ## Axiom closures -/ + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_defeqs' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_defeqs + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_WF' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_WF + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_simple' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_simple + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.ext_covers' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.ext_covers diff --git a/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean b/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean new file mode 100644 index 00000000..ed0c9574 --- /dev/null +++ b/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean @@ -0,0 +1,141 @@ +import Lean4Lean.Theory.Typing.InductivePatternEnv + +/-! # Pattern facts for concrete certified blocks + +Two self-contained certified blocks pin the L4L-10A pattern layer by +evaluation: a mutual tree/forest pair (two families, three flattened +constructors, recursion in both directions) and an indexed vector (one +family, a `Nat` index, indices spelled with `Nat.zero`/`Nat.succ`). Both +use literal names throughout, keeping every closedness and inventory bit +kernel-decidable. The expected `SimplePattern` inventories are written by +hand: the major arity counts shared parameters, all motives, all minors, and +the constructor's result indices; the argument arity counts the +constructor's parameters and fields. -/ + +namespace Lean4Lean.InductivePatternFixtures + +open Lean4Lean.VInductDecl +open Lean4Lean.VInductDecl.BlockGenerationChecked + +deriving instance DecidableEq for SimplePattern + +/-- `mutual inductive PatTree (α : Type u) | node : α → PatForest α → PatTree α +inductive PatForest (α : Type u) | nil | cons : PatTree α → PatForest α → +PatForest α end` -/ +def patBlock : VInductDecl where + uvars := 1 + nparams := 1 + types := + [{ name := `PatTree + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + ctors := + [⟨⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const `PatForest [.param 0]) (.bvar 1)) + (.app (.const `PatTree [.param 0]) (.bvar 2))))⟩, + `PatTree.node⟩] }, + { name := `PatForest + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + ctors := + [⟨⟨1, .forallE (.sort (.succ (.param 0))) + (.app (.const `PatForest [.param 0]) (.bvar 0))⟩, + `PatForest.nil⟩, + ⟨⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.app (.const `PatTree [.param 0]) (.bvar 0)) + (.forallE (.app (.const `PatForest [.param 0]) (.bvar 1)) + (.app (.const `PatForest [.param 0]) (.bvar 2))))⟩, + `PatForest.cons⟩] }] + +/-- `inductive PatVec (α : Type) : Nat → Type | nil : PatVec α Nat.zero +| cons : α → (n : Nat) → PatVec α n → PatVec α (Nat.succ n)` -/ +def patVec : VInductDecl where + uvars := 0 + nparams := 1 + types := + [{ name := `PatVec + uvars := 0 + type := .forallE (.sort (.succ .zero)) + (.forallE (.const `Nat []) (.sort (.succ .zero))) + ctors := + [⟨⟨0, .forallE (.sort (.succ .zero)) + (.app (.app (.const `PatVec []) (.bvar 0)) + (.const `Nat.zero []))⟩, + `PatVec.nil⟩, + ⟨⟨0, .forallE (.sort (.succ .zero)) + (.forallE (.bvar 0) + (.forallE (.const `Nat []) + (.forallE (.app (.app (.const `PatVec []) (.bvar 2)) (.bvar 0)) + (.app (.app (.const `PatVec []) (.bvar 3)) + (.app (.const `Nat.succ []) (.bvar 1))))))⟩, + `PatVec.cons⟩] }] + +#guard patBlock.stage3 +#guard patVec.stage3 + +/-- The certified mutual block. -/ +def patTreeGen : patBlock.BlockGenerationChecked := + (identityBlockGeneration? patBlock).get (by decide) + +/-- The certified indexed block. -/ +def patVecGen : patVec.BlockGenerationChecked := + (identityBlockGeneration? patVec).get (by decide) + +/-! ## Pattern inventories + +Majors: `PatTree`/`PatForest` share one parameter, two motives, and three +minors with no indices (major arity 6); `PatVec` has one parameter, one +motive, two minors, and one index (major arity 5). -/ + +#guard patTreeGen.flatCtors.map (fun c => patTreeGen.rulePattern c) == + [.iota (.str `PatTree "rec") 6 `PatTree.node 3, + .iota (.str `PatForest "rec") 6 `PatForest.nil 1, + .iota (.str `PatForest "rec") 6 `PatForest.cons 3] + +#guard patVecGen.flatCtors.map (fun c => patVecGen.rulePattern c) == + [.iota (.str `PatVec "rec") 5 `PatVec.nil 1, + .iota (.str `PatVec "rec") 5 `PatVec.cons 4] + +/-! ## Payload closedness by evaluation -/ + +theorem patTreeClosure : patTreeGen.RuleClosure := + RuleClosure.of_all _ (by decide) (by decide) + +theorem patVecClosure : patVecGen.RuleClosure := + RuleClosure.of_all _ (by decide) (by decide) + +/-! ## The instantiated pattern sets + +Both blocks now carry complete pattern payloads: `patTreeGen.IotaPat +patTreeClosure` and `patVecGen.IotaPat patVecClosure` satisfy every generic +obligation proved in `Theory/Typing/InductivePattern.lean`, at the standard +axiom closure recorded below. -/ + +/-- info: 'Lean4Lean.InductivePatternFixtures.patTreeClosure' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in +#print axioms patTreeClosure + +/-- info: 'Lean4Lean.InductivePatternFixtures.patVecClosure' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in +#print axioms patVecClosure + +/-! ## The assembled block-local environments + +Both blocks assemble over the empty base with no extensions; their defeq +sets are exactly their generated rules. -/ + +#guard (patTreeGen.assembleEnv .empty []).isSome +#guard (patVecGen.assembleEnv .empty []).isSome + +/-- Every defeq of the assembled tree/forest environment is a generated +rule: the base is defeq-free and no extensions are registered. -/ +example {env' : VEnv} (h : patTreeGen.assembleEnv .empty [] = some env') + {df : VDefEq} (hdf : env'.defeqs df) : + df ∈ patTreeGen.generatedRules := by + rcases patTreeGen.assembleEnv_defeq_cases h (fun _ hd => hd) hdf with + hrule | ⟨ext, hm, -⟩ + · exact hrule + · cases hm + +end Lean4Lean.InductivePatternFixtures diff --git a/Lean4Lean/Theory/Typing/InductivePatternWF.lean b/Lean4Lean/Theory/Typing/InductivePatternWF.lean new file mode 100644 index 00000000..519253da --- /dev/null +++ b/Lean4Lean/Theory/Typing/InductivePatternWF.lean @@ -0,0 +1,872 @@ +import Lean4Lean.Theory.Typing.InductivePattern +import Lean4Lean.Theory.Typing.UniqueTyping + +/-! # Pattern soundness for generated iota rules + +The typed β-collapse layer for L4L-10B: applying a lambda tower to a +well-typed argument spine is definitionally equal to the iterated +instantiation of its body (`IsDefEq.appN_lamN`), applications are +congruent along spines (`IsDefEq.appN_congr`, `IsDefEq.appN_defEq` over +`SpineDefEq`), and a matched pattern's captures are exactly the spine +arguments (`varN_matches_paths`). `pat_wf` then proves that a successful +match whose checks hold is definitionally equal to its RHS template — by +applying the registered `addInduct` rule tower to the captured arguments +and β-collapsing both readings. -/ + +namespace Lean4Lean + +open VExpr + +namespace VExpr + +/-- Instantiation pushes under a lambda telescope, mirroring +`instN_forallN`. -/ +theorem instN_lamN (a : VExpr) : ∀ (tel : List VExpr) (X : VExpr) (k : Nat), + (lamN tel X).inst a k = lamN (instTelN a tel k) (X.inst a (k + tel.length)) + | [], _, _ => rfl + | A :: tel, X, k => by + show VExpr.lam _ _ = VExpr.lam _ _ + rw [instN_lamN a tel X (k+1), + show k+1+tel.length = k+(tel.length+1) from by omega] + rfl + +/-- Universe instantiation pushes under a lambda telescope. -/ +theorem instL_lamN (ls : List VLevel) : ∀ (As : List VExpr) (e : VExpr), + (lamN As e).instL ls = lamN (As.map (instL ls)) (e.instL ls) + | [], _ => rfl + | A :: As, e => by + show VExpr.lam _ _ = VExpr.lam _ _ + rw [instL_lamN ls As e] + +end VExpr + +/-- Matching a constant `varN` tower captures exactly the spine arguments: +the `varNPaths` read back the argument list. -/ +theorem Pattern.varN_matches_paths {c : Name} {m1 : List VLevel} : + ∀ (n : Nat) (as : List VExpr) {f : VExpr} {m2}, + (Pattern.varN (.const c) n).Matches (VExpr.appN f as) m1 m2 → + as.length = n → + (Pattern.varNPaths (.const c) n).map m2 = as := by + intro n + induction n with + | zero => + intro as f m2 H hlen + obtain rfl : as = [] := List.length_eq_zero_iff.1 hlen + rfl + | succ n ih => + intro as f m2 H hlen + have hne : as ≠ [] := by rintro rfl; simp at hlen + obtain ⟨as', a, rfl⟩ : ∃ as' a, as = as' ++ [a] := + ⟨as.dropLast, as.getLast hne, (List.dropLast_concat_getLast hne).symm⟩ + rw [VExpr.appN_append] at H + have has : as'.length = n := by simpa using hlen + cases H with + | var h => + show ((Pattern.varNPaths (.const c) n).map some ++ [none]).map _ = + as' ++ [a] + rw [List.map_append, List.map_map] + exact congrArg (· ++ [a]) (ih as' h has) + +/-- Applying an RHS template spine computes to the applied template +values. -/ +theorem Pattern.RHS.appN_apply {p : Pattern} (m1 : List VLevel) + (m2 : p.Path → VExpr) : + ∀ (f : p.RHS) (as : List (p.RHS)), + (Pattern.RHS.appN f as).apply m1 m2 = + VExpr.appN (f.apply m1 m2) (as.map (Pattern.RHS.apply m1 m2)) + | _, [] => rfl + | f, a :: as => by + show (Pattern.RHS.appN (.app f a) as).apply m1 m2 = _ + rw [Pattern.RHS.appN_apply m1 m2 (.app f a) as] + rfl + +/-- A `HeadConstN` spine names its argument list. -/ +theorem HeadConstN.exists_appN {c : Name} {ls : List VLevel} : + ∀ {n : Nat} {e : VExpr}, HeadConstN c ls n e → + ∃ as : List VExpr, e = VExpr.appN (.const c ls) as ∧ as.length = n + | _, _, .const => ⟨[], rfl, rfl⟩ + | _, _, .app (a := a) h => + let ⟨as, he, hl⟩ := h.exists_appN + ⟨as ++ [a], by rw [VExpr.appN_append, ← he]; rfl, by simp [hl]⟩ + +namespace VExpr + +/-- The value of a bound variable under iterated instantiation: the spine +argument at its reverse position. -/ +theorem instRev_bvar_lt : ∀ (es : List VExpr) {i : Nat} (h : i < es.length), + instRev (.bvar i) es = es[es.length - 1 - i]'(by omega) + | e :: es, i, h => by + rcases Nat.lt_or_ge i es.length with h' | h' + · rw [show instRev (.bvar i) (e :: es) = instRev (.bvar i) es from + instRev_bvar_lt_cons es e h', instRev_bvar_lt es h'] + simp only [show (e :: es).length - 1 - i = (es.length - 1 - i) + 1 from by + simp only [List.length_cons]; omega, List.getElem_cons_succ] + · obtain rfl : i = es.length := by + simp only [List.length_cons] at h; omega + show instRev (instVar es.length e es.length) es = _ + rw [show instVar es.length e es.length = liftN es.length e from by + simp [instVar]] + rw [instRev_liftN_len] + simp only [show (e :: es).length - 1 - es.length = 0 from by + simp only [List.length_cons]; omega, List.getElem_cons_zero] + +/-- Iterated instantiation of a reverse bound-variable segment reads back +the corresponding spine segment. -/ +theorem map_instRev_bvarRevRange_seg (es : List VExpr) : + ∀ (q off : Nat), off + q ≤ es.length → + (bvarRevRange off q).map (instRev · es) = + (es.drop (es.length - off - q)).take q := by + intro q + induction q with + | zero => intro off h; simp [VExpr.bvarRevRange] + | succ q ih => + intro off h + show instRev (.bvar (off + q)) es :: (bvarRevRange off q).map (instRev · es) = _ + rw [instRev_bvar_lt es (by omega), ih off (by omega)] + have hd : es.length - off - (q + 1) < es.length := by omega + simp only [show es.length - 1 - (off + q) = es.length - off - (q + 1) from by + omega, show es.length - off - q = (es.length - off - (q + 1)) + 1 from by + omega] + rw [List.drop_eq_getElem_cons hd, List.take_succ_cons] + +end VExpr + +/-! ## Typed β-collapse of applied telescopes -/ + +/-- Instantiating below a reversed telescope, mirroring +`Ctx.LiftN.consTel`. -/ +theorem Ctx.InstN.consTel {Γ₀ : List VExpr} {e₀ A₀ : VExpr} : + ∀ (As : List VExpr) {k : Nat} {Γ Γ' : List VExpr}, + Ctx.InstN Γ₀ e₀ A₀ k Γ Γ' → + Ctx.InstN Γ₀ e₀ A₀ (As.length + k) (As.reverse ++ Γ) + ((VExpr.instTelN e₀ As k).reverse ++ Γ') + | [], k, Γ, Γ', W => by simpa [VExpr.instTelN] using W + | A :: As, k, Γ, Γ', W => by + have h := Ctx.InstN.consTel As (Ctx.InstN.succ (A := A) W) + rw [show As.length + (k+1) = (A :: As).length + k from by simp; omega] at h + simpa [VExpr.instTelN, List.append_assoc] using h + +/-- Instantiating a telescope's context. -/ +theorem VEnv.OnTel.instN {env : VEnv} (henv : env.Ordered) {U : Nat} + {Γ₀ : List VExpr} {e₀ A₀ : VExpr} (h₀ : env.HasType U Γ₀ e₀ A₀) : + ∀ {As : List VExpr} {k : Nat} {Γ Γ' : List VExpr}, + Ctx.InstN Γ₀ e₀ A₀ k Γ Γ' → VEnv.OnTel env U Γ As → + VEnv.OnTel env U Γ' (VExpr.instTelN e₀ As k) + | [], _, _, _, _, _ => trivial + | _ :: _, _, _, _, W, ⟨⟨u, hA⟩, hT⟩ => + ⟨⟨u, hA.instN henv W h₀⟩, VEnv.OnTel.instN henv h₀ W.succ hT⟩ + +/-- Pointwise defeq of two application spines against a peeled pi type. -/ +inductive VEnv.SpineDefEq (env : VEnv) (U : Nat) (Γ : List VExpr) : + VExpr → List VExpr → List VExpr → VExpr → Prop where + | nil : VEnv.SpineDefEq env U Γ A [] [] A + | cons : env.IsDefEq U Γ a a' A₁ → + VEnv.SpineDefEq env U Γ (A₂.inst a) es es' B → + VEnv.SpineDefEq env U Γ (.forallE A₁ A₂) (a :: es) (a' :: es') B + +/-- Iterated application congruence along a pointwise defeq spine. -/ +theorem VEnv.IsDefEq.appN_defEq {env : VEnv} {U : Nat} {Γ : List VExpr} : + ∀ {es es' : List VExpr} {F B X Y : VExpr}, + env.IsDefEq U Γ X Y F → VEnv.SpineDefEq env U Γ F es es' B → + env.IsDefEq U Γ (VExpr.appN X es) (VExpr.appN Y es') B + | [], _, _, _, _, _, h, .nil => h + | a :: _, a' :: _, _, _, X, Y, h, .cons ha hrest => + VEnv.IsDefEq.appN_defEq (X := X.app a) (Y := Y.app a') (h.appDF ha) hrest + +/-- A well-typed spine is a reflexive defeq spine. -/ +theorem VEnv.SpineWF.toSpineDefEq {env : VEnv} {U : Nat} {Γ : List VExpr} : + ∀ {es : List VExpr} {F B : VExpr}, env.SpineWF U Γ F es B → + VEnv.SpineDefEq env U Γ F es es B + | [], _, _, h => h ▸ .nil + | _ :: _, _, _, ⟨_, _, hA, ha, hrest⟩ => hA ▸ .cons ha hrest.toSpineDefEq + +/-- Iterated application congruence in the function position. -/ +theorem VEnv.IsDefEq.appN_congr {env : VEnv} {U : Nat} {Γ : List VExpr} + {es : List VExpr} {F B X Y : VExpr} + (h : env.IsDefEq U Γ X Y F) (hs : env.SpineWF U Γ F es B) : + env.IsDefEq U Γ (VExpr.appN X es) (VExpr.appN Y es) B := + h.appN_defEq hs.toSpineDefEq + +/-- Applying a lambda telescope to a full well-typed spine collapses to the +iterated instantiation of its body. -/ +theorem VEnv.IsDefEq.appN_lamN {env : VEnv} (henv : env.Ordered) {U : Nat} : + ∀ {As : List VExpr} {Γ : List VExpr} {body T B : VExpr} {es : List VExpr}, + VEnv.OnTel env U Γ As → + env.HasType U (As.reverse ++ Γ) body T → + env.SpineWF U Γ (VExpr.forallN As T) es B → + es.length = As.length → + env.IsDefEq U Γ (VExpr.appN (VExpr.lamN As body) es) + (VExpr.instRev body es) B + | [], Γ, body, T, B, es, _, hb, hs, hlen => by + obtain rfl : es = [] := List.length_eq_zero_iff.1 hlen + obtain rfl : T = B := hs + exact hb + | A :: As, Γ, body, T, B, e :: es, ⟨⟨u, hA⟩, hT⟩, hb, + ⟨A₁, A₂, heq, he, hrest⟩, hlen => by + injection (show VExpr.forallE A (VExpr.forallN As T) = .forallE A₁ A₂ + from heq) with h1 h2 + subst h1; subst h2 + have hb' : env.HasType U (As.reverse ++ (A :: Γ)) body T := by + simpa [List.append_assoc] using hb + have hlam : env.HasType U (A :: Γ) (VExpr.lamN As body) + (VExpr.forallN As T) := VEnv.HasType.lamN hT hb' + have hbeta := VEnv.IsDefEq.beta hlam he + rw [VExpr.instN_lamN, Nat.zero_add] at hbeta + have hlen2 : es.length = As.length := by simpa using hlen + have hT' : VEnv.OnTel env U Γ (VExpr.instTelN e As 0) := + VEnv.OnTel.instN henv he .zero hT + have hb'' : env.HasType U ((VExpr.instTelN e As 0).reverse ++ Γ) + (body.inst e As.length) (T.inst e As.length) := by + have W := Ctx.InstN.consTel (Γ₀ := Γ) (e₀ := e) (A₀ := A) As .zero + have := hb'.instN henv W he + simpa using this + have hrest' : env.SpineWF U Γ + (VExpr.forallN (VExpr.instTelN e As 0) (T.inst e As.length)) es B := by + rw [VExpr.instN_forallN] at hrest + simpa using hrest + have hlen' : es.length = (VExpr.instTelN e As 0).length := by + rw [VExpr.instTelN_length]; exact hlen2 + have IH := VEnv.IsDefEq.appN_lamN henv hT' hb'' hrest' hlen' + have hstep := VEnv.IsDefEq.appN_congr hbeta hrest + show env.IsDefEq U Γ + (VExpr.appN ((VExpr.lam A (VExpr.lamN As body)).app e) es) + (VExpr.instRev (body.inst e es.length) es) B + rw [hlen2] + exact hstep.trans IH + +/-- Iterated inversion of a lambda tower's typing: the telescope is +well-formed and the body is typed under it. -/ +theorem VEnv.HasType.lamN_wf {env : VEnv} {U : Nat} (henv : env.Ordered) : + ∀ {As : List VExpr} {Γ : List VExpr} {body V : VExpr}, + OnCtx Γ (env.IsType U) → + env.HasType U Γ (VExpr.lamN As body) V → + VEnv.OnTel env U Γ As ∧ + ∃ T₀, env.HasType U (As.reverse ++ Γ) body T₀ + | [], Γ, body, V, _, H => ⟨trivial, V, H⟩ + | A :: As, Γ, body, V, hΓ, H => by + obtain ⟨⟨u, hA⟩, W, hrest⟩ := VEnv.HasType.lam_inv henv hΓ H + obtain ⟨hT, T₀, hbody⟩ := + VEnv.HasType.lamN_wf henv (As := As) (Γ := A :: Γ) ⟨hΓ, u, hA⟩ hrest + exact ⟨⟨⟨u, hA⟩, hT⟩, T₀, by simpa [List.append_assoc] using hbody⟩ + +/-- The levels of a `HeadConstN` spine are unique. -/ +theorem HeadConstN.levels_uniq {c : Name} : + ∀ {n : Nat} {e : VExpr} {ls ls' : List VLevel}, + HeadConstN c ls n e → HeadConstN c ls' n e → ls = ls' + | _, _, _, _, .const, .const => rfl + | _, _, _, _, .app h, .app h' => h.levels_uniq h' + +/-- Zip a well-typed spine with pointwise defeqs into a defeq spine. +Reflexive entries need no defeq evidence. -/ +theorem VEnv.SpineWF.defEq_of_pointwise {env : VEnv} (henv : env.WF) + {U : Nat} {Γ : List VExpr} (hΓ : OnCtx Γ (env.IsType U)) : + ∀ {es es' : List VExpr} {F B : VExpr}, + env.SpineWF U Γ F es B → + List.Forall₂ (fun a a' => a = a' ∨ env.IsDefEqU U Γ a a') es es' → + VEnv.SpineDefEq env U Γ F es es' B + | [], [], _, _, h, .nil => h ▸ .nil + | _ :: _, _ :: _, _, _, ⟨A₁, A₂, hF, he, hrest⟩, .cons hd htl => by + subst hF + refine .cons ?_ (hrest.defEq_of_pointwise henv hΓ htl) + rcases hd with rfl | hd + · exact he + · exact VEnv.IsDefEqU.of_l henv hΓ hd he + +/-- Unfold the `OK` predicate through a folded list of defeq checks. -/ +theorem Pattern.Check.OK.of_foldr {p : Pattern} {α : Type _} + {df : VExpr → VExpr → Prop} {m1 : List VLevel} {m2 : p.Path → VExpr} + (f g : α → p.RHS) : + ∀ {xs : List α} {rest : p.Check}, + ((xs.foldr (fun x acc => Pattern.Check.defeq (f x) (g x) acc) + rest).OK df m1 m2) → + (∀ x ∈ xs, df ((f x).apply m1 m2) ((g x).apply m1 m2)) ∧ + rest.OK df m1 m2 + | [], _, h => ⟨nofun, h⟩ + | _ :: xs, rest, h => by + obtain ⟨h1, h2⟩ := h + obtain ⟨h3, h4⟩ := Pattern.Check.OK.of_foldr f g (xs := xs) h2 + refine ⟨fun x hx => ?_, h4⟩ + rcases List.mem_cons.1 hx with rfl | hx + · exact h1 + · exact h3 x hx + +/-- Build a pointwise relation between two mapped lists from their zip. -/ +private theorem forall₂_zip_map {α β : Type _} (F : α → VExpr) (G : β → VExpr) + (R : VExpr → VExpr → Prop) : + ∀ (xs : List α) (ys : List β), xs.length = ys.length → + (∀ p ∈ xs.zip ys, R (F p.1) (G p.2)) → + List.Forall₂ R (xs.map F) (ys.map G) + | [], [], _, _ => .nil + | x :: xs, y :: ys, hlen, hall => + .cons (hall (x, y) (.head _)) + (forall₂_zip_map F G R xs ys (by simpa using hlen) + fun p hp => hall p (.tail _ hp)) + | [], _ :: _, hlen, _ => by simp at hlen + | _ :: _, [], hlen, _ => by simp at hlen + +/-- Universe instantiation fixes a reverse bound-variable range. -/ +theorem VExpr.bvarRevRange_map_instL (ls : List VLevel) : + ∀ (off m : Nat), + (VExpr.bvarRevRange off m).map (VExpr.instL ls) = + VExpr.bvarRevRange off m + | _, 0 => rfl + | off, m+1 => by + simp only [VExpr.bvarRevRange, List.map_cons, VExpr.instL, + VExpr.bvarRevRange_map_instL ls off m] + +/-- A well-formed telescope extends a well-formed context. -/ +theorem VEnv.OnTel.onCtx {env : VEnv} {U : Nat} : + ∀ {As Γ : List VExpr}, OnCtx Γ (env.IsType U) → + VEnv.OnTel env U Γ As → OnCtx (As.reverse ++ Γ) (env.IsType U) + | [], _, hΓ, _ => hΓ + | A :: As, Γ, hΓ, ⟨hA, hT⟩ => by + simpa [List.append_assoc] using + VEnv.OnTel.onCtx (As := As) (Γ := A :: Γ) ⟨hΓ, hA⟩ hT + +/-- Every argument of a well-typed application spine is well-typed. -/ +theorem VEnv.HasType.appN_args_wf {env : VEnv} (henv : env.WF) {U : Nat} + {Γ : List VExpr} (hΓ : OnCtx Γ (env.IsType U)) : + ∀ (n : Nat) (es : List VExpr), es.length = n → ∀ {f B : VExpr}, + env.HasType U Γ (VExpr.appN f es) B → + ∀ e ∈ es, ∃ T, env.HasType U Γ e T := by + intro n + induction n with + | zero => + intro es hlen f B H e he + obtain rfl := List.length_eq_zero_iff.1 hlen + cases he + | succ n ih => + intro es hlen f B H e he + have hne : es ≠ [] := by rintro rfl; simp at hlen + obtain ⟨es', a, rfl⟩ : ∃ es' a, es = es' ++ [a] := + ⟨es.dropLast, es.getLast hne, (List.dropLast_concat_getLast hne).symm⟩ + rw [VExpr.appN_append] at H + have H' : env.HasType U Γ ((VExpr.appN f es').app a) B := H + obtain ⟨A₁, B₁, hf, ha⟩ := H'.app_inv henv hΓ + rcases List.mem_append.1 he with he' | he' + · exact ih es' (by simpa using hlen) hf e he' + · obtain rfl : e = a := by simpa using he' + exact ⟨A₁, ha⟩ + +/-- Iterated inversion of a pi tower's typing: the telescope is well formed +and the body is typed under it. -/ +theorem VEnv.HasType.forallN_wf {env : VEnv} {U : Nat} (henv : env.Ordered) : + ∀ {As : List VExpr} {Γ : List VExpr} {body V : VExpr}, + env.HasType U Γ (VExpr.forallN As body) V → + VEnv.OnTel env U Γ As ∧ ∃ V', env.HasType U (As.reverse ++ Γ) body V' + | [], _, _, V, H => ⟨trivial, V, H⟩ + | A :: As, Γ, body, V, H => by + obtain ⟨⟨u, hA⟩, v, hB⟩ := VEnv.HasType.forallE_inv henv H + obtain ⟨hT, V', hbody⟩ := VEnv.HasType.forallN_wf henv (As := As) hB + exact ⟨⟨⟨u, hA⟩, hT⟩, V', by simpa [List.append_assoc] using hbody⟩ + +private theorem forall₂_refl_or {R : VExpr → VExpr → Prop} : + ∀ (l : List VExpr), List.Forall₂ (fun a a' => a = a' ∨ R a a') l l + | [] => .nil + | _ :: l => .cons (Or.inl rfl) (forall₂_refl_or l) + +private theorem forall₂_append {R : VExpr → VExpr → Prop} : + ∀ {l₁ l₂ l₁' l₂' : List VExpr}, List.Forall₂ R l₁ l₂ → + List.Forall₂ R l₁' l₂' → List.Forall₂ R (l₁ ++ l₁') (l₂ ++ l₂') + | [], [], _, _, .nil, h => h + | _ :: _, _ :: _, _, _, .cons hd htl, h => .cons hd (forall₂_append htl h) + +namespace VInductDecl + +namespace BlockGenerationChecked + +variable {source : VInductDecl} (gen : source.BlockGenerationChecked) + +/-! ## Named shapes of one generated rule -/ + +theorem rule_type (i : Nat) (c : NormalizedBlockCtor) : + (gen.rule i c).type = + VExpr.forallN (gen.ruleBinders c) + (VExpr.appN + (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount + + gen.ruleFieldCount c)) + (gen.ruleIdx c ++ [gen.ruleCtorApp c])) := rfl + +theorem rule_uvars (i : Nat) (c : NormalizedBlockCtor) : + (gen.rule i c).uvars = gen.recUvars := rfl + +theorem paramsTel_length : gen.paramsTel.length = source.nparams := by + show ((generationParams gen.block.rawParams gen.block.checked.params).map + (VExpr.instL gen.sourceLevels)).length = _ + rw [List.length_map] + exact (generationParams_length_of_eq gen.shape.2.1).trans gen.shape.1 + +theorem ruleBinders_length (c : NormalizedBlockCtor) : + (gen.ruleBinders c).length = + source.nparams + gen.familyCount + gen.minorCount + + gen.ruleFieldCount c := by + simp only [ruleBinders, List.length_append, gen.paramsTel_length, + motiveTypes, gen.motiveTypesAux_length, minorTypes, + gen.minorTypesAux_length, VExpr.liftTelN_length, ruleFieldCount] + try omega + +/-- The instantiated left body as one flattened application spine. -/ +theorem ruleLhsBody_instL (c : NormalizedBlockCtor) {m1 : List VLevel} + (hlen1 : m1.length = gen.recUvars) : + (gen.ruleLhsBody c).instL m1 = + VExpr.appN (.const (gen.ruleRecName c) m1) + (VExpr.bvarRevRange (gen.ruleFieldCount c) + (source.nparams + gen.familyCount + gen.minorCount) ++ + (gen.ruleIdx c).map (VExpr.instL m1) ++ + [(gen.ruleCtorApp c).instL m1]) := by + show (VExpr.appN + (VExpr.appN (.const (gen.ruleRecName c) gen.recLevels) + (VExpr.bvarRevRange (gen.ruleFieldCount c) + (source.nparams + gen.familyCount + gen.minorCount))) + (gen.ruleIdx c ++ [gen.ruleCtorApp c])).instL m1 = _ + rw [← VExpr.appN_append, VExpr.instL_appN] + show VExpr.appN (.const (gen.ruleRecName c) + (gen.recLevels.map (VLevel.inst m1))) _ = _ + rw [show gen.recLevels.map (VLevel.inst m1) = m1 from + VLevel.inst_map_id hlen1] + rw [List.map_append, List.map_append, VExpr.bvarRevRange_map_instL, + List.append_assoc] + rfl + +/-- The instantiated major premise of the rule body. -/ +theorem ruleCtorApp_instL (c : NormalizedBlockCtor) (m1 : List VLevel) : + (gen.ruleCtorApp c).instL m1 = + VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) + (VExpr.bvarRevRange + (gen.ruleFieldCount c + (gen.familyCount + gen.minorCount)) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.ruleFieldCount c)) := by + show (VExpr.appN (.const c.ctor.raw.name gen.sourceLevels) _).instL m1 = _ + rw [VExpr.instL_appN, List.map_append, VExpr.bvarRevRange_map_instL, + VExpr.bvarRevRange_map_instL] + rfl + +/-- The captured template values are exactly the shared prefix of the +recursor spine and the field suffix of the major premise. -/ +private theorem captureArgs_apply {c : NormalizedBlockCtor} {m1 : List VLevel} + {g1 : Pattern.Path + (Pattern.varN (.const (gen.ruleRecName c)) (gen.ruleMajorArity c)) → VExpr} + {g2 : Pattern.Path + (Pattern.varN (.const c.ctor.raw.name) (gen.ruleArgArity c)) → VExpr} + {fArgs aArgs : List VExpr} + (hg1 : (Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).map g1 = fArgs) + (hg2 : (Pattern.varNPaths (.const c.ctor.raw.name) + (gen.ruleArgArity c)).map g2 = aArgs) : + (gen.captureArgs c).map + (Pattern.RHS.apply (p := (gen.rulePattern c).toPattern) m1 + (Sum.elim g1 g2)) = + fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams := by + rw [captureArgs, List.map_append, List.map_map, List.map_map] + show List.map g1 (List.take + (source.nparams + gen.familyCount + gen.minorCount) + (Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c))) ++ + List.map g2 (List.drop source.nparams + (Pattern.varNPaths (.const c.ctor.raw.name) + (gen.ruleArgArity c))) = _ + rw [List.map_take, List.map_drop, hg1, hg2] + +/-- Pattern soundness for one certified block (`pat_wf`): a successful match +of a rule's pattern whose checks hold is definitionally equal to the +instantiated RHS template, derived from the rule defeq registered by +`addInduct` via typed β-collapse. The redex arrives decomposed into its +recursor and constructor spines with spine-form typing, and the major +premise's levels pinned to the rule's source levels; both are exactly what +a verified reduction site holds. -/ +theorem pat_wf {env : VEnv} (henv : env.WF) {univs : Nat} {Γ : List VExpr} + (hΓ : OnCtx Γ (env.IsType univs)) + (hcl : gen.RuleClosure) + {i : Nat} {c : NormalizedBlockCtor} (h : gen.ruleEntry i c) + (hreg : env.defeqs (gen.rule i c)) + (hwf : (gen.rule i c).WF env) + {m1 : List VLevel} {m2} + (hm1 : ∀ l ∈ m1, l.WF univs) (hlen1 : m1.length = gen.recUvars) + {fArgs aArgs : List VExpr} + (hMlen : fArgs.length = gen.ruleMajorArity c) + (hNlen : aArgs.length = gen.ruleArgArity c) + (hm : ((gen.rulePattern c).toPattern).Matches + (.app (VExpr.appN (.const (gen.ruleRecName c) m1) fArgs) + (VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) aArgs)) m1 m2) + (hck : (gen.ruleCheck hcl (List.mem_of_getElem? h)).OK + (env.IsDefEqU univs Γ) m1 m2) + {Frec Ae : VExpr} + (hehead : env.HasType univs Γ (.const (gen.ruleRecName c) m1) Frec) + (hespine : env.SpineWF univs Γ Frec + (fArgs ++ [VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) aArgs]) Ae) + {Fctor Actor : VExpr} + (hctorhead : env.HasType univs Γ + (.const c.ctor.raw.name (gen.sourceLevels.map (VLevel.inst m1))) Fctor) + (hctorspine : env.SpineWF univs Γ Fctor aArgs Actor) + {B : VExpr} + (hcaps : env.SpineWF univs Γ ((gen.rule i c).type.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams) B) : + env.IsDefEqU univs Γ + (.app (VExpr.appN (.const (gen.ruleRecName c) m1) fArgs) + (VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) aArgs)) + ((gen.ruleRHS hcl h).apply m1 m2) := by + have henvo := henv.ordered + have hc := List.mem_of_getElem? h + cases hm with + | @app _ _ _ g1 _ _ f2 g2 h1 h2 => + -- canonical captures + have hg1 : (Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).map g1 = fArgs := + Pattern.varN_matches_paths _ fArgs h1 hMlen + have hg2 : (Pattern.varNPaths (.const c.ctor.raw.name) + (gen.ruleArgArity c)).map g2 = aArgs := + Pattern.varN_matches_paths _ aArgs h2 hNlen + have hcapsVals := gen.captureArgs_apply (m1 := m1) hg1 hg2 + -- length bookkeeping + have hcommon_le : source.nparams + gen.familyCount + gen.minorCount ≤ + gen.ruleMajorArity c := Nat.le_add_right _ _ + have hnp_le : source.nparams ≤ gen.ruleArgArity c := Nat.le_add_right _ _ + have htakelen : (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount)).length = + source.nparams + gen.familyCount + gen.minorCount := by + rw [List.length_take, hMlen]; omega + have hdroplen : (aArgs.drop source.nparams).length = + gen.ruleFieldCount c := by + rw [List.length_drop, hNlen] + show gen.ruleArgArity c - source.nparams = _ + simp only [ruleArgArity]; omega + have hcapslen : (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).length = + ((gen.ruleBinders c).map (VExpr.instL m1)).length := by + rw [List.length_append, htakelen, hdroplen, List.length_map, + gen.ruleBinders_length] + -- tower shapes + have htype' : (gen.rule i c).type.instL m1 = + VExpr.forallN ((gen.ruleBinders c).map (VExpr.instL m1)) + ((VExpr.appN + (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount + + gen.ruleFieldCount c)) + (gen.ruleIdx c ++ [gen.ruleCtorApp c])).instL m1) := by + rw [gen.rule_type, VExpr.instL_forallN] + have hlhs' : (gen.rule i c).lhs.instL m1 = + VExpr.lamN ((gen.ruleBinders c).map (VExpr.instL m1)) + ((gen.ruleLhsBody c).instL m1) := by + rw [gen.rule_lhs, VExpr.instL_lamN] + -- tower typing at the working context + have hlhsT : env.HasType univs Γ + (VExpr.lamN ((gen.ruleBinders c).map (VExpr.instL m1)) + ((gen.ruleLhsBody c).instL m1)) + ((gen.rule i c).type.instL m1) := by + rw [← hlhs'] + exact (hwf.1.instL hm1).weak0 henvo + obtain ⟨hTel, T₀, hbody⟩ := VEnv.HasType.lamN_wf henvo hΓ hlhsT + -- β-collapse of the applied left tower + have hcapsF : env.SpineWF univs Γ + (VExpr.forallN ((gen.ruleBinders c).map (VExpr.instL m1)) + ((VExpr.appN + (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount + + gen.ruleFieldCount c)) + (gen.ruleIdx c ++ [gen.ruleCtorApp c])).instL m1)) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams) B := htype' ▸ hcaps + have hretT0 := (VEnv.SpineWF.retarget hcapsF hcapslen) T₀ + have hcollapseL := VEnv.IsDefEq.appN_lamN henvo hTel hbody hretT0 hcapslen + -- the registered defeq, applied + have hex : env.IsDefEq univs Γ ((gen.rule i c).lhs.instL m1) + ((gen.rule i c).rhs.instL m1) ((gen.rule i c).type.instL m1) := + .extra hreg hm1 hlen1 + rw [hlhs'] at hex + have happlied := VEnv.IsDefEq.appN_congr hex hcaps + -- conclusion-side template computation + have hRHS : Pattern.RHS.apply (p := (gen.rulePattern c).toPattern) m1 + (Sum.elim g1 g2) (gen.ruleRHS hcl h) = + VExpr.appN ((gen.rule i c).rhs.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams) := by + rw [ruleRHS, Pattern.RHS.appN_apply, hcapsVals] + rfl + -- typing of the rule type's index spine + obtain ⟨u₀, htypeT⟩ := hlhsT.isType henvo hΓ + rw [htype'] at htypeT + obtain ⟨-, V', htypeBody⟩ := VEnv.HasType.forallN_wf henvo htypeT + have hCtxTel : OnCtx (((gen.ruleBinders c).map (VExpr.instL m1)).reverse ++ Γ) + (env.IsType univs) := VEnv.OnTel.onCtx hΓ hTel + rw [show ((VExpr.appN + (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount + + gen.ruleFieldCount c)) + (gen.ruleIdx c ++ [gen.ruleCtorApp c])).instL m1) = + VExpr.appN (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount + + gen.ruleFieldCount c)) + ((gen.ruleIdx c ++ [gen.ruleCtorApp c]).map (VExpr.instL m1)) from by + rw [VExpr.instL_appN]; rfl] at htypeBody + have hargsWF := VEnv.HasType.appN_args_wf henv hCtxTel _ _ rfl htypeBody + -- check extraction + unfold ruleCheck at hck + obtain ⟨hparams, hidxOK⟩ := Pattern.Check.OK.of_foldr _ _ hck + obtain ⟨hidxs, -⟩ := Pattern.Check.OK.of_foldr _ _ hidxOK + -- per-index tower collapse and check composition + have hidxLink : ∀ x ∈ (gen.ruleIdx c).attach.zip + ((Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).drop + (source.nparams + gen.familyCount + gen.minorCount)), + env.IsDefEqU univs Γ (Sum.elim g1 g2 (Sum.inl x.2)) + (VExpr.instRev (x.1.1.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) := by + intro x hx + have hfact := hidxs x hx + rw [Pattern.RHS.appN_apply, hcapsVals] at hfact + have htower : Pattern.RHS.apply (p := (gen.rulePattern c).toPattern) m1 + (Sum.elim g1 g2) + (.fixed (VExpr.lamN (gen.ruleBinders c) x.1.1) + (hcl.idxTower_closed hc x.1.1 x.1.2)) = + VExpr.lamN ((gen.ruleBinders c).map (VExpr.instL m1)) + (x.1.1.instL m1) := by + show (VExpr.lamN (gen.ruleBinders c) x.1.1).instL m1 = _ + rw [VExpr.instL_lamN] + rw [htower] at hfact + obtain ⟨Tx, hTx⟩ := hargsWF (x.1.1.instL m1) + (by + rw [List.map_append] + exact List.mem_append.2 (.inl (List.mem_map_of_mem x.1.2))) + have hretTx := (VEnv.SpineWF.retarget hcapsF hcapslen) Tx + have hcollapseX := VEnv.IsDefEq.appN_lamN henvo hTel hTx hretTx hcapslen + exact VEnv.IsDefEqU.trans henv hΓ hfact ⟨_, hcollapseX⟩ + -- major premise: constructor spine against its rebuilt form + have hparamsF₂ : List.Forall₂ + (fun a a' => a = a' ∨ env.IsDefEqU univs Γ a a') + aArgs + (fArgs.take source.nparams ++ aArgs.drop source.nparams) := by + have hb := forall₂_zip_map (α := Pattern.Path + (Pattern.varN (.const c.ctor.raw.name) (gen.ruleArgArity c))) + (β := Pattern.Path + (Pattern.varN (.const (gen.ruleRecName c)) (gen.ruleMajorArity c))) + g2 g1 (fun a a' => a = a' ∨ env.IsDefEqU univs Γ a a') + ((Pattern.varNPaths (.const c.ctor.raw.name) + (gen.ruleArgArity c)).take source.nparams) + ((Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).take source.nparams) + (by + rw [List.length_take, List.length_take, + Pattern.varNPaths_length, Pattern.varNPaths_length] + omega) + (fun p hp => Or.inr (hparams p hp)) + rw [List.map_take, List.map_take, hg1, hg2] at hb + have hall := forall₂_append hb + (forall₂_refl_or (R := env.IsDefEqU univs Γ) + (aArgs.drop source.nparams)) + rwa [List.take_append_drop] at hall + have hmajorLink : env.IsDefEqU univs Γ + (VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) aArgs) + (VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) + (fArgs.take source.nparams ++ aArgs.drop source.nparams)) := + ⟨_, VEnv.IsDefEq.appN_defEq hctorhead + (VEnv.SpineWF.defEq_of_pointwise henv hΓ hctorspine hparamsF₂)⟩ + -- the collapsed left spine, computed + have hL : (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams).length = + gen.ruleFieldCount c + + (source.nparams + gen.familyCount + gen.minorCount) := by + rw [List.length_append, htakelen, hdroplen]; omega + have hcapsTake : (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).take + (source.nparams + gen.familyCount + gen.minorCount) = + fArgs.take (source.nparams + gen.familyCount + gen.minorCount) := by + rw [List.take_append_of_le_length (by omega : _ ≤ (fArgs.take + (source.nparams + gen.familyCount + gen.minorCount)).length)] + exact List.take_of_length_le (Nat.le_of_eq htakelen) + have hcapsTakeNp : (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).take source.nparams = + fArgs.take source.nparams := by + rw [List.take_append_of_le_length (by omega : _ ≤ (fArgs.take + (source.nparams + gen.familyCount + gen.minorCount)).length)] + rw [List.take_take] + congr 1 + omega + have hcapsDrop : (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).drop + (source.nparams + gen.familyCount + gen.minorCount) = + aArgs.drop source.nparams := by + have hdl := List.drop_left (l₁ := fArgs.take (source.nparams + gen.familyCount + gen.minorCount)) (l₂ := aArgs.drop source.nparams) + rwa [htakelen] at hdl + have hsegNp : (VExpr.bvarRevRange + (gen.ruleFieldCount c + (gen.familyCount + gen.minorCount)) + source.nparams).map (VExpr.instRev · + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) = fArgs.take source.nparams := by + rw [VExpr.map_instRev_bvarRevRange_seg _ source.nparams _ (by omega)] + rw [show (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).length - + (gen.ruleFieldCount c + (gen.familyCount + gen.minorCount)) - + source.nparams = 0 from by omega, List.drop_zero] + exact hcapsTakeNp + have hsegFld : (VExpr.bvarRevRange 0 (gen.ruleFieldCount c)).map + (VExpr.instRev · + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) = aArgs.drop source.nparams := by + rw [VExpr.map_instRev_bvarRevRange_seg _ (gen.ruleFieldCount c) 0 + (by omega)] + rw [show (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).length - 0 - + gen.ruleFieldCount c = + source.nparams + gen.familyCount + gen.minorCount from by omega] + rw [hcapsDrop] + exact List.take_of_length_le (Nat.le_of_eq hdroplen) + have hsegCommon : (VExpr.bvarRevRange (gen.ruleFieldCount c) + (source.nparams + gen.familyCount + gen.minorCount)).map + (VExpr.instRev · + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) = + fArgs.take (source.nparams + gen.familyCount + gen.minorCount) := by + rw [VExpr.map_instRev_bvarRevRange_seg _ + (source.nparams + gen.familyCount + gen.minorCount) + (gen.ruleFieldCount c) (by omega)] + rw [show (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).length - + gen.ruleFieldCount c - + (source.nparams + gen.familyCount + gen.minorCount) = 0 from by + omega, List.drop_zero] + exact hcapsTake + have hctorImg : VExpr.instRev ((gen.ruleCtorApp c).instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams) = + VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) + (fArgs.take source.nparams ++ aArgs.drop source.nparams) := by + rw [gen.ruleCtorApp_instL, VExpr.instRev_appN, + VExpr.instRev_closedN (C := .const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) _ trivial, List.map_append, + hsegNp, hsegFld] + have hcollapsedEq : VExpr.instRev ((gen.ruleLhsBody c).instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams) = + VExpr.appN (.const (gen.ruleRecName c) m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + ((gen.ruleIdx c).map (fun x => VExpr.instRev (x.instL m1) + (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams)) ++ + [VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) + (fArgs.take source.nparams ++ aArgs.drop source.nparams)])) := by + rw [gen.ruleLhsBody_instL c hlen1, VExpr.instRev_appN, + VExpr.instRev_closedN (C := .const (gen.ruleRecName c) m1) _ trivial, + List.map_append, List.map_append, hsegCommon, List.map_map] + rw [show ((gen.ruleCtorApp c).instL m1 :: + ([] : List VExpr)).map (VExpr.instRev · + (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams)) = + [VExpr.instRev ((gen.ruleCtorApp c).instL m1) + (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams)] from rfl] + rw [hctorImg] + simp only [Function.comp_def] + rw [List.append_assoc] + -- pointwise defeq between the redex spine and the collapsed spine + have hidxF₂ : List.Forall₂ (fun a a' => a = a' ∨ env.IsDefEqU univs Γ a a') + (fArgs.drop (source.nparams + gen.familyCount + gen.minorCount)) + ((gen.ruleIdx c).map (fun x => VExpr.instRev (x.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams))) := by + have hb := forall₂_zip_map + (α := {x // x ∈ gen.ruleIdx c}) + (β := Pattern.Path (Pattern.varN (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c))) + (fun s => VExpr.instRev (s.1.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) + (fun p => Sum.elim g1 g2 (Sum.inl p)) + (fun t v => v = t ∨ env.IsDefEqU univs Γ v t) + (gen.ruleIdx c).attach + ((Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).drop + (source.nparams + gen.familyCount + gen.minorCount)) + (by + rw [List.length_attach, List.length_drop, Pattern.varNPaths_length] + show (gen.ruleIdx c).length = gen.ruleMajorArity c - _ + simp only [ruleIdx, ruleMajorArity, List.length_map] + omega) + (fun p hp => Or.inr (hidxLink p hp)) + have hflip := List.Forall₂.flip hb + have hmapG : ((Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).drop + (source.nparams + gen.familyCount + gen.minorCount)).map + (fun p => Sum.elim g1 g2 (Sum.inl p)) = + fArgs.drop (source.nparams + gen.familyCount + gen.minorCount) := by + show ((Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).drop + (source.nparams + gen.familyCount + gen.minorCount)).map g1 = _ + rw [List.map_drop, hg1] + have hmapF : ((gen.ruleIdx c).attach).map + (fun s => VExpr.instRev (s.1.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) = + (gen.ruleIdx c).map (fun x => VExpr.instRev (x.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) := by + exact List.attach_map_val + (f := fun x : VExpr => VExpr.instRev (x.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) .. + rw [hmapG, hmapF] at hflip + exact hflip + have hbigF₂ : List.Forall₂ (fun a a' => a = a' ∨ env.IsDefEqU univs Γ a a') + (fArgs ++ [VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) aArgs]) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + ((gen.ruleIdx c).map (fun x => VExpr.instRev (x.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) ++ + [VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) + (fArgs.take source.nparams ++ aArgs.drop source.nparams)])) := by + have hres := forall₂_append + (forall₂_refl_or (R := env.IsDefEqU univs Γ) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount))) + (forall₂_append hidxF₂ (.cons (Or.inr hmajorLink) .nil)) + rwa [← List.append_assoc, List.take_append_drop] at hres + -- the redex is defeq to the collapsed left spine + have hE := VEnv.IsDefEq.appN_defEq hehead + (VEnv.SpineWF.defEq_of_pointwise henv hΓ hespine hbigF₂) + rw [← hcollapsedEq, VExpr.appN_append] at hE + -- assemble + rw [hRHS] + exact VEnv.IsDefEqU.trans henv hΓ ⟨_, hE⟩ + (VEnv.IsDefEqU.trans henv hΓ ⟨_, hcollapseL.symm⟩ ⟨_, happlied⟩) + +end BlockGenerationChecked + +end VInductDecl + +end Lean4Lean + +/-! ## Axiom closures + +The typed β-collapse layer is sorry-free. `pat_wf` composes typed defeqs +through `IsDefEqU.of_l`/`IsDefEqU.trans` and therefore carries exactly the +transitional unique-typing closure the Church–Rosser development itself +carries; it sheds `sorryAx` automatically when the L4L-16/17 inversion +milestones land, with no restatement. -/ + +/-- info: 'Lean4Lean.VEnv.IsDefEq.appN_lamN' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VEnv.IsDefEq.appN_lamN + +/-- info: 'Lean4Lean.VEnv.IsDefEq.appN_defEq' depends on axioms: [propext] -/ +#guard_msgs in +#print axioms Lean4Lean.VEnv.IsDefEq.appN_defEq + +/-- info: 'Lean4Lean.Pattern.varN_matches_paths' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.Pattern.varN_matches_paths + +/-- +info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.pat_wf' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.pat_wf diff --git a/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean b/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean new file mode 100644 index 00000000..095bc531 --- /dev/null +++ b/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean @@ -0,0 +1,184 @@ +import Lean4Lean.Theory.NestedInductive +import Lean4Lean.Theory.Typing.InductiveLemmas + +/-! +# Nested transaction facts and preservation (L4L-09C) + +The `addInductNested` analog of the block-wide transaction lemma suite: +exact phase recovery, atomicity, monotonicity, freshness, lookup and rule +membership through `ctorFold_spec`/`rulesFold_spec`, and `Ordered` +preservation from the `NestedBlockChecked.WF` package. +-/ + +namespace Lean4Lean + +open VInductDecl + +namespace VEnv + +/-- Recover every phase boundary from a successful nested transaction. -/ +theorem addInductNested_trace {source : VInductDecl} + {nested : source.NestedBlockChecked} + (hadd : addInductNested env nested = some env') : + Nonempty (AddInductNestedTrace env env' nested) := by + unfold addInductNested at hadd + obtain ⟨typeEnv, addTypes, hadd⟩ := Option.bind_eq_some_iff.1 hadd + obtain ⟨ctorEnv, addCtors, hadd⟩ := Option.bind_eq_some_iff.1 hadd + obtain ⟨recEnv, addRecs, hadd⟩ := Option.bind_eq_some_iff.1 hadd + cases hadd + exact ⟨⟨typeEnv, ctorEnv, recEnv, addTypes, addCtors, addRecs, rfl⟩⟩ + +/-- The nested transaction is atomic at its public `Option` boundary. -/ +theorem addInductNested_atomic {source : VInductDecl} + (env : VEnv) (nested : source.NestedBlockChecked) : + addInductNested env nested = none ∨ + ∃ env', addInductNested env nested = some env' ∧ + Nonempty (AddInductNestedTrace env env' nested) := by + cases hadd : addInductNested env nested with + | none => exact .inl rfl + | some env' => exact .inr ⟨env', rfl, addInductNested_trace hadd⟩ + +namespace AddInductNestedTrace + +variable {source : VInductDecl} {nested : source.NestedBlockChecked} + +/-- Every phase of a successful nested transaction only grows the Theory +environment. -/ +theorem le (H : AddInductNestedTrace env env' nested) : env ≤ env' := by + have htypes := (ctorFold_spec source.blockTypeConstants H.addTypes).1 + have hctors := (ctorFold_spec source.blockConstructorConstants H.addCtors).1 + have hrecs := (ctorFold_spec nested.recursors H.addRecs).1 + have hrules : H.recEnv ≤ env' := by + simpa only [H.addRules] using + (rulesFold_spec nested.generatedRules H.recEnv).1 + exact htypes.trans (hctors.trans (hrecs.trans hrules)) + +/-- Every source family name was fresh before the transaction. -/ +theorem family_fresh (H : AddInductNestedTrace env env' nested) + {type : VInductiveType} (htype : type ∈ source.types) : + env.constants type.name = none := by + have hmem : type.toVConstVal ∈ source.blockTypeConstants := + List.mem_map.2 ⟨type, htype, rfl⟩ + simpa [VInductDecl.blockTypeConstants] using + (ctorFold_spec source.blockTypeConstants H.addTypes).2.2 + type.toVConstVal hmem + +/-- The final environment stores every exact source family constant. -/ +theorem family_lookup (H : AddInductNestedTrace env env' nested) + {type : VInductiveType} (htype : type ∈ source.types) : + env'.constants type.name = some type.toVConstant := by + have hmem : type.toVConstVal ∈ source.blockTypeConstants := + List.mem_map.2 ⟨type, htype, rfl⟩ + have hlookup := + (ctorFold_spec source.blockTypeConstants H.addTypes).2.1 + type.toVConstVal hmem + have hctors := (ctorFold_spec source.blockConstructorConstants H.addCtors).1 + have hrecs := (ctorFold_spec nested.recursors H.addRecs).1 + have hrules : H.recEnv ≤ env' := by + simpa only [H.addRules] using + (rulesFold_spec nested.generatedRules H.recEnv).1 + exact (hctors.trans (hrecs.trans hrules)).constants hlookup + +/-- Every flattened source constructor name was fresh before the nested +transaction. -/ +theorem ctor_fresh (H : AddInductNestedTrace env env' nested) + {c : VConstVal} (hc : c ∈ source.blockConstructorConstants) : + env.constants c.name = none := by + have htypes := (ctorFold_spec source.blockTypeConstants H.addTypes).1 + have hfresh := + (ctorFold_spec source.blockConstructorConstants H.addCtors).2.2 c hc + exact htypes.constants_none hfresh + +/-- The final environment stores every exact source constructor +constant. -/ +theorem ctor_lookup (H : AddInductNestedTrace env env' nested) + {type : VInductiveType} (htype : type ∈ source.types) + {c : VConstVal} (hc : c ∈ type.ctors) : + env'.constants c.name = some c.toVConstant := by + have hmem : c ∈ source.blockConstructorConstants := + List.mem_flatMap.2 ⟨type, htype, hc⟩ + have hlookup := + (ctorFold_spec source.blockConstructorConstants H.addCtors).2.1 c hmem + have hrecs := (ctorFold_spec nested.recursors H.addRecs).1 + have hrules : H.recEnv ≤ env' := by + simpa only [H.addRules] using + (rulesFold_spec nested.generatedRules H.recEnv).1 + exact (hrecs.trans hrules).constants hlookup + +/-- The final environment stores every restored recursor constant. -/ +theorem rec_lookup (H : AddInductNestedTrace env env' nested) + {recursor : VConstVal} (hrec : recursor ∈ nested.recursors) : + env'.constants recursor.name = some recursor.toVConstant := by + have hlookup := (ctorFold_spec nested.recursors H.addRecs).2.1 recursor hrec + have hrules : H.recEnv ≤ env' := by + simpa only [H.addRules] using + (rulesFold_spec nested.generatedRules H.recEnv).1 + exact hrules.constants hlookup + +/-- Every restored recursor name was fresh before the nested transaction. -/ +theorem rec_fresh (H : AddInductNestedTrace env env' nested) + {recursor : VConstVal} (hrec : recursor ∈ nested.recursors) : + env.constants recursor.name = none := by + have htypes := (ctorFold_spec source.blockTypeConstants H.addTypes).1 + have hctors := + (ctorFold_spec source.blockConstructorConstants H.addCtors).1 + have hfresh := (ctorFold_spec nested.recursors H.addRecs).2.2 recursor hrec + exact (htypes.trans hctors).constants_none hfresh + +/-- The final environment registers every restored rule. -/ +theorem rule_mem (H : AddInductNestedTrace env env' nested) + {df : VDefEq} (hdf : df ∈ nested.generatedRules) : + env'.defeqs df := by + simpa only [H.addRules] using + (rulesFold_spec nested.generatedRules H.recEnv).2 df hdf + +end AddInductNestedTrace + +nonrec theorem addInductNested_le {source : VInductDecl} + {nested : source.NestedBlockChecked} + (hadd : addInductNested env nested = some env') : env ≤ env' := by + obtain ⟨H⟩ := addInductNested_trace hadd + exact H.le + +end VEnv + +/-- A chained constant package folds into `Ordered` preservation. -/ +theorem NestedConstsWF.fold_ordered : + ∀ {cs : List VConstVal} {env env' : VEnv}, + VEnv.Ordered env → NestedConstsWF env cs → + cs.foldlM (fun env c => env.addConst c.name c.toVConstant) env = + some env' → + VEnv.Ordered env' + | [], _, _, h, _, hf => by cases hf; exact h + | c :: cs, env, env', h, hwf, hf => by + rw [List.foldlM_cons] at hf + obtain ⟨env₁, hadd, htail⟩ := Option.bind_eq_some_iff.1 hf + exact NestedConstsWF.fold_ordered (.const h hwf.1 hadd) + (hwf.2 env₁ hadd) htail + +/-- A chained rule package folds into `Ordered` preservation. -/ +theorem NestedRulesWF.fold_ordered : + ∀ {dfs : List VDefEq} {env : VEnv}, + VEnv.Ordered env → NestedRulesWF env dfs → + VEnv.Ordered (dfs.foldl VEnv.addDefEq env) + | [], _, h, _ => h + | df :: dfs, env, h, hwf => by + rw [List.foldl_cons] + exact NestedRulesWF.fold_ordered (.defeq h hwf.1) hwf.2 + +/-- `Ordered` preservation for the nested transaction. -/ +theorem VEnv.addInductNested_WF {source : VInductDecl} + {nested : source.NestedBlockChecked} + (ih : VEnv.Ordered env) (h1 : nested.WF env) + (h2 : addInductNested env nested = some env') : VEnv.Ordered env' := by + unfold addInductNested at h2 + obtain ⟨typeEnv, addTypes, h2⟩ := Option.bind_eq_some_iff.1 h2 + obtain ⟨ctorEnv, addCtors, h2⟩ := Option.bind_eq_some_iff.1 h2 + obtain ⟨recEnv, addRecs, h2⟩ := Option.bind_eq_some_iff.1 h2 + cases h2 + have hT := NestedConstsWF.fold_ordered ih h1.types addTypes + have hC := NestedConstsWF.fold_ordered hT (h1.ctors addTypes) addCtors + have hR := NestedConstsWF.fold_ordered hC (h1.recs addTypes addCtors) addRecs + exact NestedRulesWF.fold_ordered hR (h1.rules addTypes addCtors addRecs) + +end Lean4Lean diff --git a/Lean4Lean/Theory/Typing/NestedTransport.lean b/Lean4Lean/Theory/Typing/NestedTransport.lean new file mode 100644 index 00000000..b51751a2 --- /dev/null +++ b/Lean4Lean/Theory/Typing/NestedTransport.lean @@ -0,0 +1,222 @@ +import Lean4Lean.Theory.Typing.NestedInductiveLemmas +import Lean4Lean.Theory.Typing.Strong + +/-! +# Constant-interpretation substitution (L4L-09C transport, part 1) + +The clean compositional substitution σ̂ underlying nested restoration: +each interpreted constant is replaced by a closed value, level-instantiated +per occurrence. The spine-collapsed artifact substitution `restoreExpr` +is the β-image of σ̂ at fully applied auxiliary heads; the typed transport +built on σ̂ is the route from the flattened block's staged semantic +certificate to restored-artifact well-formedness recorded in the L4L-09A +design note. + +This file establishes σ̂, its commutation calculus with lifting, +instantiation, and level instantiation, context-lookup transport, the +`ConstInterp` environment morphism, and the typed transport +`IsDefEq.substConst` with its `HasType`/`IsType`/`VConstant.WF`/ +`VDefEq.WF` corollaries. The β-collapse bridge from σ̂ to the +spine-collapsed artifact substitution and the per-phase morphism +construction for a staged flattened block are the remaining transport +obligations. +-/ + +namespace Lean4Lean + +/-- σ̂: replace each interpreted constant by its closed value at the +occurrence's levels. -/ +def VExpr.substConst (interp : Name → Option VExpr) : VExpr → VExpr + | .bvar i => .bvar i + | .sort l => .sort l + | .const c ls => + match interp c with + | some v => v.instL ls + | none => .const c ls + | .app f a => .app (f.substConst interp) (a.substConst interp) + | .lam ty body => .lam (ty.substConst interp) (body.substConst interp) + | .forallE ty body => .forallE (ty.substConst interp) (body.substConst interp) + +/-- Every interpreted value is closed. -/ +def InterpClosed (interp : Name → Option VExpr) : Prop := + ∀ c v, interp c = some v → v.ClosedN 0 + +namespace VExpr + +variable {interp : Name → Option VExpr} + +theorem substConst_liftN (hc : InterpClosed interp) : + ∀ (e : VExpr) (k : Nat), + (e.liftN n k).substConst interp = (e.substConst interp).liftN n k + | .bvar _, _ => rfl + | .sort _, _ => rfl + | .const c ls, k => by + simp only [liftN, substConst] + cases h : interp c with + | none => simp [liftN] + | some v => + exact (((hc c v h).instL (ls := ls)).liftN_eq (Nat.zero_le k)).symm + | .app f a, k => by + simp only [liftN, substConst, substConst_liftN hc f k, + substConst_liftN hc a k] + | .lam ty body, k => by + simp only [liftN, substConst, substConst_liftN hc ty k, + substConst_liftN hc body (k+1)] + | .forallE ty body, k => by + simp only [liftN, substConst, substConst_liftN hc ty k, + substConst_liftN hc body (k+1)] + +theorem substConst_lift (hc : InterpClosed interp) (e : VExpr) : + (e.lift).substConst interp = (e.substConst interp).lift := + substConst_liftN hc e 0 + +theorem substConst_instN (hc : InterpClosed interp) : + ∀ (e a : VExpr) (k : Nat), + (e.inst a k).substConst interp = + (e.substConst interp).inst (a.substConst interp) k + | .bvar i, a, k => by + simp only [inst, substConst] + unfold instVar + split + · simp [substConst] + · split + · exact (substConst_liftN hc a 0).symm ▸ rfl + · simp [substConst] + | .sort _, _, _ => rfl + | .const c ls, a, k => by + simp only [inst, substConst] + cases h : interp c with + | none => simp [inst] + | some v => + exact (((hc c v h).instL (ls := ls)).instN_eq (Nat.zero_le k)).symm + | .app f b, a, k => by + simp only [inst, substConst, substConst_instN hc f a k, + substConst_instN hc b a k] + | .lam ty body, a, k => by + simp only [inst, substConst, substConst_instN hc ty a k, + substConst_instN hc body a (k+1)] + | .forallE ty body, a, k => by + simp only [inst, substConst, substConst_instN hc ty a k, + substConst_instN hc body a (k+1)] + +theorem substConst_inst (hc : InterpClosed interp) (e a : VExpr) : + (e.inst a).substConst interp = + (e.substConst interp).inst (a.substConst interp) := + substConst_instN hc e a 0 + +theorem substConst_instL : + ∀ (e : VExpr), + (e.instL ls).substConst interp = ((e.substConst interp).instL ls : VExpr) + | .bvar _ => rfl + | .sort _ => by simp [instL, substConst] + | .const c ls' => by + simp only [instL, substConst] + cases interp c with + | none => simp [instL] + | some v => exact (instL_instL).symm + | .app f a => by + simp only [instL, substConst, substConst_instL f, substConst_instL a] + | .lam ty body => by + simp only [instL, substConst, substConst_instL ty, substConst_instL body] + | .forallE ty body => by + simp only [instL, substConst, substConst_instL ty, substConst_instL body] + +end VExpr + +/-- Context-lookup transport along σ̂. -/ +theorem Lookup.substConst {interp : Name → Option VExpr} + (hc : InterpClosed interp) : + ∀ {Γ i A}, Lookup Γ i A → + Lookup (Γ.map (VExpr.substConst interp)) i (A.substConst interp) + | _, _, _, .zero => by + rw [List.map_cons, VExpr.substConst_lift hc] + exact .zero + | _, _, _, .succ h => by + rw [List.map_cons, VExpr.substConst_lift hc] + exact .succ (h.substConst hc) + +namespace VEnv + +/-- Environment morphism along a constant interpretation: interpreted +constants become closed values typed at their σ̂-image types in the target +environment; surviving constants and registered defeqs are σ̂-imaged. The +staged flattened environments of a nested block and their restored +counterparts form exactly such a morphism, with the auxiliary families, +constructors, and recursors interpreted by their restoration closures. -/ +structure ConstInterp (E E' : VEnv) (interp : Name → Option VExpr) : Prop where + ordered' : VEnv.Ordered E' + closed : InterpClosed interp + value : ∀ {c ci v}, E.constants c = some ci → interp c = some v → + E'.HasType ci.uvars [] v (ci.type.substConst interp) + keep : ∀ {c ci}, E.constants c = some ci → interp c = none → + E'.constants c = some ⟨ci.uvars, ci.type.substConst interp⟩ + defeq : ∀ {df}, E.defeqs df → + E'.defeqs ⟨df.uvars, df.lhs.substConst interp, + df.rhs.substConst interp, df.type.substConst interp⟩ + +/-- Typed transport along a constant interpretation: every Theory judgment +of the interpreted environment holds of the σ̂-images in the target +environment. -/ +theorem IsDefEq.substConst {E E' : VEnv} {interp : Name → Option VExpr} + (hi : ConstInterp E E' interp) (H : E.IsDefEq U Γ e1 e2 A) : + E'.IsDefEq U (Γ.map (VExpr.substConst interp)) + (e1.substConst interp) (e2.substConst interp) + (A.substConst interp) := by + induction H with + | bvar h => exact .bvar (h.substConst hi.closed) + | symm _ ih => exact .symm ih + | trans _ _ ih1 ih2 => exact .trans ih1 ih2 + | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3 + | @constDF c ci ls ls' _ h1 h2 h3 h4 h5 => + rw [VExpr.substConst_instL (e := ci.type)] + simp only [VExpr.substConst] + cases hv : interp c with + | none => exact .constDF (hi.keep h1 hv) h2 h3 h4 h5 + | some v => + have hval := hi.value h1 hv + have hnil : OnCtx ([] : List VExpr) (E'.IsType ci.uvars) := trivial + have hcore := hval.instL_r hi.ordered' hnil h2 h3 h5 + exact hcore.weak0 hi.ordered' + | appDF _ _ ih1 ih2 => + exact (VExpr.substConst_inst hi.closed ..).symm ▸ .appDF ih1 ih2 + | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2 + | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2 + | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2 + | beta _ _ ih1 ih2 => + simpa [VExpr.substConst, VExpr.substConst_inst hi.closed] using + VEnv.IsDefEq.beta ih1 ih2 + | eta _ ih => + simpa [VExpr.substConst, VExpr.substConst_lift hi.closed] using + VEnv.IsDefEq.eta ih + | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3 + | extra h1 h2 h3 => + simpa [VExpr.substConst_instL] using + VEnv.IsDefEq.extra (env := E') (hi.defeq h1) h2 (by simpa using h3) + +theorem HasType.substConst {E E' : VEnv} {interp : Name → Option VExpr} + (hi : ConstInterp E E' interp) (H : E.HasType U Γ e A) : + E'.HasType U (Γ.map (VExpr.substConst interp)) + (e.substConst interp) (A.substConst interp) := + IsDefEq.substConst hi H + +theorem IsType.substConst {E E' : VEnv} {interp : Name → Option VExpr} + (hi : ConstInterp E E' interp) (H : E.IsType U Γ A) : + E'.IsType U (Γ.map (VExpr.substConst interp)) (A.substConst interp) := + let ⟨_, h⟩ := H; ⟨_, IsDefEq.substConst hi h⟩ + +end VEnv + +/-- Constant well-formedness transports to the σ̂-image constant. -/ +theorem VConstant.WF.substConst {E E' : VEnv} {interp : Name → Option VExpr} + {ci : VConstant} (hi : VEnv.ConstInterp E E' interp) (H : ci.WF E) : + VConstant.WF E' ⟨ci.uvars, ci.type.substConst interp⟩ := + VEnv.IsType.substConst hi H + +/-- Rule well-formedness transports to the σ̂-image rule. -/ +theorem VDefEq.WF.substConst {E E' : VEnv} {interp : Name → Option VExpr} + {df : VDefEq} (hi : VEnv.ConstInterp E E' interp) (H : df.WF E) : + VDefEq.WF E' ⟨df.uvars, df.lhs.substConst interp, + df.rhs.substConst interp, df.type.substConst interp⟩ := + ⟨VEnv.IsDefEq.substConst hi H.1, VEnv.IsDefEq.substConst hi H.2⟩ + +end Lean4Lean diff --git a/Lean4Lean/Theory/Typing/Pattern.lean b/Lean4Lean/Theory/Typing/Pattern.lean index 87e77492..2c2c5375 100644 --- a/Lean4Lean/Theory/Typing/Pattern.lean +++ b/Lean4Lean/Theory/Typing/Pattern.lean @@ -230,3 +230,215 @@ inductive SimplePattern where def SimplePattern.toPattern : SimplePattern → Pattern | .defn c => .const c | .iota r m c n => .app (.varN (.const r) m) (.varN (.const c) n) + +/-! ## Shape helpers for generated recursor patterns + +`HeadConstN`, `HeadConst`, `of_varN_matches`, `RecursorIotaPattern`, and +`matches_shape` form the implementation-independent shape layer consumed by +the generated iota patterns of a certified inductive block +(`Theory/Typing/InductivePattern.lean`). They characterize matching against +`Pattern.varN` towers and `SimplePattern.iota` patterns without referring to +any generator data. -/ + +/-- `HeadConstN c ls n e`: `e` is the constant `c` at levels `ls` applied to +exactly `n` arguments. This is the expression shape captured by matching the +pattern `Pattern.varN (.const c) n`. -/ +inductive HeadConstN (c : Name) (ls : List VLevel) : Nat → VExpr → Prop where + | const : HeadConstN c ls 0 (.const c ls) + | app : HeadConstN c ls n f → HeadConstN c ls (n+1) (.app f a) + +/-- `e` is an application spine headed by the constant `c`. -/ +def HeadConst (c : Name) (e : VExpr) : Prop := ∃ ls n, HeadConstN c ls n e + +/-- Matching a `varN` tower of a constant captures exactly a `HeadConstN` +spine whose head levels are the pattern's level assignment. -/ +theorem Pattern.of_varN_matches {c : Name} : + ∀ {n : Nat} {e : VExpr} {m2}, (Pattern.varN (.const c) n).Matches e m1 m2 → + HeadConstN c m1 n e := by + intro n + induction n with + | zero => intro e m2 H; cases H; exact .const + | succ n ih => intro e m2 H; cases H with | var h => exact .app (ih h) + +/-- Every `HeadConstN` spine matches its `varN` tower. -/ +theorem HeadConstN.matches : HeadConstN c ls n e → + ∃ m2, (Pattern.varN (.const c) n).Matches e ls m2 + | .const => ⟨_, .const⟩ + | .app h => let ⟨_, h'⟩ := h.matches; ⟨_, .var h'⟩ + +/-- The capture paths of an `n`-ary `varN` tower in argument order (outermost +application first): matching assigns the `t`-th entry the `t`-th spine +argument. -/ +def Pattern.varNPaths (p : Pattern) : ∀ n, List (Pattern.Path (p.varN n)) + | 0 => [] + | n+1 => (varNPaths p n).map some ++ [none] + +@[simp] theorem Pattern.varNPaths_length (p : Pattern) : + ∀ n, (varNPaths p n).length = n + | 0 => rfl + | n+1 => by + show ((varNPaths p n).map some ++ [none]).length = n + 1 + rw [List.length_append, List.length_map, varNPaths_length p n]; rfl + +/-- The exact pattern of one generated iota rule: the recursor constant +applied to `major` arguments (parameters, motives, minors, and the +constructor's result indices), with a `ctor`-headed major premise carrying +`args` arguments. Definitionally `(SimplePattern.iota recursor major ctor +args).toPattern`. -/ +def RecursorIotaPattern (recursor : Name) (major : Nat) + (ctor : Name) (args : Nat) : Pattern := + .app (.varN (.const recursor) major) (.varN (.const ctor) args) + +theorem SimplePattern.toPattern_iota : + (SimplePattern.iota r m c n).toPattern = RecursorIotaPattern r m c n := rfl + +/-- Match inversion for an iota pattern: the expression is exactly a +recursor-headed spine at the pattern's level assignment whose last argument +is a constructor-headed spine (at unconstrained levels). -/ +theorem RecursorIotaPattern.matches_shape + (H : (RecursorIotaPattern r mj c n).Matches e m1 m2) : + ∃ f a ls, e = .app f a ∧ HeadConstN r m1 mj f ∧ HeadConstN c ls n a := by + cases H with + | app h1 h2 => + exact ⟨_, _, _, rfl, Pattern.of_varN_matches h1, Pattern.of_varN_matches h2⟩ + +/-- Match construction for an iota pattern from the two head spines. -/ +theorem RecursorIotaPattern.matches_of + (h1 : HeadConstN r ls mj f) (h2 : HeadConstN c ls' n a) : + ∃ m2, (RecursorIotaPattern r mj c n).Matches (.app f a) ls m2 := + let ⟨_, hf⟩ := h1.matches + let ⟨_, ha⟩ := h2.matches + ⟨_, .app hf ha⟩ + +/-- Subpatterns of a constant `varN` tower are exactly its shorter towers. -/ +theorem Subpattern.varN_const_le : + ∀ {n}, Subpattern p (Pattern.varN (.const c) n) → + ∃ j, j ≤ n ∧ p = Pattern.varN (.const c) j := by + intro n + induction n with + | zero => intro H; cases H; exact ⟨0, Nat.le_refl _, rfl⟩ + | succ n ih => + intro H + cases H with + | refl => exact ⟨n+1, Nat.le_refl _, rfl⟩ + | varL h => + let ⟨j, hj, hp⟩ := ih h + exact ⟨j, Nat.le_succ_of_le hj, hp⟩ + +/-- Subpattern classification for an iota pattern: the whole pattern, a +prefix of the recursor head, or a prefix of the constructor spine. -/ +theorem RecursorIotaPattern.subpattern_inv + (H : Subpattern p (RecursorIotaPattern r mj c n)) : + p = RecursorIotaPattern r mj c n ∨ + (∃ j, j ≤ mj ∧ p = .varN (.const r) j) ∨ + (∃ j, j ≤ n ∧ p = .varN (.const c) j) := by + cases H with + | refl => exact .inl rfl + | appL h => exact .inr (.inl h.varN_const_le) + | appR h => exact .inr (.inr h.varN_const_le) + +/-- Two constant `varN` towers intersect only when they agree exactly. -/ +theorem Pattern.varN_const_inter_some : + ∀ {n n' p}, (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') = some p → + c = c' ∧ n = n' ∧ p = Pattern.varN (.const c) n := by + intro n + induction n with + | zero => + intro n' p h + cases n' with + | zero => + simp [Pattern.varN, Pattern.inter] at h + exact ⟨h.1, rfl, h.2.symm⟩ + | succ n' => simp [Pattern.varN, Pattern.inter] at h + | succ n ih => + intro n' p h + cases n' with + | zero => simp [Pattern.varN, Pattern.inter] at h + | succ n' => + simp only [Pattern.varN, Pattern.inter, bind, Option.bind_eq_some_iff, + Option.pure_def, Option.some.injEq] at h + obtain ⟨q, hq, rfl⟩ := h + obtain ⟨rfl, rfl, rfl⟩ := ih hq + exact ⟨rfl, rfl, rfl⟩ + +theorem Pattern.varN_const_inter_of_ne_name (h : c ≠ c') (n n' : Nat) : + (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') = none := by + cases e : (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') with + | none => rfl + | some p => exact absurd (varN_const_inter_some e).1 h + +theorem Pattern.varN_const_inter_of_ne_arity (h : n ≠ n') (c c' : Name) : + (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') = none := by + cases e : (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') with + | none => rfl + | some p => exact absurd (varN_const_inter_some e).2.1 h + +/-- An application pattern intersects a constant `varN` tower only through a +positive tower whose inner tower intersects the function part. -/ +theorem Pattern.app_inter_varN_const_some {f a : Pattern} + (h : (Pattern.app f a).inter (Pattern.varN (.const c) n) = some p) : + ∃ n' q, n = n' + 1 ∧ f.inter (Pattern.varN (.const c) n') = some q ∧ + p = .app q a := by + cases n with + | zero => simp [Pattern.varN, Pattern.inter] at h + | succ n' => + simp only [Pattern.varN, Pattern.inter, bind, Option.bind_eq_some_iff, + Option.pure_def, Option.some.injEq] at h + obtain ⟨q, hq, rfl⟩ := h + exact ⟨n', q, rfl, hq, rfl⟩ + +/-- Two iota patterns intersect only when they agree exactly. -/ +theorem RecursorIotaPattern.inter_some + (h : (RecursorIotaPattern r mj c n).inter (RecursorIotaPattern r' mj' c' n') = some p) : + r = r' ∧ mj = mj' ∧ c = c' ∧ n = n' ∧ p = RecursorIotaPattern r mj c n := by + simp only [RecursorIotaPattern, Pattern.inter, bind, Option.bind_eq_some_iff, + Option.pure_def, Option.some.injEq] at h + obtain ⟨q1, h1, q2, h2, rfl⟩ := h + obtain ⟨rfl, rfl, rfl⟩ := Pattern.varN_const_inter_some h1 + obtain ⟨rfl, rfl, rfl⟩ := Pattern.varN_const_inter_some h2 + exact ⟨rfl, rfl, rfl, rfl, rfl⟩ + +/-- An iota pattern intersects a constant `varN` tower only at a tower whose +inner arity is the pattern's major arity with the recursor's name. -/ +theorem RecursorIotaPattern.inter_varN_const_some + (h : (RecursorIotaPattern r mj c n).inter (Pattern.varN (.const b) j) = some p) : + b = r ∧ j = mj + 1 := by + obtain ⟨j', q, rfl, hq, rfl⟩ := Pattern.app_inter_varN_const_some h + obtain ⟨rfl, rfl, rfl⟩ := Pattern.varN_const_inter_some hq + exact ⟨rfl, rfl⟩ + +/-- Constant `varN` towers are injective in the head name and the arity. -/ +theorem Pattern.varN_const_inj {c c' : Name} : + ∀ {n n' : Nat}, Pattern.varN (.const c) n = Pattern.varN (.const c') n' → + c = c' ∧ n = n' + | 0, 0, h => by cases h; exact ⟨rfl, rfl⟩ + | 0, n'+1, h => absurd h (by simp [Pattern.varN]) + | n+1, 0, h => absurd h (by simp [Pattern.varN]) + | n+1, n'+1, h => by + injection h with h1 + obtain ⟨rfl, rfl⟩ := Pattern.varN_const_inj h1 + exact ⟨rfl, rfl⟩ + +/-- Iota patterns are injective in all four components. -/ +theorem RecursorIotaPattern.inj + (h : RecursorIotaPattern r mj c n = RecursorIotaPattern r' mj' c' n') : + r = r' ∧ mj = mj' ∧ c = c' ∧ n = n' := by + injection h with h1 h2 + obtain ⟨rfl, rfl⟩ := Pattern.varN_const_inj h1 + obtain ⟨rfl, rfl⟩ := Pattern.varN_const_inj h2 + exact ⟨rfl, rfl, rfl, rfl⟩ + +/-- The only application subpattern of an iota pattern is the pattern +itself. -/ +theorem RecursorIotaPattern.app_subpattern + (H : Subpattern (.app p₁ p₂) (RecursorIotaPattern r mj c n)) : + p₁ = .varN (.const r) mj ∧ p₂ = .varN (.const c) n := by + rcases RecursorIotaPattern.subpattern_inv H with heq | ⟨j, hj, heq⟩ | ⟨j, hj, heq⟩ + · injection heq with h1 h2; exact ⟨h1, h2⟩ + · cases j <;> exact absurd heq (by simp [Pattern.varN]) + · cases j <;> exact absurd heq (by simp [Pattern.varN]) + +/-- Apply an RHS template head to a list of template arguments. -/ +def Pattern.RHS.appN {p : Pattern} (f : p.RHS) : List p.RHS → p.RHS + | [] => f + | a :: as => Pattern.RHS.appN (.app f a) as diff --git a/Lean4Lean/TypeChecker.lean b/Lean4Lean/TypeChecker.lean index c71b1d61..cf9a2b00 100644 --- a/Lean4Lean/TypeChecker.lean +++ b/Lean4Lean/TypeChecker.lean @@ -200,32 +200,46 @@ def getSortLevel (e : Expr) : RecM Level := do def isProp (e : Expr) : RecM Bool := return (← getSortLevel e).isAlwaysZero +def invalidProj (e : Expr) : RecM α := do + throw <| .invalidProj (← getEnv) (← getLCtx) e + +def inferProjParams (proj : Expr) : List Expr → Expr → RecM Expr + | [], r => pure r + | arg :: args, r => do + let .forallE _ _ body _ ← whnf r | invalidProj proj + inferProjParams proj args (body.instantiate1 arg) + +def inferProjFields (proj : Expr) (typeName : Name) + (struct : Expr) (maybePropType : Bool) : + Nat → Nat → Expr → RecM Expr + | _, 0, r => pure r + | fieldIdx, count + 1, r => do + let .forallE _ dom body _ ← whnf r | invalidProj proj + if body.hasLooseBVars && maybePropType then + if !(← isProp dom) then invalidProj proj + inferProjFields proj typeName struct maybePropType (fieldIdx + 1) count + (body.instantiate1 (.proj typeName fieldIdx struct)) + def inferProj (typeName : Name) (idx : Nat) (struct structType : Expr) : RecM Expr := do let e := Expr.proj typeName idx struct let type ← whnf structType type.withApp fun I args => do let env ← getEnv - let fail {_} := do throw <| .invalidProj env (← getLCtx) e - let .const I_name I_levels := I | fail - if typeName != I_name then fail - let .inductInfo I_val ← env.get I_name | fail - let [c] := I_val.ctors | fail - if args.size != I_val.numParams + I_val.numIndices then fail + let .const I_name I_levels := I | invalidProj e + if typeName != I_name then invalidProj e + let .inductInfo I_val ← env.get I_name | invalidProj e + let [c] := I_val.ctors | invalidProj e + unless env.isProjectionReadyStructure I_name do invalidProj e + if args.size != I_val.numParams + I_val.numIndices then invalidProj e let c_info ← env.get c - let mut r := c_info.instantiateTypeLevelParams I_levels - for i in [:I_val.numParams] do - let .forallE _ _ b _ ← whnf r | fail - r := b.instantiate1 args[i]! + let .ctorInfo ctorInfo := c_info | invalidProj e + unless idx < ctorInfo.numFields do invalidProj e + let r ← inferProjParams e (args.toList.take I_val.numParams) + (c_info.instantiateTypeLevelParams I_levels) let maybePropType := !(← getSortLevel type).isNeverZero - for i in [:idx] do - let .forallE _ dom b _ ← whnf r | fail - if b.hasLooseBVars then - if maybePropType then if !(← isProp dom) then fail - r := b.instantiate1 (.proj I_name i struct) - else - r := b - let .forallE _ dom _ _ ← whnf r | fail - if maybePropType then if !(← isProp dom) then fail + let r ← inferProjFields e I_name struct maybePropType 0 idx r + let .forallE _ dom _ _ ← whnf r | invalidProj e + if maybePropType then if !(← isProp dom) then invalidProj e return dom def inferType' (e : Expr) (inferOnly : Bool) : RecM Expr := do diff --git a/Lean4Lean/Verify.lean b/Lean4Lean/Verify.lean index d9faa29f..5e476764 100644 --- a/Lean4Lean/Verify.lean +++ b/Lean4Lean/Verify.lean @@ -1 +1,2 @@ import Lean4Lean.Verify.Typing.Lemmas +import Lean4Lean.Verify.Environment.InductiveReplayMatrix diff --git a/Lean4Lean/Verify/Environment/Basic.lean b/Lean4Lean/Verify/Environment/Basic.lean index c5102ead..1c921cba 100644 --- a/Lean4Lean/Verify/Environment/Basic.lean +++ b/Lean4Lean/Verify/Environment/Basic.lean @@ -196,6 +196,35 @@ def AddInductBlock (m₁ : ConstMap) (env₁ : VEnv) (decl : VInductDecl) (m₂ : ConstMap) (env₂ : VEnv) : Prop := Nonempty (AddInductBlockTrace m₁ env₁ decl m₂ env₂) +/-- Data-bearing alignment trace for a nested inductive declaration: the +source families and constructors are the stored payload, followed by the +restored recursors and restored rules. The implementation map receives +only restored metadata; no auxiliary constant appears in either the map or +the Theory environment. -/ +structure AddInductNestedTrace + (m₁ : ConstMap) (env₁ : VEnv) (decl : VInductDecl) + (m₂ : ConstMap) (env₂ : VEnv) where + nested : decl.NestedBlockChecked + nested_wf : nested.WF env₁ + typeMap : ConstMap + typeEnv : VEnv + ctorMap : ConstMap + ctorEnv : VEnv + recEnv : VEnv + addTypes : AddInductConstants .induct m₁ env₁ + decl.blockTypeConstants typeMap typeEnv + addCtors : AddInductConstants .ctor typeMap typeEnv + decl.blockConstructorConstants ctorMap ctorEnv + addRecs : AddInductConstants .recursor ctorMap ctorEnv + nested.recursors m₂ recEnv + recK : RecursorMapKMatches m₂ nested.recursors nested.generation.kTarget + addRules : AddDefEqs recEnv nested.generatedRules env₂ + +/-- Proposition-valued alignment for a nested declaration. -/ +def AddInductNested (m₁ : ConstMap) (env₁ : VEnv) (decl : VInductDecl) + (m₂ : ConstMap) (env₂ : VEnv) : Prop := + Nonempty (AddInductNestedTrace m₁ env₁ decl m₂ env₂) + theorem AddInductConstants.to_foldlM : AddInductConstants kind m₁ env₁ cis m₂ env₂ → List.foldlM (fun env (ci : VConstVal) => env.addConst ci.name ci.toVConstant) env₁ cis = @@ -270,6 +299,12 @@ theorem AddInductBlockTrace.to_addInductBlockGeneration simp [VEnv.addInductBlockGeneration, H.addTypes.to_foldlM, H.addCtors.to_foldlM, H.addRecs.to_foldlM, H.addRules.to_add] +theorem AddInductNestedTrace.to_addInductNested + (H : AddInductNestedTrace m₁ env₁ decl m₂ env₂) : + env₁.addInductNested H.nested = some env₂ := by + simp [VEnv.addInductNested, H.addTypes.to_foldlM, + H.addCtors.to_foldlM, H.addRecs.to_foldlM, H.addRules.to_add] + /-- Recover the exact certified normalized Theory transaction represented by an implementation metadata replay. This replaces the old, false-for-aliases claim that every replay must pass the identity-only `VEnv.addInduct` wrapper. -/ @@ -303,44 +338,55 @@ theorem AddInductBlock.le rcases VEnv.addInductBlockGeneration_trace hadd with ⟨trace⟩ exact trace.le -/- The Verify relation currently mentions `TrExprS`, whose projection branch -mentions the still-sorried `TrProj`. These guards make that inherited debt -visible and will fail (intentionally) when Track P removes `sorryAx`. -/ +/-- Recover the exact nested Theory transaction represented by an +implementation metadata replay. -/ +theorem AddInductNested.to_addInductNested + (H : AddInductNested m₁ env₁ decl m₂ env₂) : + ∃ nested : decl.NestedBlockChecked, + nested.WF env₁ ∧ env₁.addInductNested nested = some env₂ := by + rcases H with ⟨H⟩ + exact ⟨H.nested, H.nested_wf, H.to_addInductNested⟩ + +theorem AddInductNested.le + (H : AddInductNested m₁ env₁ decl m₂ env₂) : env₁ ≤ env₂ := by + obtain ⟨nested, -, hadd⟩ := H.to_addInductNested + exact VEnv.addInductNested_le hadd + +/- The projection relation is now a concrete Theory proposition, so merely +mentioning `TrExprS` no longer contaminates these projection-free roots with +the deferred structural-law sorries. -/ /-- -info: 'Lean4Lean.AddInductTrace.to_addInductGeneration' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.AddInductTrace.to_addInductGeneration' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms AddInductTrace.to_addInductGeneration /-- -info: 'Lean4Lean.AddInduct.to_addInduct' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.AddInduct.to_addInduct' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms AddInduct.to_addInduct /-- -info: 'Lean4Lean.AddInduct.le' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.AddInduct.le' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms AddInduct.le /-- -info: 'Lean4Lean.AddInductBlockTrace.to_addInductBlockGeneration' depends on axioms: [propext, - sorryAx, - Classical.choice, - Quot.sound] +info: 'Lean4Lean.AddInductBlockTrace.to_addInductBlockGeneration' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms AddInductBlockTrace.to_addInductBlockGeneration /-- -info: 'Lean4Lean.AddInductBlock.to_addInductBlock' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.AddInductBlock.to_addInductBlock' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms AddInductBlock.to_addInductBlock /-- -info: 'Lean4Lean.AddInductBlock.le' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.AddInductBlock.le' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms AddInductBlock.le @@ -390,6 +436,10 @@ inductive TrEnv' : ConstMap → Bool → VEnv → Prop where AddInductBlock C env decl C' env' → TrEnv' C Q env → TrEnv' C' Q env' + | inductNested : + AddInductNested C env decl C' env' → + TrEnv' C Q env → + TrEnv' C' Q env' def TrEnv (safety : DefinitionSafety) (env : Environment) (venv : VEnv) : Prop := TrEnv' safety env.constants env.quotInit venv @@ -423,9 +473,13 @@ theorem TrEnv'.wf (H : TrEnv' safety C Q venv) : venv.WF := by obtain ⟨generation, blockEnv, hgen, hadd⟩ := h1.to_addInductBlock exact ⟨_, H.decl <| .inductBlock (blockEnv := blockEnv) hgen hadd⟩ + | inductNested h1 _ ih => + have ⟨_, H⟩ := ih + obtain ⟨nested, hwf, hadd⟩ := h1.to_addInductNested + exact ⟨_, H.decl <| .inductNested hwf hadd⟩ /-- -info: 'Lean4Lean.TrEnv'.wf' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.TrEnv'.wf' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TrEnv'.wf diff --git a/Lean4Lean/Verify/Environment/ConstructorValidation.lean b/Lean4Lean/Verify/Environment/ConstructorValidation.lean index 305bde7d..3a466725 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidation.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidation.lean @@ -1071,6 +1071,24 @@ theorem nonempty_of_check contradiction | ok alignment => exact ⟨alignment⟩ +/-- A successful alignment audit guarantees the retained builder returns its +trace, so audit owners can replay `build` instead of choosing from +`Nonempty`. -/ +theorem build_ok_of_check + {validationTrace : ConstructorListValidationTrace stats isUnsafe familyIdx + context seen constructors} + {candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor constructors} + (success : check validationTrace candidates context = .ok ()) : + ∃ alignment, build validationTrace candidates = .ok alignment := by + unfold check at success + cases h : build validationTrace candidates with + | error error => + rw [h] at success + change Except.error error = Except.ok () at success + contradiction + | ok alignment => exact ⟨alignment, rfl⟩ + end ConstructorCandidateAlignmentTrace /-- Source-ordered supplemental alignment audit for every exact constructor @@ -3937,6 +3955,32 @@ theorem ConstructorPreFamilyListTrace.nonempty_of_check exact ⟨⟨translationUnique, familyIndices, parameters, constructors⟩⟩ +/-- A successful executable D3 gate guarantees the retained builder returns +its trace, so gate owners can replay `buildConstructorPreFamilySafety` +instead of choosing from `Nonempty`. -/ +theorem buildConstructorPreFamilySafety_ok_of_check + (success : checkConstructorPreFamilySafety stats familyView candidates + context = .ok ()) : + ∃ trace, buildConstructorPreFamilySafety stats familyView candidates + context = .ok trace := by + unfold checkConstructorPreFamilySafety at success + unfold buildConstructorPreFamilySafety + split + next translationUnique => + simp [translationUnique] at success + next translationUnique => + split + next error parameters => + simp [translationUnique, parameters, Bind.bind, Except.bind] at success + next familyIndices parameters => + cases hbuild : ConstructorPreFamilyListTrace.build stats 0 familyIndices + context candidates with + | error error => + simp [translationUnique, parameters, hbuild, + Bind.bind, Except.bind] at success + | ok constructors => + exact ⟨_, rfl⟩ + end AddInductive namespace TypeChecker @@ -4331,8 +4375,10 @@ structure StagedNormalizationCandidatePostFamilyInput /-- Package a successful executable alignment audit into the staged D2 owner. The direct `alignment` field also permits proof-oriented clients to assemble -the same indexed trace from already-retained checker observations. -/ -noncomputable def StagedNormalizationCandidatePostFamilyInput.ofRun +the same indexed trace from already-retained checker observations. The +retained trace is computed by replaying the alignment builder; the audit +premise only discharges its impossible error branch. -/ +def StagedNormalizationCandidatePostFamilyInput.ofRun {familyContext constructorContext : AddInductive.Context} {env : VEnv} {Us : List Name} {source : InductiveType} {candidate : AddInductive.NormalizationCandidate [source]} @@ -4347,9 +4393,16 @@ noncomputable def StagedNormalizationCandidatePostFamilyInput.ofRun StagedNormalizationCandidatePostFamilyInput familyContext constructorContext env Us candidate rawDecl where universeInput := universeInput - alignment := Classical.choice <| - AddInductive.ConstructorCandidateAlignmentTrace.nonempty_of_check - alignmentRun + alignment := + match h : AddInductive.ConstructorCandidateAlignmentTrace.build + universeInput.staged.constructorValidation.trace + candidate.families.singleton.constructors with + | .ok alignment => alignment + | .error _ => + absurd + (AddInductive.ConstructorCandidateAlignmentTrace.build_ok_of_check + alignmentRun) + (by simp [h]) /-- The exact output of D2: the established produced semantic hierarchy plus the actual post-family validation context, retained source/candidate @@ -4454,8 +4507,10 @@ structure StagedNormalizationCandidatePreFamilyInput /-- Package a successful executable D3 gate into the staged owner. The gate itself, rather than a caller-supplied Theory premise, selects the retained -parameter-instantiated family telescope and constructor traces. -/ -noncomputable def StagedNormalizationCandidatePreFamilyInput.ofRun +parameter-instantiated family telescope and constructor traces. The trace +is computed by replaying the safety builder; the gate premise only +discharges its impossible error branch. -/ +def StagedNormalizationCandidatePreFamilyInput.ofRun {familyContext constructorContext : AddInductive.Context} {env : VEnv} {Us : List Name} {source : InductiveType} {candidate : AddInductive.NormalizationCandidate [source]} @@ -4471,8 +4526,17 @@ noncomputable def StagedNormalizationCandidatePreFamilyInput.ofRun StagedNormalizationCandidatePreFamilyInput familyContext constructorContext env Us candidate rawDecl where postFamilyInput := postFamilyInput - safety := Classical.choice <| - AddInductive.ConstructorPreFamilyListTrace.nonempty_of_check safetyRun + safety := + match h : AddInductive.buildConstructorPreFamilySafety + postFamilyInput.universeInput.staged.family.validation.stats + candidate.families.singleton.familyType.type.view + candidate.families.singleton.constructors + candidate.families.singleton.familyType.type.trace.terminalContext with + | .ok safety => safety + | .error _ => + absurd + (AddInductive.buildConstructorPreFamilySafety_ok_of_check safetyRun) + (by simp [h]) /-- D3's produced meaning: D2's post-family semantics together with the exact verified pre-family context and source-ordered family-free replay selected by @@ -5151,21 +5215,6 @@ theorem Closed.getAppArgsList | bvar | fvar | mvar | sort | const | lit | mdata | proj | lam | forallE | letE => simp [Expr.getAppArgsList] -theorem FVarsIn.getAppArgsList - (fvars : FVarsIn predicate expression) : - ∀ argument ∈ expression.getAppArgsList, - FVarsIn predicate argument := by - induction expression with - | app function argument functionIH argumentIH => - intro candidate member - rw [Expr.getAppArgsList, expr_getAppArgsList_acc] at member - simp only [List.mem_append, List.mem_singleton] at member - rcases member with member | rfl - · exact functionIH fvars.1 candidate member - · exact fvars.2 - | bvar | fvar | mvar | sort | const | lit | mdata | proj | lam | forallE | - letE => simp [Expr.getAppArgsList] - private theorem vexpr_appHead_appN (head : VExpr) (arguments : List VExpr) : VExpr.appHead (VExpr.appN head arguments) = VExpr.appHead head := by induction arguments generalizing head with @@ -8577,6 +8626,102 @@ theorem StagedNormalizationCandidatePreFamilyInput.normalization_eq rw [familyEq] exact Normalization.eq_of_view_eq viewDeclEq +/-- Choice-free constructor-root interpretation: the semantic root's view is +computed by the deterministic translator under the constructor's strict-view +uniqueness certificate. -/ +def CandidateConstructorSemanticInput.semanticOfUnique + {env : VEnv} {Us : List Name} {source : Constructor} + {candidate : AddInductive.CandidateConstructor source} {raw : VConstVal} + (input : CandidateConstructorSemanticInput env Us candidate raw) + (unique : TypeChecker.CandidateExprTraceViewIsUnique + candidate.type.trace) : + CandidateConstructorSemanticRun env Us candidate raw where + name_eq := input.name_eq + uvars_eq := input.uvars_eq + type := input.type.semanticOfUnique unique + +/-- Choice-free source-ordered interpretation of a complete constructor list +under its source-ordered strict-view certificate. -/ +def CandidateConstructorSemanticListInput.semanticOfUnique + {env : VEnv} {Us : List Name} : + {sources : List Constructor} → + {candidates : AddInductive.CandidateList + AddInductive.CandidateConstructor sources} → + {raws : List VConstVal} → + CandidateConstructorSemanticListInput env Us candidates raws → + candidates.ViewTranslationUnique → + CandidateConstructorSemanticListRun env Us candidates raws + | _, _, _, .nil, _ => .nil + | _, _, _, .cons head tail, unique => + .cons (head.semanticOfUnique unique.1) (tail.semanticOfUnique unique.2) + +/-- Choice-free family interpretation: the family type and every +post-insertion constructor view are computed by the deterministic +translator. -/ +def CandidateFamilySemanticInput.semanticOfUnique + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.CandidateFamily source} {raw : VInductiveType} + (input : CandidateFamilySemanticInput env Us candidate raw) + (uniqueType : TypeChecker.CandidateExprTraceViewIsUnique + candidate.familyType.type.trace) + (uniqueCtors : candidate.constructors.ViewTranslationUnique) : + CandidateFamilySemanticRun env Us candidate raw where + name_eq := input.name_eq + uvars_eq := input.uvars_eq + type := input.type.semanticOfUnique uniqueType + typeEnv := input.typeEnv + addType := input.addType + constructors := input.constructors.semanticOfUnique uniqueCtors + +/-- Choice-free singleton semantic hierarchy: every normalized Theory view +in the family and constructor list is computed by the deterministic +translator, with `Nonempty` interpretation transferred onto the computed +values. -/ +def NormalizationCandidateSemanticInput.semanticOfUnique + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.NormalizationCandidate [source]} + {rawDecl : VInductDecl} + (input : NormalizationCandidateSemanticInput env Us candidate rawDecl) + (uniqueType : TypeChecker.CandidateExprTraceViewIsUnique + candidate.families.singleton.familyType.type.trace) + (uniqueCtors : + candidate.families.singleton.constructors.ViewTranslationUnique) : + NormalizationCandidateSemanticRun env Us candidate rawDecl where + raw := input.raw + raw_types_eq := input.raw_types_eq + uvars_eq := input.uvars_eq + family := input.family.semanticOfUnique uniqueType uniqueCtors + +/-- The executable D3 gate's uniqueness Bool supplies the family strict-view +certificate consumed by the choice-free semantic assembly. -/ +theorem StagedNormalizationCandidatePreFamilyInput.familyViewUnique + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.NormalizationCandidate [source]} + {rawDecl : VInductDecl} + (input : StagedNormalizationCandidatePreFamilyInput familyContext + constructorContext env Us candidate rawDecl) : + TypeChecker.CandidateExprTraceViewIsUnique + candidate.families.singleton.familyType.type.trace := by + have h := input.safety.translationUnique + simp only [Bool.and_eq_true] at h + exact AddInductive.CandidateExprTrace.viewTranslationUnique_sound _ + ((AddInductive.CandidateExprTrace.viewTranslationUnique_eq _).trans h.1) + +/-- The executable D3 gate's uniqueness Bool likewise supplies the +constructor-list strict-view certificate. -/ +theorem StagedNormalizationCandidatePreFamilyInput.constructorViewsUnique + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} {source : InductiveType} + {candidate : AddInductive.NormalizationCandidate [source]} + {rawDecl : VInductDecl} + (input : StagedNormalizationCandidatePreFamilyInput familyContext + constructorContext env Us candidate rawDecl) : + candidate.families.singleton.constructors.ViewTranslationUnique := by + have h := input.safety.translationUnique + simp only [Bool.and_eq_true] at h + exact AddInductive.CandidateList.viewTranslationUnique_sound _ h.2 + /-- Exact, source-indexed refinement of the public producer package. The public `ProducedGenerationCandidatePackage` deliberately erases its @@ -8613,6 +8758,41 @@ def ExactProducedGenerationCandidatePackage.package exact.semantic.producedPackage context source.nparams numNested isUnsafe producedCandidate.produced +/-- Close one strengthened singleton producer choice-free. The semantic +hierarchy is computed by the deterministic translator under the executable +D3 strict-view gate carried by the staged owner, so the retained package is +data rather than a `Classical.choice` selection from `Nonempty`. -/ +def ProducedGenerationShapeCandidate.exactProducedPackage + {familyContext constructorContext : AddInductive.Context} + {env : VEnv} {Us : List Name} + {kernelSource : InductiveType} {source : VInductDecl} + {raw : VInductiveType} {numNested : Nat} {isUnsafe : Bool} + {context : AddInductive.Context} + (producedCandidate : ProducedGenerationShapeCandidate source raw + kernelSource numNested isUnsafe context) + (input : StagedNormalizationCandidatePreFamilyInput familyContext + constructorContext env Us producedCandidate.candidate source) + (rawOwnerEq : raw = + input.postFamilyInput.universeInput.staged.raw) + (generation : GenerationChecked source) + (analysis : ∀ normalization : NormalizationCandidateSemanticRun env Us + producedCandidate.candidate source, + normalization.root.normalization.generation? = some generation) : + ExactProducedGenerationCandidatePackage env Us + producedCandidate generation := + let normalization := + input.postFamilyInput.universeInput.staged.semanticInput.semanticOfUnique + input.familyViewUnique input.constructorViewsUnique + { normalization := normalization + raw_eq := rawOwnerEq + semantic := GenerationCandidateSemanticRun.ofGenerationShape input + normalization generation (analysis normalization) + (by + have hraw : normalization.raw = + input.postFamilyInput.universeInput.staged.raw := rfl + simpa only [NormalizationCandidateSemanticRun.generationShape, + rawOwnerEq, hraw] using producedCandidate.shape) } + /-- Close one strengthened singleton producer from the staged D1--D4 owner without choosing a semantic hierarchy at the API boundary, while retaining the exact dependent source and generation indices needed by consumers. -/ @@ -8952,7 +9132,6 @@ new universe bridge itself remains separately guarded above; staging does not hide the transitional dependencies already present in the semantic owner. -/ /-- info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidateUniverseInput.semanticValidation' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -8961,7 +9140,6 @@ info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidateUniverseInput.semanticV /-- info: 'Lean4Lean.VInductDecl.StagedNormalizationCandidateUniverseInput.universeSemantics' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ diff --git a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean index 9e096ec3..58606b72 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean @@ -79,6 +79,13 @@ theorem cvmEmptyVEnvsWF : hasPrimitives := l4l05EmptyHasPrimitives safePrimitives := cvmEmptySafePrimitives mono := fun _ => .rfl + projectionReady := by + intro _ name _ _ h + simp only [constructorValidityMatrixContext, + Kernel.Environment.isProjectionReadyStructure, + Kernel.Environment.ofConstants] at h + simp only [SMap.WF.find?'_eq_find? SMap.WF.empty] at h + simp [SMap.find?] at h theorem prbEmptySafePrimitives : propRecursiveBoundaryContext.env.find? name = some info → @@ -98,6 +105,13 @@ theorem prbEmptyVEnvsWF : hasPrimitives := l4l05EmptyHasPrimitives safePrimitives := prbEmptySafePrimitives mono := fun _ => .rfl + projectionReady := by + intro _ name _ _ h + simp only [propRecursiveBoundaryContext, + Kernel.Environment.isProjectionReadyStructure, + Kernel.Environment.ofConstants] at h + simp only [SMap.WF.find?'_eq_find? SMap.WF.empty] at h + simp [SMap.find?] at h def cvmExecutionResult := AddInductive.buildNormalizationCandidateExecution 2 @@ -544,6 +558,24 @@ def cvmDeclaredInfo : ConstantInfo := 0 false cvmCandidate.families.singleton.familyType.type.trace.terminalContext +theorem cvmDeclaredInfo_isRec : + (AddInductive.singletonDeclaredInfo + cvmFamilyValidationRun.stats 2 0 constructorValidityMatrixKernelType + 0 false + cvmCandidate.families.singleton.familyType.type.trace.terminalContext).isRec = + true := by + simp only [AddInductive.singletonDeclaredInfo] + rw [cvmFamilyValidationRun.stats_eq] + simp [cvmFamilyValidationRun, + AddInductive.CandidateExprTrace.singletonCandidateInductiveStats, + AddInductive.isRec, AddInductive.isRec.loop, + AddInductive.hasIndOcc, + constructorValidityMatrixKernelType, + constructorValidityMatrixKernelCtor, + constructorValidityMatrixInfo, constructorValidityMatrixMkInfo, + ConstantInfo.name, ConstantInfo.type, ConstantInfo.toConstantVal, + Expr.constName!] + theorem cvmFamilyNames_eq : constructorValidityMatrixKernelType.name = constructorValidityMatrixType.name := by @@ -563,6 +595,43 @@ theorem cvmFamilyMap_add : cvmCandidate.families.singleton.familyType.type.trace.terminalContext cvmExecution.familyEnv cvmStatsNindices_eq h +theorem cvmConstructorContext_noProjectionReady (name : Name) : + cvmConstructorContext.env.isProjectionReadyStructure name = false := by + have hConstants : + cvmConstructorContext.env.constants = + ({} : ConstMap).insert constructorValidityMatrixType.name + cvmDeclaredInfo := by + simp only [cvmConstructorContext] + rw [cvmFamilyMap_add, cvmTerminalEnv_eq] + rfl + have hMap : + (({} : ConstMap).insert constructorValidityMatrixType.name + cvmDeclaredInfo).WF := + SMap.WF.empty.insert _ _ (by simp [SMap.find?]) + by_cases hName : constructorValidityMatrixType.name = name + · subst name + apply Kernel.Environment.isProjectionReadyStructure_false_of_no_ctorInfo + (info := AddInductive.singletonDeclaredInfo + cvmFamilyValidationRun.stats 2 0 constructorValidityMatrixKernelType + 0 false + cvmCandidate.families.singleton.familyType.type.trace.terminalContext) + · rw [hConstants, hMap.find?'_eq_find?, + SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + simp [cvmDeclaredInfo] + · intro ctor ctorInfo hctor + rw [hConstants, hMap.find?'_eq_find?, + SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] at hctor + split at hctor + · cases hctor + · simp [SMap.find?] at hctor + · apply Kernel.Environment.isProjectionReadyStructure_false_of_not_found + rw [hConstants, hMap.find?'_eq_find?, + SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + simp [hName, SMap.find?] + def cvmTypeEnv : VEnv := (VEnv.empty.addConst constructorValidityMatrixType.name constructorValidityMatrixType.toVConstant).get! @@ -626,6 +695,10 @@ def cvmFamilyStage : validation := cvmFamilyValidationRun typeEnv := cvmTypeEnv addInduct := cvmAddType + projectionReady := by + intro name _ _ h + rw [cvmConstructorContext_noProjectionReady] at h + contradiction family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := by @@ -1789,6 +1862,37 @@ theorem prbTerminalEnv_eq : congrArg AddInductive.Context.env prbFamilyCandidateContext_eq _ = propRecursiveBoundaryContext.env := rfl +theorem prbConstructorContext_noProjectionReady (name : Name) : + prbConstructorContext.env.isProjectionReadyStructure name = false := by + have hConstants : + prbConstructorContext.env.constants = + ({} : ConstMap).insert propRecursiveBoundaryType.name + prbDeclaredInfo := by + simp only [prbConstructorContext] + rw [prbFamilyMap_add, prbTerminalEnv_eq] + rfl + have hMap : + (({} : ConstMap).insert propRecursiveBoundaryType.name + prbDeclaredInfo).WF := + SMap.WF.empty.insert _ _ (by simp [SMap.find?]) + by_cases hName : propRecursiveBoundaryType.name = name + · subst name + apply Kernel.Environment.isProjectionReadyStructure_false_of_numIndices_ne + (info := AddInductive.singletonDeclaredInfo + prbFamilyValidationRun.stats 1 1 propRecursiveBoundaryKernelType + 0 false + prbCandidate.families.singleton.familyType.type.trace.terminalContext) + · rw [hConstants, hMap.find?'_eq_find?, + SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + simp [prbDeclaredInfo] + · simp [AddInductive.singletonDeclaredInfo] + · apply Kernel.Environment.isProjectionReadyStructure_false_of_not_found + rw [hConstants, hMap.find?'_eq_find?, + SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + simp [hName, SMap.find?] + theorem prbDeclaredInfo_tr : TrConstVal .safe VEnv.empty prbDeclaredInfo propRecursiveBoundaryType.toVConstVal := by @@ -1842,6 +1946,10 @@ def prbFamilyStage : validation := prbFamilyValidationRun typeEnv := prbTypeEnv addInduct := prbAddType + projectionReady := by + intro name _ _ h + rw [prbConstructorContext_noProjectionReady] at h + contradiction family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := by @@ -3628,14 +3736,14 @@ private theorem prbCandidateWhnfResult_eq rw [self] at other exact (Except.ok.inj other).symm -noncomputable def prbConstructorValidation : +def prbConstructorValidation : AddInductive.ConstructorValidationRun propRecursiveBoundaryKernelType prbFamilyValidationRun.stats false prbConstructorValidationContext := AddInductive.ConstructorValidationRun.of_run (by simpa [prbConstructorValidationContext] using prbCheckConstructorsRun) -noncomputable def prbStagedUniverseInput : +def prbStagedUniverseInput : VInductDecl.StagedNormalizationCandidateUniverseInput prbFamilyContext prbConstructorContext VEnv.empty [`u] prbCandidate propRecursiveBoundaryDecl where @@ -3712,7 +3820,7 @@ private def prbValidationNextDomainAnnotations : ⟨AddInductive.candidateIsDefEqRefl prbValidationAContext prbValidationNextDomain⟩ -private noncomputable def prbValidationAlphaPositivityAlignment +private def prbValidationAlphaPositivityAlignment (trace : AddInductive.ConstructorPositivityModeTrace prbStagedUniverseInput.staged.family.validation.stats false propRecursiveBoundaryKernelCtor.name 1 prbValidationRootContext @@ -3766,7 +3874,7 @@ private def prbTransportPositivityAlignment subst source' exact alignment -private noncomputable def prbValidationNextPositivityAlignment +private def prbValidationNextPositivityAlignment (trace : AddInductive.ConstructorPositivityModeTrace prbStagedUniverseInput.staged.family.validation.stats false propRecursiveBoundaryKernelCtor.name 2 prbValidationAContext @@ -3940,7 +4048,7 @@ private def prbTransportViewAlignmentIndexed set_option pp.universes false in set_option pp.all false in -noncomputable def prbStagedPostFamilyInput : +def prbStagedPostFamilyInput : VInductDecl.StagedNormalizationCandidatePostFamilyInput prbFamilyContext prbConstructorContext VEnv.empty [`u] prbCandidate propRecursiveBoundaryDecl where @@ -5457,7 +5565,7 @@ theorem prbSafetyRun : VInductDecl.StagedNormalizationCandidatePostFamilyInput.ofRun] using prbSafetyRunDirect -noncomputable def prbStagedPreFamilyInput : +def prbStagedPreFamilyInput : VInductDecl.StagedNormalizationCandidatePreFamilyInput prbFamilyContext prbConstructorContext VEnv.empty [`u] prbCandidate propRecursiveBoundaryDecl := @@ -6716,7 +6824,7 @@ theorem cvmCtorTerminalValidationShapeTest : AddInductive.Context.freshExpr, AddInductive.Context.freshFVarId, Expr.bindingBody!, Expr.instantiate1_eq, Expr.instantiate1'] -noncomputable def cvmConstructorValidationTest : +def cvmConstructorValidationTest : AddInductive.ConstructorValidationRun constructorValidityMatrixKernelType cvmFamilyValidationRun.stats false cvmValidationRootContextTest := @@ -8402,7 +8510,7 @@ def cvmValidationFunctionPosBodyCheckedTest : rw [cvmValidationPFindInFunctionPosTest] rfl) cvmValidationFunctionPosBodyCheckTest -noncomputable def cvmStagedUniverseInputTest : +def cvmStagedUniverseInputTest : VInductDecl.StagedNormalizationCandidateUniverseInput cvmFamilyContext cvmConstructorContext VEnv.empty [`u] cvmCandidate constructorValidityMatrixDecl where @@ -8673,7 +8781,7 @@ def cvmTransportPositivityFuelAlignmentTest subst fuel' exact alignment -noncomputable def cvmAbsentPositivityAlignmentCoreTest +def cvmAbsentPositivityAlignmentCoreTest (self : AddInductive.CandidateWhnfStep.Valid ⟨context, source, source⟩) (notForall : source.isForall = false) @@ -8701,7 +8809,7 @@ noncomputable def cvmAbsentPositivityAlignmentCoreTest rw [noOccurrence] at occurs contradiction -noncomputable def cvmTargetPositivityAlignmentCoreTest +def cvmTargetPositivityAlignmentCoreTest (self : AddInductive.CandidateWhnfStep.Valid ⟨context, source, source⟩) (notForall : source.isForall = false) @@ -8729,7 +8837,7 @@ noncomputable def cvmTargetPositivityAlignmentCoreTest subst result exact .target checked -noncomputable def cvmAbsentPositivityModeAlignmentTest +def cvmAbsentPositivityModeAlignmentTest (self : AddInductive.CandidateWhnfStep.Valid ⟨context, source, source⟩) (notForall : source.isForall = false) @@ -8750,7 +8858,7 @@ noncomputable def cvmAbsentPositivityModeAlignmentTest exact cvmTransportPositivityFuelAlignmentTest inductiveFuel positivityTrace normalizedAlignment -noncomputable def cvmTargetPositivityModeAlignmentTest +def cvmTargetPositivityModeAlignmentTest (self : AddInductive.CandidateWhnfStep.Valid ⟨context, source, source⟩) (notForall : source.isForall = false) @@ -8771,7 +8879,7 @@ noncomputable def cvmTargetPositivityModeAlignmentTest exact cvmTransportPositivityFuelAlignmentTest inductiveFuel positivityTrace normalizedAlignment -noncomputable def cvmValidationXPositivityAlignmentTest +def cvmValidationXPositivityAlignmentTest (trace : AddInductive.ConstructorPositivityModeTrace cvmStagedUniverseInputTest.staged.family.validation.stats false constructorValidityMatrixKernelCtor.name 2 @@ -8781,7 +8889,7 @@ noncomputable def cvmValidationXPositivityAlignmentTest (by rw [cvmCtorXDomainValidationShapeTest]; rfl) cvmValidationXHasNoIndOccTest cvmValidationXCheckedTest (by rfl) trace -noncomputable def cvmValidationProofPositivityAlignmentTest +def cvmValidationProofPositivityAlignmentTest (trace : AddInductive.ConstructorPositivityModeTrace cvmStagedUniverseInputTest.staged.family.validation.stats false constructorValidityMatrixKernelCtor.name 3 @@ -8792,7 +8900,7 @@ noncomputable def cvmValidationProofPositivityAlignmentTest cvmValidationProofHasNoIndOccTest cvmValidationProofCheckedTest (by rfl) trace -noncomputable def cvmValidationDirectPositivityAlignmentTest +def cvmValidationDirectPositivityAlignmentTest (trace : AddInductive.ConstructorPositivityModeTrace cvmStagedUniverseInputTest.staged.family.validation.stats false constructorValidityMatrixKernelCtor.name 4 @@ -8803,7 +8911,7 @@ noncomputable def cvmValidationDirectPositivityAlignmentTest cvmValidationDirectHasIndOccTest cvmValidationDirectCheckedTest (by rfl) trace -noncomputable def cvmValidationLaterPositivityAlignmentTest +def cvmValidationLaterPositivityAlignmentTest (trace : AddInductive.ConstructorPositivityModeTrace cvmStagedUniverseInputTest.staged.family.validation.stats false constructorValidityMatrixKernelCtor.name 6 @@ -8814,7 +8922,7 @@ noncomputable def cvmValidationLaterPositivityAlignmentTest cvmValidationLaterHasNoIndOccTest cvmValidationLaterCheckedTest (by rfl) trace -noncomputable def cvmValidationLaterProofPositivityAlignmentTest +def cvmValidationLaterProofPositivityAlignmentTest (trace : AddInductive.ConstructorPositivityModeTrace cvmStagedUniverseInputTest.staged.family.validation.stats false constructorValidityMatrixKernelCtor.name 7 @@ -8850,7 +8958,7 @@ def cvmTransportPositivityAlignmentTest subst source' exact alignment -noncomputable def cvmValidationFunctionPositivityAlignmentTest +def cvmValidationFunctionPositivityAlignmentTest (trace : AddInductive.ConstructorPositivityModeTrace cvmStagedUniverseInputTest.staged.family.validation.stats false constructorValidityMatrixKernelCtor.name 5 @@ -9061,7 +9169,7 @@ def cvmTransportViewAlignmentIndexedTest set_option pp.universes false in set_option pp.all false in -noncomputable def cvmStagedPostFamilyInputTest : +def cvmStagedPostFamilyInputTest : VInductDecl.StagedNormalizationCandidatePostFamilyInput cvmFamilyContext cvmConstructorContext VEnv.empty [`u] cvmCandidate constructorValidityMatrixDecl where @@ -11234,7 +11342,7 @@ theorem cvmSafetyRunTest : .ok () := by simpa [cvmStagedPostFamilyInputTest] using cvmSafetyRunDirectTest -noncomputable def cvmStagedPreFamilyInputTest : +def cvmStagedPreFamilyInputTest : VInductDecl.StagedNormalizationCandidatePreFamilyInput cvmFamilyContext cvmConstructorContext VEnv.empty [`u] cvmCandidate constructorValidityMatrixDecl := @@ -11254,11 +11362,11 @@ theorem cvmUniverseRun : rw [cvmConstructorValidationContextTest_root] exact cvmUniverseRunTest -noncomputable def cvmConstructorValidation := cvmConstructorValidationTest +def cvmConstructorValidation := cvmConstructorValidationTest -noncomputable def cvmStagedUniverseInput := cvmStagedUniverseInputTest +def cvmStagedUniverseInput := cvmStagedUniverseInputTest -noncomputable def cvmStagedPostFamilyInput := cvmStagedPostFamilyInputTest +def cvmStagedPostFamilyInput := cvmStagedPostFamilyInputTest theorem cvmSafetyRunDirect : AddInductive.checkConstructorPreFamilySafety @@ -11278,7 +11386,7 @@ theorem cvmSafetyRun : .ok () := cvmSafetyRunTest -noncomputable def cvmStagedPreFamilyInput := cvmStagedPreFamilyInputTest +def cvmStagedPreFamilyInput := cvmStagedPreFamilyInputTest /- The accepted CVM package may inherit the ordinary verified-checker transition frontier and the one exact L4L-01E execution witness, but no @@ -11362,7 +11470,7 @@ theorem cvmCanonicalCandidate_produced : rw [← cvmCandidate_eq_canonical] exact cvmCandidate_produced -noncomputable abbrev cvmCanonicalStagedPreFamilyInput : +abbrev cvmCanonicalStagedPreFamilyInput : VInductDecl.StagedNormalizationCandidatePreFamilyInput cvmFamilyContext cvmConstructorContext VEnv.empty [`u] cvmCanonicalCandidate constructorValidityMatrixDecl := @@ -11466,19 +11574,24 @@ theorem cvmExactProducedGenerationCandidatePackage_exists : constructorValidityMatrixGenerationChecked cvmCandidate_analysis -private noncomputable def cvmExactProducedGenerationCandidatePackage : +private def cvmExactProducedGenerationCandidatePackage : VInductDecl.ExactProducedGenerationCandidatePackage VEnv.empty [`u] cvmProducedGenerationShapeCandidate constructorValidityMatrixGenerationChecked := - Classical.choice cvmExactProducedGenerationCandidatePackage_exists + cvmProducedGenerationShapeCandidate.exactProducedPackage + cvmCanonicalStagedPreFamilyInput + (stagedPreFamily_transport_raw cvmCandidate_eq_canonical + cvmStagedPreFamilyInput).symm + constructorValidityMatrixGenerationChecked + cvmCandidate_analysis -noncomputable def cvmGenerationCandidateSemanticRun : +def cvmGenerationCandidateSemanticRun : VInductDecl.GenerationCandidateSemanticRun cvmExactProducedGenerationCandidatePackage.normalization constructorValidityMatrixGenerationChecked := cvmExactProducedGenerationCandidatePackage.semantic -noncomputable def cvmProducedGenerationCandidatePackage : +def cvmProducedGenerationCandidatePackage : VInductDecl.ProducedGenerationCandidatePackage VEnv.empty [`u] := cvmExactProducedGenerationCandidatePackage.package @@ -11557,7 +11670,7 @@ theorem prbCanonicalCandidate_produced : rw [← prbCandidate_eq_canonical] exact prbCandidate_produced -noncomputable abbrev prbCanonicalStagedPreFamilyInput : +abbrev prbCanonicalStagedPreFamilyInput : VInductDecl.StagedNormalizationCandidatePreFamilyInput prbFamilyContext prbConstructorContext VEnv.empty [`u] prbCanonicalCandidate propRecursiveBoundaryDecl := @@ -11661,19 +11774,23 @@ theorem prbExactProducedGenerationCandidatePackage_exists : prbStagedPreFamilyInput).symm propRecursiveBoundaryGenerationChecked prbCandidate_analysis -private noncomputable def prbExactProducedGenerationCandidatePackage : +private def prbExactProducedGenerationCandidatePackage : VInductDecl.ExactProducedGenerationCandidatePackage VEnv.empty [`u] prbProducedGenerationShapeCandidate propRecursiveBoundaryGenerationChecked := - Classical.choice prbExactProducedGenerationCandidatePackage_exists + prbProducedGenerationShapeCandidate.exactProducedPackage + prbCanonicalStagedPreFamilyInput + (stagedPreFamily_transport_raw prbCandidate_eq_canonical + prbStagedPreFamilyInput).symm propRecursiveBoundaryGenerationChecked + prbCandidate_analysis -noncomputable def prbGenerationCandidateSemanticRun : +def prbGenerationCandidateSemanticRun : VInductDecl.GenerationCandidateSemanticRun prbExactProducedGenerationCandidatePackage.normalization propRecursiveBoundaryGenerationChecked := prbExactProducedGenerationCandidatePackage.semantic -noncomputable def prbProducedGenerationCandidatePackage : +def prbProducedGenerationCandidatePackage : VInductDecl.ProducedGenerationCandidatePackage VEnv.empty [`u] := prbExactProducedGenerationCandidatePackage.package @@ -11823,7 +11940,7 @@ theorem cvmReplayRec_fresh : SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] simp [constructorValidityMatrixType, SMap.find?] -noncomputable def cvmAddInductTraceChecked : +def cvmAddInductTraceChecked : AddInductTrace ({} : ConstMap) VEnv.empty constructorValidityMatrixDecl cvmReplayMap cvmCertifiedFinalEnv := by refine cvmProducedGenerationCandidatePackage.package.addInductTrace @@ -12064,7 +12181,7 @@ theorem prbReplayRec_fresh : SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] simp [propRecursiveBoundaryType, SMap.find?] -noncomputable def prbAddInductTraceChecked : +def prbAddInductTraceChecked : AddInductTrace ({} : ConstMap) VEnv.empty propRecursiveBoundaryDecl prbReplayMap prbCertifiedFinalEnv := by refine prbProducedGenerationCandidatePackage.package.addInductTrace diff --git a/Lean4Lean/Verify/Environment/DeepNestedReplay.lean b/Lean4Lean/Verify/Environment/DeepNestedReplay.lean new file mode 100644 index 00000000..39a76804 --- /dev/null +++ b/Lean4Lean/Verify/Environment/DeepNestedReplay.lean @@ -0,0 +1,790 @@ +import Lean4Lean.Verify.Environment.NestedReplay + +/-! +# Deep, multi-parameter nested replay + +`BiBox` supplies an actual two-parameter dependency block. `DeepBi` then +nests through `BiBox` twice: the second occurrence is discovered only while +the first auxiliary constructor is processed. The pair exercises both +simultaneous parameter substitution and the flattening work queue beyond the +original one-parameter ladder fixtures. +-/ + +namespace Lean4Lean.DeepNestedReplayFixtures + +open Lean +open Lean4Lean.InductiveReplayFixtures +open Lean4Lean.NestedRepresentation +open VInductDecl + +/- `nestedBlockChecked?` is executable Theory data. Reify one of its closed +generated equations as constructor syntax so the ordinary `type_tac` checker +can audit the equation without unfolding the analyzer. This is the same +elaboration-time quotation boundary used by the kernel-metadata macros; the +subsequent `rfl` parity lemmas below separately pin every quoted RHS to the +actual stored recursor metadata. -/ +syntax "computedVDefEq%" term : term + +elab_rules : term + | `(computedVDefEq% $rule:term) => do + let e ← Lean.Elab.Term.elabTerm rule (Lean.mkConst ``VDefEq) + let e ← Lean.instantiateMVars e + let value ← unsafe Lean.Meta.evalExpr VDefEq (Lean.mkConst ``VDefEq) e + return Lean.toExpr value + +local instance : Inhabited VEnv := ⟨.empty⟩ +local instance : Inhabited VConstVal := + ⟨⟨⟨0, .sort .zero⟩, .anonymous⟩⟩ +local instance : Inhabited VDefEq := + ⟨⟨0, .sort .zero, .sort .zero, .sort (.succ .zero)⟩⟩ + +/-! ## An actual two-parameter dependency replay -/ + +inductive BiBox (α β : Type) : Type where + | mk : α → β → BiBox α β + +def biBoxType : VInductiveType where + name := ``BiBox + uvars := 0 + type := nestedConstVType09A% BiBox + ctors := [⟨⟨0, nestedConstVType09A% BiBox.mk⟩, ``BiBox.mk⟩] + +def biBoxDecl : VInductDecl where + uvars := 0 + nparams := 2 + types := [biBoxType] + +def biBoxChecked : biBoxDecl.Checked := + biBoxDecl.checked?.get (by decide) + +def biBoxGeneration : biBoxDecl.GenerationChecked := + biBoxDecl.identityGeneration?.get (by decide) + +def biBoxFamilyV : VConstVal := biBoxType.toVConstVal +def biBoxCtorV : VConstVal := biBoxType.ctors[0] +def biBoxRecV : VConstVal := inductGenerationRecVal biBoxGeneration + +/-- The executable analyzer's concrete view of the actual dependency block. +Keep these observations in one named trust-manifest entry. -/ +theorem biBoxObservedShape : + biBoxChecked.type.name = ``BiBox ∧ + biBoxChecked.resultLevel = .succ .zero ∧ + biBoxChecked.indices = [] ∧ + biBoxChecked.params.reverse = + [.sort (.succ .zero), .sort (.succ .zero)] ∧ + biBoxGeneration.block.sourceType.ctors = [biBoxCtorV] := by + native_decide + +theorem biBoxCheckedWF : biBoxChecked.WF VEnv.empty := by + constructor + · change VEnv.empty.OnTel 0 [] + [.sort (.succ .zero), .sort (.succ .zero)] + exact ⟨⟨.succ (.succ .zero), VEnv.HasType.sort (by decide)⟩, + ⟨⟨.succ (.succ .zero), VEnv.HasType.sort (by decide)⟩, trivial⟩⟩ + · intro ctor hctor + have hctor' := List.mem_singleton.1 hctor + subst ctor + obtain ⟨hname, hresult, hindices, hparams, -⟩ := biBoxObservedShape + constructor + · rw [show biBoxDecl.uvars = 0 from rfl, + hname, + show biBoxDecl.nparams = 2 from rfl, + hresult, hindices, hparams] + change VInductDecl.fieldsWF 0 ``BiBox 2 VEnv.empty + (.succ .zero) [] [.sort (.succ .zero), .sort (.succ .zero)] 0 + [.bvar 1, .bvar 1] + constructor + · exact .inr (.inr ⟨rfl, .succ .zero, by type_tac, + .inr (VLevel.le_refl _)⟩) + constructor + · intro recursive + contradiction + constructor + · exact .inr (.inr ⟨rfl, .succ .zero, by type_tac, + .inr (VLevel.le_refl _)⟩) + constructor + · intro recursive + contradiction + · trivial + · rfl + +def biBoxGenerationWF : biBoxGeneration.WF VEnv.empty := by + exact biBoxCheckedWF.identityGeneration .empty + +def biBoxTypeEnv : VEnv := + (VEnv.empty.addConst biBoxFamilyV.name biBoxFamilyV.toVConstant).get! + +def biBoxCtorEnv : VEnv := + (biBoxTypeEnv.addConst biBoxCtorV.name biBoxCtorV.toVConstant).get! + +def biBoxRecEnv : VEnv := + (biBoxCtorEnv.addConst biBoxRecV.name biBoxRecV.toVConstant).get! + +def biBoxFinalEnv : VEnv := + biBoxGeneration.generatedRules.foldl VEnv.addDefEq biBoxRecEnv + +def biBoxInfo : ConstantInfo := kernelInductInfo% BiBox +def biBoxMkInfo : ConstantInfo := kernelCtorInfo% BiBox.mk +def biBoxRecInfo : ConstantInfo := kernelRecInfo% BiBox.rec + +def biBoxTypeMap : ConstMap := + ({} : ConstMap).insert ``BiBox biBoxInfo + +def biBoxCtorMap : ConstMap := + biBoxTypeMap.insert ``BiBox.mk biBoxMkInfo + +def biBoxMap : ConstMap := + biBoxCtorMap.insert ``BiBox.rec biBoxRecInfo + +theorem biBoxTypeEnvOrdered : biBoxTypeEnv.Ordered := + replayTypeEnv_ordered07 .empty biBoxGenerationWF rfl + +theorem biBoxCtorEnvOrdered : biBoxCtorEnv.Ordered := + replayCtorEnv_ordered07 biBoxGenerationWF rfl biBoxTypeEnvOrdered rfl + +def biBoxGenerationEnv : + VInductDecl.GenerationEnv biBoxGeneration biBoxCtorEnv := + replayGenerationEnv07 biBoxGenerationWF rfl rfl biBoxCtorEnvOrdered + +theorem biBoxInfoTr : + TrConstVal .safe VEnv.empty biBoxInfo biBoxFamilyV := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr VEnv.empty biBoxInfo.levelParams [] + biBoxInfo.type biBoxFamilyV.type := by + tr_type_expr_tac + obtain ⟨sort, familyType⟩ := replayRawFamilyWF07 biBoxGenerationWF + exact shape.to_trExprS .empty trivial ⟨.sort sort, familyType⟩ + +theorem biBoxCtorInfoTr : + TrConstVal .safe biBoxTypeEnv biBoxMkInfo biBoxCtorV := by + have hBiBox : biBoxTypeEnv.constants ``BiBox = + some biBoxFamilyV.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr biBoxTypeEnv biBoxMkInfo.levelParams [] + biBoxMkInfo.type biBoxCtorV.type := by + tr_type_expr_tac + have hctors := biBoxObservedShape.2.2.2.2 + obtain ⟨sort, ctorType⟩ := replayRawCtorWF07 biBoxGenerationWF rfl + biBoxCtorV (by rw [hctors]; simp) + exact shape.to_trExprS biBoxTypeEnvOrdered trivial + ⟨.sort sort, ctorType⟩ + +theorem biBoxRecInfoTr : + TrConstVal .safe biBoxCtorEnv biBoxRecInfo biBoxRecV := by + have hBiBox : biBoxCtorEnv.constants ``BiBox = + some biBoxFamilyV.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr biBoxCtorEnv biBoxRecInfo.levelParams [] + biBoxRecInfo.type biBoxRecV.type := by + tr_type_expr_tac + obtain ⟨sort, recursorType⟩ := biBoxGenerationEnv.recursor_wf + exact shape.to_trExprS biBoxCtorEnvOrdered trivial + ⟨.sort sort, recursorType⟩ + +theorem biBoxTypeFresh : ({} : ConstMap).find? ``BiBox = none := by + simp [SMap.find?] + +theorem biBoxTypeMapWF : biBoxTypeMap.WF := + SMap.WF.empty.insert _ _ biBoxTypeFresh + +theorem biBoxCtorFresh : biBoxTypeMap.find? ``BiBox.mk = none := by + rw [biBoxTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem biBoxCtorMapWF : biBoxCtorMap.WF := + biBoxTypeMapWF.insert _ _ biBoxCtorFresh + +theorem biBoxRecFresh : biBoxCtorMap.find? ``BiBox.rec = none := by + rw [biBoxCtorMap, biBoxTypeMapWF.find?_insert, biBoxTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem biBoxAddInduct : AddInduct ({} : ConstMap) VEnv.empty biBoxDecl + biBoxMap biBoxFinalEnv := by + refine ⟨{ + generation := biBoxGeneration + generation_wf := biBoxGenerationWF + typeMap := biBoxTypeMap + typeEnv := biBoxTypeEnv + ctorMap := biBoxCtorMap + ctorEnv := biBoxCtorEnv + recEnv := biBoxRecEnv + addType := { + info := biBoxInfo + kind_eq := by simp [biBoxInfo, InductConstantKind.Matches] + tr := biBoxInfoTr + map_fresh := biBoxTypeFresh + env_add := rfl + map_add := rfl } + addCtors := ?_ + addRec := { + info := biBoxRecInfo + kind_eq := by simp [biBoxRecInfo, InductConstantKind.Matches] + tr := biBoxRecInfoTr + map_fresh := biBoxRecFresh + env_add := rfl + map_add := rfl } + recK := by decide + addRules := ⟨rfl⟩ }⟩ + exact .cons { + info := biBoxMkInfo + kind_eq := by simp [biBoxMkInfo, InductConstantKind.Matches] + tr := biBoxCtorInfoTr + map_fresh := by simpa [biBoxCtorV, biBoxType] using biBoxCtorFresh + env_add := rfl + map_add := rfl } .nil + +theorem biBoxAligned : Aligned .safe biBoxMap biBoxFinalEnv := + Aligned.addInduct biBoxAddInduct .empty + +def biBoxReplay : SingletonReplayArtifact where + label := ``BiBox + source := biBoxDecl + inputMap := {} + inputEnv := .empty + inputMapWF := SMap.WF.empty + outputMap := biBoxMap + outputEnv := biBoxFinalEnv + inputOrdered := .empty + transaction := biBoxAddInduct + aligned := biBoxAligned + +/-! ## Analyzer-produced deep nested block -/ + +inductive DeepBi (α β : Type) : Type where + | node : BiBox (DeepBi α β) (BiBox α (DeepBi α β)) → DeepBi α β + +def biBoxTarget : NestedTargetBlock where + nparams := 2 + families := biBoxDecl.types + +def deepSourceV : VInductDecl where + uvars := 0 + nparams := 2 + types := + [{ name := ``DeepBi + uvars := 0 + type := nestedConstVType09A% DeepBi + ctors := + [⟨⟨0, nestedConstVType09A% DeepBi.node⟩, ``DeepBi.node⟩] }] + +def deepNestedC? : Option (NestedBlockChecked deepSourceV) := + nestedBlockChecked? [biBoxTarget] deepSourceV + +#guard deepNestedC?.isSome + +theorem deepNestedC_some : deepNestedC?.isSome := by + native_decide + +def deepNestedC : NestedBlockChecked deepSourceV := + deepNestedC?.get deepNestedC_some + +theorem deepNestedC_produced : + nestedBlockChecked? [biBoxTarget] deepSourceV = some deepNestedC := by + change deepNestedC? = some deepNestedC + exact (Option.some_get deepNestedC_some).symm + +#guard deepNestedC.elim.numNested == 2 +#guard deepNestedC.recursors.length == 3 +#guard deepNestedC.recursors.map (·.name) == + [``DeepBi.rec, + `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_1, + `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_2] + +def deepFamilyV : VConstVal := deepSourceV.types[0].toVConstVal +def deepNodeV : VConstVal := deepSourceV.types[0].ctors[0] + +def deepRecTypeL : VExpr := nestedConstVType09A% DeepBi.rec +def deepRec1TypeL : VExpr := nestedConstVType09A% DeepBi.rec_1 +def deepRec2TypeL : VExpr := nestedConstVType09A% DeepBi.rec_2 + +def deepRecVL : VConstVal := + ⟨⟨1, deepRecTypeL⟩, ``DeepBi.rec⟩ +def deepRec1VL : VConstVal := + ⟨⟨1, deepRec1TypeL⟩, + `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_1⟩ +def deepRec2VL : VConstVal := + ⟨⟨1, deepRec2TypeL⟩, + `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_2⟩ + +theorem deepRecursors_eq : + deepNestedC.recursors = [deepRecVL, deepRec1VL, deepRec2VL] := by + native_decide + +def deepRule0L : VDefEq := + computedVDefEq% deepNestedC.generatedRules[0]! +def deepRule1L : VDefEq := + computedVDefEq% deepNestedC.generatedRules[1]! +def deepRule2L : VDefEq := + computedVDefEq% deepNestedC.generatedRules[2]! + +def deepRulesL : List VDefEq := [deepRule0L, deepRule1L, deepRule2L] + +theorem deepRules_eq : deepNestedC.generatedRules = deepRulesL := by + native_decide + +/- Each analyzer-produced rule is pinned to the corresponding rule emitted +by Lean for the actual declaration. The equality is definitional after the +two independent elaboration-time quotations. -/ +theorem deepRule0_rhs_metadata : + deepRule0L.rhs = kernelRecRuleRhs% DeepBi.rec 0 := by + rfl + +theorem deepRule1_rhs_metadata : + deepRule1L.rhs = kernelRecRuleRhs% DeepBi.rec_1 0 := by + rfl + +theorem deepRule2_rhs_metadata : + deepRule2L.rhs = kernelRecRuleRhs% DeepBi.rec_2 0 := by + rfl + +/-! ## Exact semantic phase environments -/ + +def deepTypeEnv : VEnv := + (biBoxFinalEnv.addConst deepFamilyV.name deepFamilyV.toVConstant).get! + +def deepCtorEnv : VEnv := + (deepTypeEnv.addConst deepNodeV.name deepNodeV.toVConstant).get! + +def deepRecEnv : VEnv := + (deepCtorEnv.addConst deepRecVL.name deepRecVL.toVConstant).get! + +def deepRec1Env : VEnv := + (deepRecEnv.addConst deepRec1VL.name deepRec1VL.toVConstant).get! + +def deepRec2Env : VEnv := + (deepRec1Env.addConst deepRec2VL.name deepRec2VL.toVConstant).get! + +def deepFinalEnv : VEnv := + deepRulesL.foldl VEnv.addDefEq deepRec2Env + +theorem biBoxTrEnv : TrEnv' .safe biBoxMap false biBoxFinalEnv := + .induct biBoxAddInduct .empty + +theorem biBoxFinalOrdered : biBoxFinalEnv.Ordered := + biBoxTrEnv.wf.ordered + +theorem biBoxFinalWF : biBoxFinalEnv.WF := + biBoxTrEnv.wf + +theorem deepFamilyWF : deepFamilyV.toVConstant.WF biBoxFinalEnv := + ⟨_, by type_tac⟩ + +theorem deepTypeEnv_eq : + biBoxFinalEnv.addConst deepFamilyV.name deepFamilyV.toVConstant = + some deepTypeEnv := rfl + +theorem deepTypeOrdered : deepTypeEnv.Ordered := + .const biBoxFinalOrdered deepFamilyWF deepTypeEnv_eq + +theorem deepNodeWF : deepNodeV.toVConstant.WF deepTypeEnv := by + have hBiBox : deepTypeEnv.constants ``BiBox = + some biBoxFamilyV.toVConstant := rfl + have hDeep : deepTypeEnv.constants ``DeepBi = + some deepFamilyV.toVConstant := rfl + exact ⟨_, by type_tac⟩ + +theorem deepCtorEnv_eq : + deepTypeEnv.addConst deepNodeV.name deepNodeV.toVConstant = + some deepCtorEnv := rfl + +theorem deepCtorOrdered : deepCtorEnv.Ordered := + .const deepTypeOrdered deepNodeWF deepCtorEnv_eq + +macro "deep_const_hyps" e:term : tactic => `(tactic| ( + have hBiBox : VEnv.constants $e ``BiBox = + some biBoxFamilyV.toVConstant := rfl + have hBiBoxMk : VEnv.constants $e ``BiBox.mk = + some biBoxCtorV.toVConstant := rfl + have hDeep : VEnv.constants $e ``DeepBi = + some deepFamilyV.toVConstant := rfl + have hNode : VEnv.constants $e ``DeepBi.node = + some deepNodeV.toVConstant := rfl)) + +set_option maxRecDepth 20000 in +theorem deepRecWF : deepRecVL.toVConstant.WF deepCtorEnv := by + deep_const_hyps deepCtorEnv + exact ⟨_, by type_tac⟩ + +theorem deepRecEnv_eq : + deepCtorEnv.addConst deepRecVL.name deepRecVL.toVConstant = + some deepRecEnv := rfl + +theorem deepRecOrdered : deepRecEnv.Ordered := + .const deepCtorOrdered deepRecWF deepRecEnv_eq + +set_option maxRecDepth 20000 in +theorem deepRec1WF : deepRec1VL.toVConstant.WF deepRecEnv := by + deep_const_hyps deepRecEnv + exact ⟨_, by type_tac⟩ + +theorem deepRec1Env_eq : + deepRecEnv.addConst deepRec1VL.name deepRec1VL.toVConstant = + some deepRec1Env := rfl + +theorem deepRec1Ordered : deepRec1Env.Ordered := + .const deepRecOrdered deepRec1WF deepRec1Env_eq + +set_option maxRecDepth 20000 in +theorem deepRec2WF : deepRec2VL.toVConstant.WF deepRec1Env := by + deep_const_hyps deepRec1Env + exact ⟨_, by type_tac⟩ + +theorem deepRec2Env_eq : + deepRec1Env.addConst deepRec2VL.name deepRec2VL.toVConstant = + some deepRec2Env := rfl + +theorem deepRec2Ordered : deepRec2Env.Ordered := + .const deepRec1Ordered deepRec2WF deepRec2Env_eq + +/-! ## Restored rule well-formedness -/ + +macro "deep_rule_hyps" e:term : tactic => `(tactic| ( + deep_const_hyps $e + have hRec : VEnv.constants $e ``DeepBi.rec = + some deepRecVL.toVConstant := rfl + have hRec1 : VEnv.constants $e + `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_1 = + some deepRec1VL.toVConstant := rfl + have hRec2 : VEnv.constants $e + `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_2 = + some deepRec2VL.toVConstant := rfl)) + +def deepRuleEnv1 : VEnv := deepRec2Env.addDefEq deepRule0L +def deepRuleEnv2 : VEnv := deepRuleEnv1.addDefEq deepRule1L + +set_option maxRecDepth 30000 in +theorem deepRule0WF : deepRule0L.WF deepRec2Env := by + constructor + · deep_rule_hyps deepRec2Env + type_tac + · deep_rule_hyps deepRec2Env + type_tac + +set_option maxRecDepth 30000 in +theorem deepRule1WF : deepRule1L.WF deepRuleEnv1 := by + constructor + · deep_rule_hyps deepRuleEnv1 + type_tac + · deep_rule_hyps deepRuleEnv1 + type_tac + +set_option maxRecDepth 30000 in +theorem deepRule2WF : deepRule2L.WF deepRuleEnv2 := by + constructor + · deep_rule_hyps deepRuleEnv2 + type_tac + · deep_rule_hyps deepRuleEnv2 + type_tac + +/-! ## Semantic package and exact nested transaction phases -/ + +theorem deepTypesFold_eq : + deepSourceV.blockTypeConstants.foldlM + (fun env c => env.addConst c.name c.toVConstant) biBoxFinalEnv = + some deepTypeEnv := rfl + +theorem deepCtorsFold_eq : + deepSourceV.blockConstructorConstants.foldlM + (fun env c => env.addConst c.name c.toVConstant) deepTypeEnv = + some deepCtorEnv := rfl + +theorem deepRecsFold_eq : + deepNestedC.recursors.foldlM + (fun env c => env.addConst c.name c.toVConstant) deepCtorEnv = + some deepRec2Env := by + rw [deepRecursors_eq] + rfl + +theorem deepNestedWF : deepNestedC.WF biBoxFinalEnv := by + refine ⟨⟨deepFamilyWF, fun env' h => ?_⟩, fun {typeEnv} h => ?_, + fun {typeEnv ctorEnv} hT hC => ?_, + fun {typeEnv ctorEnv recEnv} hT hC hR => ?_⟩ + · cases Option.some.inj (deepTypeEnv_eq.symm.trans h) + exact trivial + · cases Option.some.inj (deepTypesFold_eq.symm.trans h) + exact ⟨deepNodeWF, fun env' h' => by + cases Option.some.inj (deepCtorEnv_eq.symm.trans h') + exact trivial⟩ + · cases Option.some.inj (deepTypesFold_eq.symm.trans hT) + cases Option.some.inj (deepCtorsFold_eq.symm.trans hC) + rw [deepRecursors_eq] + exact ⟨deepRecWF, fun env' h' => by + cases Option.some.inj (deepRecEnv_eq.symm.trans h') + exact ⟨deepRec1WF, fun env'' h'' => by + cases Option.some.inj (deepRec1Env_eq.symm.trans h'') + exact ⟨deepRec2WF, fun env''' h''' => by + cases Option.some.inj (deepRec2Env_eq.symm.trans h''') + exact trivial⟩⟩⟩ + · cases Option.some.inj (deepTypesFold_eq.symm.trans hT) + cases Option.some.inj (deepCtorsFold_eq.symm.trans hC) + cases Option.some.inj (deepRecsFold_eq.symm.trans hR) + rw [deepRules_eq] + exact ⟨deepRule0WF, deepRule1WF, deepRule2WF, trivial⟩ + +/-! ## Actual stored metadata and implementation maps -/ + +def deepInfo : ConstantInfo := kernelInductInfo% DeepBi +def deepNodeInfo : ConstantInfo := kernelCtorInfo% DeepBi.node +def deepRecInfo : ConstantInfo := kernelRecInfo% DeepBi.rec +def deepRec1Info : ConstantInfo := kernelRecInfo% DeepBi.rec_1 +def deepRec2Info : ConstantInfo := kernelRecInfo% DeepBi.rec_2 + +def deepTypeMap : ConstMap := + biBoxMap.insert ``DeepBi deepInfo + +def deepCtorMap : ConstMap := + deepTypeMap.insert ``DeepBi.node deepNodeInfo + +def deepRecMap : ConstMap := + deepCtorMap.insert ``DeepBi.rec deepRecInfo + +def deepRec1Map : ConstMap := + deepRecMap.insert + `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_1 deepRec1Info + +def deepMap : ConstMap := + deepRec1Map.insert + `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_2 deepRec2Info + +theorem biBoxMapWF : biBoxMap.WF := + biBoxCtorMapWF.insert _ _ biBoxRecFresh + +theorem deepTypeFresh : biBoxMap.find? ``DeepBi = none := by + rw [biBoxMap, biBoxCtorMapWF.find?_insert, biBoxCtorMap, + biBoxTypeMapWF.find?_insert, biBoxTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem deepTypeMapWF : deepTypeMap.WF := + biBoxMapWF.insert _ _ deepTypeFresh + +theorem deepNodeFresh : deepTypeMap.find? ``DeepBi.node = none := by + rw [deepTypeMap, biBoxMapWF.find?_insert, biBoxMap, + biBoxCtorMapWF.find?_insert, biBoxCtorMap, + biBoxTypeMapWF.find?_insert, biBoxTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem deepCtorMapWF : deepCtorMap.WF := + deepTypeMapWF.insert _ _ deepNodeFresh + +theorem deepRecFresh : deepCtorMap.find? ``DeepBi.rec = none := by + rw [deepCtorMap, deepTypeMapWF.find?_insert, deepTypeMap, + biBoxMapWF.find?_insert, biBoxMap, + biBoxCtorMapWF.find?_insert, biBoxCtorMap, + biBoxTypeMapWF.find?_insert, biBoxTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem deepRecMapWF : deepRecMap.WF := + deepCtorMapWF.insert _ _ deepRecFresh + +theorem deepRec1Fresh : deepRecMap.find? + `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_1 = none := by + rw [deepRecMap, deepCtorMapWF.find?_insert, deepCtorMap, + deepTypeMapWF.find?_insert, deepTypeMap, + biBoxMapWF.find?_insert, biBoxMap, + biBoxCtorMapWF.find?_insert, biBoxCtorMap, + biBoxTypeMapWF.find?_insert, biBoxTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem deepRec1MapWF : deepRec1Map.WF := + deepRecMapWF.insert _ _ deepRec1Fresh + +theorem deepRec2Fresh : deepRec1Map.find? + `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_2 = none := by + rw [deepRec1Map, deepRecMapWF.find?_insert, deepRecMap, + deepCtorMapWF.find?_insert, deepCtorMap, + deepTypeMapWF.find?_insert, deepTypeMap, + biBoxMapWF.find?_insert, biBoxMap, + biBoxCtorMapWF.find?_insert, biBoxCtorMap, + biBoxTypeMapWF.find?_insert, biBoxTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +/-! ## Stored metadata translations at the exact insertion boundaries -/ + +theorem deepInfoTr : + TrConstVal .safe biBoxFinalEnv deepInfo deepFamilyV := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr biBoxFinalEnv deepInfo.levelParams [] + deepInfo.type deepFamilyV.toVConstant.type := by + tr_type_expr_tac + obtain ⟨u, hty⟩ := deepFamilyWF + exact shape.to_trExprS biBoxFinalOrdered trivial ⟨_, hty⟩ + +theorem deepNodeInfoTr : + TrConstVal .safe deepTypeEnv deepNodeInfo deepNodeV := by + have hBiBox : deepTypeEnv.constants ``BiBox = + some biBoxFamilyV.toVConstant := rfl + have hDeep : deepTypeEnv.constants ``DeepBi = + some deepFamilyV.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr deepTypeEnv deepNodeInfo.levelParams [] + deepNodeInfo.type deepNodeV.toVConstant.type := by + tr_type_expr_tac + obtain ⟨u, hty⟩ := deepNodeWF + exact shape.to_trExprS deepTypeOrdered trivial ⟨_, hty⟩ + +set_option maxRecDepth 20000 in +theorem deepRecInfoTr : + TrConstVal .safe deepCtorEnv deepRecInfo deepRecVL := by + deep_const_hyps deepCtorEnv + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr deepCtorEnv deepRecInfo.levelParams [] + deepRecInfo.type deepRecVL.toVConstant.type := by + tr_type_expr_tac + obtain ⟨u, hty⟩ := deepRecWF + exact shape.to_trExprS deepCtorOrdered trivial ⟨_, hty⟩ + +set_option maxRecDepth 20000 in +theorem deepRec1InfoTr : + TrConstVal .safe deepRecEnv deepRec1Info deepRec1VL := by + deep_const_hyps deepRecEnv + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr deepRecEnv deepRec1Info.levelParams [] + deepRec1Info.type deepRec1VL.toVConstant.type := by + tr_type_expr_tac + obtain ⟨u, hty⟩ := deepRec1WF + exact shape.to_trExprS deepRecOrdered trivial ⟨_, hty⟩ + +set_option maxRecDepth 20000 in +theorem deepRec2InfoTr : + TrConstVal .safe deepRec1Env deepRec2Info deepRec2VL := by + deep_const_hyps deepRec1Env + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr deepRec1Env deepRec2Info.levelParams [] + deepRec2Info.type deepRec2VL.toVConstant.type := by + tr_type_expr_tac + obtain ⟨u, hty⟩ := deepRec2WF + exact shape.to_trExprS deepRec1Ordered trivial ⟨_, hty⟩ + +/-! ## Recursor flags, final lookups, and the replay trace -/ + +theorem deepMapWF : deepMap.WF := + deepRec1MapWF.insert _ _ deepRec2Fresh + +theorem deepKTarget : deepNestedC.generation.kTarget = false := by + native_decide + +theorem deepRecLookup : + deepMap.find? ``DeepBi.rec = some deepRecInfo := by + rw [deepMap, deepRec1MapWF.find?_insert, deepRec1Map, + deepRecMapWF.find?_insert, deepRecMap, + deepCtorMapWF.find?_insert] + simp + +theorem deepRec1Lookup : + deepMap.find? + `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_1 = + some deepRec1Info := by + rw [deepMap, deepRec1MapWF.find?_insert] + simp [deepRec1Map, deepRecMapWF.find?_insert] + +theorem deepRec2Lookup : + deepMap.find? + `Lean4Lean.DeepNestedReplayFixtures.DeepBi.rec_2 = + some deepRec2Info := by + rw [deepMap, deepRec1MapWF.find?_insert] + simp + +theorem deepRecK : + RecursorMapKMatches deepMap deepNestedC.recursors + deepNestedC.generation.kTarget := by + rw [deepRecursors_eq, deepKTarget] + intro recursor hmem + rcases List.mem_cons.1 hmem with rfl | hmem + · exact ⟨deepRecInfo, deepRecLookup, by decide⟩ + rcases List.mem_cons.1 hmem with rfl | hmem + · exact ⟨deepRec1Info, deepRec1Lookup, by decide⟩ + rcases List.mem_cons.1 hmem with rfl | hmem + · exact ⟨deepRec2Info, deepRec2Lookup, by decide⟩ + · cases hmem + +def deepTrace : + AddInductNestedTrace biBoxMap biBoxFinalEnv deepSourceV + deepMap deepFinalEnv where + nested := deepNestedC + nested_wf := deepNestedWF + typeMap := deepTypeMap + typeEnv := deepTypeEnv + ctorMap := deepCtorMap + ctorEnv := deepCtorEnv + recEnv := deepRec2Env + addTypes := .cons + { info := deepInfo + kind_eq := by simp [deepInfo, InductConstantKind.Matches] + tr := deepInfoTr + map_fresh := deepTypeFresh + env_add := deepTypeEnv_eq + map_add := rfl } .nil + addCtors := .cons + { info := deepNodeInfo + kind_eq := by simp [deepNodeInfo, InductConstantKind.Matches] + tr := deepNodeInfoTr + map_fresh := deepNodeFresh + env_add := deepCtorEnv_eq + map_add := rfl } .nil + addRecs := deepRecursors_eq ▸ .cons + { info := deepRecInfo + kind_eq := by simp [deepRecInfo, InductConstantKind.Matches] + tr := deepRecInfoTr + map_fresh := deepRecFresh + env_add := deepRecEnv_eq + map_add := rfl } (.cons + { info := deepRec1Info + kind_eq := by simp [deepRec1Info, InductConstantKind.Matches] + tr := deepRec1InfoTr + map_fresh := deepRec1Fresh + env_add := deepRec1Env_eq + map_add := rfl } (.cons + { info := deepRec2Info + kind_eq := by simp [deepRec2Info, InductConstantKind.Matches] + tr := deepRec2InfoTr + map_fresh := deepRec2Fresh + env_add := deepRec2Env_eq + map_add := rfl } .nil)) + recK := deepRecK + addRules := ⟨by rw [deepRules_eq]; rfl⟩ + +theorem deepAddInductNested : + AddInductNested biBoxMap biBoxFinalEnv deepSourceV + deepMap deepFinalEnv := + ⟨deepTrace⟩ + +theorem deepTrEnv : TrEnv' .safe deepMap false deepFinalEnv := + .inductNested deepAddInductNested biBoxTrEnv + +theorem deepFinalOrdered : deepFinalEnv.Ordered := + deepTrEnv.wf.ordered + +theorem deepFinalWF : deepFinalEnv.WF := + deepTrEnv.wf + +theorem deepAddInductNested_success : + biBoxFinalEnv.addInductNested deepNestedC = some deepFinalEnv := + deepTrace.to_addInductNested + +/- The replay is now free of `sorryAx`; its remaining native-decision and +persistent-map closure is recorded exactly below. The Theory certificate +exported from this trace has the stricter guards in `InductiveCertificate`. -/ +/-- +info: 'Lean4Lean.DeepNestedReplayFixtures.deepTrEnv' depends on axioms: [propext, + Classical.choice, + Quot.sound, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert, + biBoxObservedShape._native.native_decide.ax_1_1, + deepKTarget._native.native_decide.ax_1_1, + deepNestedC_some._native.native_decide.ax_1_1, + deepRecursors_eq._native.native_decide.ax_1_1, + deepRules_eq._native.native_decide.ax_1_1] +-/ +#guard_msgs in +#print axioms deepTrEnv + +end Lean4Lean.DeepNestedReplayFixtures diff --git a/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean b/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean index 30465a28..f963b5e5 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean @@ -1604,7 +1604,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.candidateIsDefEqSelfValid' depends on a /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecFamily_candidateTrace' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -1628,7 +1627,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecFamily_candidateTrace' depend /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVec_checkInductiveTypes' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -1653,7 +1651,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVec_checkInductiveTypes' depends /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecCandidateInductiveStats_nindices' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -1677,7 +1674,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecCandidateInductiveStats_nindi /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecCandidateInductiveStats_params' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, diff --git a/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean index 4cd4666b..00c3600d 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean @@ -1739,7 +1739,6 @@ theorem indexedVecNormalizationCandidateProduced : /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecNormalizationCandidateProduced' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, diff --git a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean index b7eeac2a..48c90694 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean @@ -103,6 +103,60 @@ theorem indexedVecSemanticNatSafePrimitives : exact ⟨rfl, rfl⟩ · simp [SMap.find?] at hfind +theorem indexedVecKernelEnv_noProjectionReady (name : Name) : + indexedVecKernelEnv.isProjectionReadyStructure name = false := by + simp only [indexedVecKernelEnv, + Kernel.Environment.isProjectionReadyStructure, + Kernel.Environment.ofConstants] + simp only [natMap_wf.find?'_eq_find?] + simp only [natMap, natCtorMap_wf.find?_insert] + simp only [natCtorMap, natZeroMap_wf.find?_insert] + simp only [natZeroMap, natTypeMap_wf.find?_insert] + simp only [natTypeMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + by_cases hRec : ``Nat.rec = name + · subst name + simp [SMap.find?, natRecInfo] + · by_cases hSucc : ``Nat.succ = name + · subst name + simp [hRec, SMap.find?, natSuccInfo] + · by_cases hZero : ``Nat.zero = name + · subst name + simp [hRec, hSucc, SMap.find?, natZeroInfo] + · by_cases hNat : ``Nat = name + · subst name + simp [hRec, hSucc, hZero, SMap.find?, natInfo] + · simp [hRec, hSucc, hZero, hNat, SMap.find?] + +theorem indexedVecTypeEnv_noProjectionReady (name : Name) : + ctorContext.env.isProjectionReadyStructure name = false := by + simp only [ctorContext, ctorEnv, + Kernel.Environment.isProjectionReadyStructure, + Kernel.Environment.ofConstants] + simp only [indexedVecTypeMap_wf.find?'_eq_find?] + simp only [indexedVecTypeMap, natMap_wf.find?_insert] + simp only [natMap, natCtorMap_wf.find?_insert] + simp only [natCtorMap, natZeroMap_wf.find?_insert] + simp only [natZeroMap, natTypeMap_wf.find?_insert] + simp only [natTypeMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + by_cases hVec : ``IndexedVec = name + · subst name + simp [SMap.find?, indexedVecInfo] + · by_cases hRec : ``Nat.rec = name + · subst name + simp [hVec, SMap.find?, natRecInfo] + · by_cases hSucc : ``Nat.succ = name + · subst name + simp [hVec, hRec, SMap.find?, natSuccInfo] + · by_cases hZero : ``Nat.zero = name + · subst name + simp [hVec, hRec, hSucc, SMap.find?, natZeroInfo] + · by_cases hNat : ``Nat = name + · subst name + simp [hVec, hRec, hSucc, hZero, SMap.find?, natInfo] + · simp [hVec, hRec, hSucc, hZero, hNat, SMap.find?] + def indexedVecSemanticNatVEnvs : VEnvs where venv _ := natFinalEnv @@ -114,6 +168,10 @@ theorem indexedVecSemanticNatVEnvsWF : indexedVecSemanticNatVEnvs.WF indexedVecK hasPrimitives := indexedVecSemanticNatHasPrimitives safePrimitives := indexedVecSemanticNatSafePrimitives mono := fun _ => .rfl + projectionReady := by + intro _ name _ _ h + rw [indexedVecKernelEnv_noProjectionReady] at h + contradiction def indexedVecSemanticAddType : AddInductConstant .induct natMap natFinalEnv @@ -172,6 +230,10 @@ def indexedVecFamilyStage : validation := indexedVecFamilyValidationRun typeEnv := indexedVecTypeEnv addInduct := indexedVecSemanticAddType + projectionReady := by + intro name _ _ h + rw [indexedVecTypeEnv_noProjectionReady] at h + contradiction family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := rfl @@ -213,7 +275,7 @@ theorem indexedVecSemanticConsSourceTr : exact hshape.to_trExprS indexedVecTypeEnv_ordered trivial ⟨.sort u, htype⟩ -noncomputable def indexedVecStagedUniverseInput : +def indexedVecStagedUniverseInput : VInductDecl.StagedNormalizationCandidateUniverseInput indexedVecFamilyCandidateContext ctorContext natFinalEnv [`u] indexedVecNormalizationCandidate indexedVecDecl where @@ -786,7 +848,7 @@ private theorem indexedVecCandidateWhnfResult_eq rw [self] at other exact (Except.ok.inj other).symm -private noncomputable def indexedVecValidationNatPositivityAlignment +private def indexedVecValidationNatPositivityAlignment (trace : AddInductive.ConstructorPositivityModeTrace indexedVecStagedUniverseInput.staged.family.validation.stats false indexedVecKernelCons.name 1 indexedVecCtorValidationContext @@ -816,7 +878,7 @@ private noncomputable def indexedVecValidationNatPositivityAlignment indexedVecValidationNatHasNoIndOcc] at occurs contradiction -private noncomputable def indexedVecValidationAlphaPositivityAlignment +private def indexedVecValidationAlphaPositivityAlignment (trace : AddInductive.ConstructorPositivityModeTrace indexedVecStagedUniverseInput.staged.family.validation.stats false indexedVecKernelCons.name 2 indexedVecValidationNContext @@ -849,7 +911,7 @@ private noncomputable def indexedVecValidationAlphaPositivityAlignment rw [indexedVecValidationAlphaHasNoIndOcc] at occurs contradiction -private noncomputable def indexedVecValidationTailPositivityAlignment +private def indexedVecValidationTailPositivityAlignment (trace : AddInductive.ConstructorPositivityModeTrace indexedVecStagedUniverseInput.staged.family.validation.stats false indexedVecKernelCons.name 3 indexedVecValidationHeadContext @@ -926,7 +988,7 @@ theorem indexedVecValidationCandidateFieldFVars_ne : /-- Exact D2 owner for `IndexedVec`. Its validator telescope is transported only across proved context/source equalities, while every candidate view is instantiated with the validator-owned locals at the same de Bruijn position. -/ -noncomputable def indexedVecStagedPostFamilyInput : +def indexedVecStagedPostFamilyInput : VInductDecl.StagedNormalizationCandidatePostFamilyInput indexedVecFamilyCandidateContext ctorContext natFinalEnv [`u] indexedVecNormalizationCandidate indexedVecDecl where @@ -2595,7 +2657,7 @@ private theorem indexedVecPreFamilySafetyRun : rw [constructorListRun] rfl -private noncomputable def indexedVecStagedPreFamilyInput : +private def indexedVecStagedPreFamilyInput : VInductDecl.StagedNormalizationCandidatePreFamilyInput indexedVecFamilyCandidateContext ctorContext natFinalEnv [`u] indexedVecNormalizationCandidate indexedVecDecl := @@ -2862,31 +2924,32 @@ theorem indexedVecSemanticExactProducedGenerationCandidatePackage_exists : |>.exactProducedPackage_nonempty indexedVecStagedPreFamilyInput rfl indexedVecChecked.identityGeneration indexedVecSemanticCandidate_analysis -private noncomputable def +private def indexedVecSemanticExactProducedGenerationCandidatePackage : VInductDecl.ExactProducedGenerationCandidatePackage natFinalEnv [`u] indexedVecSemanticProducedGenerationShapeCandidate indexedVecChecked.identityGeneration := - Classical.choice - indexedVecSemanticExactProducedGenerationCandidatePackage_exists + indexedVecSemanticProducedGenerationShapeCandidate.exactProducedPackage + indexedVecStagedPreFamilyInput rfl indexedVecChecked.identityGeneration + indexedVecSemanticCandidate_analysis -noncomputable def indexedVecSemanticGenerationCandidateSemanticRun : +def indexedVecSemanticGenerationCandidateSemanticRun : VInductDecl.GenerationCandidateSemanticRun indexedVecSemanticExactProducedGenerationCandidatePackage.normalization indexedVecChecked.identityGeneration := indexedVecSemanticExactProducedGenerationCandidatePackage.semantic -noncomputable def indexedVecSemanticGenerationCandidateRun : +def indexedVecSemanticGenerationCandidateRun : VInductDecl.GenerationCandidateRun indexedVecSemanticExactProducedGenerationCandidatePackage.normalization.root indexedVecChecked.identityGeneration := indexedVecSemanticGenerationCandidateSemanticRun.run -noncomputable def indexedVecSemanticGenerationCandidatePackage : +def indexedVecSemanticGenerationCandidatePackage : VInductDecl.GenerationCandidatePackage natFinalEnv [`u] := indexedVecSemanticGenerationCandidateSemanticRun.package -noncomputable def indexedVecSemanticProducedGenerationCandidatePackage : +def indexedVecSemanticProducedGenerationCandidatePackage : VInductDecl.ProducedGenerationCandidatePackage natFinalEnv [`u] := indexedVecSemanticExactProducedGenerationCandidatePackage.package @@ -2911,7 +2974,7 @@ theorem indexedVecSemanticCertified_ordered : VEnv.addInductCertified_WF nat_env_wf.ordered indexedVecSemantic_addInductCertified -noncomputable def indexedVecSemanticAddInductTraceChecked : +def indexedVecSemanticAddInductTraceChecked : AddInductTrace natMap natFinalEnv indexedVecDecl indexedVecMap indexedVecFinalEnv := by refine indexedVecSemanticProducedGenerationCandidatePackage.package.addInductTrace @@ -3120,7 +3183,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecReorderedView_rejected' depen /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticCandidate_missingRawShape_rejected' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -3152,7 +3214,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticCandidate_extraRawSha /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecSemanticGenerationShapeCandidate_produced' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, diff --git a/Lean4Lean/Verify/Environment/InductiveFixtures.lean b/Lean4Lean/Verify/Environment/InductiveFixtures.lean index 330016e2..2fc2d0e9 100644 --- a/Lean4Lean/Verify/Environment/InductiveFixtures.lean +++ b/Lean4Lean/Verify/Environment/InductiveFixtures.lean @@ -352,9 +352,8 @@ theorem nat_final_matches_addInduct : VEnv.empty.addInduct natDecl = some natFinalEnv := rfl -/-- Theory-only ordering evidence for the Nat dependency environment. This -keeps later inductive preservation proofs independent of the Verify relation's -known projection-sorry frontier. -/ +/-- Theory-only ordering evidence for the Nat dependency environment. This +keeps later inductive preservation proofs entirely within the Theory layer. -/ theorem natFinalEnv_ordered : natFinalEnv.Ordered := VEnv.addInductGeneration_WF .empty ((natChecked.wf_of_decl natDecl_wf).identityGeneration .empty) rfl @@ -412,12 +411,10 @@ theorem nat_rec_lookup_unique : (VInductDecl.recConst 0 ``Nat 0 natType) := nat_aligned.find?_uniq nat_rec_map_lookup nat_rec_env_lookup -/- This closure is transitional for exactly the reasons recorded in the -roadmap: `sorryAx` comes from `TrProj`, and the persistent-map contracts come +/- This closure is now free of `sorryAx`; the persistent-map contracts come from proving concrete `SMap` freshness. The fixture introduces no new axiom. -/ /-- info: 'Lean4Lean.InductiveReplayFixtures.nat_trEnv'' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -637,7 +634,6 @@ theorem seed_after_nat_of_value : /-- info: 'Lean4Lean.InductiveReplayFixtures.seed_after_nat_of_value' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -918,7 +914,6 @@ theorem eq_rec_lookup_unique : /-- info: 'Lean4Lean.InductiveReplayFixtures.eq_trEnv'' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -1431,7 +1426,6 @@ theorem indexedVec_rec_lookup_unique : /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVec_trEnv'' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -1721,12 +1715,10 @@ theorem acc_rec_lookup_unique : (VInductDecl.recConstRec 1 ``Acc 2 accType) := acc_aligned.find?_uniq acc_rec_map_lookup acc_rec_env_lookup -/- This has the same transitional Verify closure as the direct replay roots: -`sorryAx` enters through `TrProj`, and the persistent-map contracts enter -through concrete `SMap` freshness proofs. -/ +/- This has the same `sorryAx`-free closure as the direct replay roots; the +persistent-map contracts enter through concrete `SMap` freshness proofs. -/ /-- info: 'Lean4Lean.InductiveReplayFixtures.acc_trEnv'' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -2530,6 +2522,11 @@ private theorem outParam_trEnv' : private theorem outParamMap_wf : outParamMap.WF := outParam_trEnv'.map_wf +/-- Public map-well-formedness boundary for replay artifacts whose concrete +dependency map is intentionally kept private to this fixture module. -/ +theorem annotatedReplayInputMap_wf : outParamMap.WF := + outParamMap_wf + private def outParamKernelEnv : Kernel.Environment := Kernel.Environment.ofConstants `_annotatedPiCandidate outParamMap @@ -2572,6 +2569,14 @@ private theorem outParamVEnvs_wf : outParamVEnvs.WF outParamKernelEnv where hasPrimitives := outParam_hasPrimitives safePrimitives := outParam_safePrimitives mono := fun _ => .rfl + projectionReady := by + intro _ name _ _ h + simp only [Kernel.Environment.isProjectionReadyStructure, + outParamKernelEnv, Kernel.Environment.ofConstants] at h + simp only [outParamMap_wf.find?'_eq_find?] at h + simp only [outParamMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] at h + simp [SMap.find?, annotationOutParamInfo] at h /-! ## Definitionally equal constructor parameters -/ @@ -3431,6 +3436,15 @@ private theorem aliasFormerNormalizationVEnvs_wf : hasPrimitives := aliasFormerNormalization_hasPrimitives safePrimitives := aliasFormerNormalization_safePrimitives mono := fun _ => .rfl + projectionReady := by + intro _ name _ _ h + simp only [Kernel.Environment.isProjectionReadyStructure, + aliasFormerNormalizationKernelEnv, + Kernel.Environment.ofConstants] at h + simp only [typeFamilyAliasMap_wf.find?'_eq_find?] at h + simp only [typeFamilyAliasMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] at h + simp [SMap.find?, typeFamilyAliasInfo] at h private def aliasFormerNormalizationContext : TypeChecker.VContext := TypeChecker.VContext.mk' aliasFormerNormalizationVEnvs_wf @@ -3545,6 +3559,19 @@ private theorem aliasRecNormalizationVEnvs_wf : hasPrimitives := aliasRecNormalization_hasPrimitives safePrimitives := aliasRecNormalization_safePrimitives mono := fun _ => .rfl + projectionReady := by + intro _ name _ _ h + simp only [Kernel.Environment.isProjectionReadyStructure, + aliasRecNormalizationKernelEnv, + Kernel.Environment.ofConstants] at h + simp only [aliasRecTypeMap_wf.find?'_eq_find?] at h + simp only [aliasRecTypeMap, recAliasMap_wf.find?_insert] at h + simp only [recAliasMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] at h + by_cases hAliasRec : ``AliasRec = name <;> + by_cases hRecAlias : ``RecAlias = name <;> + simp +decide [hAliasRec, hRecAlias, SMap.find?, aliasRecInfo, + recAliasInfo] at h private def aliasRecNormalizationContext : TypeChecker.VContext := TypeChecker.VContext.mk' aliasRecNormalizationVEnvs_wf @@ -7443,6 +7470,25 @@ private def aliasFormerFamilyStage : validation := aliasFormerFamilyValidationRun typeEnv := aliasFormerTypeEnv addInduct := aliasFormerCtorNormalizationAddType + projectionReady := by + intro name _ _ h + simp only [aliasFormerCtorCandidateContext, + aliasFormerCtorNormalizationKernelEnv, + Kernel.Environment.isProjectionReadyStructure, + Kernel.Environment.ofConstants] at h + simp only [aliasFormerTypeMap_wf.find?'_eq_find?] at h + simp only [aliasFormerTypeMap, typeFamilyAliasMap_wf.find?_insert] at h + simp only [typeFamilyAliasMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] at h + by_cases hAliasFormer : ``AliasFormer = name + · subst name + simp [SMap.find?, aliasFormerInfo, typeFamilyAliasInfo] at h + · by_cases hTypeFamilyAlias : ``TypeFamilyAlias = name + · subst name + simp [hAliasFormer, SMap.find?, aliasFormerInfo, + typeFamilyAliasInfo] at h + · simp [hAliasFormer, hTypeFamilyAlias, SMap.find?, aliasFormerInfo, + typeFamilyAliasInfo] at h family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := rfl @@ -7703,7 +7749,7 @@ private def aliasFormerCandidateFamilyRun : aliasFormerFamilyListCandidate aliasFormerRawType := aliasFormerCandidateFamilySemanticRun.root -private noncomputable def aliasFormerStagedUniverseInput : +private def aliasFormerStagedUniverseInput : VInductDecl.StagedNormalizationCandidateUniverseInput aliasFormerCandidateContext aliasFormerCtorCandidateContext typeFamilyAliasEnv [] aliasFormerNormalizationCandidate @@ -7811,7 +7857,7 @@ private theorem aliasFormerAlignmentRun : ConstantInfo.toConstantVal] rfl -private noncomputable def aliasFormerStagedPostFamilyInput : +private def aliasFormerStagedPostFamilyInput : VInductDecl.StagedNormalizationCandidatePostFamilyInput aliasFormerCandidateContext aliasFormerCtorCandidateContext typeFamilyAliasEnv [] aliasFormerNormalizationCandidate @@ -7930,7 +7976,7 @@ private theorem aliasFormerPreFamilySafetyRun : simp [parametersRun, listRun, Bind.bind, Except.bind, Except.pure, Pure.pure] -private noncomputable def aliasFormerStagedPreFamilyInput : +private def aliasFormerStagedPreFamilyInput : VInductDecl.StagedNormalizationCandidatePreFamilyInput aliasFormerCandidateContext aliasFormerCtorCandidateContext typeFamilyAliasEnv [] aliasFormerNormalizationCandidate @@ -8114,21 +8160,23 @@ theorem aliasFormerExactProducedGenerationCandidatePackage_exists : aliasFormerStagedPreFamilyInput rfl aliasFormerGenerationChecked aliasFormerCandidate_analysis -private noncomputable def +private def aliasFormerExactProducedGenerationCandidatePackage : VInductDecl.ExactProducedGenerationCandidatePackage typeFamilyAliasEnv [] aliasFormerProducedGenerationShapeCandidate aliasFormerGenerationChecked := - Classical.choice aliasFormerExactProducedGenerationCandidatePackage_exists + aliasFormerProducedGenerationShapeCandidate.exactProducedPackage + aliasFormerStagedPreFamilyInput rfl aliasFormerGenerationChecked + aliasFormerCandidate_analysis /-- Complete source-indexed candidate certificate for the non-identity AliasFormer generation transaction. -/ -noncomputable def aliasFormerGenerationCandidateSemanticRun : +def aliasFormerGenerationCandidateSemanticRun : VInductDecl.GenerationCandidateSemanticRun aliasFormerExactProducedGenerationCandidatePackage.normalization aliasFormerGenerationChecked := aliasFormerExactProducedGenerationCandidatePackage.semantic -noncomputable def aliasFormerGenerationCandidateRun : +def aliasFormerGenerationCandidateRun : VInductDecl.GenerationCandidateRun aliasFormerExactProducedGenerationCandidatePackage.normalization.root aliasFormerGenerationChecked := @@ -8137,14 +8185,14 @@ noncomputable def aliasFormerGenerationCandidateRun : /-- The generic dependent package retains the exact AliasFormer kernel source, candidate trace, reconstructed normalization, successful dependent analysis, and semantic generation run in one value. -/ -noncomputable def aliasFormerGenerationCandidatePackage : +def aliasFormerGenerationCandidatePackage : VInductDecl.GenerationCandidatePackage typeFamilyAliasEnv [] := aliasFormerGenerationCandidateSemanticRun.package /-- The complete AliasFormer semantic package is selected by the exact successful whole-call metadata producer, including its pre-family and post-family checker environments. -/ -noncomputable def aliasFormerProducedGenerationCandidatePackage : +def aliasFormerProducedGenerationCandidatePackage : VInductDecl.ProducedGenerationCandidatePackage typeFamilyAliasEnv [] := aliasFormerExactProducedGenerationCandidatePackage.package @@ -8175,7 +8223,7 @@ theorem aliasFormerCertified_ordered : aliasFormerFinalEnv.Ordered := /-- Complete checker-side AliasFormer generation run, now derived by the generic family/constructor spine assembler from the executable singleton candidate rather than assembled field-by-field by the fixture. -/ -noncomputable def aliasFormerGenerationRun : +def aliasFormerGenerationRun : VInductDecl.GenerationRun aliasFormerGenerationChecked typeFamilyAliasEnv := aliasFormerProducedGenerationCandidatePackage.package.run.generationRun @@ -8380,6 +8428,19 @@ private def annotatedPiFamilyStage : validation := annotatedPiFamilyValidationRun typeEnv := annotatedPiTypeEnv addInduct := annotatedPiAddType + projectionReady := by + intro name _ _ h + simp only [annotatedPiCtorCandidateContext, annotatedPiTypeKernelEnv, + Kernel.Environment.isProjectionReadyStructure, + Kernel.Environment.ofConstants] at h + simp only [annotatedPiTypeMap_wf.find?'_eq_find?] at h + simp only [annotatedPiTypeMap, outParamMap_wf.find?_insert] at h + simp only [outParamMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] at h + by_cases hAnnotatedPi : ``AnnotatedPi = name <;> + by_cases hOutParam : ``outParam = name <;> + simp +decide [hAnnotatedPi, hOutParam, SMap.find?, annotatedPiInfo, + annotationOutParamInfo] at h family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := rfl @@ -8769,7 +8830,7 @@ private def annotatedPiCandidateFamilyRun : annotatedPiFamilyListCandidate annotatedPiRawType := annotatedPiCandidateFamilySemanticRun.root -private noncomputable def annotatedPiStagedUniverseInput : +private def annotatedPiStagedUniverseInput : VInductDecl.StagedNormalizationCandidateUniverseInput annotatedPiFamilyCandidateContext annotatedPiCtorCandidateContext outParamEnv [] annotatedPiNormalizationCandidate @@ -9333,7 +9394,7 @@ private theorem constructorTypeValidationTrace_eq_terminal | terminal => rfl set_option maxHeartbeats 10000000 in -private noncomputable def annotatedPiStagedPostFamilyInput : +private def annotatedPiStagedPostFamilyInput : VInductDecl.StagedNormalizationCandidatePostFamilyInput annotatedPiFamilyCandidateContext annotatedPiCtorCandidateContext outParamEnv [] annotatedPiNormalizationCandidate @@ -10094,7 +10155,7 @@ private theorem annotatedPiPreFamilySafetyRun : rw [listRun] rfl -private noncomputable def annotatedPiStagedPreFamilyInput : +private def annotatedPiStagedPreFamilyInput : VInductDecl.StagedNormalizationCandidatePreFamilyInput annotatedPiFamilyCandidateContext annotatedPiCtorCandidateContext outParamEnv [] annotatedPiNormalizationCandidate annotatedPiRawDecl := @@ -10214,22 +10275,24 @@ theorem annotatedPiExactProducedGenerationCandidatePackage_exists : annotatedPiStagedPreFamilyInput rfl annotatedPiGenerationChecked annotatedPiCandidate_analysis -private noncomputable def +private def annotatedPiExactProducedGenerationCandidatePackage : VInductDecl.ExactProducedGenerationCandidatePackage outParamEnv [] annotatedPiProducedGenerationShapeCandidate annotatedPiGenerationChecked := - Classical.choice annotatedPiExactProducedGenerationCandidatePackage_exists + annotatedPiProducedGenerationShapeCandidate.exactProducedPackage + annotatedPiStagedPreFamilyInput rfl annotatedPiGenerationChecked + annotatedPiCandidate_analysis /-- Complete source-indexed checker certificate for annotated recursive-Π generation. This is the first live generation run whose main constructor spine contains an annotation-normalized recursive function domain. -/ -noncomputable def annotatedPiGenerationCandidateSemanticRun : +def annotatedPiGenerationCandidateSemanticRun : VInductDecl.GenerationCandidateSemanticRun annotatedPiExactProducedGenerationCandidatePackage.normalization annotatedPiGenerationChecked := annotatedPiExactProducedGenerationCandidatePackage.semantic -noncomputable def annotatedPiGenerationCandidateRun : +def annotatedPiGenerationCandidateRun : VInductDecl.GenerationCandidateRun annotatedPiExactProducedGenerationCandidatePackage.normalization.root annotatedPiGenerationChecked := @@ -10237,14 +10300,14 @@ noncomputable def annotatedPiGenerationCandidateRun : /-- Complete dependent producer package for the annotation-bearing recursive Π candidate. -/ -noncomputable def annotatedPiGenerationCandidatePackage : +def annotatedPiGenerationCandidatePackage : VInductDecl.GenerationCandidatePackage outParamEnv [] := annotatedPiGenerationCandidateSemanticRun.package /-- The complete AnnotatedPi semantic package is selected by the exact successful whole-call metadata producer, including its nested annotation- consuming traversal in the post-family environment. -/ -noncomputable def annotatedPiProducedGenerationCandidatePackage : +def annotatedPiProducedGenerationCandidatePackage : VInductDecl.ProducedGenerationCandidatePackage outParamEnv [] := annotatedPiExactProducedGenerationCandidatePackage.package @@ -10254,7 +10317,7 @@ def annotatedPiGenerationCertificate : generation := annotatedPiGenerationChecked wf := annotatedPiExactProducedGenerationCandidatePackage.semantic.run.wf -noncomputable def annotatedPiGenerationRun : +def annotatedPiGenerationRun : VInductDecl.GenerationRun annotatedPiGenerationChecked outParamEnv := annotatedPiProducedGenerationCandidatePackage.package.run.generationRun @@ -10372,7 +10435,7 @@ private theorem annotatedPiRec_fresh : /-- Complete kernel-metadata replay transaction for `AnnotatedPi`, driven by the checker-produced non-identity normalization certificate. -/ -noncomputable def annotatedPiAddInductTraceChecked : +def annotatedPiAddInductTraceChecked : AddInductTrace outParamMap outParamEnv annotatedPiRawDecl annotatedPiMap annotatedPiFinalEnv := by refine annotatedPiProducedGenerationCandidatePackage.package.addInductTrace @@ -10780,7 +10843,7 @@ theorem annotatedParam_rec_lookup_unique : /-- The complete AliasFormer metadata trace with the generation-WF field supplied by the checker-produced certificate. All computational metadata witnesses are shared with the existing replay. -/ -noncomputable def aliasFormerAddInductTraceChecked : +def aliasFormerAddInductTraceChecked : AddInductTrace typeFamilyAliasMap typeFamilyAliasEnv aliasFormerRawDecl aliasFormerMap aliasFormerFinalEnv := let replay := @@ -10830,12 +10893,10 @@ theorem aliasRec_aligned_checked : /- The operational traces do not reach the pointer-equality contracts. Their semantic endpoints intentionally inherit Verify's existing checker-refinement -and reflection contracts, including pointer equality, plus the separately -tracked `TrProj` frontier. No new axiom or native-evaluation principle is -used. -/ +and reflection contracts, including pointer equality. No new axiom or +native-evaluation principle is used. -/ /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidateTrace' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -10851,7 +10912,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidateTrace' depen /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_candidateTrace' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -10867,7 +10927,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_candidateTrace' depends /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidate' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -10916,7 +10975,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidateRun_exists' /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidateSource_tr' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -11037,7 +11095,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerTruncatedView_rejected' depe /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasRecField_checkType' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -11091,7 +11148,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRecField_hasType_checked' depends /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_whnf' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -11106,7 +11162,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_whnf' depends on axio /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_whnf' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -11121,7 +11176,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_whnf' depends on axioms /-- info: 'Lean4Lean.InductiveReplayFixtures.recAlias_whnf' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -11140,7 +11194,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.recAlias_whnf' depends on axioms: [prop /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_checkType' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -11156,7 +11209,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_checkType' depends on /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_checkType' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -11535,7 +11587,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationCandidatePackage' /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerNormalizationCandidate_produced' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -11553,7 +11604,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerNormalizationCandidate_produ /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationShapeCandidate_produced' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -11899,13 +11949,11 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRec_trEnv'_checked' depends on axi #guard_msgs in #print axioms aliasRec_trEnv'_checked -/- Both alias replays have the same explicitly transitional Verify closure as -the identity fixtures. `sorryAx` is inherited only through `TrProj`, and the -three persistent-map contracts enter through concrete `ConstMap` freshness -proofs. -/ +/- Both alias replays have the same `sorryAx`-free Verify closure as the +identity fixtures. The three persistent-map contracts enter through concrete +`ConstMap` freshness proofs. -/ /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_trEnv'' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -11917,7 +11965,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_trEnv'' depends on axioms: /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_env_wf' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -11929,7 +11976,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_env_wf' depends on axioms: /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_aligned' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -11941,7 +11987,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormer_aligned' depends on axioms: /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasRec_trEnv'' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -11953,7 +11998,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRec_trEnv'' depends on axioms: [pr /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasRec_env_wf' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -11965,7 +12009,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasRec_env_wf' depends on axioms: [pr /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasRec_aligned' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -12208,7 +12251,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationCandidatePackage' /-- info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiCtor_candidateTrace' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -12247,7 +12289,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiFamily_candidateTrace' depen /-- info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiNormalizationCandidate_produced' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -12274,7 +12315,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiNormalizationCandidate_produ /-- info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationShapeCandidate_produced' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -12516,7 +12556,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedParam_addInductCertified' depe /-- info: 'Lean4Lean.InductiveReplayFixtures.annotatedParamAddInductTraceChecked' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -12528,7 +12567,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedParamAddInductTraceChecked' de /-- info: 'Lean4Lean.InductiveReplayFixtures.annotatedParam_trEnv'_checked' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, diff --git a/Lean4Lean/Verify/Environment/InductiveReplayMatrix.lean b/Lean4Lean/Verify/Environment/InductiveReplayMatrix.lean new file mode 100644 index 00000000..0daafb22 --- /dev/null +++ b/Lean4Lean/Verify/Environment/InductiveReplayMatrix.lean @@ -0,0 +1,763 @@ +import Lean4Lean.Theory.Typing.InductiveCertificate +import Lean4Lean.Verify.Environment.MutualInductiveFixtures +import Lean4Lean.Verify.Environment.DeepNestedReplay + +/-! +# Complete inductive replay matrix + +This module puts the singleton, mutual, and nested replay rows behind one +uniform completion interface. A row is accepted only when it carries its +real implementation map, its explicit dependency environment, an exact +Theory transaction, and final alignment. The generic metadata facts below +then check the family role, every constructor role, and every recursor role +at the final map rather than at an intermediate insertion phase. + +The mutual and nested packages retain data-bearing traces. Consequently a +consumer-neutral `BlockCertificate` (or `NestedBlockCertificate`) is built +from the exact replay data, without selecting a second generation or asking +the consumer for a semantic oracle. +-/ + +namespace Lean4Lean + +open Lean +open VInductDecl + +/-- One final implementation-map entry, with its exact inductive role and +translation into the final Theory environment. -/ +def FinalTranslatedMetadata + (kind : InductConstantKind) (map : ConstMap) (env : VEnv) + (constant : VConstVal) : Prop := + ∃ info, map.find? constant.name = some info ∧ + kind.Matches info ∧ TrConstVal .safe env info constant + +/-- Final recursor metadata together with the public exact-lookup uniqueness +contract required by consumers. -/ +def FinalRecursorMetadata + (map : ConstMap) (env : VEnv) (recursor : VConstVal) : Prop := + FinalTranslatedMetadata .recursor map env recursor ∧ + ∀ {left right : ConstantInfo}, + map.find? recursor.name = some left → + map.find? recursor.name = some right → left = right + +namespace FinalTranslatedMetadata + +/-- A final metadata lookup cannot name two different implementation +records. This is the lookup-uniqueness fact used for every recursor row. -/ +theorem lookup_unique {map : ConstMap} {constant : VConstVal} + {left right : ConstantInfo} + (leftLookup : map.find? constant.name = some left) + (rightLookup : map.find? constant.name = some right) : + left = right := + Option.some.inj (leftLookup.symm.trans rightLookup) + +/-- Promote an exact translated recursor lookup to the complete public +recursor contract. -/ +theorem recursor_complete {map : ConstMap} {env : VEnv} + {recursor : VConstVal} + (metadata : FinalTranslatedMetadata .recursor map env recursor) : + FinalRecursorMetadata map env recursor := by + refine ⟨metadata, ?_⟩ + intro left right leftLookup rightLookup + exact lookup_unique leftLookup rightLookup + +end FinalTranslatedMetadata + +namespace InductiveReplayFixtures + +/-- Proof-only completion package recovered from a singleton replay. The +generation, semantic certificate, successful Theory transaction, and all +three metadata roles are selected by the same data-bearing replay witness. -/ +def SingletonReplayCompletion + (artifact : SingletonReplayArtifact) : Prop := + ∃ generation : artifact.source.GenerationChecked, + artifact.source.types = [generation.block.sourceType] ∧ + generation.WF artifact.inputEnv ∧ + artifact.inputEnv.addInductGeneration generation = + some artifact.outputEnv ∧ + FinalTranslatedMetadata .induct artifact.outputMap artifact.outputEnv + generation.block.sourceType.toVConstVal ∧ + (∀ {constructor : VConstVal}, + constructor ∈ generation.block.sourceType.ctors → + FinalTranslatedMetadata .ctor artifact.outputMap artifact.outputEnv + constructor) ∧ + FinalRecursorMetadata artifact.outputMap artifact.outputEnv + (inductGenerationRecVal generation) + +/-- Automatically recover the complete singleton package from the retained +transaction; no `Classical.choice` is used at this boundary. -/ +theorem SingletonReplayArtifact.completion + (artifact : SingletonReplayArtifact) : + SingletonReplayCompletion artifact := by + rcases artifact.transaction with ⟨trace⟩ + refine ⟨trace.generation, trace.generation.block.source_types_eq, + trace.generation_wf, trace.to_addInductGeneration, ?_, ?_, ?_⟩ + · obtain ⟨info, lookup, role, translated⟩ := + trace.type_translated_lookup artifact.inputMapWF + exact ⟨info, lookup, role, translated⟩ + · intro constructor hconstructor + obtain ⟨info, lookup, role, translated⟩ := + trace.constructor_translated_lookup artifact.inputMapWF hconstructor + exact ⟨info, lookup, role, translated⟩ + · obtain ⟨info, lookup, role, translated⟩ := + trace.recursor_translated_lookup artifact.inputMapWF + exact FinalTranslatedMetadata.recursor_complete + ⟨info, lookup, role, translated⟩ + +end InductiveReplayFixtures + +namespace CompleteInductiveReplay + +open InductiveReplayFixtures +open MutualInductiveReplayFixtures +open MutualInductiveFixtures +open InductiveFixtures +open NestedReplayFixtures +open NestedRepresentation +open DeepNestedReplayFixtures + +/-- The real kernel metadata and dependency map from which one singleton +candidate is reconstructed. The replay artifact is retained in the same +value, so candidate construction and environment replay cannot drift into +parallel inventories. -/ +structure SingletonCandidateInput where + replay : SingletonReplayArtifact + inductInfo : ConstantInfo + ctorInfos : List ConstantInfo + +namespace SingletonCandidateInput + +private def metadataStored (map : ConstMap) (info : ConstantInfo) : Bool := + match map.find? info.name with + | some stored => ptrEqConstantInfo stored info + | none => false + +private def constructor? : ConstantInfo → Option Constructor + | .ctorInfo constructor => + some { name := constructor.name, type := constructor.type } + | _ => none + +def kernelType? (input : SingletonCandidateInput) : Option InductiveType := do + let .inductInfo family := input.inductInfo | none + let constructors ← input.ctorInfos.mapM constructor? + return { name := family.name, type := family.type, ctors := constructors } + +def context (input : SingletonCandidateInput) : AddInductive.Context where + env := Kernel.Environment.ofConstants + (.str `_completeSingletonReplay input.replay.label.toString) + input.replay.inputMap + lparams := input.inductInfo.levelParams + safety := .safe + allowPrimitive := input.replay.source.types.any fun family => + family.name == ``Nat || family.name == ``Bool + +end SingletonCandidateInput + +/-- The data-bearing result of the ordinary singleton candidate constructor, +including exact source-order agreement. -/ +structure ProducedSingletonCandidate (input : SingletonCandidateInput) where + kernelType : InductiveType + execution : AddInductive.NormalizationCandidateExecution + input.replay.source.nparams [kernelType] 0 false input.context + kernelType_eq : input.kernelType? = some kernelType + produced : AddInductive.buildNormalizationCandidateExecution + input.replay.source.nparams [kernelType] 0 false input.context = + .ok execution + familyNames : [kernelType.name] = input.replay.source.types.map (·.name) + constructorNames : kernelType.ctors.map (·.name) = + input.replay.source.blockConstructorConstants.map (·.name) + familyMetadataStored : SingletonCandidateInput.metadataStored + input.replay.outputMap input.inductInfo = true + constructorMetadataStored : input.ctorInfos.all fun info => + SingletonCandidateInput.metadataStored input.replay.outputMap info + +namespace SingletonCandidateInput + +/-- Execute and package one candidate automatically. Failed metadata shape, +ordinary candidate rejection, or source-order mismatch all return `none`. -/ +def producedCandidate? (input : SingletonCandidateInput) : + Option (ProducedSingletonCandidate input) := + match htype : input.kernelType? with + | none => none + | some kernelType => + match hproduced : AddInductive.buildNormalizationCandidateExecution + input.replay.source.nparams [kernelType] 0 false input.context with + | .error _ => none + | .ok execution => + if hfamilies : [kernelType.name] = + input.replay.source.types.map (·.name) then + if hconstructors : kernelType.ctors.map (·.name) = + input.replay.source.blockConstructorConstants.map (·.name) then + if hfamilyStored : SingletonCandidateInput.metadataStored + input.replay.outputMap input.inductInfo then + if hconstructorsStored : input.ctorInfos.all fun info => + SingletonCandidateInput.metadataStored + input.replay.outputMap info then + some { + kernelType := kernelType + execution := execution + kernelType_eq := htype + produced := hproduced + familyNames := hfamilies + constructorNames := hconstructors + familyMetadataStored := hfamilyStored + constructorMetadataStored := hconstructorsStored } + else none + else none + else none + else none + +end SingletonCandidateInput + +/-- One inseparable singleton candidate/replay package. -/ +structure SingletonCandidateReplayArtifact where + input : SingletonCandidateInput + candidate : ProducedSingletonCandidate input + +namespace SingletonCandidateInput + +def complete? (input : SingletonCandidateInput) : + Option SingletonCandidateReplayArtifact := do + let candidate ← input.producedCandidate? + return { input, candidate } + +end SingletonCandidateInput + +/-! The complete singleton metadata matrix, now with data-bearing ordinary +candidate executions rather than Boolean acceptance witnesses. -/ + +def singletonCandidateInputs : List SingletonCandidateInput := + [ { replay := natReplay07 + inductInfo := natInfo + ctorInfos := [natZeroInfo, natSuccInfo] }, + { replay := boolReplay07 + inductInfo := boolInfo07 + ctorInfos := [boolFalseInfo07, boolTrueInfo07] }, + { replay := listReplay07 + inductInfo := listInfo07 + ctorInfos := [listNilInfo07, listConsInfo07] }, + { replay := optionReplay07 + inductInfo := optionInfo07 + ctorInfos := [optionNoneInfo07, optionSomeInfo07] }, + { replay := prodReplay07 + inductInfo := prodInfo07 + ctorInfos := [prodMkInfo07] }, + { replay := punitReplay07 + inductInfo := punitInfo06C + ctorInfos := [punitCtorInfo06C] }, + { replay := emptyReplay07 + inductInfo := emptyInfo06C + ctorInfos := [] }, + { replay := orReplay07 + inductInfo := orInfo06 + ctorInfos := [orInlInfo06, orInrInfo06] }, + { replay := andReplay07 + inductInfo := andInfo06 + ctorInfos := [andIntroInfo06] }, + { replay := eqReplay07 + inductInfo := eqInfo + ctorInfos := [eqReflInfo] }, + { replay := heqReplay07 + inductInfo := heqInfo07 + ctorInfos := [heqReflInfo07] }, + { replay := finReplay07 + inductInfo := finInfo07 + ctorInfos := [finMkInfo07] }, + { replay := vectorReplay07 + inductInfo := vectorInfo07 + ctorInfos := [vectorMkInfo07] }, + { replay := accReplay07 + inductInfo := accInfo + ctorInfos := [accIntroInfo] }, + { replay := aliasFormerReplay07 + inductInfo := aliasFormerInfo + ctorInfos := [aliasFormerMkInfo] }, + { replay := aliasRecReplay07 + inductInfo := aliasRecInfo + ctorInfos := [aliasRecMkInfo] }, + { replay := normalizationMatrixReplay07 + inductInfo := normalizationMatrixInfo + ctorInfos := [normalizationMatrixMkInfo] }, + { replay := annotatedPiReplay07 + inductInfo := annotatedPiInfo + ctorInfos := [annotatedPiMkInfo] }, + { replay := annotatedParamReplay07 + inductInfo := annotatedParamInfo + ctorInfos := [annotatedParamMkInfo] }, + { replay := biBoxReplay + inductInfo := biBoxInfo + ctorInfos := [biBoxMkInfo] } ] + +def singletonCandidateReplayMatrix? : + Option (List SingletonCandidateReplayArtifact) := + singletonCandidateInputs.mapM (·.complete?) + +#guard singletonCandidateReplayMatrix?.isSome + +/-- All 20 singleton packages selected from the actual executable results, +including the two-parameter dependency used by the deep nested row. -/ +def singletonCandidateReplayMatrix : + List SingletonCandidateReplayArtifact := + singletonCandidateReplayMatrix?.get (by native_decide) + +example : singletonCandidateInputs.map (·.replay) = + singletonReplayMatrix ++ [biBoxReplay] := rfl +example : singletonCandidateInputs.length = 20 := rfl +example : singletonCandidateReplayMatrix.length = 20 := by native_decide + +/-- Provenance for the implementation's ordinary mutual-block candidate +constructor. This data deliberately stays on the Verify side: the exported +Theory certificate below retains only the translated declaration and its +semantic transaction. -/ +structure ProducedBlockCandidate (source : VInductDecl) where + nparams : Nat + kernelTypes : List InductiveType + numNested : Nat + isUnsafe : Bool + context : AddInductive.Context + execution : AddInductive.NormalizationCandidateExecution nparams + kernelTypes numNested isUnsafe context + produced : + AddInductive.buildNormalizationCandidateExecution nparams kernelTypes + numNested isUnsafe context = .ok execution + familyNames : kernelTypes.map (·.name) = source.types.map (·.name) + constructorNames : + kernelTypes.flatMap (fun family => family.ctors.map (·.name)) = + source.blockConstructorConstants.map (·.name) + +/-- One non-nested arbitrary-block replay package. Its trace owns the exact +generation and every implementation metadata insertion; `inputWF` supplies +the explicit dependency history needed to export a Theory certificate. -/ +structure BlockReplayArtifact where + label : Name + source : VInductDecl + inputMap : ConstMap + inputEnv : VEnv + outputMap : ConstMap + outputEnv : VEnv + inputMapWF : inputMap.WF + inputWF : inputEnv.WF + candidate : ProducedBlockCandidate source + trace : AddInductBlockTrace inputMap inputEnv source outputMap outputEnv + generationProduced : + source.identityBlockGeneration? = some trace.generation + aligned : Aligned .safe outputMap outputEnv + +namespace BlockReplayArtifact + +/-- Erase implementation metadata and retain the consumer-neutral completed +block certificate. -/ +def certificate (artifact : BlockReplayArtifact) : + artifact.source.BlockCertificate artifact.inputEnv artifact.outputEnv where + semantic := { + generation := artifact.trace.generation + blockEnv := artifact.trace.blockEnv + wf := artifact.trace.generation_wf } + success := by + simpa [VEnv.addInductBlockCertified] using + artifact.trace.to_addInductBlockGeneration + beforeWF := artifact.inputWF + +/-- The concrete replay succeeds through the ordinary raw entry point, not +only through its proof-carrying block helper. -/ +theorem addInduct (artifact : BlockReplayArtifact) : + artifact.inputEnv.addInduct artifact.source = some artifact.outputEnv := + artifact.certificate.addInduct artifact.generationProduced + +/-- The concrete block replay grows its explicit dependency environment. -/ +theorem addInduct_le (artifact : BlockReplayArtifact) : + artifact.inputEnv ≤ artifact.outputEnv := + artifact.certificate.addInduct_le + +/-- The concrete block replay preserves environment well-formedness. -/ +theorem addInduct_WF (artifact : BlockReplayArtifact) : + artifact.outputEnv.WF := + artifact.certificate.addInduct_WF + +theorem familyMetadata (artifact : BlockReplayArtifact) + {family : VInductiveType} (hfamily : family ∈ artifact.source.types) : + FinalTranslatedMetadata .induct artifact.outputMap artifact.outputEnv + family.toVConstVal := by + obtain ⟨info, lookup, role, translated⟩ := + artifact.trace.family_translated_lookup artifact.inputMapWF hfamily + exact ⟨info, lookup, role, translated⟩ + +theorem constructorMetadata (artifact : BlockReplayArtifact) + {constructor : VConstVal} + (hconstructor : + constructor ∈ artifact.source.blockConstructorConstants) : + FinalTranslatedMetadata .ctor artifact.outputMap artifact.outputEnv + constructor := by + obtain ⟨info, lookup, role, translated⟩ := + artifact.trace.constructor_translated_lookup artifact.inputMapWF + hconstructor + exact ⟨info, lookup, role, translated⟩ + +theorem recursorMetadata (artifact : BlockReplayArtifact) + {recursor : VConstVal} + (hrecursor : recursor ∈ artifact.trace.generation.recursors) : + FinalTranslatedMetadata .recursor artifact.outputMap artifact.outputEnv + recursor := by + obtain ⟨info, lookup, role, translated⟩ := + artifact.trace.recursor_translated_lookup artifact.inputMapWF hrecursor + exact ⟨info, lookup, role, translated⟩ + +theorem recursorMetadataComplete (artifact : BlockReplayArtifact) + {recursor : VConstVal} + (hrecursor : recursor ∈ artifact.trace.generation.recursors) : + FinalRecursorMetadata artifact.outputMap artifact.outputEnv recursor := + (artifact.recursorMetadata hrecursor).recursor_complete + +/-- All implementation metadata roles are complete for this exact block. -/ +def MetadataComplete (artifact : BlockReplayArtifact) : Prop := + (∀ family ∈ artifact.source.types, FinalTranslatedMetadata .induct + artifact.outputMap artifact.outputEnv family.toVConstVal) ∧ + (∀ constructor ∈ artifact.source.blockConstructorConstants, + FinalTranslatedMetadata .ctor artifact.outputMap artifact.outputEnv + constructor) ∧ + (∀ recursor ∈ artifact.trace.generation.recursors, + FinalRecursorMetadata artifact.outputMap artifact.outputEnv recursor) + +theorem metadataComplete (artifact : BlockReplayArtifact) : + artifact.MetadataComplete := by + refine ⟨?_, ?_, ?_⟩ + · intro family hfamily + exact artifact.familyMetadata hfamily + · intro constructor hconstructor + exact artifact.constructorMetadata hconstructor + · intro recursor hrecursor + exact artifact.recursorMetadataComplete hrecursor + +end BlockReplayArtifact + +/-- Provenance for the environment-free nested analyzer. As above, target +copies and analyzer output remain a Verify artifact and do not cross the +Theory certificate boundary. -/ +structure ProducedNestedCandidate (source : VInductDecl) where + targets : List NestedTargetBlock + nested : source.NestedBlockChecked + produced : nestedBlockChecked? targets source = some nested + +/-- One completed nested replay package. Only restored source metadata is +present in the trace and output map; auxiliary flattening constants therefore +cannot be smuggled through this public inventory. -/ +structure NestedReplayArtifact where + label : Name + source : VInductDecl + inputMap : ConstMap + inputEnv : VEnv + outputMap : ConstMap + outputEnv : VEnv + inputMapWF : inputMap.WF + inputWF : inputEnv.WF + candidate : ProducedNestedCandidate source + trace : AddInductNestedTrace inputMap inputEnv source outputMap outputEnv + candidateAgrees : candidate.nested = trace.nested + aligned : Aligned .safe outputMap outputEnv + +namespace NestedReplayArtifact + +/-- Erase implementation metadata and retain the consumer-neutral nested +completion certificate. -/ +def certificate (artifact : NestedReplayArtifact) : + artifact.source.NestedBlockCertificate artifact.inputEnv + artifact.outputEnv where + nested := artifact.trace.nested + semantic := artifact.trace.nested_wf + success := artifact.trace.to_addInductNested + beforeWF := artifact.inputWF + +/-- The concrete analyzer-produced nested transaction succeeds exactly. -/ +theorem addInductNested (artifact : NestedReplayArtifact) : + artifact.inputEnv.addInductNested artifact.trace.nested = + some artifact.outputEnv := + artifact.certificate.success + +/-- The concrete nested replay grows its explicit dependency environment. -/ +theorem addInduct_le (artifact : NestedReplayArtifact) : + artifact.inputEnv ≤ artifact.outputEnv := + artifact.certificate.addInduct_le + +/-- The concrete nested replay preserves environment well-formedness. -/ +theorem addInduct_WF (artifact : NestedReplayArtifact) : + artifact.outputEnv.WF := + artifact.certificate.addInduct_WF + +theorem familyMetadata (artifact : NestedReplayArtifact) + {family : VInductiveType} (hfamily : family ∈ artifact.source.types) : + FinalTranslatedMetadata .induct artifact.outputMap artifact.outputEnv + family.toVConstVal := by + obtain ⟨info, lookup, role, translated⟩ := + artifact.trace.family_translated_lookup artifact.inputMapWF hfamily + exact ⟨info, lookup, role, translated⟩ + +theorem constructorMetadata (artifact : NestedReplayArtifact) + {constructor : VConstVal} + (hconstructor : + constructor ∈ artifact.source.blockConstructorConstants) : + FinalTranslatedMetadata .ctor artifact.outputMap artifact.outputEnv + constructor := by + obtain ⟨info, lookup, role, translated⟩ := + artifact.trace.constructor_translated_lookup artifact.inputMapWF + hconstructor + exact ⟨info, lookup, role, translated⟩ + +theorem recursorMetadata (artifact : NestedReplayArtifact) + {recursor : VConstVal} + (hrecursor : recursor ∈ artifact.trace.nested.recursors) : + FinalTranslatedMetadata .recursor artifact.outputMap artifact.outputEnv + recursor := by + obtain ⟨info, lookup, role, translated⟩ := + artifact.trace.recursor_translated_lookup artifact.inputMapWF hrecursor + exact ⟨info, lookup, role, translated⟩ + +theorem recursorMetadataComplete (artifact : NestedReplayArtifact) + {recursor : VConstVal} + (hrecursor : recursor ∈ artifact.trace.nested.recursors) : + FinalRecursorMetadata artifact.outputMap artifact.outputEnv recursor := + (artifact.recursorMetadata hrecursor).recursor_complete + +def MetadataComplete (artifact : NestedReplayArtifact) : Prop := + (∀ family ∈ artifact.source.types, FinalTranslatedMetadata .induct + artifact.outputMap artifact.outputEnv family.toVConstVal) ∧ + (∀ constructor ∈ artifact.source.blockConstructorConstants, + FinalTranslatedMetadata .ctor artifact.outputMap artifact.outputEnv + constructor) ∧ + (∀ recursor ∈ artifact.trace.nested.recursors, + FinalRecursorMetadata artifact.outputMap artifact.outputEnv recursor) + +theorem metadataComplete (artifact : NestedReplayArtifact) : + artifact.MetadataComplete := by + refine ⟨?_, ?_, ?_⟩ + · intro family hfamily + exact artifact.familyMetadata hfamily + · intro constructor hconstructor + exact artifact.constructorMetadata hconstructor + · intro recursor hrecursor + exact artifact.recursorMetadataComplete hrecursor + +end NestedReplayArtifact + +/-! ## Actual mutual and nested rows -/ + +def treeReplay11 : BlockReplayArtifact where + label := ``Tree + source := treeDecl + inputMap := {} + inputEnv := .empty + outputMap := treeReplayMap + outputEnv := treeFinalEnv + inputMapWF := SMap.WF.empty + inputWF := ⟨[], .empty⟩ + candidate := { + nparams := 1 + kernelTypes := treeKernelTypes + numNested := 0 + isUnsafe := false + context := treeKernelContext + execution := treeExecution + produced := treeProducedExecution.property + familyNames := rfl + constructorNames := rfl } + generationProduced := rfl + trace := treeAddInductBlockTrace + aligned := tree_verify_aligned + +def indexedTreeReplay11 : BlockReplayArtifact where + label := ``IndexedTree + source := indexedTreeDecl + inputMap := natMap + inputEnv := natFinalEnv + outputMap := indexedReplayMap + outputEnv := indexedTreeFinalEnv + inputMapWF := nat_aligned.map_wf + inputWF := nat_trEnv'.wf + candidate := { + nparams := 1 + kernelTypes := indexedTreeKernelTypes + numNested := 0 + isUnsafe := false + context := indexedTreeKernelContext + execution := indexedTreeExecution + produced := indexedTreeProducedExecution.property + familyNames := rfl + constructorNames := rfl } + generationProduced := rfl + trace := indexedTreeAddInductBlockTrace + aligned := indexedTree_verify_aligned + +def mutualReplayMatrix : List BlockReplayArtifact := + [treeReplay11, indexedTreeReplay11] + +def roseReplay11 : NestedReplayArtifact where + label := ``RoseTree + source := roseSourceV + inputMap := listMap07 + inputEnv := listFinalEnv07 + outputMap := roseMap09 + outputEnv := roseFinalEnv09 + inputMapWF := listTrEnv07.map_wf + inputWF := listTrEnv07.wf + candidate := { + targets := [NestedInductiveFixtures.listTarget] + nested := roseNestedC + produced := by + exact (Option.some_get (x := roseNestedC?) + (of_decide_eq_true + Lean4Lean.NestedReplayFixtures.roseNestedC._native.native_decide.ax_1)).symm } + candidateAgrees := rfl + trace := roseTrace09 + aligned := roseTrEnv09.aligned + +def nestedIndexedReplay11 : NestedReplayArtifact where + label := ``NVTree + source := nvSourceV + inputMap := pvecCtorMap09 + inputEnv := pvecCtorEnv09 + outputMap := nvMap09 + outputEnv := nvFinalEnv09 + inputMapWF := pvecTrEnv09.map_wf + inputWF := pvecTrEnv09.wf + candidate := { + targets := [NestedTransformation.pvecStoredTarget] + nested := nvNestedC + produced := by + exact (Option.some_get (x := nvNestedC?) + (of_decide_eq_true + Lean4Lean.NestedReplayFixtures.nvNestedC._native.native_decide.ax_1)).symm } + candidateAgrees := rfl + trace := nvTrace09 + aligned := nvTrEnv09.aligned + +/-- A two-parameter target with a second nested occurrence discovered while +processing the first auxiliary constructor. The explicit input is the full +replay of `BiBox`, and all three restored recursors are inserted from actual +kernel metadata. -/ +def deepNestedReplay11 : NestedReplayArtifact where + label := ``DeepBi + source := deepSourceV + inputMap := biBoxMap + inputEnv := biBoxFinalEnv + outputMap := deepMap + outputEnv := deepFinalEnv + inputMapWF := biBoxMapWF + inputWF := biBoxFinalWF + candidate := { + targets := [biBoxTarget] + nested := deepNestedC + produced := deepNestedC_produced } + candidateAgrees := rfl + trace := deepTrace + aligned := deepTrEnv.aligned + +def nestedReplayMatrix : List NestedReplayArtifact := + [roseReplay11, nestedIndexedReplay11, deepNestedReplay11] + +/-- The three supported transaction modes in one consumer-facing inventory. -/ +inductive ReplayArtifact where + | singleton (artifact : SingletonCandidateReplayArtifact) + | block (artifact : BlockReplayArtifact) + | nested (artifact : NestedReplayArtifact) + +namespace ReplayArtifact + +def MetadataComplete : ReplayArtifact → Prop + | .singleton artifact => SingletonReplayCompletion artifact.input.replay + | .block artifact => artifact.MetadataComplete + | .nested artifact => artifact.MetadataComplete + +theorem metadataComplete : ∀ artifact : ReplayArtifact, + artifact.MetadataComplete + | .singleton artifact => artifact.input.replay.completion + | .block artifact => artifact.metadataComplete + | .nested artifact => artifact.metadataComplete + +end ReplayArtifact + +/-- Complete actual-metadata matrix: all 20 singleton rows, both mutual rows, +and all three nested rows, with dependency environments retained per row. -/ +def completeReplayMatrix : List ReplayArtifact := + singletonCandidateReplayMatrix.map .singleton ++ + mutualReplayMatrix.map .block ++ nestedReplayMatrix.map .nested + +example : singletonReplayMatrix.length = 19 := rfl +example : singletonCandidateReplayMatrix.length = 20 := by native_decide +example : mutualReplayMatrix.length = 2 := rfl +example : nestedReplayMatrix.length = 3 := rfl +example : completeReplayMatrix.length = 25 := by native_decide + +theorem completeReplayMatrix_metadataComplete : + ∀ artifact ∈ completeReplayMatrix, artifact.MetadataComplete := by + intro artifact _ + exact artifact.metadataComplete + +end CompleteInductiveReplay + +end Lean4Lean + +/-! ## Exact trust manifests -/ + +/-- +info: 'Lean4Lean.CompleteInductiveReplay.BlockReplayArtifact.certificate' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms Lean4Lean.CompleteInductiveReplay.BlockReplayArtifact.certificate + +/-- +info: 'Lean4Lean.CompleteInductiveReplay.NestedReplayArtifact.certificate' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms Lean4Lean.CompleteInductiveReplay.NestedReplayArtifact.certificate + +/-- +info: 'Lean4Lean.CompleteInductiveReplay.completeReplayMatrix_metadataComplete' depends on axioms: [propext, + sorryAx, + Classical.choice, + Lean4Lean.ptrEqConstantInfo_eq, + Lean4Lean.ptrEqExpr_eq, + Quot.sound, + Lean.Expr.abstractRange_eq, + Lean.Expr.abstract_eq, + Lean.Expr.eqv_eq, + Lean.Expr.hasLooseBVar_eq, + Lean.Expr.instantiate1_eq, + Lean.Expr.instantiateRange_eq, + Lean.Expr.instantiateRevRange_eq, + Lean.Expr.instantiateRev_eq, + Lean.Expr.instantiate_eq, + Lean.Expr.looseBVarRange_eq, + Lean.Expr.lowerLooseBVars_eq, + Lean.Expr.mkAppData_eq, + Lean.Expr.mkData_eq, + Lean.Expr.replace_eq, + Lean.Level.hasMVar_eq, + Lean.Level.hasParam_eq, + Lean.Level.instLawfulBEqLevel, + Lean.PersistentArray.toList'_push, + Lean.PersistentHashMap.findAux_isSome, + Lean.Syntax.structEq_eq, + Lean.PersistentHashMap.WF.find?_eq, + Lean.PersistentHashMap.WF.toList'_insert, + Lean4Lean.CompleteInductiveReplay.singletonCandidateReplayMatrix._native.native_decide.ax_1, + Lean4Lean.DeepNestedReplayFixtures.biBoxObservedShape._native.native_decide.ax_1_1, + Lean4Lean.DeepNestedReplayFixtures.deepKTarget._native.native_decide.ax_1_1, + Lean4Lean.DeepNestedReplayFixtures.deepNestedC_some._native.native_decide.ax_1_1, + Lean4Lean.DeepNestedReplayFixtures.deepRecursors_eq._native.native_decide.ax_1_1, + Lean4Lean.DeepNestedReplayFixtures.deepRules_eq._native.native_decide.ax_1_1, + Lean4Lean.MutualInductiveReplayFixtures.indexedTreeExecutionResult_isOk._native.native_decide.ax_1_1, + Lean4Lean.MutualInductiveReplayFixtures.treeExecutionResult_isOk._native.native_decide.ax_1_1, + Lean4Lean.NestedReplayFixtures.nvKTarget09._native.native_decide.ax_1_1, + Lean4Lean.NestedReplayFixtures.nvNestedC._native.native_decide.ax_1, + Lean4Lean.NestedReplayFixtures.nvRecursors_eq._native.native_decide.ax_1_1, + Lean4Lean.NestedReplayFixtures.nvRules_eq._native.native_decide.ax_1_1, + Lean4Lean.NestedReplayFixtures.roseKTarget09._native.native_decide.ax_1_1, + Lean4Lean.NestedReplayFixtures.roseNestedC._native.native_decide.ax_1, + Lean4Lean.NestedReplayFixtures.roseRecursors_eq._native.native_decide.ax_1_1, + Lean4Lean.NestedReplayFixtures.roseRules_eq._native.native_decide.ax_1_1] +-/ +#guard_msgs in +#print axioms Lean4Lean.CompleteInductiveReplay.completeReplayMatrix_metadataComplete diff --git a/Lean4Lean/Verify/Environment/Lemmas.lean b/Lean4Lean/Verify/Environment/Lemmas.lean index 0af803b9..fd6a9a60 100644 --- a/Lean4Lean/Verify/Environment/Lemmas.lean +++ b/Lean4Lean/Verify/Environment/Lemmas.lean @@ -35,6 +35,8 @@ theorem TrEnv'.sf_mono (hsf : safety ≤ safety') : .induct hadd (H.sf_mono hsf) | .inductBlock hadd H => .inductBlock hadd (H.sf_mono hsf) + | .inductNested hadd H => + .inductNested 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' := @@ -94,6 +96,31 @@ theorem AddInductConstant.map_wf rw [H.map_add] exact wf.insert _ _ H.map_fresh +/-- The implementation metadata inserted by one inductive-constant step is +still available at that step's output boundary. -/ +theorem AddInductConstant.map_lookup + (H : AddInductConstant kind C₁ env₁ ci C₂ env₂) + (wf : C₁.WF) : C₂.find? ci.name = some H.info := by + simpa [H.map_add, wf.find?_insert] + +/-- An inductive-metadata insertion preserves every lookup already present in +the input map. Freshness rules out the only key at which `insert` could +replace that entry. -/ +theorem AddInductConstant.preserve_map_lookup + (H : AddInductConstant kind C₁ env₁ ci' C₂ env₂) + (wf : C₁.WF) {name : Name} {info : ConstantInfo} + (hlookup : C₁.find? name = some info) : + C₂.find? name = some info := by + rw [H.map_add, wf.find?_insert] + split + · rename_i heq + have hname : ci'.name = name := by simpa using heq + subst name + have hfresh := H.map_fresh + rw [hlookup] at hfresh + contradiction + · exact hlookup + theorem InductConstantKind.Matches.deltaValue?_eq_none {kind : InductConstantKind} {ci : ConstantInfo} (H : InductConstantKind.Matches kind ci) : ci.deltaValue? = none := by @@ -119,6 +146,34 @@ theorem AddInductConstants.map_wf : | .nil, wf => wf | .cons h hrest, wf => hrest.map_wf (h.map_wf wf) +/-- A whole insertion fold preserves every lookup from its input map. -/ +theorem AddInductConstants.preserve_map_lookup + (H : AddInductConstants kind C₁ env₁ cis C₂ env₂) + (wf : C₁.WF) {name : Name} {info : ConstantInfo} + (hlookup : C₁.find? name = some info) : + C₂.find? name = some info := by + induction H with + | nil => exact hlookup + | cons h hrest ih => + exact ih (h.map_wf wf) (h.preserve_map_lookup wf hlookup) + +/-- Final-map evidence for any member of an inductive metadata fold. The +result retains the exact implementation object, its role tag, and its +translation against the final Theory environment. -/ +theorem AddInductConstants.translated_lookup + (H : AddInductConstants kind C₁ env₁ cis C₂ env₂) + (wf : C₁.WF) {ci : VConstVal} (hmem : ci ∈ cis) : ∃ info, + C₂.find? ci.name = some info ∧ + kind.Matches info ∧ TrConstVal .safe env₂ info ci := by + induction H with + | nil => contradiction + | cons h hrest ih => + rcases List.mem_cons.1 hmem with rfl | hmem + · refine ⟨h.info, ?_, h.kind_eq, ?_⟩ + exact hrest.preserve_map_lookup (h.map_wf wf) (h.map_lookup wf) + exact h.tr.mono (h.le.trans hrest.le) + · exact ih (h.map_wf wf) hmem + theorem AddInductConstants.old_of_value : (H : AddInductConstants kind C₁ env₁ cis C₂ env₂) → C₁.WF → C₂.find? name = some ci → ci.deltaValue? = some v → C₁.find? name = some ci @@ -126,6 +181,141 @@ theorem AddInductConstants.old_of_value : | .cons h hrest, wf, hout, hv => h.old_of_value wf (hrest.old_of_value (h.map_wf wf) hout hv) hv +/-! ## Final translated metadata inventories -/ + +/-- Final-map and final-environment evidence for the family emitted by a +singleton inductive replay. -/ +theorem AddInductTrace.type_translated_lookup + (H : AddInductTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF) : + ∃ info, + C₂.find? H.generation.block.sourceType.name = some info ∧ + InductConstantKind.induct.Matches info ∧ + TrConstVal .safe env₂ info H.generation.block.sourceType.toVConstVal := by + refine ⟨H.addType.info, ?_, H.addType.kind_eq, ?_⟩ + · exact H.addRec.preserve_map_lookup + (H.addCtors.map_wf (H.addType.map_wf wf)) + (H.addCtors.preserve_map_lookup (H.addType.map_wf wf) + (H.addType.map_lookup wf)) + · exact H.addType.tr.mono + (H.addType.le.trans <| H.addCtors.le.trans <| + H.addRec.le.trans H.addRules.le) + +/-- Final-map and final-environment evidence for every constructor emitted by +a singleton inductive replay. -/ +theorem AddInductTrace.constructor_translated_lookup + (H : AddInductTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF) + {constructor : VConstVal} + (hconstructor : constructor ∈ H.generation.block.sourceType.ctors) : + ∃ info, + C₂.find? constructor.name = some info ∧ + InductConstantKind.ctor.Matches info ∧ + TrConstVal .safe env₂ info constructor := by + obtain ⟨info, hlookup, hkind, htr⟩ := + H.addCtors.translated_lookup (H.addType.map_wf wf) hconstructor + exact ⟨info, + H.addRec.preserve_map_lookup (H.addCtors.map_wf (H.addType.map_wf wf)) hlookup, + hkind, htr.mono (H.addRec.le.trans H.addRules.le)⟩ + +/-- Final-map and final-environment evidence for the recursor emitted by a +singleton inductive replay. -/ +theorem AddInductTrace.recursor_translated_lookup + (H : AddInductTrace C₁ env₁ decl C₂ env₂) + (wf : C₁.WF) : ∃ info, + C₂.find? (inductGenerationRecVal H.generation).name = some info ∧ + InductConstantKind.recursor.Matches info ∧ + TrConstVal .safe env₂ info (inductGenerationRecVal H.generation) := by + exact ⟨H.addRec.info, H.addRec.map_lookup + (H.addCtors.map_wf (H.addType.map_wf wf)), H.addRec.kind_eq, + H.addRec.tr.mono (H.addRec.le.trans H.addRules.le)⟩ + +/-- Final translated lookup for every source family in a mutual block. -/ +theorem AddInductBlockTrace.family_translated_lookup + (H : AddInductBlockTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF) + {family : VInductiveType} (hfamily : family ∈ decl.types) : ∃ info, + C₂.find? family.name = some info ∧ + InductConstantKind.induct.Matches info ∧ + TrConstVal .safe env₂ info family.toVConstVal := by + have hmember : family.toVConstVal ∈ decl.blockTypeConstants := + List.mem_map.2 ⟨family, hfamily, rfl⟩ + obtain ⟨info, hlookup, hkind, htr⟩ := + H.addTypes.translated_lookup wf hmember + exact ⟨info, + H.addRecs.preserve_map_lookup + (H.addCtors.map_wf (H.addTypes.map_wf wf)) + (H.addCtors.preserve_map_lookup (H.addTypes.map_wf wf) hlookup), + hkind, htr.mono (H.addCtors.le.trans <| H.addRecs.le.trans H.addRules.le)⟩ + +/-- Final translated lookup for every flattened constructor in a mutual +block. -/ +theorem AddInductBlockTrace.constructor_translated_lookup + (H : AddInductBlockTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF) + {constructor : VConstVal} + (hconstructor : constructor ∈ decl.blockConstructorConstants) : ∃ info, + C₂.find? constructor.name = some info ∧ + InductConstantKind.ctor.Matches info ∧ + TrConstVal .safe env₂ info constructor := by + obtain ⟨info, hlookup, hkind, htr⟩ := + H.addCtors.translated_lookup (H.addTypes.map_wf wf) hconstructor + exact ⟨info, + H.addRecs.preserve_map_lookup + (H.addCtors.map_wf (H.addTypes.map_wf wf)) hlookup, + hkind, htr.mono (H.addRecs.le.trans H.addRules.le)⟩ + +/-- Final translated lookup for every generated recursor in a mutual block. -/ +theorem AddInductBlockTrace.recursor_translated_lookup + (H : AddInductBlockTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF) + {recursor : VConstVal} (hrecursor : recursor ∈ H.generation.recursors) : + ∃ info, + C₂.find? recursor.name = some info ∧ + InductConstantKind.recursor.Matches info ∧ + TrConstVal .safe env₂ info recursor := by + obtain ⟨info, hlookup, hkind, htr⟩ := H.addRecs.translated_lookup + (H.addCtors.map_wf (H.addTypes.map_wf wf)) hrecursor + exact ⟨info, hlookup, hkind, htr.mono H.addRules.le⟩ + +/-- Final translated lookup for every source family in a nested replay. -/ +theorem AddInductNestedTrace.family_translated_lookup + (H : AddInductNestedTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF) + {family : VInductiveType} (hfamily : family ∈ decl.types) : ∃ info, + C₂.find? family.name = some info ∧ + InductConstantKind.induct.Matches info ∧ + TrConstVal .safe env₂ info family.toVConstVal := by + have hmember : family.toVConstVal ∈ decl.blockTypeConstants := + List.mem_map.2 ⟨family, hfamily, rfl⟩ + obtain ⟨info, hlookup, hkind, htr⟩ := + H.addTypes.translated_lookup wf hmember + exact ⟨info, + H.addRecs.preserve_map_lookup + (H.addCtors.map_wf (H.addTypes.map_wf wf)) + (H.addCtors.preserve_map_lookup (H.addTypes.map_wf wf) hlookup), + hkind, htr.mono (H.addCtors.le.trans <| H.addRecs.le.trans H.addRules.le)⟩ + +/-- Final translated lookup for every source constructor in a nested replay. -/ +theorem AddInductNestedTrace.constructor_translated_lookup + (H : AddInductNestedTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF) + {constructor : VConstVal} + (hconstructor : constructor ∈ decl.blockConstructorConstants) : ∃ info, + C₂.find? constructor.name = some info ∧ + InductConstantKind.ctor.Matches info ∧ + TrConstVal .safe env₂ info constructor := by + obtain ⟨info, hlookup, hkind, htr⟩ := + H.addCtors.translated_lookup (H.addTypes.map_wf wf) hconstructor + exact ⟨info, + H.addRecs.preserve_map_lookup + (H.addCtors.map_wf (H.addTypes.map_wf wf)) hlookup, + hkind, htr.mono (H.addRecs.le.trans H.addRules.le)⟩ + +/-- Final translated lookup for every restored recursor in a nested replay. -/ +theorem AddInductNestedTrace.recursor_translated_lookup + (H : AddInductNestedTrace C₁ env₁ decl C₂ env₂) (wf : C₁.WF) + {recursor : VConstVal} (hrecursor : recursor ∈ H.nested.recursors) : ∃ info, + C₂.find? recursor.name = some info ∧ + InductConstantKind.recursor.Matches info ∧ + TrConstVal .safe env₂ info recursor := by + obtain ⟨info, hlookup, hkind, htr⟩ := H.addRecs.translated_lookup + (H.addCtors.map_wf (H.addTypes.map_wf wf)) hrecursor + exact ⟨info, hlookup, hkind, htr.mono H.addRules.le⟩ + theorem AddInduct.map_wf (H : AddInduct C₁ env₁ decl C₂ env₂) (wf : C₁.WF) : C₂.WF := by rcases H with ⟨H⟩ @@ -158,6 +348,24 @@ theorem AddInductBlock.old_of_value (H.addCtors.old_of_value wfTypes (H.addRecs.old_of_value wfCtors hout hv) hv) hv +theorem AddInductNested.map_wf + (H : AddInductNested C₁ env₁ decl C₂ env₂) + (wf : C₁.WF) : C₂.WF := by + rcases H with ⟨H⟩ + exact H.addRecs.map_wf <| H.addCtors.map_wf <| + H.addTypes.map_wf wf + +theorem AddInductNested.old_of_value + (H : AddInductNested C₁ env₁ decl C₂ env₂) + (wf : C₁.WF) (hout : C₂.find? name = some ci) + (hv : ci.deltaValue? = some v) : C₁.find? name = some ci := by + rcases H with ⟨H⟩ + have wfTypes := H.addTypes.map_wf wf + have wfCtors := H.addCtors.map_wf wfTypes + exact H.addTypes.old_of_value wf + (H.addCtors.old_of_value wfTypes + (H.addRecs.old_of_value wfCtors hout hv) hv) hv + theorem Aligned.addInductConstant (wf : Aligned safety C₁ env₁) (H : AddInductConstant kind C₁ env₁ ci C₂ env₂) : Aligned safety C₂ env₂ := by @@ -196,14 +404,24 @@ theorem Aligned.addInductBlock have wfRecs := wfCtors.addInductConstants H.addRecs exact wfRecs.addDefEqFold _ +theorem Aligned.addInductNested + (H : AddInductNested C₁ env₁ decl C₂ env₂) + (wf : Aligned safety C₁ env₁) : Aligned safety C₂ env₂ := by + rcases H with ⟨H⟩ + rw [← H.addRules.to_add] + have wfTypes := wf.addInductConstants H.addTypes + have wfCtors := wfTypes.addInductConstants H.addCtors + have wfRecs := wfCtors.addInductConstants H.addRecs + exact wfRecs.addDefEqFold _ + /-- -info: 'Lean4Lean.Aligned.addInduct' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.Aligned.addInduct' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms Aligned.addInduct /-- -info: 'Lean4Lean.Aligned.addInductBlock' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.Aligned.addInductBlock' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms Aligned.addInductBlock @@ -218,9 +436,10 @@ theorem TrEnv'.aligned (H : TrEnv' safety C Q venv) : Aligned safety C venv := b | inductStaging h _ _ ih => exact ih.addInductConstant h | induct h _ ih => exact ih.addInduct h | inductBlock h _ ih => exact ih.addInductBlock h + | inductNested h _ ih => exact ih.addInductNested h /-- -info: 'Lean4Lean.TrEnv'.aligned' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.TrEnv'.aligned' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TrEnv'.aligned @@ -325,6 +544,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 | inductBlock h1 H ih => exact (ih (h1.old_of_value H.map_wf h hv)).mono h1.le + | inductNested h1 H ih => + exact (ih (h1.old_of_value H.map_wf h hv)).mono h1.le nonrec theorem TrEnv.of_value (H : TrEnv safety env venv) (h : env.find? name = some ci) (hs : safety ≤ ci.safety) (hv : ci.deltaValue? = some v) : diff --git a/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean b/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean index 32f09cb3..fd1b8bb2 100644 --- a/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean +++ b/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean @@ -3120,12 +3120,11 @@ info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeFinalEnv_ordered' depe #guard_msgs in #print axioms indexedTreeFinalEnv_ordered -/- The implementation metadata replay inherits only the already classified -Verify relation and persistent-map contracts; fixture-local native-decision +/- The implementation metadata replay is now `sorryAx`-free and inherits only +the already classified persistent-map contracts; fixture-local native-decision axioms are deliberately absent. -/ /-- info: 'Lean4Lean.MutualInductiveReplayFixtures.treeAddInductBlock' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -3137,7 +3136,6 @@ info: 'Lean4Lean.MutualInductiveReplayFixtures.treeAddInductBlock' depends on ax /-- info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeAddInductBlock' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -3149,7 +3147,6 @@ info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeAddInductBlock' depend /-- info: 'Lean4Lean.MutualInductiveReplayFixtures.tree_verify_aligned' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -3161,7 +3158,6 @@ info: 'Lean4Lean.MutualInductiveReplayFixtures.tree_verify_aligned' depends on a /-- info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTree_verify_aligned' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, diff --git a/Lean4Lean/Verify/Environment/NestedReplay.lean b/Lean4Lean/Verify/Environment/NestedReplay.lean new file mode 100644 index 00000000..c31f091f --- /dev/null +++ b/Lean4Lean/Verify/Environment/NestedReplay.lean @@ -0,0 +1,3404 @@ +import Lean4Lean.Verify.Environment.SingletonParityReplay +import Lean4Lean.Verify.Environment.NestedTransformation + +/-! +# Nested environment replay (L4L-09C) + +Both ladder fixtures replayed from real stored metadata: the rose tree +over the completed `List` environment and the nested-indexed family over +a staged `PVec` boundary. Each inserts its stored constants through +`AddInductNestedTrace`, proves the `NestedBlockChecked.WF` package by +direct concrete typing derivations over the exact phase environments, +and drives the final map and environment through `TrEnv'.inductNested`, +with `Ordered` derived and the transitional closures guarded. +-/ + +namespace Lean4Lean.NestedReplayFixtures + +open Lean +open Lean4Lean.InductiveReplayFixtures +open Lean4Lean.NestedRepresentation +open Lean4Lean.NestedInductiveFixtures +open VInductDecl + +local instance : Inhabited VEnv := ⟨.empty⟩ +local instance : Inhabited VConstVal := ⟨⟨⟨0, .sort .zero⟩, .anonymous⟩⟩ + +/-! ## The completed List replay as the input boundary -/ + +theorem listTrEnv07 : TrEnv' .safe listMap07 false listFinalEnv07 := + .induct listAddInduct07 .empty + +theorem listFinalOrdered07 : listFinalEnv07.Ordered := + listTrEnv07.wf.ordered + +/-! ## The translated rose source and its nested artifact -/ + +def roseSourceV : VInductDecl where + uvars := 1 + nparams := 1 + types := + [{ name := ``RoseTree + uvars := 1 + type := nestedConstVType09A% RoseTree + ctors := + [⟨⟨1, nestedConstVType09A% RoseTree.node⟩, ``RoseTree.node⟩] }] + +def roseNestedC? : Option (NestedBlockChecked roseSourceV) := + nestedBlockChecked? [listTarget] roseSourceV + +#guard roseNestedC?.isSome + +def roseNestedC : NestedBlockChecked roseSourceV := + roseNestedC?.get (by native_decide) + +/-! ## Stored metadata and phase maps/environments -/ + +def roseInfo09 : ConstantInfo := kernelInductInfo% RoseTree +def roseNodeInfo09 : ConstantInfo := kernelCtorInfo% RoseTree.node +def roseRecInfo09 : ConstantInfo := kernelRecInfo% RoseTree.rec +def roseRec1Info09 : ConstantInfo := kernelRecInfo% RoseTree.rec_1 + +def roseFamilyV : VConstVal := roseSourceV.types[0].toVConstVal +def roseNodeV : VConstVal := roseSourceV.types[0].ctors[0] +def roseRecV : VConstVal := roseNestedC.recursors[0]! +def roseRec1V : VConstVal := roseNestedC.recursors[1]! + +#guard roseRecV.name == ``RoseTree.rec +#guard roseRec1V.name == `Lean4Lean.NestedRepresentation.RoseTree.rec_1 + +def roseTypeMap09 : ConstMap := listMap07.insert ``RoseTree roseInfo09 +def roseCtorMap09 : ConstMap := roseTypeMap09.insert ``RoseTree.node roseNodeInfo09 +def roseRecMap09 : ConstMap := roseCtorMap09.insert ``RoseTree.rec roseRecInfo09 +def roseMap09 : ConstMap := + roseRecMap09.insert `Lean4Lean.NestedRepresentation.RoseTree.rec_1 roseRec1Info09 + +def roseTypeEnv09 : VEnv := + (listFinalEnv07.addConst roseFamilyV.name roseFamilyV.toVConstant).get! +def roseCtorEnv09 : VEnv := + (roseTypeEnv09.addConst roseNodeV.name roseNodeV.toVConstant).get! +-- the recursor and rule phase environments are defined below, over the +-- printed literal inventories + + +/-! ## Printed artifact literals + +The restored recursor types and rule components, printed from the +computed artifact and tied back to it below; the concrete typing +derivations are stated over these literals. -/ + +/-- Printed image of `roseNestedC.recursors[0]!.type`. -/ +def roseRecTypeL : VExpr := + .forallE + (.sort (.succ (.param 1))) + (.forallE + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 0)) + (.sort (.param 0))) + (.forallE + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 1))) + (.sort (.param 0))) + (.forallE + (.forallE + (.bvar 2) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3))) + (.forallE + (.app (.bvar 2) (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 5)) + (.bvar 2)) + (.bvar 1)))))) + (.forallE + (.app + (.bvar 1) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3)))) + (.forallE + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 4)) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.app + (.bvar 6) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 8))) + (.bvar 3)) + (.bvar 2))))))) + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5)) + (.app (.bvar 5) (.bvar 0)))))))) + +def roseRec1TypeL : VExpr := + .forallE + (.sort (.succ (.param 1))) + (.forallE + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 0)) + (.sort (.param 0))) + (.forallE + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 1))) + (.sort (.param 0))) + (.forallE + (.forallE + (.bvar 2) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3))) + (.forallE + (.app (.bvar 2) (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 5)) + (.bvar 2)) + (.bvar 1)))))) + (.forallE + (.app + (.bvar 1) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3)))) + (.forallE + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 4)) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.app + (.bvar 6) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 8))) + (.bvar 3)) + (.bvar 2))))))) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))) + (.app (.bvar 4) (.bvar 0)))))))) + +def roseRule0LhsL : VExpr := + .lam + (.sort (.succ (.param 1))) + (.lam + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 0)) + (.sort (.param 0))) + (.lam + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 1))) + (.sort (.param 0))) + (.lam + (.forallE + (.bvar 2) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3))) + (.forallE + (.app (.bvar 2) (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 5)) + (.bvar 2)) + (.bvar 1)))))) + (.lam + (.app + (.bvar 1) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3)))) + (.lam + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 4)) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.app + (.bvar 6) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 8))) + (.bvar 3)) + (.bvar 2))))))) + (.lam + (.bvar 5) + (.lam + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 6))) + (.app + (.app + (.app + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.rec + [.param 0, .param 1]) + (.bvar 7)) + (.bvar 6)) + (.bvar 5)) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 7)) + (.bvar 1)) + (.bvar 0)))))))))) + +def roseRule0RhsL : VExpr := + .lam + (.sort (.succ (.param 1))) + (.lam + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 0)) + (.sort (.param 0))) + (.lam + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 1))) + (.sort (.param 0))) + (.lam + (.forallE + (.bvar 2) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3))) + (.forallE + (.app (.bvar 2) (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 5)) + (.bvar 2)) + (.bvar 1)))))) + (.lam + (.app + (.bvar 1) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3)))) + (.lam + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 4)) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.app + (.bvar 6) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 8))) + (.bvar 3)) + (.bvar 2))))))) + (.lam + (.bvar 5) + (.lam + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 6))) + (.app + (.app + (.app (.bvar 4) (.bvar 1)) + (.bvar 0)) + (.app + (.app + (.app + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.rec_1 + [.param 0, .param 1]) + (.bvar 7)) + (.bvar 6)) + (.bvar 5)) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)) + (.bvar 0)))))))))) + +def roseRule0TypeL : VExpr := + .forallE + (.sort (.succ (.param 1))) + (.forallE + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 0)) + (.sort (.param 0))) + (.forallE + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 1))) + (.sort (.param 0))) + (.forallE + (.forallE + (.bvar 2) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3))) + (.forallE + (.app (.bvar 2) (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 5)) + (.bvar 2)) + (.bvar 1)))))) + (.forallE + (.app + (.bvar 1) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3)))) + (.forallE + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 4)) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.app + (.bvar 6) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 8))) + (.bvar 3)) + (.bvar 2))))))) + (.forallE + (.bvar 5) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 6))) + (.app + (.bvar 6) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 7)) + (.bvar 1)) + (.bvar 0)))))))))) + +def roseRule1LhsL : VExpr := + .lam + (.sort (.succ (.param 1))) + (.lam + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 0)) + (.sort (.param 0))) + (.lam + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 1))) + (.sort (.param 0))) + (.lam + (.forallE + (.bvar 2) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3))) + (.forallE + (.app (.bvar 2) (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 5)) + (.bvar 2)) + (.bvar 1)))))) + (.lam + (.app + (.bvar 1) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3)))) + (.lam + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 4)) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.app + (.bvar 6) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 8))) + (.bvar 3)) + (.bvar 2))))))) + (.app + (.app + (.app + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.rec_1 + [.param 0, .param 1]) + (.bvar 5)) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)) + (.bvar 1)) + (.bvar 0)) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))))))))) + +def roseRule1RhsL : VExpr := + .lam + (.sort (.succ (.param 1))) + (.lam + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 0)) + (.sort (.param 0))) + (.lam + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 1))) + (.sort (.param 0))) + (.lam + (.forallE + (.bvar 2) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3))) + (.forallE + (.app (.bvar 2) (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 5)) + (.bvar 2)) + (.bvar 1)))))) + (.lam + (.app + (.bvar 1) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3)))) + (.lam + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 4)) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.app + (.bvar 6) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 8))) + (.bvar 3)) + (.bvar 2))))))) + (.bvar 1)))))) + +def roseRule1TypeL : VExpr := + .forallE + (.sort (.succ (.param 1))) + (.forallE + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 0)) + (.sort (.param 0))) + (.forallE + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 1))) + (.sort (.param 0))) + (.forallE + (.forallE + (.bvar 2) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3))) + (.forallE + (.app (.bvar 2) (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 5)) + (.bvar 2)) + (.bvar 1)))))) + (.forallE + (.app + (.bvar 1) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3)))) + (.forallE + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 4)) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.app + (.bvar 6) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 8))) + (.bvar 3)) + (.bvar 2))))))) + (.app + (.bvar 3) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))))))))) + +def roseRule2LhsL : VExpr := + .lam + (.sort (.succ (.param 1))) + (.lam + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 0)) + (.sort (.param 0))) + (.lam + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 1))) + (.sort (.param 0))) + (.lam + (.forallE + (.bvar 2) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3))) + (.forallE + (.app (.bvar 2) (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 5)) + (.bvar 2)) + (.bvar 1)))))) + (.lam + (.app + (.bvar 1) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3)))) + (.lam + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 4)) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.app + (.bvar 6) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 8))) + (.bvar 3)) + (.bvar 2))))))) + (.lam + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5)) + (.lam + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 6))) + (.app + (.app + (.app + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.rec_1 + [.param 0, .param 1]) + (.bvar 7)) + (.bvar 6)) + (.bvar 5)) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 7))) + (.bvar 1)) + (.bvar 0)))))))))) + +def roseRule2RhsL : VExpr := + .lam + (.sort (.succ (.param 1))) + (.lam + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 0)) + (.sort (.param 0))) + (.lam + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 1))) + (.sort (.param 0))) + (.lam + (.forallE + (.bvar 2) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3))) + (.forallE + (.app (.bvar 2) (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 5)) + (.bvar 2)) + (.bvar 1)))))) + (.lam + (.app + (.bvar 1) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3)))) + (.lam + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 4)) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.app + (.bvar 6) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 8))) + (.bvar 3)) + (.bvar 2))))))) + (.lam + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5)) + (.lam + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 6))) + (.app + (.app + (.app + (.app (.bvar 2) (.bvar 1)) + (.bvar 0)) + (.app + (.app + (.app + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.rec + [.param 0, .param 1]) + (.bvar 7)) + (.bvar 6)) + (.bvar 5)) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)) + (.bvar 1))) + (.app + (.app + (.app + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.rec_1 + [.param 0, .param 1]) + (.bvar 7)) + (.bvar 6)) + (.bvar 5)) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)) + (.bvar 0)))))))))) + +def roseRule2TypeL : VExpr := + .forallE + (.sort (.succ (.param 1))) + (.forallE + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 0)) + (.sort (.param 0))) + (.forallE + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 1))) + (.sort (.param 0))) + (.forallE + (.forallE + (.bvar 2) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3))) + (.forallE + (.app (.bvar 2) (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree.node + [.param 1]) + (.bvar 5)) + (.bvar 2)) + (.bvar 1)))))) + (.forallE + (.app + (.bvar 1) + (.app + (.const `List.nil [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 3)))) + (.forallE + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 4)) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5))) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.forallE + (.app (.bvar 5) (.bvar 1)) + (.app + (.bvar 6) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 8))) + (.bvar 3)) + (.bvar 2))))))) + (.forallE + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 5)) + (.forallE + (.app + (.const `List [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 6))) + (.app + (.bvar 5) + (.app + (.app + (.app + (.const `List.cons [.param 1]) + (.app + (.const + `Lean4Lean.NestedRepresentation.RoseTree + [.param 1]) + (.bvar 7))) + (.bvar 1)) + (.bvar 0)))))))))) + +#guard roseRecV.type == roseRecTypeL +#guard roseRec1V.type == roseRec1TypeL +#guard roseNestedC.generatedRules.map (fun df => (df.uvars, df.lhs, df.rhs, df.type)) == + [(2, roseRule0LhsL, roseRule0RhsL, roseRule0TypeL), + (2, roseRule1LhsL, roseRule1RhsL, roseRule1TypeL), + (2, roseRule2LhsL, roseRule2RhsL, roseRule2TypeL)] +#guard roseRecV.uvars == 2 && roseRec1V.uvars == 2 + + +/-! ## Literal inventories -/ + +def roseRecVL : VConstVal := ⟨⟨2, roseRecTypeL⟩, ``RoseTree.rec⟩ +def roseRec1VL : VConstVal := + ⟨⟨2, roseRec1TypeL⟩, `Lean4Lean.NestedRepresentation.RoseTree.rec_1⟩ + +def roseRulesL : List VDefEq := + [⟨2, roseRule0LhsL, roseRule0RhsL, roseRule0TypeL⟩, + ⟨2, roseRule1LhsL, roseRule1RhsL, roseRule1TypeL⟩, + ⟨2, roseRule2LhsL, roseRule2RhsL, roseRule2TypeL⟩] + +theorem roseRecursors_eq : roseNestedC.recursors = [roseRecVL, roseRec1VL] := by + native_decide + +theorem roseRules_eq : roseNestedC.generatedRules = roseRulesL := by + native_decide + +def roseRecEnv09 : VEnv := + (roseCtorEnv09.addConst roseRecVL.name roseRecVL.toVConstant).get! +def roseRec1Env09 : VEnv := + (roseRecEnv09.addConst roseRec1VL.name roseRec1VL.toVConstant).get! +def roseFinalEnv09 : VEnv := + roseRulesL.foldl VEnv.addDefEq roseRec1Env09 + +/-! ## Concrete constant well-formedness -/ + +theorem roseFamilyWF09 : roseFamilyV.toVConstant.WF listFinalEnv07 := + ⟨_, by type_tac⟩ + +theorem roseTypeEnv09_eq : + listFinalEnv07.addConst roseFamilyV.name roseFamilyV.toVConstant = + some roseTypeEnv09 := rfl + +theorem roseTypeOrdered09 : roseTypeEnv09.Ordered := + .const listFinalOrdered07 roseFamilyWF09 roseTypeEnv09_eq + +theorem roseNodeWF09 : roseNodeV.toVConstant.WF roseTypeEnv09 := by + have hList : roseTypeEnv09.constants ``List = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + have hRose : roseTypeEnv09.constants ``RoseTree = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + exact ⟨_, by type_tac⟩ + + +theorem roseCtorEnv09_eq : + roseTypeEnv09.addConst roseNodeV.name roseNodeV.toVConstant = + some roseCtorEnv09 := rfl + +theorem roseCtorOrdered09 : roseCtorEnv09.Ordered := + .const roseTypeOrdered09 roseNodeWF09 roseCtorEnv09_eq + +set_option maxRecDepth 4000 in +theorem roseRecWF09 : (⟨2, roseRecTypeL⟩ : VConstant).WF roseCtorEnv09 := by + have hList : roseCtorEnv09.constants ``List = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + have hRose : roseCtorEnv09.constants ``RoseTree = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + have hNode : roseCtorEnv09.constants ``RoseTree.node = + some roseNodeV.toVConstant := rfl + have hNil : roseCtorEnv09.constants ``List.nil = + some ⟨1, .forallE (.sort (.succ (.param 0))) + (.app (.const `List [.param 0]) (.bvar 0))⟩ := rfl + have hCons : roseCtorEnv09.constants ``List.cons = + some ⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const `List [.param 0]) (.bvar 1)) + (.app (.const `List [.param 0]) (.bvar 2))))⟩ := rfl + exact ⟨_, by type_tac⟩ + + +theorem roseRecEnv09_eq : + roseCtorEnv09.addConst roseRecVL.name roseRecVL.toVConstant = + some roseRecEnv09 := rfl + +theorem roseRecOrdered09 : roseRecEnv09.Ordered := + .const roseCtorOrdered09 roseRecWF09 roseRecEnv09_eq + +set_option maxRecDepth 4000 in +theorem roseRec1WF09 : (⟨2, roseRec1TypeL⟩ : VConstant).WF roseRecEnv09 := by + have hList : roseRecEnv09.constants ``List = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + have hRose : roseRecEnv09.constants ``RoseTree = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + have hNode : roseRecEnv09.constants ``RoseTree.node = + some roseNodeV.toVConstant := rfl + have hNil : roseRecEnv09.constants ``List.nil = + some ⟨1, .forallE (.sort (.succ (.param 0))) + (.app (.const `List [.param 0]) (.bvar 0))⟩ := rfl + have hCons : roseRecEnv09.constants ``List.cons = + some ⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const `List [.param 0]) (.bvar 1)) + (.app (.const `List [.param 0]) (.bvar 2))))⟩ := rfl + exact ⟨_, by type_tac⟩ + +theorem roseRec1Env09_eq : + roseRecEnv09.addConst roseRec1VL.name roseRec1VL.toVConstant = + some roseRec1Env09 := rfl + +theorem roseRec1Ordered09 : roseRec1Env09.Ordered := + .const roseRecOrdered09 roseRec1WF09 roseRec1Env09_eq + + +/-! ## Rule well-formedness at the rule-phase environment -/ + +section RuleWF + +set_option maxRecDepth 8000 + +/-- The lookup hypotheses shared by every rule component derivation; the +environment argument is any `addDefEq` extension of `roseRec1Env09`, whose +constants agree definitionally. -/ +macro "rose_rule_hyps" e:term : tactic => `(tactic| ( + have hList : VEnv.constants $e ``List = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + have hRose : VEnv.constants $e ``RoseTree = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + have hNode : VEnv.constants $e ``RoseTree.node = + some roseNodeV.toVConstant := rfl + have hNil : VEnv.constants $e ``List.nil = + some ⟨1, .forallE (.sort (.succ (.param 0))) + (.app (.const `List [.param 0]) (.bvar 0))⟩ := rfl + have hCons : VEnv.constants $e ``List.cons = + some ⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const `List [.param 0]) (.bvar 1)) + (.app (.const `List [.param 0]) (.bvar 2))))⟩ := rfl + have hRec : VEnv.constants $e ``RoseTree.rec = + some ⟨2, roseRecTypeL⟩ := rfl + have hRec1 : VEnv.constants $e + `Lean4Lean.NestedRepresentation.RoseTree.rec_1 = + some ⟨2, roseRec1TypeL⟩ := rfl)) + +def roseRuleEnv1 : VEnv := roseRec1Env09.addDefEq roseRulesL[0] +def roseRuleEnv2 : VEnv := roseRuleEnv1.addDefEq roseRulesL[1] + +theorem roseRule0WF09 : roseRulesL[0].WF roseRec1Env09 := by + constructor + · rose_rule_hyps roseRec1Env09; type_tac + · rose_rule_hyps roseRec1Env09; type_tac + +theorem roseRule1WF09 : roseRulesL[1].WF roseRuleEnv1 := by + constructor + · rose_rule_hyps roseRuleEnv1; type_tac + · rose_rule_hyps roseRuleEnv1; type_tac + +theorem roseRule2WF09 : roseRulesL[2].WF roseRuleEnv2 := by + constructor + · rose_rule_hyps roseRuleEnv2; type_tac + · rose_rule_hyps roseRuleEnv2; type_tac + +end RuleWF + + +/-! ## The semantic package -/ + +theorem roseTypesFold_eq : + roseSourceV.blockTypeConstants.foldlM + (fun env c => env.addConst c.name c.toVConstant) listFinalEnv07 = + some roseTypeEnv09 := rfl + +theorem roseCtorsFold_eq : + roseSourceV.blockConstructorConstants.foldlM + (fun env c => env.addConst c.name c.toVConstant) roseTypeEnv09 = + some roseCtorEnv09 := rfl + +theorem roseRecsFold_eq : + roseNestedC.recursors.foldlM + (fun env c => env.addConst c.name c.toVConstant) roseCtorEnv09 = + some roseRec1Env09 := by + rw [roseRecursors_eq]; rfl + +theorem roseNestedWF09 : roseNestedC.WF listFinalEnv07 := by + refine ⟨⟨roseFamilyWF09, fun env' h => ?_⟩, fun {typeEnv} h => ?_, + fun {typeEnv ctorEnv} hT hC => ?_, fun {typeEnv ctorEnv recEnv} hT hC hR => ?_⟩ + · cases Option.some.inj (roseTypeEnv09_eq.symm.trans h) + exact trivial + · cases Option.some.inj (roseTypesFold_eq.symm.trans h) + exact ⟨roseNodeWF09, fun env' h' => by + cases Option.some.inj (roseCtorEnv09_eq.symm.trans h') + exact trivial⟩ + · cases Option.some.inj (roseTypesFold_eq.symm.trans hT) + cases Option.some.inj (roseCtorsFold_eq.symm.trans hC) + rw [roseRecursors_eq] + exact ⟨roseRecWF09, fun env' h' => by + cases Option.some.inj (roseRecEnv09_eq.symm.trans h') + exact ⟨roseRec1WF09, fun env'' h'' => by + cases Option.some.inj (roseRec1Env09_eq.symm.trans h'') + exact trivial⟩⟩ + · cases Option.some.inj (roseTypesFold_eq.symm.trans hT) + cases Option.some.inj (roseCtorsFold_eq.symm.trans hC) + cases Option.some.inj (roseRecsFold_eq.symm.trans hR) + rw [roseRules_eq] + exact ⟨roseRule0WF09, roseRule1WF09, roseRule2WF09, trivial⟩ + + +/-! ## Freshness of the stored insertions -/ + +theorem listMapWF07 : listMap07.WF := + listCtorMapWF07.insert _ _ listRecFresh07 + +theorem roseTypeFresh09 : listMap07.find? ``RoseTree = none := by + rw [listMap07, listCtorMapWF07.find?_insert, listCtorMap07, + listNilMapWF07.find?_insert, listNilMap07, + listTypeMapWF07.find?_insert, listTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem roseTypeMapWF09 : roseTypeMap09.WF := + listMapWF07.insert _ _ roseTypeFresh09 + +theorem roseNodeFresh09 : roseTypeMap09.find? ``RoseTree.node = none := by + rw [roseTypeMap09, listMapWF07.find?_insert, listMap07, + listCtorMapWF07.find?_insert, listCtorMap07, + listNilMapWF07.find?_insert, listNilMap07, + listTypeMapWF07.find?_insert, listTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem roseCtorMapWF09 : roseCtorMap09.WF := + roseTypeMapWF09.insert _ _ roseNodeFresh09 + +theorem roseRecFresh09 : roseCtorMap09.find? ``RoseTree.rec = none := by + rw [roseCtorMap09, roseTypeMapWF09.find?_insert, roseTypeMap09, + listMapWF07.find?_insert, listMap07, + listCtorMapWF07.find?_insert, listCtorMap07, + listNilMapWF07.find?_insert, listNilMap07, + listTypeMapWF07.find?_insert, listTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem roseRecMapWF09 : roseRecMap09.WF := + roseCtorMapWF09.insert _ _ roseRecFresh09 + +theorem roseRec1Fresh09 : + roseRecMap09.find? `Lean4Lean.NestedRepresentation.RoseTree.rec_1 = none := by + rw [roseRecMap09, roseCtorMapWF09.find?_insert, roseCtorMap09, + roseTypeMapWF09.find?_insert, roseTypeMap09, + listMapWF07.find?_insert, listMap07, + listCtorMapWF07.find?_insert, listCtorMap07, + listNilMapWF07.find?_insert, listNilMap07, + listTypeMapWF07.find?_insert, listTypeMap07, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +/-! ## Stored-metadata translations -/ + +theorem roseInfoTr09 : + TrConstVal .safe listFinalEnv07 roseInfo09 roseFamilyV := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr listFinalEnv07 roseInfo09.levelParams [] + roseInfo09.type roseFamilyV.toVConstant.type := by + tr_type_expr_tac + exact shape.to_trExprS listFinalOrdered07 trivial ⟨_, by type_tac⟩ + +theorem roseNodeTr09 : + TrConstVal .safe roseTypeEnv09 roseNodeInfo09 roseNodeV := by + have hList : roseTypeEnv09.constants ``List = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + have hRose : roseTypeEnv09.constants ``RoseTree = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr roseTypeEnv09 roseNodeInfo09.levelParams [] + roseNodeInfo09.type roseNodeV.toVConstant.type := by + tr_type_expr_tac + exact shape.to_trExprS roseTypeOrdered09 trivial ⟨_, by type_tac⟩ + +theorem roseRecTr09 : + TrConstVal .safe roseCtorEnv09 roseRecInfo09 roseRecVL := by + have hList : roseCtorEnv09.constants ``List = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + have hRose : roseCtorEnv09.constants ``RoseTree = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + have hNode : roseCtorEnv09.constants ``RoseTree.node = + some roseNodeV.toVConstant := rfl + have hNil : roseCtorEnv09.constants ``List.nil = + some ⟨1, .forallE (.sort (.succ (.param 0))) + (.app (.const `List [.param 0]) (.bvar 0))⟩ := rfl + have hCons : roseCtorEnv09.constants ``List.cons = + some ⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const `List [.param 0]) (.bvar 1)) + (.app (.const `List [.param 0]) (.bvar 2))))⟩ := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr roseCtorEnv09 roseRecInfo09.levelParams [] + roseRecInfo09.type roseRecVL.toVConstant.type := by + tr_type_expr_tac + obtain ⟨u, hty⟩ := roseRecWF09 + exact shape.to_trExprS roseCtorOrdered09 trivial ⟨_, hty⟩ + +theorem roseRec1Tr09 : + TrConstVal .safe roseRecEnv09 roseRec1Info09 roseRec1VL := by + have hList : roseRecEnv09.constants ``List = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + have hRose : roseRecEnv09.constants ``RoseTree = + some ⟨1, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))⟩ := rfl + have hNode : roseRecEnv09.constants ``RoseTree.node = + some roseNodeV.toVConstant := rfl + have hNil : roseRecEnv09.constants ``List.nil = + some ⟨1, .forallE (.sort (.succ (.param 0))) + (.app (.const `List [.param 0]) (.bvar 0))⟩ := rfl + have hCons : roseRecEnv09.constants ``List.cons = + some ⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const `List [.param 0]) (.bvar 1)) + (.app (.const `List [.param 0]) (.bvar 2))))⟩ := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr roseRecEnv09 roseRec1Info09.levelParams [] + roseRec1Info09.type roseRec1VL.toVConstant.type := by + tr_type_expr_tac + obtain ⟨u, hty⟩ := roseRec1WF09 + exact shape.to_trExprS roseRecOrdered09 trivial ⟨_, hty⟩ + + +/-! ## Recursor K metadata and stored lookups -/ + +theorem roseKTarget09 : roseNestedC.generation.kTarget = false := by + native_decide + +theorem roseRecLookup09 : + roseMap09.find? ``RoseTree.rec = some roseRecInfo09 := by + rw [roseMap09, roseRecMapWF09.find?_insert] + simp [roseRecMap09, roseCtorMapWF09.find?_insert] + +theorem roseRec1Lookup09 : + roseMap09.find? `Lean4Lean.NestedRepresentation.RoseTree.rec_1 = + some roseRec1Info09 := by + rw [roseMap09, roseRecMapWF09.find?_insert] + simp + +theorem roseRecK09 : + RecursorMapKMatches roseMap09 roseNestedC.recursors + roseNestedC.generation.kTarget := by + rw [roseRecursors_eq, roseKTarget09] + intro recursor hmem + rcases List.mem_cons.1 hmem with rfl | hmem + · exact ⟨roseRecInfo09, roseRecLookup09, by decide⟩ + rcases List.mem_cons.1 hmem with rfl | hmem + · exact ⟨roseRec1Info09, roseRec1Lookup09, by decide⟩ + · cases hmem + +/-! ## The nested alignment trace and its `TrEnv'` drive -/ + +def roseTrace09 : + AddInductNestedTrace listMap07 listFinalEnv07 roseSourceV + roseMap09 roseFinalEnv09 where + nested := roseNestedC + nested_wf := roseNestedWF09 + typeMap := roseTypeMap09 + typeEnv := roseTypeEnv09 + ctorMap := roseCtorMap09 + ctorEnv := roseCtorEnv09 + recEnv := roseRec1Env09 + addTypes := .cons + { info := roseInfo09 + kind_eq := trivial + tr := roseInfoTr09 + map_fresh := roseTypeFresh09 + env_add := roseTypeEnv09_eq + map_add := rfl } .nil + addCtors := .cons + { info := roseNodeInfo09 + kind_eq := trivial + tr := roseNodeTr09 + map_fresh := roseNodeFresh09 + env_add := roseCtorEnv09_eq + map_add := rfl } .nil + addRecs := roseRecursors_eq ▸ .cons + { info := roseRecInfo09 + kind_eq := trivial + tr := roseRecTr09 + map_fresh := roseRecFresh09 + env_add := roseRecEnv09_eq + map_add := rfl } (.cons + { info := roseRec1Info09 + kind_eq := trivial + tr := roseRec1Tr09 + map_fresh := roseRec1Fresh09 + env_add := roseRec1Env09_eq + map_add := rfl } .nil) + recK := roseRecK09 + addRules := ⟨by rw [roseRules_eq]; rfl⟩ + +theorem roseAddInductNested09 : + AddInductNested listMap07 listFinalEnv07 roseSourceV + roseMap09 roseFinalEnv09 := + ⟨roseTrace09⟩ + +/-- The rose-tree nested declaration, replayed from real stored metadata +over the completed `List` environment through the nested alignment +constructor. -/ +theorem roseTrEnv09 : TrEnv' .safe roseMap09 false roseFinalEnv09 := + .inductNested roseAddInductNested09 listTrEnv07 + +theorem roseFinalOrdered09 : roseFinalEnv09.Ordered := + roseTrEnv09.wf.ordered + + +/-! ## Round-trip guards + +The stored-metadata surface inserted by the trace is tied to the Theory +artifact inventory, and the final map/environment pair carries the +documented closure (persistent-map contracts plus the compiler-trust axioms +introduced by the `native_decide` observations). -/ + +#guard roseNestedC.elim.numNested == 1 +#guard roseRecV == roseRecVL && roseRec1V == roseRec1VL + +/-- +info: 'Lean4Lean.NestedReplayFixtures.roseTrEnv09' depends on axioms: [propext, + Classical.choice, + Quot.sound, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert, + roseKTarget09._native.native_decide.ax_1_1, + roseNestedC._native.native_decide.ax_1, + roseRecursors_eq._native.native_decide.ax_1_1, + roseRules_eq._native.native_decide.ax_1_1] +-/ +#guard_msgs in +#print axioms roseTrEnv09 + +/-- +info: 'Lean4Lean.NestedReplayFixtures.roseNestedWF09' depends on axioms: [propext, + Classical.choice, + Quot.sound, + roseNestedC._native.native_decide.ax_1, + roseRecursors_eq._native.native_decide.ax_1_1, + roseRules_eq._native.native_decide.ax_1_1] +-/ +#guard_msgs in +#print axioms roseNestedWF09 + + +/-! # The nested-indexed fixture + +`NVTree` nests through the locally declared indexed `PVec`. The base +environment stages the `PVec` family and constructors over the completed +`Nat` replay through `TrEnv'.inductStaging`; the nested trace then inserts +the stored `NVTree` metadata and drives `TrEnv'.inductNested`. -/ + +/-! ## Staged `PVec` base -/ + +def pvecInfo09 : ConstantInfo := kernelInductInfo% PVec +def pvecNilInfo09 : ConstantInfo := kernelCtorInfo% PVec.nil +def pvecConsInfo09 : ConstantInfo := kernelCtorInfo% PVec.cons + +def pvecFamilyVL : VConstVal := + ⟨⟨0, .forallE (.sort (.succ .zero)) + (.forallE (.const `Nat []) (.sort (.succ .zero)))⟩, ``PVec⟩ +def pvecNilVL : VConstVal := ⟨⟨0, nestedConstVType09A% PVec.nil⟩, ``PVec.nil⟩ +def pvecConsVL : VConstVal := ⟨⟨0, nestedConstVType09A% PVec.cons⟩, ``PVec.cons⟩ + +def pvecTypeMap09 : ConstMap := natMap.insert ``PVec pvecInfo09 +def pvecNilMap09 : ConstMap := pvecTypeMap09.insert ``PVec.nil pvecNilInfo09 +def pvecCtorMap09 : ConstMap := pvecNilMap09.insert ``PVec.cons pvecConsInfo09 + +def pvecTypeEnv09 : VEnv := + (natFinalEnv.addConst pvecFamilyVL.name pvecFamilyVL.toVConstant).get! +def pvecNilEnv09 : VEnv := + (pvecTypeEnv09.addConst pvecNilVL.name pvecNilVL.toVConstant).get! +def pvecCtorEnv09 : VEnv := + (pvecNilEnv09.addConst pvecConsVL.name pvecConsVL.toVConstant).get! + +theorem pvecTypeFresh09 : natMap.find? ``PVec = none := by + rw [natMap, natCtorMap_wf.find?_insert, natCtorMap, + natZeroMap_wf.find?_insert, natZeroMap, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem pvecTypeMapWF09 : pvecTypeMap09.WF := + natMap_wf.insert _ _ pvecTypeFresh09 + +theorem pvecNilFresh09 : pvecTypeMap09.find? ``PVec.nil = none := by + rw [pvecTypeMap09, natMap_wf.find?_insert, natMap, + natCtorMap_wf.find?_insert, natCtorMap, + natZeroMap_wf.find?_insert, natZeroMap, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem pvecNilMapWF09 : pvecNilMap09.WF := + pvecTypeMapWF09.insert _ _ pvecNilFresh09 + +theorem pvecConsFresh09 : pvecNilMap09.find? ``PVec.cons = none := by + rw [pvecNilMap09, pvecTypeMapWF09.find?_insert, pvecTypeMap09, + natMap_wf.find?_insert, natMap, + natCtorMap_wf.find?_insert, natCtorMap, + natZeroMap_wf.find?_insert, natZeroMap, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem pvecCtorMapWF09 : pvecCtorMap09.WF := + pvecNilMapWF09.insert _ _ pvecConsFresh09 + +theorem natFinalOrdered09 : natFinalEnv.Ordered := + nat_trEnv'.wf.ordered + +theorem pvecFamilyWF09 : pvecFamilyVL.toVConstant.WF natFinalEnv := by + have hNat : natFinalEnv.constants ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl + exact ⟨_, by type_tac⟩ + +theorem pvecTypeEnv09_eq : + natFinalEnv.addConst pvecFamilyVL.name pvecFamilyVL.toVConstant = + some pvecTypeEnv09 := rfl + +theorem pvecTypeOrdered09 : pvecTypeEnv09.Ordered := + .const natFinalOrdered09 pvecFamilyWF09 pvecTypeEnv09_eq + +theorem pvecNilWF09 : pvecNilVL.toVConstant.WF pvecTypeEnv09 := by + have hNat : pvecTypeEnv09.constants ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl + have hZero : pvecTypeEnv09.constants ``Nat.zero = some ⟨0, .const `Nat []⟩ := rfl + have hPVec : pvecTypeEnv09.constants ``PVec = some pvecFamilyVL.toVConstant := rfl + exact ⟨_, by type_tac⟩ + +theorem pvecNilEnv09_eq : + pvecTypeEnv09.addConst pvecNilVL.name pvecNilVL.toVConstant = + some pvecNilEnv09 := rfl + +theorem pvecNilOrdered09 : pvecNilEnv09.Ordered := + .const pvecTypeOrdered09 pvecNilWF09 pvecNilEnv09_eq + +theorem pvecConsWF09 : pvecConsVL.toVConstant.WF pvecNilEnv09 := by + have hNat : pvecNilEnv09.constants ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl + have hSucc : pvecNilEnv09.constants ``Nat.succ = + some ⟨0, .forallE (.const `Nat []) (.const `Nat [])⟩ := rfl + have hPVec : pvecNilEnv09.constants ``PVec = some pvecFamilyVL.toVConstant := rfl + exact ⟨_, by type_tac⟩ + +theorem pvecConsEnv09_eq : + pvecNilEnv09.addConst pvecConsVL.name pvecConsVL.toVConstant = + some pvecCtorEnv09 := rfl + +theorem pvecCtorOrdered09 : pvecCtorEnv09.Ordered := + .const pvecNilOrdered09 pvecConsWF09 pvecConsEnv09_eq + +theorem pvecInfoTr09 : TrConstVal .safe natFinalEnv pvecInfo09 pvecFamilyVL := by + have hNat : natFinalEnv.constants ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr natFinalEnv pvecInfo09.levelParams [] + pvecInfo09.type pvecFamilyVL.toVConstant.type := by + tr_type_expr_tac + exact shape.to_trExprS natFinalOrdered09 trivial ⟨_, by type_tac⟩ + +theorem pvecNilTr09 : TrConstVal .safe pvecTypeEnv09 pvecNilInfo09 pvecNilVL := by + have hNat : pvecTypeEnv09.constants ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl + have hZero : pvecTypeEnv09.constants ``Nat.zero = some ⟨0, .const `Nat []⟩ := rfl + have hPVec : pvecTypeEnv09.constants ``PVec = some pvecFamilyVL.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr pvecTypeEnv09 pvecNilInfo09.levelParams [] + pvecNilInfo09.type pvecNilVL.toVConstant.type := by + tr_type_expr_tac + exact shape.to_trExprS pvecTypeOrdered09 trivial ⟨_, by type_tac⟩ + +theorem pvecConsTr09 : TrConstVal .safe pvecNilEnv09 pvecConsInfo09 pvecConsVL := by + have hNat : pvecNilEnv09.constants ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl + have hSucc : pvecNilEnv09.constants ``Nat.succ = + some ⟨0, .forallE (.const `Nat []) (.const `Nat [])⟩ := rfl + have hPVec : pvecNilEnv09.constants ``PVec = some pvecFamilyVL.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr pvecNilEnv09 pvecConsInfo09.levelParams [] + pvecConsInfo09.type pvecConsVL.toVConstant.type := by + tr_type_expr_tac + exact shape.to_trExprS pvecNilOrdered09 trivial ⟨_, by type_tac⟩ + +/-- The staged `PVec` boundary: family and constructors present, no +recursor or rules — exactly the constants the nested `NVTree` artifacts +reference. -/ +theorem pvecTrEnv09 : TrEnv' .safe pvecCtorMap09 false pvecCtorEnv09 := + .inductStaging (kind := .ctor) + { info := pvecConsInfo09 + kind_eq := trivial + tr := pvecConsTr09 + map_fresh := pvecConsFresh09 + env_add := pvecConsEnv09_eq + map_add := rfl } pvecConsWF09 <| + .inductStaging (kind := .ctor) + { info := pvecNilInfo09 + kind_eq := trivial + tr := pvecNilTr09 + map_fresh := pvecNilFresh09 + env_add := pvecNilEnv09_eq + map_add := rfl } pvecNilWF09 <| + .inductStaging (kind := .induct) + { info := pvecInfo09 + kind_eq := trivial + tr := pvecInfoTr09 + map_fresh := pvecTypeFresh09 + env_add := pvecTypeEnv09_eq + map_add := rfl } pvecFamilyWF09 nat_trEnv' + + +/-! ## The translated NV source and its nested artifact -/ + +def nvSourceV : VInductDecl where + uvars := 0 + nparams := 0 + types := + [{ name := ``NVTree + uvars := 0 + type := nestedConstVType09A% NVTree + ctors := [⟨⟨0, nestedConstVType09A% NVTree.node⟩, ``NVTree.node⟩] }] + +def nvNestedC? : Option (NestedBlockChecked nvSourceV) := + nestedBlockChecked? [NestedTransformation.pvecStoredTarget] nvSourceV + +#guard nvNestedC?.isSome + +def nvNestedC : NestedBlockChecked nvSourceV := + nvNestedC?.get (by native_decide) + +def nvInfo09 : ConstantInfo := kernelInductInfo% NVTree +def nvNodeInfo09 : ConstantInfo := kernelCtorInfo% NVTree.node +def nvRecInfo09 : ConstantInfo := kernelRecInfo% NVTree.rec +def nvRec1Info09 : ConstantInfo := kernelRecInfo% NVTree.rec_1 + +def nvFamilyV : VConstVal := nvSourceV.types[0].toVConstVal +def nvNodeV : VConstVal := nvSourceV.types[0].ctors[0] + +def nvTypeMap09 : ConstMap := pvecCtorMap09.insert ``NVTree nvInfo09 +def nvCtorMap09 : ConstMap := nvTypeMap09.insert ``NVTree.node nvNodeInfo09 +def nvRecMap09 : ConstMap := nvCtorMap09.insert ``NVTree.rec nvRecInfo09 +def nvMap09 : ConstMap := + nvRecMap09.insert `Lean4Lean.NestedRepresentation.NVTree.rec_1 nvRec1Info09 + +def nvTypeEnv09 : VEnv := + (pvecCtorEnv09.addConst nvFamilyV.name nvFamilyV.toVConstant).get! +def nvCtorEnv09 : VEnv := + (nvTypeEnv09.addConst nvNodeV.name nvNodeV.toVConstant).get! + +def nvFamilyTypeL : VExpr := + .sort (.succ (.zero)) + +def nvNodeTypeL : VExpr := + .forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + +def nvRecTypeL : VExpr := + .forallE + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.sort (.param 0))) + (.forallE + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.sort (.param 0)))) + (.forallE + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app + (.app (.bvar 2) (.bvar 1)) + (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 2)) + (.bvar 1)))))) + (.forallE + (.app + (.app (.bvar 1) (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))) + (.forallE + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app (.bvar 6) (.bvar 2)) + (.forallE + (.app + (.app (.bvar 6) (.bvar 2)) + (.bvar 1)) + (.app + (.app + (.bvar 7) + (.app + (.const `Nat.succ []) + (.bvar 3))) + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.PVec.cons + []) + (.const + `Lean4Lean.NestedRepresentation.NVTree + [])) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)))))))) + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.app (.bvar 5) (.bvar 0))))))) + +def nvRec1TypeL : VExpr := + .forallE + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.sort (.param 0))) + (.forallE + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.sort (.param 0)))) + (.forallE + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app + (.app (.bvar 2) (.bvar 1)) + (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 2)) + (.bvar 1)))))) + (.forallE + (.app + (.app (.bvar 1) (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))) + (.forallE + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app (.bvar 6) (.bvar 2)) + (.forallE + (.app + (.app (.bvar 6) (.bvar 2)) + (.bvar 1)) + (.app + (.app + (.bvar 7) + (.app + (.const `Nat.succ []) + (.bvar 3))) + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.PVec.cons + []) + (.const + `Lean4Lean.NestedRepresentation.NVTree + [])) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)))))))) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.app + (.app (.bvar 5) (.bvar 1)) + (.bvar 0)))))))) + +def nvRule0LhsL : VExpr := + .lam + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.sort (.param 0))) + (.lam + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.sort (.param 0)))) + (.lam + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app + (.app (.bvar 2) (.bvar 1)) + (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 2)) + (.bvar 1)))))) + (.lam + (.app + (.app (.bvar 1) (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))) + (.lam + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app (.bvar 6) (.bvar 2)) + (.forallE + (.app + (.app (.bvar 6) (.bvar 2)) + (.bvar 1)) + (.app + (.app + (.bvar 7) + (.app + (.const `Nat.succ []) + (.bvar 3))) + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.PVec.cons + []) + (.const + `Lean4Lean.NestedRepresentation.NVTree + [])) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)))))))) + (.lam + (.const `Nat []) + (.lam + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.app + (.app + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.NVTree.rec + [.param 0]) + (.bvar 6)) + (.bvar 5)) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 1)) + (.bvar 0))))))))) + +def nvRule0RhsL : VExpr := + .lam + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.sort (.param 0))) + (.lam + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.sort (.param 0)))) + (.lam + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app + (.app (.bvar 2) (.bvar 1)) + (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 2)) + (.bvar 1)))))) + (.lam + (.app + (.app (.bvar 1) (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))) + (.lam + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app (.bvar 6) (.bvar 2)) + (.forallE + (.app + (.app (.bvar 6) (.bvar 2)) + (.bvar 1)) + (.app + (.app + (.bvar 7) + (.app + (.const `Nat.succ []) + (.bvar 3))) + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.PVec.cons + []) + (.const + `Lean4Lean.NestedRepresentation.NVTree + [])) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)))))))) + (.lam + (.const `Nat []) + (.lam + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.app + (.app + (.app (.bvar 4) (.bvar 1)) + (.bvar 0)) + (.app + (.app + (.app + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.NVTree.rec_1 + [.param 0]) + (.bvar 6)) + (.bvar 5)) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)) + (.bvar 1)) + (.bvar 0))))))))) + +def nvRule0TypeL : VExpr := + .forallE + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.sort (.param 0))) + (.forallE + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.sort (.param 0)))) + (.forallE + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app + (.app (.bvar 2) (.bvar 1)) + (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 2)) + (.bvar 1)))))) + (.forallE + (.app + (.app (.bvar 1) (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))) + (.forallE + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app (.bvar 6) (.bvar 2)) + (.forallE + (.app + (.app (.bvar 6) (.bvar 2)) + (.bvar 1)) + (.app + (.app + (.bvar 7) + (.app + (.const `Nat.succ []) + (.bvar 3))) + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.PVec.cons + []) + (.const + `Lean4Lean.NestedRepresentation.NVTree + [])) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)))))))) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.app + (.bvar 6) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 1)) + (.bvar 0))))))))) + +def nvRule1LhsL : VExpr := + .lam + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.sort (.param 0))) + (.lam + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.sort (.param 0)))) + (.lam + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app + (.app (.bvar 2) (.bvar 1)) + (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 2)) + (.bvar 1)))))) + (.lam + (.app + (.app (.bvar 1) (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))) + (.lam + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app (.bvar 6) (.bvar 2)) + (.forallE + (.app + (.app (.bvar 6) (.bvar 2)) + (.bvar 1)) + (.app + (.app + (.bvar 7) + (.app + (.const `Nat.succ []) + (.bvar 3))) + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.PVec.cons + []) + (.const + `Lean4Lean.NestedRepresentation.NVTree + [])) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)))))))) + (.app + (.app + (.app + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.NVTree.rec_1 + [.param 0]) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)) + (.bvar 1)) + (.bvar 0)) + (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))))))) + +def nvRule1RhsL : VExpr := + .lam + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.sort (.param 0))) + (.lam + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.sort (.param 0)))) + (.lam + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app + (.app (.bvar 2) (.bvar 1)) + (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 2)) + (.bvar 1)))))) + (.lam + (.app + (.app (.bvar 1) (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))) + (.lam + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app (.bvar 6) (.bvar 2)) + (.forallE + (.app + (.app (.bvar 6) (.bvar 2)) + (.bvar 1)) + (.app + (.app + (.bvar 7) + (.app + (.const `Nat.succ []) + (.bvar 3))) + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.PVec.cons + []) + (.const + `Lean4Lean.NestedRepresentation.NVTree + [])) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)))))))) + (.bvar 1))))) + +def nvRule1TypeL : VExpr := + .forallE + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.sort (.param 0))) + (.forallE + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.sort (.param 0)))) + (.forallE + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app + (.app (.bvar 2) (.bvar 1)) + (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 2)) + (.bvar 1)))))) + (.forallE + (.app + (.app (.bvar 1) (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))) + (.forallE + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app (.bvar 6) (.bvar 2)) + (.forallE + (.app + (.app (.bvar 6) (.bvar 2)) + (.bvar 1)) + (.app + (.app + (.bvar 7) + (.app + (.const `Nat.succ []) + (.bvar 3))) + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.PVec.cons + []) + (.const + `Lean4Lean.NestedRepresentation.NVTree + [])) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)))))))) + (.app + (.app (.bvar 3) (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))))))) + +def nvRule2LhsL : VExpr := + .lam + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.sort (.param 0))) + (.lam + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.sort (.param 0)))) + (.lam + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app + (.app (.bvar 2) (.bvar 1)) + (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 2)) + (.bvar 1)))))) + (.lam + (.app + (.app (.bvar 1) (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))) + (.lam + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app (.bvar 6) (.bvar 2)) + (.forallE + (.app + (.app (.bvar 6) (.bvar 2)) + (.bvar 1)) + (.app + (.app + (.bvar 7) + (.app + (.const `Nat.succ []) + (.bvar 3))) + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.PVec.cons + []) + (.const + `Lean4Lean.NestedRepresentation.NVTree + [])) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)))))))) + (.lam + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.lam + (.const `Nat []) + (.lam + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.app + (.app + (.app + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.NVTree.rec_1 + [.param 0]) + (.bvar 7)) + (.bvar 6)) + (.bvar 5)) + (.bvar 4)) + (.bvar 3)) + (.app + (.const `Nat.succ []) + (.bvar 1))) + (.app + (.app + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.cons []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 2)) + (.bvar 1)) + (.bvar 0)))))))))) + +def nvRule2RhsL : VExpr := + .lam + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.sort (.param 0))) + (.lam + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.sort (.param 0)))) + (.lam + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app + (.app (.bvar 2) (.bvar 1)) + (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 2)) + (.bvar 1)))))) + (.lam + (.app + (.app (.bvar 1) (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))) + (.lam + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app (.bvar 6) (.bvar 2)) + (.forallE + (.app + (.app (.bvar 6) (.bvar 2)) + (.bvar 1)) + (.app + (.app + (.bvar 7) + (.app + (.const `Nat.succ []) + (.bvar 3))) + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.PVec.cons + []) + (.const + `Lean4Lean.NestedRepresentation.NVTree + [])) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)))))))) + (.lam + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.lam + (.const `Nat []) + (.lam + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.app + (.app + (.app + (.app + (.app (.bvar 3) (.bvar 2)) + (.bvar 1)) + (.bvar 0)) + (.app + (.app + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.NVTree.rec + [.param 0]) + (.bvar 7)) + (.bvar 6)) + (.bvar 5)) + (.bvar 4)) + (.bvar 3)) + (.bvar 2))) + (.app + (.app + (.app + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.NVTree.rec_1 + [.param 0]) + (.bvar 7)) + (.bvar 6)) + (.bvar 5)) + (.bvar 4)) + (.bvar 3)) + (.bvar 1)) + (.bvar 0)))))))))) + +def nvRule2TypeL : VExpr := + .forallE + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.sort (.param 0))) + (.forallE + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.sort (.param 0)))) + (.forallE + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app + (.app (.bvar 2) (.bvar 1)) + (.bvar 0)) + (.app + (.bvar 4) + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.NVTree.node []) + (.bvar 2)) + (.bvar 1)))))) + (.forallE + (.app + (.app (.bvar 1) (.const `Nat.zero [])) + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.nil []) + (.const `Lean4Lean.NestedRepresentation.NVTree []))) + (.forallE + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.forallE + (.app (.bvar 6) (.bvar 2)) + (.forallE + (.app + (.app (.bvar 6) (.bvar 2)) + (.bvar 1)) + (.app + (.app + (.bvar 7) + (.app + (.const `Nat.succ []) + (.bvar 3))) + (.app + (.app + (.app + (.app + (.const + `Lean4Lean.NestedRepresentation.PVec.cons + []) + (.const + `Lean4Lean.NestedRepresentation.NVTree + [])) + (.bvar 4)) + (.bvar 3)) + (.bvar 2)))))))) + (.forallE + (.const `Lean4Lean.NestedRepresentation.NVTree []) + (.forallE + (.const `Nat []) + (.forallE + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 0)) + (.app + (.app + (.bvar 6) + (.app + (.const `Nat.succ []) + (.bvar 1))) + (.app + (.app + (.app + (.app + (.const `Lean4Lean.NestedRepresentation.PVec.cons []) + (.const `Lean4Lean.NestedRepresentation.NVTree [])) + (.bvar 2)) + (.bvar 1)) + (.bvar 0)))))))))) + +def nvRecVL : VConstVal := ⟨⟨1, nvRecTypeL⟩, ``NVTree.rec⟩ +def nvRec1VL : VConstVal := + ⟨⟨1, nvRec1TypeL⟩, `Lean4Lean.NestedRepresentation.NVTree.rec_1⟩ + +def nvRulesL : List VDefEq := + [⟨1, nvRule0LhsL, nvRule0RhsL, nvRule0TypeL⟩, + ⟨1, nvRule1LhsL, nvRule1RhsL, nvRule1TypeL⟩, + ⟨1, nvRule2LhsL, nvRule2RhsL, nvRule2TypeL⟩] + +theorem nvRecursors_eq : nvNestedC.recursors = [nvRecVL, nvRec1VL] := by + native_decide + +theorem nvRules_eq : nvNestedC.generatedRules = nvRulesL := by + native_decide + +def nvRecEnv09 : VEnv := + (nvCtorEnv09.addConst nvRecVL.name nvRecVL.toVConstant).get! +def nvRec1Env09 : VEnv := + (nvRecEnv09.addConst nvRec1VL.name nvRec1VL.toVConstant).get! +def nvFinalEnv09 : VEnv := + nvRulesL.foldl VEnv.addDefEq nvRec1Env09 + + +/-! ## NV constant well-formedness and phase chains -/ + +macro "nv_hyps" e:term : tactic => `(tactic| ( + have hNat : VEnv.constants $e ``Nat = some ⟨0, .sort (.succ .zero)⟩ := rfl + have hZero : VEnv.constants $e ``Nat.zero = some ⟨0, .const `Nat []⟩ := rfl + have hSucc : VEnv.constants $e ``Nat.succ = + some ⟨0, .forallE (.const `Nat []) (.const `Nat [])⟩ := rfl + have hPVec : VEnv.constants $e ``PVec = some pvecFamilyVL.toVConstant := rfl + have hPNil : VEnv.constants $e ``PVec.nil = some pvecNilVL.toVConstant := rfl + have hPCons : VEnv.constants $e ``PVec.cons = some pvecConsVL.toVConstant := rfl)) + +theorem nvFamilyWF09 : nvFamilyV.toVConstant.WF pvecCtorEnv09 := + ⟨_, by type_tac⟩ + +theorem nvTypeEnv09_eq : + pvecCtorEnv09.addConst nvFamilyV.name nvFamilyV.toVConstant = + some nvTypeEnv09 := rfl + +theorem nvTypeOrdered09 : nvTypeEnv09.Ordered := + .const pvecCtorOrdered09 nvFamilyWF09 nvTypeEnv09_eq + +theorem nvNodeWF09 : nvNodeV.toVConstant.WF nvTypeEnv09 := by + nv_hyps nvTypeEnv09 + have hNV : nvTypeEnv09.constants ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl + exact ⟨_, by type_tac⟩ + +theorem nvCtorEnv09_eq : + nvTypeEnv09.addConst nvNodeV.name nvNodeV.toVConstant = + some nvCtorEnv09 := rfl + +theorem nvCtorOrdered09 : nvCtorEnv09.Ordered := + .const nvTypeOrdered09 nvNodeWF09 nvCtorEnv09_eq + +set_option maxRecDepth 4000 in +theorem nvRecWF09 : (⟨1, nvRecTypeL⟩ : VConstant).WF nvCtorEnv09 := by + nv_hyps nvCtorEnv09 + have hNV : nvCtorEnv09.constants ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl + have hNode : nvCtorEnv09.constants ``NVTree.node = + some nvNodeV.toVConstant := rfl + exact ⟨_, by type_tac⟩ + +theorem nvRecEnv09_eq : + nvCtorEnv09.addConst nvRecVL.name nvRecVL.toVConstant = + some nvRecEnv09 := rfl + +theorem nvRecOrdered09 : nvRecEnv09.Ordered := + .const nvCtorOrdered09 nvRecWF09 nvRecEnv09_eq + +set_option maxRecDepth 4000 in +theorem nvRec1WF09 : (⟨1, nvRec1TypeL⟩ : VConstant).WF nvRecEnv09 := by + nv_hyps nvRecEnv09 + have hNV : nvRecEnv09.constants ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl + have hNode : nvRecEnv09.constants ``NVTree.node = + some nvNodeV.toVConstant := rfl + exact ⟨_, by type_tac⟩ + +theorem nvRec1Env09_eq : + nvRecEnv09.addConst nvRec1VL.name nvRec1VL.toVConstant = + some nvRec1Env09 := rfl + +theorem nvRec1Ordered09 : nvRec1Env09.Ordered := + .const nvRecOrdered09 nvRec1WF09 nvRec1Env09_eq + +section NVRuleWF + +set_option maxRecDepth 8000 + +macro "nv_rule_hyps" e:term : tactic => `(tactic| ( + nv_hyps $e + have hNV : VEnv.constants $e ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl + have hNode : VEnv.constants $e ``NVTree.node = some nvNodeV.toVConstant := rfl + have hRec : VEnv.constants $e ``NVTree.rec = some ⟨1, nvRecTypeL⟩ := rfl + have hRec1 : VEnv.constants $e + `Lean4Lean.NestedRepresentation.NVTree.rec_1 = some ⟨1, nvRec1TypeL⟩ := rfl)) + +def nvRuleEnv1 : VEnv := nvRec1Env09.addDefEq nvRulesL[0] +def nvRuleEnv2 : VEnv := nvRuleEnv1.addDefEq nvRulesL[1] + +theorem nvRule0WF09 : nvRulesL[0].WF nvRec1Env09 := by + constructor + · nv_rule_hyps nvRec1Env09; type_tac + · nv_rule_hyps nvRec1Env09; type_tac + +theorem nvRule1WF09 : nvRulesL[1].WF nvRuleEnv1 := by + constructor + · nv_rule_hyps nvRuleEnv1; type_tac + · nv_rule_hyps nvRuleEnv1; type_tac + +theorem nvRule2WF09 : nvRulesL[2].WF nvRuleEnv2 := by + constructor + · nv_rule_hyps nvRuleEnv2; type_tac + · nv_rule_hyps nvRuleEnv2; type_tac + +end NVRuleWF + + +/-! ## NV semantic package -/ + +theorem nvTypesFold_eq : + nvSourceV.blockTypeConstants.foldlM + (fun env c => env.addConst c.name c.toVConstant) pvecCtorEnv09 = + some nvTypeEnv09 := rfl + +theorem nvCtorsFold_eq : + nvSourceV.blockConstructorConstants.foldlM + (fun env c => env.addConst c.name c.toVConstant) nvTypeEnv09 = + some nvCtorEnv09 := rfl + +theorem nvRecsFold_eq : + nvNestedC.recursors.foldlM + (fun env c => env.addConst c.name c.toVConstant) nvCtorEnv09 = + some nvRec1Env09 := by + rw [nvRecursors_eq]; rfl + +theorem nvNestedWF09 : nvNestedC.WF pvecCtorEnv09 := by + refine ⟨⟨nvFamilyWF09, fun env' h => ?_⟩, fun {typeEnv} h => ?_, + fun {typeEnv ctorEnv} hT hC => ?_, fun {typeEnv ctorEnv recEnv} hT hC hR => ?_⟩ + · cases Option.some.inj (nvTypeEnv09_eq.symm.trans h) + exact trivial + · cases Option.some.inj (nvTypesFold_eq.symm.trans h) + exact ⟨nvNodeWF09, fun env' h' => by + cases Option.some.inj (nvCtorEnv09_eq.symm.trans h') + exact trivial⟩ + · cases Option.some.inj (nvTypesFold_eq.symm.trans hT) + cases Option.some.inj (nvCtorsFold_eq.symm.trans hC) + rw [nvRecursors_eq] + exact ⟨nvRecWF09, fun env' h' => by + cases Option.some.inj (nvRecEnv09_eq.symm.trans h') + exact ⟨nvRec1WF09, fun env'' h'' => by + cases Option.some.inj (nvRec1Env09_eq.symm.trans h'') + exact trivial⟩⟩ + · cases Option.some.inj (nvTypesFold_eq.symm.trans hT) + cases Option.some.inj (nvCtorsFold_eq.symm.trans hC) + cases Option.some.inj (nvRecsFold_eq.symm.trans hR) + rw [nvRules_eq] + exact ⟨nvRule0WF09, nvRule1WF09, nvRule2WF09, trivial⟩ + +/-! ## NV freshness and stored-metadata translations -/ + +theorem nvTypeFresh09 : pvecCtorMap09.find? ``NVTree = none := by + rw [pvecCtorMap09, pvecNilMapWF09.find?_insert, pvecNilMap09, + pvecTypeMapWF09.find?_insert, pvecTypeMap09, + natMap_wf.find?_insert, natMap, + natCtorMap_wf.find?_insert, natCtorMap, + natZeroMap_wf.find?_insert, natZeroMap, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem nvTypeMapWF09 : nvTypeMap09.WF := + pvecCtorMapWF09.insert _ _ nvTypeFresh09 + +theorem nvNodeFresh09 : nvTypeMap09.find? ``NVTree.node = none := by + rw [nvTypeMap09, pvecCtorMapWF09.find?_insert, pvecCtorMap09, + pvecNilMapWF09.find?_insert, pvecNilMap09, + pvecTypeMapWF09.find?_insert, pvecTypeMap09, + natMap_wf.find?_insert, natMap, + natCtorMap_wf.find?_insert, natCtorMap, + natZeroMap_wf.find?_insert, natZeroMap, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem nvCtorMapWF09 : nvCtorMap09.WF := + nvTypeMapWF09.insert _ _ nvNodeFresh09 + +theorem nvRecFresh09 : nvCtorMap09.find? ``NVTree.rec = none := by + rw [nvCtorMap09, nvTypeMapWF09.find?_insert, nvTypeMap09, + pvecCtorMapWF09.find?_insert, pvecCtorMap09, + pvecNilMapWF09.find?_insert, pvecNilMap09, + pvecTypeMapWF09.find?_insert, pvecTypeMap09, + natMap_wf.find?_insert, natMap, + natCtorMap_wf.find?_insert, natCtorMap, + natZeroMap_wf.find?_insert, natZeroMap, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem nvRecMapWF09 : nvRecMap09.WF := + nvCtorMapWF09.insert _ _ nvRecFresh09 + +theorem nvRec1Fresh09 : + nvRecMap09.find? `Lean4Lean.NestedRepresentation.NVTree.rec_1 = none := by + rw [nvRecMap09, nvCtorMapWF09.find?_insert, nvCtorMap09, + nvTypeMapWF09.find?_insert, nvTypeMap09, + pvecCtorMapWF09.find?_insert, pvecCtorMap09, + pvecNilMapWF09.find?_insert, pvecNilMap09, + pvecTypeMapWF09.find?_insert, pvecTypeMap09, + natMap_wf.find?_insert, natMap, + natCtorMap_wf.find?_insert, natCtorMap, + natZeroMap_wf.find?_insert, natZeroMap, + natTypeMap_wf.find?_insert, natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + simp [SMap.find?] + +theorem nvInfoTr09 : TrConstVal .safe pvecCtorEnv09 nvInfo09 nvFamilyV := by + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr pvecCtorEnv09 nvInfo09.levelParams [] + nvInfo09.type nvFamilyV.toVConstant.type := by + tr_type_expr_tac + exact shape.to_trExprS pvecCtorOrdered09 trivial ⟨_, by type_tac⟩ + +theorem nvNodeTr09 : TrConstVal .safe nvTypeEnv09 nvNodeInfo09 nvNodeV := by + nv_hyps nvTypeEnv09 + have hNV : nvTypeEnv09.constants ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr nvTypeEnv09 nvNodeInfo09.levelParams [] + nvNodeInfo09.type nvNodeV.toVConstant.type := by + tr_type_expr_tac + exact shape.to_trExprS nvTypeOrdered09 trivial ⟨_, by type_tac⟩ + +theorem nvRecTr09 : TrConstVal .safe nvCtorEnv09 nvRecInfo09 nvRecVL := by + nv_hyps nvCtorEnv09 + have hNV : nvCtorEnv09.constants ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl + have hNode : nvCtorEnv09.constants ``NVTree.node = some nvNodeV.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr nvCtorEnv09 nvRecInfo09.levelParams [] + nvRecInfo09.type nvRecVL.toVConstant.type := by + tr_type_expr_tac + obtain ⟨u, hty⟩ := nvRecWF09 + exact shape.to_trExprS nvCtorOrdered09 trivial ⟨_, hty⟩ + +theorem nvRec1Tr09 : TrConstVal .safe nvRecEnv09 nvRec1Info09 nvRec1VL := by + nv_hyps nvRecEnv09 + have hNV : nvRecEnv09.constants ``NVTree = some ⟨0, .sort (.succ .zero)⟩ := rfl + have hNode : nvRecEnv09.constants ``NVTree.node = some nvNodeV.toVConstant := rfl + refine ⟨⟨by decide, rfl, ?_⟩, rfl⟩ + have shape : TrTypeExpr nvRecEnv09 nvRec1Info09.levelParams [] + nvRec1Info09.type nvRec1VL.toVConstant.type := by + tr_type_expr_tac + obtain ⟨u, hty⟩ := nvRec1WF09 + exact shape.to_trExprS nvRecOrdered09 trivial ⟨_, hty⟩ + +/-! ## NV recursor K metadata, trace, and `TrEnv'` drive -/ + +theorem nvKTarget09 : nvNestedC.generation.kTarget = false := by + native_decide + +theorem nvRecLookup09 : nvMap09.find? ``NVTree.rec = some nvRecInfo09 := by + rw [nvMap09, nvRecMapWF09.find?_insert] + simp [nvRecMap09, nvCtorMapWF09.find?_insert] + +theorem nvRec1Lookup09 : + nvMap09.find? `Lean4Lean.NestedRepresentation.NVTree.rec_1 = + some nvRec1Info09 := by + rw [nvMap09, nvRecMapWF09.find?_insert] + simp + +theorem nvRecK09 : + RecursorMapKMatches nvMap09 nvNestedC.recursors + nvNestedC.generation.kTarget := by + rw [nvRecursors_eq, nvKTarget09] + intro recursor hmem + rcases List.mem_cons.1 hmem with rfl | hmem + · exact ⟨nvRecInfo09, nvRecLookup09, by decide⟩ + rcases List.mem_cons.1 hmem with rfl | hmem + · exact ⟨nvRec1Info09, nvRec1Lookup09, by decide⟩ + · cases hmem + +def nvTrace09 : + AddInductNestedTrace pvecCtorMap09 pvecCtorEnv09 nvSourceV + nvMap09 nvFinalEnv09 where + nested := nvNestedC + nested_wf := nvNestedWF09 + typeMap := nvTypeMap09 + typeEnv := nvTypeEnv09 + ctorMap := nvCtorMap09 + ctorEnv := nvCtorEnv09 + recEnv := nvRec1Env09 + addTypes := .cons + { info := nvInfo09 + kind_eq := trivial + tr := nvInfoTr09 + map_fresh := nvTypeFresh09 + env_add := nvTypeEnv09_eq + map_add := rfl } .nil + addCtors := .cons + { info := nvNodeInfo09 + kind_eq := trivial + tr := nvNodeTr09 + map_fresh := nvNodeFresh09 + env_add := nvCtorEnv09_eq + map_add := rfl } .nil + addRecs := nvRecursors_eq ▸ .cons + { info := nvRecInfo09 + kind_eq := trivial + tr := nvRecTr09 + map_fresh := nvRecFresh09 + env_add := nvRecEnv09_eq + map_add := rfl } (.cons + { info := nvRec1Info09 + kind_eq := trivial + tr := nvRec1Tr09 + map_fresh := nvRec1Fresh09 + env_add := nvRec1Env09_eq + map_add := rfl } .nil) + recK := nvRecK09 + addRules := ⟨by rw [nvRules_eq]; rfl⟩ + +theorem nvAddInductNested09 : + AddInductNested pvecCtorMap09 pvecCtorEnv09 nvSourceV + nvMap09 nvFinalEnv09 := + ⟨nvTrace09⟩ + +/-- The nested-indexed declaration, replayed from real stored metadata over +the staged `PVec` boundary through the nested alignment constructor. -/ +theorem nvTrEnv09 : TrEnv' .safe nvMap09 false nvFinalEnv09 := + .inductNested nvAddInductNested09 pvecTrEnv09 + +theorem nvFinalOrdered09 : nvFinalEnv09.Ordered := + nvTrEnv09.wf.ordered + +#guard nvNestedC.elim.numNested == 1 + + +/-- +info: 'Lean4Lean.NestedReplayFixtures.nvTrEnv09' depends on axioms: [propext, + Classical.choice, + Quot.sound, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert, + nvKTarget09._native.native_decide.ax_1_1, + nvNestedC._native.native_decide.ax_1, + nvRecursors_eq._native.native_decide.ax_1_1, + nvRules_eq._native.native_decide.ax_1_1] +-/ +#guard_msgs in +#print axioms nvTrEnv09 + +end Lean4Lean.NestedReplayFixtures diff --git a/Lean4Lean/Verify/Environment/NestedRepresentation.lean b/Lean4Lean/Verify/Environment/NestedRepresentation.lean new file mode 100644 index 00000000..63b84c74 --- /dev/null +++ b/Lean4Lean/Verify/Environment/NestedRepresentation.lean @@ -0,0 +1,710 @@ +import Lean4Lean.Environment +import Lean4Lean.Theory.Inductive +import Lean4Lean.Theory.Meta + +/-! +# L4L-09A: nested-inductive representation audit and decision + +This file is the committed design note and the executable metadata probes +for the nested-inductive representation decision. Every claim below is +pinned by a build-failing probe in this file unless it is explicitly marked +as a forward-looking obligation. This checkpoint changes no acceptance +behavior: the probes only observe the implementation and the existing +Theory analyzers. + +## Audit: how the implementation represents nested inductives + +`Environment.addInductive` (Inductive/Add.lean) runs three phases: + +1. `ElimNestedInductive.run` rewrites the source declaration into a + flattened mutual block: every nested occurrence `I Ds is` whose + parametric arguments `Ds` mention a block family is replaced by + `auxI As is`, where `auxI` is a fresh auxiliary family abstracted over + the block parameters `As`, and one auxiliary family is created for each + family of `I`'s mutual block, with constructor types instantiated at + `Ds` (recursively rewritten). `aux2nested` records `auxI ↦ I Ds`, open + over the block parameters. Auxiliary names are uniquified against the + ambient environment (`mkUniqueName`). +2. `AddInductive.run` checks and generates the flattened block as an + ordinary mutual block, receiving `numNested` (the number of auxiliary + families) as opaque metadata. +3. When `numNested ≠ 0`, a restoration pass rebuilds the final environment + from the *pre-block* environment: source families and constructors are + re-added with every auxiliary constant replaced by its nested + restoration (`Result.restoreNested`), each auxiliary family's recursor + is re-added under the name `(mkRecName mainName).appendIndexAfter i` + with restored type and rules, and finally every `aux2nested` value + `I Ds` is type-checked (the lean4#14577 escape-hatch check, regression + tested in `Tests/NestedInductive.lean`). The auxiliary families, + constructors, and recursor names never enter the final environment. + +The stored metadata therefore has this shape (probes P1, P2): + +- The source `inductInfo` keeps `all` = the source family names only and + carries `numNested` = the number of auxiliary families; stored + constructor types are in restored form (they mention `I Ds`, e.g. + `List (RoseTree α)`). +- The recursor inventory is one recursor per source family plus one per + auxiliary family, all with `all` = source names, and with + `numMotives`/`numMinors` counting the *flattened* block's families and + minors. Auxiliary recursors have rules keyed by constructors of the + previously declared nested inductive (`List.nil`, `List.cons`, ...) with + `nfields` counting the instantiated auxiliary constructor's fields, and + every rule RHS references the restored recursor constants mutually. +- No `_nested.*` constant, and no auxiliary recursor under its original + name, survives into the final environment. + +## Decision: additive artifact type; `VInductDecl` unchanged + +The stored Theory payload for a nested declaration must be the *source* +`VInductDecl` (restored form), because that is what the implementation +stores and what Verify alignment must replay. Storing the flattened block +is unrepresentable: the final `ConstMap` contains neither the auxiliary +families nor their constructors (probe P2), and the stored constructor +types differ from the flattened ones (probe P1). `VInductDecl` needs no +new field: `numNested` is implementation metadata recoverable as the +number of auxiliary specifications, and parity fixtures pin it per row +exactly as they already pin `numNested == 0` for non-nested rows. + +Nested support is an additive checked-block artifact (built in L4L-09B/C), +coupling: + +1. the flattened block as an ordinary `VInductDecl` — probe P4 shows both + target fixtures' flattened blocks are already accepted by the existing + `identityBlockGeneration?` machinery, so flattening reuses the complete + L4L-08 block analyzer and generator unchanged; +2. one auxiliary specification per auxiliary family, in flattened family + order: the auxiliary name, the nested value `I Ds` open over the block + parameters (the Theory analog of `aux2nested`), and the restored + recursor name — plus executable coherence checks tying the flattened + block to the source declaration and to the environment's metadata for + `I` at `Ds`; +3. the restoration substitution σ, a structural constant substitution on + `VExpr` (probe P5, `restoreV09A`): on an application spine headed by an + auxiliary constant, the first `nparams` spine arguments are consumed + and replaced by the instantiated value `I Ds`; auxiliary constructor + constants are renamed by prefix into `I`'s constructors, applied to the + instantiated value's own arguments; auxiliary recursor constants are + renamed (checked *before* the constructor-prefix case, exactly like + `restoreNested`'s `auxRec` map); levels come from the recorded value, + not the auxiliary constant. + +σ has one level-world subtlety (probe P5): specification values live in +declaration level-world, while recursor types and rules live in recursor +level-world, so σ over generation artifacts splices +`value.instL (VLevel.params' uvars elimOffset)`. Constructor types are +restored with the unshifted value. With that splice, σ over the flattened +block's existing `BlockGenerationChecked` artifacts reproduces the stored +kernel metadata *exactly* — every recursor type and every rule RHS of all +three probe fixtures — and no auxiliary constant survives the image. +Probe P2 additionally shows the port's full nested path reproduces Lean's +stored metadata field-for-field, and that the final metadata is +independent of auxiliary-name collisions (the uniquified names are erased +by σ), so Theory may choose canonical auxiliary names as artifact data. + +Rejected alternatives: + +- *Flattened block as stored payload*: contradicts the stored metadata + (P1/P2); Verify alignment would have to invent constants the + implementation never stores. +- *Changing `VInductDecl` fields*: unnecessary — the probes demonstrate + the additive artifact expresses real rose-tree, nested-indexed, and + constant-universe metadata; a payload change would ripple through every + exported Theory API without demonstrated need. +- *A Prop-only pre-flattening relation without an artifact*: the + specifications and σ are data consumed by generation and replay; a + relation alone would force Verify to re-synthesize them. The artifact's + executable coherence checks subsume the relation. + +## Obligations recorded for L4L-09B/09C (not claimed here) + +- 09B: Theory-side flattening and auxiliary-specification validation — + positivity through the existing block analyzer on the flattened block; + executable instantiation checks of auxiliary family/constructor types + against `I`'s metadata at `Ds`; nearest rejection differentials + (ill-typed `Ds` — the lean4#14577 class — wrong specification order, + non-matching instantiation). +- 09C: σ as a total Theory function. The spine rule needs a simultaneous + `instantiateRev`-style multi-substitution for `nparams > 1`: iterating + single `VExpr.inst` is wrong once parameter arguments mention bvars. + Generation, preservation (typing transport along σ: auxiliary constants + behave as definitions `auxI := λ As, I Ds`, so staged flattened-block WF + transports to restored WF given environment lookup facts for `I`'s + families and constructors), insertion order, and replay of real + `Inductive.Add.run` output. +- The kernel's trailing `checkType (I Ds)` becomes a WF premise of the + auxiliary specification, never a trusted escape hatch. +-/ + +namespace Lean4Lean.NestedRepresentation + +open Lean + +/-! ## Probe fixtures + +`RoseTree` is the universe-polymorphic rose tree through `List`; `NVTree` +nests through the locally declared indexed family `PVec` (indices spelled +with `Nat.zero`/`Nat.succ` to keep the probe dependency maps free of +notation instances); `CURose` nests `List` at a constant universe, so its +auxiliary constant carries no block level while the restored `List` +carries level `1` — the level-instantiation case σ must represent. -/ + +inductive RoseTree (α : Type u) : Type u where + | node : α → List (RoseTree α) → RoseTree α + +inductive PVec (α : Type) : Nat → Type where + | nil : PVec α Nat.zero + | cons : α → {n : Nat} → PVec α n → PVec α (Nat.succ n) + +inductive NVTree : Type where + | node : (n : Nat) → PVec NVTree n → NVTree + +inductive CURose : Type 1 where + | node : List CURose → CURose + +/-! ## Quoted stored metadata + +Local pin records keep this file independent of the replay fixture +inventory; a change in Lean's emitted metadata is a compile failure. -/ + +structure InductPins where + name : Name + lparams : List Name + numParams : Nat + numIndices : Nat + all : List Name + ctors : List Name + numNested : Nat + isRec : Bool + isReflexive : Bool + isUnsafe : Bool + deriving ToExpr, BEq + +structure CtorPins where + name : Name + lparams : List Name + induct : Name + cidx : Nat + numParams : Nat + numFields : Nat + deriving ToExpr, BEq + +structure RecPins where + name : Name + lparams : List Name + all : List Name + numParams : Nat + numIndices : Nat + numMotives : Nat + numMinors : Nat + k : Bool + rules : List (Name × Nat) + deriving ToExpr, BEq + +open Elab Term in +elab "nestedInductPins09A%" n:ident : term => do + let name ← realizeGlobalConstNoOverloadWithInfo n + let .inductInfo i ← getConstInfo name | throwError "expected inductive {name}" + return toExpr (InductPins.mk i.name i.levelParams i.numParams i.numIndices + i.all i.ctors i.numNested i.isRec i.isReflexive i.isUnsafe) + +open Elab Term in +elab "nestedCtorPins09A%" n:ident : term => do + let name ← realizeGlobalConstNoOverloadWithInfo n + let .ctorInfo i ← getConstInfo name | throwError "expected constructor {name}" + return toExpr (CtorPins.mk i.name i.levelParams i.induct i.cidx + i.numParams i.numFields) + +open Elab Term in +elab "nestedRecPins09A%" n:ident : term => do + let name ← realizeGlobalConstNoOverloadWithInfo n + let .recInfo i ← getConstInfo name | throwError "expected recursor {name}" + return toExpr (RecPins.mk i.name i.levelParams i.all i.numParams i.numIndices + i.numMotives i.numMinors i.k (i.rules.map fun r => (r.ctor, r.nfields))) + +-- Quote a stored `ConstantInfo.type` in that record's own universe order. +open Elab Term in +elab "nestedConstVType09A%" n:ident : term => do + let name ← realizeGlobalConstNoOverloadWithInfo n + let info ← getConstInfo name + let type ← Lean4Lean.Meta.expandExpr info.type + return toExpr (← Lean4Lean.Meta.ofExpr info.levelParams {} type) + +/-! ## P1: stored-metadata pins + +The source family keeps `all` = source names and counts its auxiliary +families in `numNested`; constructor types are restored; the recursor +inventory reveals the flattened block through `numMotives`/`numMinors` and +through auxiliary recursors whose rules are keyed by the constructors of a +previously declared inductive. -/ + +def roseAux : Name := (`_nested ++ ``List).appendIndexAfter 1 +def nvAux : Name := (`_nested ++ ``PVec).appendIndexAfter 1 + +def roseInductPins : InductPins := nestedInductPins09A% RoseTree +def roseNodePins : CtorPins := nestedCtorPins09A% RoseTree.node +def roseRecPins : RecPins := nestedRecPins09A% RoseTree.rec +def roseRec1Pins : RecPins := nestedRecPins09A% RoseTree.rec_1 + +#guard roseInductPins.numNested == 1 +#guard roseInductPins.all == [``RoseTree] +#guard roseInductPins.ctors == [``RoseTree.node] +#guard roseInductPins.lparams == [`u] && roseInductPins.numParams == 1 +#guard roseInductPins.isRec && !roseInductPins.isReflexive && !roseInductPins.isUnsafe +#guard roseNodePins == + { name := ``RoseTree.node, lparams := [`u], induct := ``RoseTree, cidx := 0, + numParams := 1, numFields := 2 } +#guard roseRecPins == + { name := ``RoseTree.rec, lparams := [`u_1, `u], all := [``RoseTree], numParams := 1, + numIndices := 0, numMotives := 2, numMinors := 3, k := false, + rules := [(``RoseTree.node, 2)] } +#guard roseRec1Pins == + { name := (mkRecName ``RoseTree).appendIndexAfter 1, lparams := [`u_1, `u], + all := [``RoseTree], numParams := 1, numIndices := 0, numMotives := 2, numMinors := 3, + k := false, rules := [(``List.nil, 0), (``List.cons, 2)] } + +/-- The stored constructor type is the restored form: it mentions +`List (RoseTree α)`, not an auxiliary constant. -/ +def roseNodeStoredType : VExpr := nestedConstVType09A% RoseTree.node + +#guard roseNodeStoredType == + .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const ``List [.param 0]) (.app (.const ``RoseTree [.param 0]) (.bvar 1))) + (.app (.const ``RoseTree [.param 0]) (.bvar 2)))) + +def nvInductPins : InductPins := nestedInductPins09A% NVTree +def nvNodePins : CtorPins := nestedCtorPins09A% NVTree.node +def nvRecPins : RecPins := nestedRecPins09A% NVTree.rec +def nvRec1Pins : RecPins := nestedRecPins09A% NVTree.rec_1 + +#guard nvInductPins.numNested == 1 +#guard nvInductPins.all == [``NVTree] && nvInductPins.ctors == [``NVTree.node] +#guard nvNodePins == + { name := ``NVTree.node, lparams := [], induct := ``NVTree, cidx := 0, + numParams := 0, numFields := 2 } +#guard nvRecPins == + { name := ``NVTree.rec, lparams := [`u], all := [``NVTree], numParams := 0, + numIndices := 0, numMotives := 2, numMinors := 3, k := false, + rules := [(``NVTree.node, 2)] } +-- The auxiliary recursor keeps the auxiliary family's index and its rules +-- count the instantiated constructor's fields (`PVec.cons` retains its +-- implicit index field: 3 fields, not 2). +#guard nvRec1Pins == + { name := (mkRecName ``NVTree).appendIndexAfter 1, lparams := [`u], all := [``NVTree], + numParams := 0, numIndices := 1, numMotives := 2, numMinors := 3, k := false, + rules := [(``PVec.nil, 0), (``PVec.cons, 3)] } + +def nvNodeStoredType : VExpr := nestedConstVType09A% NVTree.node + +#guard nvNodeStoredType == + .forallE (.const ``Nat []) + (.forallE (.app (.app (.const ``PVec []) (.const ``NVTree [])) (.bvar 0)) + (.const ``NVTree [])) + +def cuInductPins : InductPins := nestedInductPins09A% CURose +def cuRecPins : RecPins := nestedRecPins09A% CURose.rec +def cuRec1Pins : RecPins := nestedRecPins09A% CURose.rec_1 + +#guard cuInductPins.numNested == 1 && cuInductPins.all == [``CURose] +#guard cuRecPins.rules == [(``CURose.node, 1)] && cuRecPins.numMotives == 2 +#guard cuRec1Pins.rules == [(``List.nil, 0), (``List.cons, 2)] + +/-- The restored constructor type instantiates `List` at the constant level +`1` even though the declaration has no level parameters. -/ +def cuNodeStoredType : VExpr := nestedConstVType09A% CURose.node + +#guard cuNodeStoredType == + .forallE (.app (.const ``List [.succ .zero]) (.const ``CURose [])) + (.const ``CURose []) + +/-! ## Shared probe plumbing -/ + +def sourceType09A (env : Environment) (n : Name) : InductiveType := Id.run do + let some (.inductInfo info) := env.find? n | panic! "expected inductive" + let ctors := info.ctors.map fun c => Id.run do + let some (.ctorInfo ci) := env.find? c | panic! "expected constructor" + return { name := c, type := ci.type : Constructor } + return { name := n, type := info.type, ctors } + +def depMap09A (env : Environment) (ns : List Name) : ConstMap := + ns.foldl (fun m n => m.insert n (env.find? n).get!) {} + +open ElimNestedInductive in +/-- Run the port's flattening phase, returning the flattened block and the +`aux2nested` values abstracted over the block parameters. -/ +def runElim09A (env : Kernel.Environment) (lparams : List Name) (nparams : Nat) + (types : List InductiveType) : + Except Kernel.Exception (List InductiveType × List (Name × Expr)) := do + let res : ElimNestedInductive.Result ← ElimNestedInductive.run 1000 nparams types env + |>.run' { lvls := lparams.map .param, newTypes := types.toArray } + return (res.types, res.aux2nested.toList.map fun (n, e) => (n, e.abstract res.params)) + +/-- Field-for-field stored/ported agreement for the constant kinds a nested +declaration emits. -/ +def sameConst09A (a b : ConstantInfo) : Bool := + a.name == b.name && a.levelParams == b.levelParams && a.type == b.type && + match a, b with + | .recInfo ra, .recInfo rb => + ra.all == rb.all && ra.numParams == rb.numParams && + ra.numIndices == rb.numIndices && ra.numMotives == rb.numMotives && + ra.numMinors == rb.numMinors && ra.k == rb.k && + ra.isUnsafe == rb.isUnsafe && + ra.rules.map (fun r => (r.ctor, r.nfields, r.rhs)) == + rb.rules.map (fun r => (r.ctor, r.nfields, r.rhs)) + | .inductInfo ia, .inductInfo ib => + ia.all == ib.all && ia.numParams == ib.numParams && + ia.numIndices == ib.numIndices && ia.ctors == ib.ctors && + ia.numNested == ib.numNested && ia.isRec == ib.isRec && + ia.isReflexive == ib.isReflexive && ia.isUnsafe == ib.isUnsafe + | .ctorInfo ca, .ctorInfo cb => + ca.induct == cb.induct && ca.cidx == cb.cidx && + ca.numParams == cb.numParams && ca.numFields == cb.numFields && + ca.isUnsafe == cb.isUnsafe + | _, _ => false + +def roseDeps : List Name := [``List, ``List.nil, ``List.cons] +def nvDeps : List Name := + [``Nat, ``Nat.zero, ``Nat.succ, ``PVec, ``PVec.nil, ``PVec.cons] + +def roseRestored : List Name := + [``RoseTree, ``RoseTree.node, mkRecName ``RoseTree, + (mkRecName ``RoseTree).appendIndexAfter 1] +def nvRestored : List Name := + [``NVTree, ``NVTree.node, mkRecName ``NVTree, + (mkRecName ``NVTree).appendIndexAfter 1] +def cuRestored : List Name := + [``CURose, ``CURose.node, mkRecName ``CURose, + (mkRecName ``CURose).appendIndexAfter 1] + +/-! ## P2: the port's nested path reproduces the stored metadata + +`Environment.addInductive`, run on a dependency-only kernel environment, +re-creates exactly the constants Lean stores — including every restored +type and rule RHS — and no auxiliary constant. The final output is +independent of auxiliary-name collisions: pre-seeding `_nested.List_1` +only shifts the uniquified internal names, which restoration erases. -/ + +open Elab in +run_meta do + let env ← getEnv + let checkPort (label : String) (main : Name) (lparams : List Name) (nparams : Nat) + (deps auxNames restored : List Name) (extra : ConstMap → ConstMap) : + MetaM Unit := do + let src := sourceType09A env main + let kenv := Kernel.Environment.ofConstants (`_l4l09A ++ main) (extra (depMap09A env deps)) + match Lean4Lean.Environment.addInductive kenv lparams nparams [src] false false with + | .error _ => throwError "{label}: port addInductive failed" + | .ok env' => + for n in restored do + let some stored := env.find? n | throwError "{label}: {n} not stored" + let some ported := env'.find? n | throwError "{label}: {n} missing from port output" + unless sameConst09A stored ported do + throwError "{label}: stored/ported metadata differ at {n}" + for n in auxNames do + unless (env'.find? n).isNone do + throwError "{label}: auxiliary constant {n} leaked into the final environment" + unless (env.find? n).isNone do + throwError "{label}: auxiliary constant {n} present in the ambient environment" + checkPort "rose" ``RoseTree [`u] 1 roseDeps + [roseAux, roseAux ++ `nil, roseAux ++ `cons, mkRecName roseAux, + (mkRecName ``RoseTree).appendIndexAfter 2] roseRestored id + checkPort "nv" ``NVTree [] 0 nvDeps + [nvAux, nvAux ++ `nil, nvAux ++ `cons, mkRecName nvAux, + (mkRecName ``NVTree).appendIndexAfter 2] nvRestored id + checkPort "cu" ``CURose [] 0 roseDeps + [roseAux, mkRecName roseAux] cuRestored id + -- auxiliary-name-collision independence + checkPort "rose-collision" ``RoseTree [`u] 1 roseDeps + [(`_nested ++ ``List).appendIndexAfter 2] roseRestored + (fun m => m.insert roseAux (env.find? ``Nat).get!) + +/-! ## P3: exact flattening pins + +The flattened blocks, translated to binder-erased `VExpr` form. These are +the descriptors the L4L-09B transformation must produce. -/ + +def roseFlatFamilies : List (Name × VExpr) := + [(``RoseTree, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))), + (roseAux, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))))] + +def roseFlatCtors : List (Name × VExpr) := + [(``RoseTree.node, + .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const roseAux [.param 0]) (.bvar 1)) + (.app (.const ``RoseTree [.param 0]) (.bvar 2))))), + (roseAux ++ `nil, + .forallE (.sort (.succ (.param 0))) (.app (.const roseAux [.param 0]) (.bvar 0))), + (roseAux ++ `cons, + .forallE (.sort (.succ (.param 0))) + (.forallE (.app (.const ``RoseTree [.param 0]) (.bvar 0)) + (.forallE (.app (.const roseAux [.param 0]) (.bvar 1)) + (.app (.const roseAux [.param 0]) (.bvar 2)))))] + +/-- `aux2nested` for the rose tree: `List (RoseTree α)`, open over `α`. -/ +def roseAuxValue : VExpr := + .app (.const ``List [.param 0]) (.app (.const ``RoseTree [.param 0]) (.bvar 0)) + +def nvFlatFamilies : List (Name × VExpr) := + [(``NVTree, .sort (.succ .zero)), + (nvAux, .forallE (.const ``Nat []) (.sort (.succ .zero)))] + +def nvFlatCtors : List (Name × VExpr) := + [(``NVTree.node, + .forallE (.const ``Nat []) + (.forallE (.app (.const nvAux []) (.bvar 0)) (.const ``NVTree []))), + (nvAux ++ `nil, .app (.const nvAux []) (.const ``Nat.zero [])), + (nvAux ++ `cons, + .forallE (.const ``NVTree []) + (.forallE (.const ``Nat []) + (.forallE (.app (.const nvAux []) (.bvar 0)) + (.app (.const nvAux []) (.app (.const ``Nat.succ []) (.bvar 1))))))] + +/-- `aux2nested` for `NVTree`: the closed partial application `PVec NVTree` +(the index argument stays behind on each occurrence). -/ +def nvAuxValue : VExpr := .app (.const ``PVec []) (.const ``NVTree []) + +def cuFlatFamilies : List (Name × VExpr) := + [(``CURose, .sort (.succ (.succ .zero))), + (roseAux, .sort (.succ (.succ .zero)))] + +def cuFlatCtors : List (Name × VExpr) := + [(``CURose.node, .forallE (.const roseAux []) (.const ``CURose [])), + (roseAux ++ `nil, .const roseAux []), + (roseAux ++ `cons, + .forallE (.const ``CURose []) (.forallE (.const roseAux []) (.const roseAux [])))] + +/-- `aux2nested` for `CURose`: the block-level-free auxiliary constant +restores to `List` at the constant level `1`. -/ +def cuAuxValue : VExpr := .app (.const ``List [.succ .zero]) (.const ``CURose []) + +open Elab in +/-- Translate one flattened block and compare it with its pinned shape. -/ +def checkFlat09A (label : String) (main : Name) (lparams : List Name) (nparams : Nat) + (deps : List Name) (families ctors : List (Name × VExpr)) + (auxValues : List (Name × VExpr)) : MetaM (List VInductiveType) := do + let env ← getEnv + let src := sourceType09A env main + let kenv := Kernel.Environment.ofConstants (`_l4l09AFlat ++ main) (depMap09A env deps) + let .ok (flatTypes, aux) := runElim09A kenv lparams nparams [src] + | throwError "{label}: flattening failed" + let uvars := lparams.length + let mut vtypes : List VInductiveType := [] + let mut actualFamilies : List (Name × VExpr) := [] + let mut actualCtors : List (Name × VExpr) := [] + for t in flatTypes do + let vty ← Lean4Lean.Meta.ofExpr lparams {} t.type + actualFamilies := actualFamilies ++ [(t.name, vty)] + let mut vctors : List VConstVal := [] + for c in t.ctors do + let vc ← Lean4Lean.Meta.ofExpr lparams {} c.type + actualCtors := actualCtors ++ [(c.name, vc)] + vctors := vctors ++ [{ name := c.name, uvars, type := vc }] + vtypes := vtypes ++ [{ name := t.name, uvars, type := vty, ctors := vctors }] + unless actualFamilies == families do + throwError "{label}: flattened families differ from the pinned shape" + unless actualCtors == ctors do + throwError "{label}: flattened constructors differ from the pinned shape" + let mut actualValues : List (Name × VExpr) := [] + for (n, e) in aux do + actualValues := actualValues ++ [(n, ← Lean4Lean.Meta.ofExpr lparams {} e)] + unless actualValues == auxValues do + throwError "{label}: aux2nested values differ from the pinned shape" + return vtypes + +/-! ## P4: Theory viability, with acceptance behavior unchanged + +The flattened blocks are already inside the supported arbitrary-block +class, while the source declarations remain rejected by every current +analyzer and by the public transaction. -/ + +open Elab in +run_meta do + let checkViability (label : String) (main : Name) (lparams : List Name) + (nparams : Nat) (deps : List Name) (families ctors : List (Name × VExpr)) + (auxValues : List (Name × VExpr)) : MetaM Unit := do + let vtypes ← checkFlat09A label main lparams nparams deps families ctors auxValues + let uvars := lparams.length + let flatDecl : VInductDecl := { uvars, nparams, types := vtypes } + unless flatDecl.stage3 do + throwError "{label}: flattened block rejected by the block analyzer" + unless flatDecl.identityBlockGeneration?.isSome do + throwError "{label}: flattened block is not generation-ready" + let env ← getEnv + let src := sourceType09A env main + let vsrcTy ← Lean4Lean.Meta.ofExpr lparams {} src.type + let mut vctors : List VConstVal := [] + for c in src.ctors do + vctors := vctors ++ [{ name := c.name, uvars, type := ← Lean4Lean.Meta.ofExpr lparams {} c.type }] + let srcTy : VInductiveType := { name := main, uvars, type := vsrcTy, ctors := vctors } + let srcDecl : VInductDecl := { uvars, nparams, types := [srcTy] } + if srcDecl.stage3 then + throwError "{label}: source declaration unexpectedly accepted by stage3" + if srcDecl.checked?.isSome then + throwError "{label}: source declaration unexpectedly accepted by checked?" + if (VEnv.empty.addInduct srcDecl).isSome then + throwError "{label}: source declaration unexpectedly accepted by addInduct" + checkViability "rose" ``RoseTree [`u] 1 roseDeps + roseFlatFamilies roseFlatCtors [(roseAux, roseAuxValue)] + checkViability "nv" ``NVTree [] 0 nvDeps + nvFlatFamilies nvFlatCtors [(nvAux, nvAuxValue)] + checkViability "cu" ``CURose [] 0 roseDeps + cuFlatFamilies cuFlatCtors [(roseAux, cuAuxValue)] + +/-! ## P5: the restoration substitution σ + +`restoreV09A` mirrors `ElimNestedInductive.Result.restoreNested` on +`VExpr`. It is probe-local: the L4L-09C artifact path must define the +total Theory version (with a simultaneous parameter substitution once +`nparams > 1` is in scope; the probe fixtures have `nparams ≤ 1`, where +iterated `VExpr.inst` coincides with it). -/ + +structure AuxSpec09A where + aux : Name + np : Nat + value : VExpr + recName : Name + +def instParams09A (value : VExpr) : List VExpr → VExpr + | [] => value + | [a] => value.inst a + | _ => panic! "the probe fixtures have nparams ≤ 1" + +def findCtorSpec09A (specs : List AuxSpec09A) (c : Name) : Option (AuxSpec09A × Name) := + specs.findSome? fun spec => + if spec.aux.isPrefixOf c && c != spec.aux then + some (spec, c.replacePrefix spec.aux .anonymous) + else none + +/-- σ. The recursor-rename case is checked before the constructor-prefix +case, exactly like `restoreNested`'s `auxRec` map: an auxiliary recursor +name is prefixed by its auxiliary family name and would otherwise be +mangled by the constructor branch. -/ +partial def restoreV09A (specs : List AuxSpec09A) (recMap : List (Name × Name)) : + VExpr → VExpr + | .bvar i => .bvar i + | .sort l => .sort l + | .lam ty body => .lam (restoreV09A specs recMap ty) (restoreV09A specs recMap body) + | .forallE ty body => + .forallE (restoreV09A specs recMap ty) (restoreV09A specs recMap body) + | e@(.app ..) => restoreSpine (VExpr.appHead e) (e.appArgs []) + | e@(.const ..) => restoreSpine e [] + where + restoreSpine (head : VExpr) (args : List VExpr) : VExpr := + let args' := args.map (restoreV09A specs recMap) + match head with + | .const c ls => + match recMap.find? (·.1 == c) with + | some (_, newName) => (VExpr.const newName ls).appN args' + | none => + match specs.find? (·.aux == c) with + | some spec => + (instParams09A spec.value (args'.take spec.np)).appN (args'.drop spec.np) + | none => + match findCtorSpec09A specs c with + | some (spec, suffix) => + let value := instParams09A spec.value (args'.take spec.np) + match VExpr.appHead value with + | .const iname ils => + (VExpr.const (iname ++ suffix) ils).appN + (value.appArgs [] ++ args'.drop spec.np) + | _ => panic! "auxiliary value head is not a constant" + | none => (VExpr.const c ls).appN args' + | h => (restoreV09A specs recMap h).appN args' + +open Elab in +/-- σ over the flattened block's existing generation artifacts reproduces +the stored kernel metadata exactly: recursor names and types, and every +rule RHS in the globally flattened order, with no auxiliary constant in +the image. Constructor types are restored with the declaration-world +value; recursor artifacts use the value spliced by the elimination +offset. -/ +def checkRestore09A (label : String) (main : Name) (lparams : List Name) + (nparams : Nat) (deps : List Name) : MetaM Unit := do + let env ← getEnv + let src := sourceType09A env main + let kenv := Kernel.Environment.ofConstants (`_l4l09ARestore ++ main) (depMap09A env deps) + let .ok (flatTypes, aux) := runElim09A kenv lparams nparams [src] + | throwError "{label}: flattening failed" + let uvars := lparams.length + let mut vtypes : List VInductiveType := [] + for t in flatTypes do + let vty ← Lean4Lean.Meta.ofExpr lparams {} t.type + let mut vctors : List VConstVal := [] + for c in t.ctors do + vctors := vctors ++ [{ name := c.name, uvars, type := ← Lean4Lean.Meta.ofExpr lparams {} c.type }] + vtypes := vtypes ++ [{ name := t.name, uvars, type := vty, ctors := vctors }] + let flatDecl : VInductDecl := { uvars, nparams, types := vtypes } + let some gen := flatDecl.identityBlockGeneration? + | throwError "{label}: flattened block is not generation-ready" + let elimOffset := gen.recUvars - uvars + let mut declSpecs : List AuxSpec09A := [] + let mut recSpecs : List AuxSpec09A := [] + let mut recMap : List (Name × Name) := [] + let mut i := 1 + for t in flatTypes.drop 1 do + let some (_, value) := aux.find? (·.1 == t.name) + | throwError "{label}: no aux2nested value for {t.name}" + let v ← Lean4Lean.Meta.ofExpr lparams {} value + let recName := (mkRecName main).appendIndexAfter i + let recValue := v.instL (VLevel.params' uvars elimOffset) + declSpecs := declSpecs ++ [{ aux := t.name, np := nparams, value := v, recName }] + recSpecs := recSpecs ++ [{ aux := t.name, np := nparams, value := recValue, recName }] + recMap := recMap ++ [(mkRecName t.name, recName)] + i := i + 1 + let auxConsts := declSpecs.map (·.aux) ++ recMap.map (·.1) ++ + (flatTypes.drop 1).flatMap (fun t => t.ctors.map (·.name)) + -- declaration-world σ: restored source constructors + for (t, vt) in flatTypes.zip vtypes do + if t.name == main then + for c in vt.ctors do + let some stored := env.find? c.name | throwError "{label}: {c.name} not stored" + let storedType ← Lean4Lean.Meta.ofExpr stored.levelParams {} + (← Lean4Lean.Meta.expandExpr stored.type) + unless restoreV09A declSpecs recMap c.type == storedType do + throwError "{label}: σ(flattened {c.name}) differs from the stored type" + -- recursor-world σ: recursor types, names, and every rule RHS + let expectedNames := [mkRecName main] ++ recSpecs.map (·.recName) + for (r, expected) in gen.recursors.zip expectedNames do + let restoredName := match recMap.find? (·.1 == r.name) with + | some (_, n) => n + | none => r.name + unless restoredName == expected do + throwError "{label}: restored recursor name {restoredName}, expected {expected}" + let some (.recInfo stored) := env.find? expected + | throwError "{label}: stored recursor {expected} missing" + let storedType ← Lean4Lean.Meta.ofExpr stored.levelParams {} + (← Lean4Lean.Meta.expandExpr stored.type) + let restored := restoreV09A recSpecs recMap r.type + unless restored == storedType do + throwError "{label}: σ(recursor type) differs from stored for {expected}" + unless !VExpr.hasAnyConst auxConsts restored do + throwError "{label}: auxiliary constant survives σ in the type of {expected}" + let mut storedRules : List (Name × Expr) := [] + for n in expectedNames do + let some (.recInfo stored) := env.find? n + | throwError "{label}: stored recursor {n} missing" + for rule in stored.rules do + storedRules := storedRules ++ [(rule.ctor, rule.rhs)] + let genRules := gen.generatedRules + unless storedRules.length == genRules.length do + throwError "{label}: {genRules.length} generated rules, {storedRules.length} stored" + let some (.recInfo mainRec) := env.find? (mkRecName main) + | throwError "{label}: stored main recursor missing" + for (df, (ctor, storedRhs)) in genRules.zip storedRules do + let storedRhs ← Lean4Lean.Meta.ofExpr mainRec.levelParams {} + (← Lean4Lean.Meta.expandExpr storedRhs) + let restoredRhs := restoreV09A recSpecs recMap df.rhs + unless restoredRhs == storedRhs do + throwError "{label}: σ(rule rhs) differs from stored for {ctor}" + unless !VExpr.hasAnyConst auxConsts restoredRhs && + !VExpr.hasAnyConst auxConsts (restoreV09A recSpecs recMap df.lhs) do + throwError "{label}: auxiliary constant survives σ in the rule for {ctor}" + +run_meta do + checkRestore09A "rose" ``RoseTree [`u] 1 roseDeps + checkRestore09A "nv" ``NVTree [] 0 nvDeps + checkRestore09A "cu" ``CURose [] 0 roseDeps + +end Lean4Lean.NestedRepresentation diff --git a/Lean4Lean/Verify/Environment/NestedTransformation.lean b/Lean4Lean/Verify/Environment/NestedTransformation.lean new file mode 100644 index 00000000..320fed6f --- /dev/null +++ b/Lean4Lean/Verify/Environment/NestedTransformation.lean @@ -0,0 +1,383 @@ +import Lean4Lean.Verify.Environment.NestedRepresentation +import Lean4Lean.Theory.NestedInductiveFixtures + +/-! +# Nested flattening differential (L4L-09B) + +Ties the Theory transformation `nestedElimination?` to the implementation: + +- the hand-written `List` target block in the Theory fixtures is exactly + Lean's stored metadata; +- on the real rose-tree, nested-indexed, and constant-universe fixtures, + the Theory flattening reproduces the port's `ElimNestedInductive` output + family for family, constructor for constructor, and specification for + `aux2nested` binding — including the canonical auxiliary names — and its + auxiliary count equals the stored `numNested`; +- Theory acceptance (`nestedStage3`) agrees with kernel acceptance on the + positives and on the nearest rejections: a parametric argument touching + a constructor-local binder (rejected by flattening itself, with the + kernel's exact error), an off-spine parametric application (rejected by + the unchanged block analyzer where the kernel fails constructor + checking), an in-block collision with the canonical auxiliary name + (rejected by `blockNamesOK` where the kernel's `checkName` rejects the + duplicate insertion), and a missing target declaration. +-/ + +namespace Lean4Lean.NestedTransformation + +open Lean +open Lean4Lean.NestedRepresentation +open Lean4Lean.NestedInductiveFixtures +open VInductDecl + +/-! ## The hand-written `List` target is the stored metadata -/ + +def listNilStoredType : VExpr := nestedConstVType09A% List.nil +def listConsStoredType : VExpr := nestedConstVType09A% List.cons +def listStoredType : VExpr := nestedConstVType09A% List + +#guard listTarget.families.map (·.name) == [``List] +#guard listTarget.nparams == 1 +#guard listTarget.families.map (·.type) == [listStoredType] +#guard listTarget.families.map (·.ctors.map fun c => (c.name, c.uvars, c.type)) == + [[(``List.nil, 1, listNilStoredType), (``List.cons, 1, listConsStoredType)]] + +/-! ## Real-metadata target blocks -/ + +def pvecStoredTarget : NestedTargetBlock where + nparams := 1 + families := + [{ name := ``PVec + uvars := 0 + type := nestedConstVType09A% PVec + ctors := + [⟨⟨0, nestedConstVType09A% PVec.nil⟩, ``PVec.nil⟩, + ⟨⟨0, nestedConstVType09A% PVec.cons⟩, ``PVec.cons⟩] }] + +/-! ## Shared translation plumbing -/ + +open Elab in +/-- Translate a list of kernel `InductiveType`s into a `VInductDecl`. -/ +def toVInductDecl09B (lparams : List Name) (nparams : Nat) + (types : List InductiveType) : MetaM VInductDecl := do + let uvars := lparams.length + let mut vtypes : List VInductiveType := [] + for t in types do + let vty ← Lean4Lean.Meta.ofExpr lparams {} t.type + let mut vctors : List VConstVal := [] + for c in t.ctors do + vctors := vctors ++ [⟨⟨uvars, ← Lean4Lean.Meta.ofExpr lparams {} c.type⟩, c.name⟩] + vtypes := vtypes ++ [{ name := t.name, uvars, type := vty, ctors := vctors }] + return { uvars, nparams, types := vtypes } + +open Elab in +/-- Check that the Theory flattening of one real source declaration equals +the port's flattening, that its specifications are the translated +`aux2nested` bindings, and that its auxiliary count is the stored +`numNested`. -/ +def checkFlattenParity (label : String) (main : Name) (lparams : List Name) + (nparams : Nat) (deps : List Name) (targets : List NestedTargetBlock) : + MetaM Unit := do + let env ← getEnv + let src := sourceType09A env main + let kenv := Kernel.Environment.ofConstants (`_l4l09B ++ main) (depMap09A env deps) + let .ok (flatTypes, aux) := runElim09A kenv lparams nparams [src] + | throwError "{label}: port flattening failed" + let sourceV ← toVInductDecl09B lparams nparams [src] + let portFlatV ← toVInductDecl09B lparams nparams flatTypes + let some elim := nestedElimination? targets sourceV + | throwError "{label}: Theory flattening failed" + unless elim.flat == portFlatV do + throwError "{label}: Theory flattened block differs from the port's" + unless elim.specs.length == aux.length do + throwError "{label}: {elim.specs.length} specs vs {aux.length} aux2nested bindings" + for spec in elim.specs do + let some (_, value) := aux.find? (·.1 == spec.aux) + | throwError "{label}: no aux2nested binding for {spec.aux}" + let valueV ← Lean4Lean.Meta.ofExpr lparams {} value + unless spec.value == valueV do + throwError "{label}: spec value for {spec.aux} differs from aux2nested" + let .const target ls := VExpr.appHead valueV + | throwError "{label}: aux2nested head is not a constant" + unless spec.target == target && spec.levels == ls && + spec.values == valueV.appArgs [] do + throwError "{label}: spec decomposition differs for {spec.aux}" + let some (.inductInfo stored) := env.find? main + | throwError "{label}: stored inductive missing" + unless elim.numNested == stored.numNested do + throwError "{label}: numNested {elim.numNested} vs stored {stored.numNested}" + unless nestedStage3 targets sourceV do + throwError "{label}: Theory acceptance rejected an accepted declaration" + +run_meta do + checkFlattenParity "rose" ``RoseTree [`u] 1 roseDeps [listTarget] + checkFlattenParity "nv" ``NVTree [] 0 nvDeps [pvecStoredTarget] + checkFlattenParity "cu" ``CURose [] 0 roseDeps [listTarget] + +/-! ## Rejection differentials + +Each negative is written once at the kernel `Expr` level and once as a +`VInductDecl`; the kernel run and the Theory gate must both reject. -/ + +def natDeps09B (env : Environment) : ConstMap := + depMap09A env [``Nat, ``Nat.zero, ``Nat.succ, ``List, ``List.nil, ``List.cons] + +/-- `inductive Loose0 | node : (n : Nat) → List (Loose0 n) → Loose0` — the +parametric argument mentions the constructor-local `n`. -/ +def looseDecl : Declaration := + .inductDecl [] 0 + [{ name := `Loose0 + type := .sort 1 + ctors := [{ + name := `Loose0.node + type := .forallE `n (.const ``Nat []) + (.forallE `t + (mkApp (mkConst ``List [.zero]) (.app (.const `Loose0 []) (.bvar 0))) + (.const `Loose0 []) .default) .default }] }] + false + +def looseSourceV : VInductDecl where + uvars := 0 + nparams := 0 + types := + [{ name := `Loose0 + uvars := 0 + type := .sort (.succ .zero) + ctors := + [⟨⟨0, .forallE (.const ``Nat []) + (.forallE (.app (.const ``List [.zero]) + (.app (.const `Loose0 []) (.bvar 0))) + (.const `Loose0 []))⟩, `Loose0.node⟩] }] + +/-- `inductive Bad0N | node : Bad0N → List (Bad0N Nat.zero) → Bad0N` — the +parametric argument applies a block family off the parameter spine. -/ +def badAppDecl : Declaration := + .inductDecl [] 0 + [{ name := `Bad0N + type := .sort 1 + ctors := [{ + name := `Bad0N.node + type := .forallE `x (.const `Bad0N []) + (.forallE `t + (mkApp (mkConst ``List [.zero]) + (.app (.const `Bad0N []) (.const ``Nat.zero []))) + (.const `Bad0N []) .default) .default }] }] + false + +def badAppSourceV : VInductDecl where + uvars := 0 + nparams := 0 + types := + [{ name := `Bad0N + uvars := 0 + type := .sort (.succ .zero) + ctors := + [⟨⟨0, .forallE (.const `Bad0N []) + (.forallE (.app (.const ``List [.zero]) + (.app (.const `Bad0N []) (.const ``Nat.zero []))) + (.const `Bad0N []))⟩, `Bad0N.node⟩] }] + +/-- A two-family source whose second family occupies the canonical first +auxiliary name `_nested.List_1`. -/ +def collisionDecl : Declaration := + let rose := fun a => mkApp (mkConst `Rose0 [.param `u]) a + .inductDecl [`u] 1 + [{ name := `Rose0 + type := .forallE `α (.sort (.succ (.param `u))) (.sort (.succ (.param `u))) .default + ctors := [{ + name := `Rose0.node + type := .forallE `α (.sort (.succ (.param `u))) + (.forallE `t (mkApp (mkConst ``List [.param `u]) (rose (.bvar 0))) + (rose (.bvar 1)) .default) .default }] }, + { name := (`_nested ++ ``List).appendIndexAfter 1 + type := .forallE `α (.sort (.succ (.param `u))) (.sort (.succ (.param `u))) .default + ctors := [] }] + false + +def collisionSourceV : VInductDecl where + uvars := 1 + nparams := 1 + types := + [{ name := `Rose0 + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + ctors := + [⟨⟨1, .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const ``List [.param 0]) + (.app (.const `Rose0 [.param 0]) (.bvar 1))) + (.app (.const `Rose0 [.param 0]) (.bvar 2))))⟩, `Rose0.node⟩] }, + { name := (`_nested ++ ``List).appendIndexAfter 1 + uvars := 1 + type := .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))) + ctors := [] }] + +open Elab in +run_meta do + let env ← getEnv + let deps := natDeps09B env + let kenv := Kernel.Environment.ofConstants `_l4l09BNeg deps + -- the loose parametric argument rejects in flattening, with the kernel's + -- exact diagnostic + match Lean4Lean.addDecl kenv looseDecl with + | .ok _ => throwError "loose: kernel accepted a local-variable parametric argument" + | .error (.other msg) => + unless msg == "invalid nested inductive datatype 'List', \ + nested inductive datatypes parameters cannot contain local variables." do + throwError "loose: unexpected kernel diagnostic {msg}" + | .error _ => throwError "loose: unexpected kernel error shape" + unless (nestedElimination? [listTarget] looseSourceV).isNone do + throwError "loose: Theory flattening accepted" + unless !nestedStage3 [listTarget] looseSourceV do + throwError "loose: Theory gate accepted" + -- the off-spine parametric application flattens but fails checking + match Lean4Lean.addDecl kenv badAppDecl with + | .ok _ => throwError "badApp: kernel accepted an off-spine parametric application" + | .error _ => pure () + unless (nestedElimination? [listTarget] badAppSourceV).isSome do + throwError "badApp: Theory flattening should succeed" + unless !nestedStage3 [listTarget] badAppSourceV do + throwError "badApp: Theory gate accepted" + -- the canonical-name collision rejects at insertion (kernel) and at + -- `blockNamesOK` (Theory) + match Lean4Lean.addDecl kenv collisionDecl with + | .ok _ => throwError "collision: kernel accepted a duplicate auxiliary name" + | .error _ => pure () + unless (nestedElimination? [listTarget] collisionSourceV).isSome do + throwError "collision: Theory flattening should succeed" + unless !nestedStage3 [listTarget] collisionSourceV do + throwError "collision: Theory gate accepted" + -- a missing target declaration rejects on both sides + let kenvNoList := Kernel.Environment.ofConstants `_l4l09BNoList + (depMap09A env [``Nat, ``Nat.zero, ``Nat.succ]) + let roseSrc := sourceType09A env ``RoseTree + match Lean4Lean.Environment.addInductive kenvNoList [`u] 1 [roseSrc] false false with + | .ok _ => throwError "noTarget: kernel accepted without the List declaration" + | .error _ => pure () + let roseV ← toVInductDecl09B [`u] 1 [roseSrc] + unless !nestedStage3 [] roseV do + throwError "noTarget: Theory gate accepted without target metadata" + +/-! ## Restoration parity (L4L-09C) + +The Theory restoration over the flattened block's generation artifacts +reproduces Lean's stored metadata exactly: every restored recursor name, +universe count, and type, and every rule RHS in the globally flattened +order, on all three real fixtures. This runs the product σ +(`NestedBlockChecked.recursors`/`generatedRules`), not the L4L-09A design +probe. -/ + +open Elab in +def checkRestoreParity (label : String) (main : Name) (lparams : List Name) + (nparams : Nat) (targets : List NestedTargetBlock) : MetaM Unit := do + let env ← getEnv + let src := sourceType09A env main + let sourceV ← toVInductDecl09B lparams nparams [src] + let some nested := nestedBlockChecked? targets sourceV + | throwError "{label}: nested acceptance failed" + let expectedNames := [mkRecName main] ++ + nested.elim.specs.mapIdx fun i _ => (mkRecName main).appendIndexAfter (i + 1) + unless nested.recursors.length == expectedNames.length do + throwError "{label}: {nested.recursors.length} restored recursors, \ + expected {expectedNames.length}" + for (r, expected) in nested.recursors.zip expectedNames do + unless r.name == expected do + throwError "{label}: restored recursor name {r.name}, expected {expected}" + let some (.recInfo stored) := env.find? expected + | throwError "{label}: stored recursor {expected} missing" + unless r.uvars == stored.levelParams.length do + throwError "{label}: recursor universe count differs for {expected}" + let storedType ← Lean4Lean.Meta.ofExpr stored.levelParams {} + (← Lean4Lean.Meta.expandExpr stored.type) + unless r.type == storedType do + throwError "{label}: restored recursor type differs from stored for {expected}" + let mut storedRules : List (Name × Expr) := [] + for n in expectedNames do + let some (.recInfo stored) := env.find? n + | throwError "{label}: stored recursor {n} missing" + for rule in stored.rules do + storedRules := storedRules ++ [(rule.ctor, rule.rhs)] + let rules := nested.generatedRules + unless rules.length == storedRules.length do + throwError "{label}: {rules.length} restored rules, stored {storedRules.length}" + let some (.recInfo mainRec) := env.find? (mkRecName main) + | throwError "{label}: stored main recursor missing" + for (df, (ctor, storedRhs)) in rules.zip storedRules do + let storedRhsV ← Lean4Lean.Meta.ofExpr mainRec.levelParams {} + (← Lean4Lean.Meta.expandExpr storedRhs) + unless df.rhs == storedRhsV do + throwError "{label}: restored rule RHS differs from stored for {ctor}" + +run_meta do + checkRestoreParity "rose" ``RoseTree [`u] 1 [listTarget] + checkRestoreParity "nv" ``NVTree [] 0 [pvecStoredTarget] + checkRestoreParity "cu" ``CURose [] 0 [listTarget] + +/-! ## Real-output round-trip (L4L-09C) + +Run the port's complete `Environment.addInductive` on a dependency-only +kernel environment and compare its entire output — not the ambient +elaborator metadata — against the Theory nested artifacts: the stored +payload against the source constants, and every emitted recursor's name, +universe count, type, rule constructors, rule field counts, and rule RHSs +against the restored inventory. Nothing in this comparison is +hand-authored: the left side is real `Inductive.Add.run`-derived output +and the right side is computed by `nestedBlockChecked?`. -/ + +open Elab in +def checkOutputRoundTrip (label : String) (main : Name) (lparams : List Name) + (nparams : Nat) (deps : List Name) (targets : List NestedTargetBlock) : + MetaM Unit := do + let env ← getEnv + let src := sourceType09A env main + let kenv := Kernel.Environment.ofConstants (`_l4l09C ++ main) (depMap09A env deps) + let .ok kout := Lean4Lean.Environment.addInductive kenv lparams nparams [src] false false + | throwError "{label}: port addInductive failed" + let sourceV ← toVInductDecl09B lparams nparams [src] + let some nested := nestedBlockChecked? targets sourceV + | throwError "{label}: nested acceptance failed" + -- the stored payload: families and constructors + for tyV in sourceV.types do + let some (.inductInfo out) := kout.find? tyV.name + | throwError "{label}: output family {tyV.name} missing" + let outType ← Lean4Lean.Meta.ofExpr out.levelParams {} (← Lean4Lean.Meta.expandExpr out.type) + unless out.levelParams.length == tyV.uvars && outType == tyV.type do + throwError "{label}: output family metadata differs for {tyV.name}" + unless out.numNested == nested.elim.numNested do + throwError "{label}: output numNested {out.numNested} vs \ + artifact {nested.elim.numNested}" + for cV in tyV.ctors do + let some (.ctorInfo outC) := kout.find? cV.name + | throwError "{label}: output constructor {cV.name} missing" + let outCType ← Lean4Lean.Meta.ofExpr outC.levelParams {} + (← Lean4Lean.Meta.expandExpr outC.type) + unless outC.levelParams.length == cV.uvars && outCType == cV.type do + throwError "{label}: output constructor metadata differs for {cV.name}" + -- the restored recursors and their rules, in inventory order + let mut ruleIdx := 0 + let rules := nested.generatedRules + for r in nested.recursors do + let some (.recInfo out) := kout.find? r.name + | throwError "{label}: output recursor {r.name} missing" + let outType ← Lean4Lean.Meta.ofExpr out.levelParams {} (← Lean4Lean.Meta.expandExpr out.type) + unless out.levelParams.length == r.uvars && outType == r.type do + throwError "{label}: output recursor metadata differs for {r.name}" + unless out.k == nested.generation.kTarget do + throwError "{label}: output recursor K flag differs for {r.name}" + for rule in out.rules do + let some df := rules[ruleIdx]? + | throwError "{label}: more output rules than restored rules" + let outRhs ← Lean4Lean.Meta.ofExpr out.levelParams {} + (← Lean4Lean.Meta.expandExpr rule.rhs) + unless outRhs == df.rhs do + throwError "{label}: output rule RHS differs for {rule.ctor}" + ruleIdx := ruleIdx + 1 + unless ruleIdx == rules.length do + throwError "{label}: {rules.length} restored rules, output consumed {ruleIdx}" + +run_meta do + checkOutputRoundTrip "rose" ``RoseTree [`u] 1 roseDeps [listTarget] + checkOutputRoundTrip "nv" ``NVTree [] 0 nvDeps [pvecStoredTarget] + checkOutputRoundTrip "cu" ``CURose [] 0 roseDeps [listTarget] + +end Lean4Lean.NestedTransformation diff --git a/Lean4Lean/Verify/Environment/Normalization.lean b/Lean4Lean/Verify/Environment/Normalization.lean index b5a87ea6..b3a5f5bd 100644 --- a/Lean4Lean/Verify/Environment/Normalization.lean +++ b/Lean4Lean/Verify/Environment/Normalization.lean @@ -2039,6 +2039,46 @@ def CandidateExprSemanticRootInput.semanticOfIdentity simpa only [input.venv_eq, input.lparams_eq, input.vlctx_eq] using recursive +/-- Interpret a staged root at the deterministic translation of its +checker-selected view. For a projection-free view the recursive semantic +run's endpoint is pinned by strict-translation agreement +(`CandidateExprRun.view_tr_strict` plus `TrExprS.trExprS?_eq`), so the +retained `view` field is computed by `trExprS?` and the `Nonempty` +interpretation is transferred onto it; no choice operator selects data. +Unlike `semanticOfIdentity` this covers non-identity normalizations, at the +cost of the executable view-uniqueness certificate. -/ +def CandidateExprSemanticRootInput.semanticOfUnique + {env : VEnv} {Us : List Name} {source : Expr} + {candidate : AddInductive.CandidateExpr source} {source' : VExpr} + (input : CandidateExprSemanticRootInput env Us candidate source') + (unique : CandidateExprTraceViewIsUnique candidate.trace) : + CandidateExprSemanticRootRun env Us candidate source' := + match hview : trExprS? Us [] candidate.trace.view with + | some view => + { contextRun := input.contextRun + venv_eq := input.venv_eq + lparams_eq := input.lparams_eq + vlctx_eq := input.vlctx_eq + source_tr := input.source_tr + whnfFuel := input.whnfFuel + whnfDepth := input.whnfDepth + view := view + recursive := by + obtain ⟨w⟩ := input.exists + obtain ⟨inferred, run⟩ := w.recursive + cases Option.some.inj + (((run.view_tr_strict unique).trExprS?_eq unique.view).symm.trans + hview) + exact ⟨inferred, run⟩ } + | none => + absurd + (show (trExprS? Us [] candidate.trace.view).isSome by + obtain ⟨w⟩ := input.exists + obtain ⟨inferred, run⟩ := w.recursive + exact TrExprS.trExprS?_isSome + ⟨w.view, run.view_tr_strict unique⟩ unique.view) + (by simp [hview]) + /-- One explicitly verified root stage shared by every candidate expression interpreted before or after family insertion. @@ -3585,6 +3625,10 @@ structure CandidateFamilyStagedInput typeEnv : VEnv addInduct : AddInductConstant .induct familyContext.env.constants env raw.toVConstVal constructorContext.env.constants typeEnv + /-- The staged family environment has not yet completed a new projection + artifact; any already-complete host structure remains backed by a registered + Theory view. -/ + projectionReady : ProjectionReady constructorContext.env typeEnv family_lctx_eq : familyContext.lctx = {} constructorContext_eq : constructorContext = { familyContext with env := constructorContext.env } @@ -3648,6 +3692,7 @@ def CandidateFamilyStagedInput.postContext rw [input.constructorContext_eq]] rw [input.quotInit_eq] exact postTr + projectionReady := input.projectionReady mlctx := .nil mlctx_wf := trivial lctx_eq := by @@ -3765,6 +3810,7 @@ theorem CandidateFamilyStagedInput.validationContextRunFromPre have postVenv : input.postContext.venv = input.typeEnv := rfl simpa only [validationSafety, postEnv, postVenv] using input.postContext.trenv + projectionReady := input.postContext.projectionReady mlctx_wf := by simpa only [terminalLparams] using postMLWF } have validationContextEq : validationContext.toContext = @@ -5422,7 +5468,6 @@ info: 'Lean4Lean.TypeChecker.VEnv.addConst_other' depends on axioms: [propext, Q /-- info: 'Lean4Lean.TypeChecker.AddInductConstant.safePrimitives' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -5433,46 +5478,31 @@ info: 'Lean4Lean.TypeChecker.AddInductConstant.safePrimitives' depends on axioms #print axioms TypeChecker.AddInductConstant.safePrimitives /-- -info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_env' depends on axioms: [propext, - sorryAx, - Classical.choice, - Quot.sound] +info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_env' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TypeChecker.CandidateContextRun.context_env /-- -info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_lctx' depends on axioms: [propext, - sorryAx, - Classical.choice, - Quot.sound] +info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_lctx' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TypeChecker.CandidateContextRun.context_lctx /-- -info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_safety' depends on axioms: [propext, - sorryAx, - Classical.choice, - Quot.sound] +info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_safety' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TypeChecker.CandidateContextRun.context_safety /-- -info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_lparams' depends on axioms: [propext, - sorryAx, - Classical.choice, - Quot.sound] +info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_lparams' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TypeChecker.CandidateContextRun.context_lparams /-- -info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_fuel' depends on axioms: [propext, - sorryAx, - Classical.choice, - Quot.sound] +info: 'Lean4Lean.TypeChecker.CandidateContextRun.context_fuel' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TypeChecker.CandidateContextRun.context_fuel @@ -5545,7 +5575,6 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.source_isType_of_termi /-- info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.viewParameters' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -5554,7 +5583,6 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.viewParameters' depend /-- info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.viewIndices' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -5562,7 +5590,7 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.viewIndices' depends o #print axioms TypeChecker.CandidateExprSemanticRootRun.viewIndices /-- -info: 'Lean4Lean.VInductDecl.CandidateFamilyStagedInput' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.VInductDecl.CandidateFamilyStagedInput' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms CandidateFamilyStagedInput @@ -5980,7 +6008,6 @@ info: 'Lean4Lean.VInductDecl.normalizationCandidateGenerationShape' depends on a /-- info: 'Lean4Lean.VInductDecl.CandidateConstructorSemanticGenerationShapeList.ofCheck' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -5989,7 +6016,6 @@ info: 'Lean4Lean.VInductDecl.CandidateConstructorSemanticGenerationShapeList.ofC /-- info: 'Lean4Lean.VInductDecl.NormalizationCandidateSemanticRun.generationShape' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6075,7 +6101,6 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateSemanticRun.producedPackage' dep /-- info: 'Lean4Lean.TypeChecker.VState.WF.empty_of_reserves' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -6096,7 +6121,6 @@ info: 'Lean4Lean.TypeChecker.candidateFreshFVarId_reserved' depends on axioms: [ /-- info: 'Lean4Lean.TypeChecker.CandidateContextRun.root' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -6108,7 +6132,6 @@ info: 'Lean4Lean.TypeChecker.CandidateContextRun.root' depends on axioms: [prope /-- info: 'Lean4Lean.TypeChecker.CandidateContextRun.pushLocalDecl' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -6155,7 +6178,7 @@ info: 'Lean4Lean.TypeChecker.candidateCheckTypeStep_exists_translation' depends #print axioms TypeChecker.candidateCheckTypeStep_exists_translation /-- -info: 'Lean4Lean.TypeChecker.IsDefEqRun.ofCandidateStep' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.TypeChecker.IsDefEqRun.ofCandidateStep' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TypeChecker.IsDefEqRun.ofCandidateStep @@ -6201,7 +6224,6 @@ info: 'Lean4Lean.TypeChecker.candidateTypeAnnotation_fvarsIn' does not depend on /-- info: 'Lean4Lean.TypeChecker.candidateTypeAnnotation_exists_translation' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6275,19 +6297,19 @@ info: 'Lean4Lean.TypeChecker.CandidateExprRun.exists_ofCandidateFVars' depends o #print axioms TypeChecker.CandidateExprRun.exists_ofCandidateFVars /-- -info: 'Lean4Lean.TypeChecker.WhnfRun.ofCandidateStep' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.TypeChecker.WhnfRun.ofCandidateStep' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TypeChecker.WhnfRun.ofCandidateStep /-- -info: 'Lean4Lean.TypeChecker.CheckTypeRun.ofCandidateStep' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.TypeChecker.CheckTypeRun.ofCandidateStep' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TypeChecker.CheckTypeRun.ofCandidateStep /-- -info: 'Lean4Lean.TypeChecker.CandidateNodeRun.ofCandidate' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.TypeChecker.CandidateNodeRun.ofCandidate' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TypeChecker.CandidateNodeRun.ofCandidate @@ -6392,7 +6414,7 @@ info: 'Lean4Lean.TypeChecker.CandidateExprRun.evidence' depends on axioms: [prop #print axioms TypeChecker.CandidateExprRun.evidence /-- -info: 'Lean4Lean.TypeChecker.CandidateExprRun.source_tr' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.TypeChecker.CandidateExprRun.source_tr' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TypeChecker.CandidateExprRun.source_tr @@ -6497,7 +6519,7 @@ info: 'Lean4Lean.TypeChecker.TelDefEqEvidence.telDefEq' depends on axioms: [prop #print axioms TypeChecker.TelDefEqEvidence.telDefEq /-- -info: 'Lean4Lean.TypeChecker.TelDefEqEvidence.ofTelDefEq' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.TypeChecker.TelDefEqEvidence.ofTelDefEq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TypeChecker.TelDefEqEvidence.ofTelDefEq @@ -6603,7 +6625,6 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSpineRun.evidenceAt' depends on axioms /-- info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.normalization_eq' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6612,7 +6633,6 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.normalization_eq' depends on /-- info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.sourceType_eq' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6621,7 +6641,6 @@ info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.sourceType_eq' depends on /-- info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.familyViewType_eq' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6629,10 +6648,7 @@ info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.familyViewType_eq' depend #print axioms NormalizationCandidateRun.familyViewType_eq /-- -info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.familyView_eq' depends on axioms: [propext, - sorryAx, - Classical.choice, - Quot.sound] +info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.familyView_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms GenerationCandidateRun.familyView_eq @@ -6737,10 +6753,7 @@ info: 'Lean4Lean.VInductDecl.CandidateNormalizedCtorRun.rightType_ofChecked' dep #print axioms CandidateNormalizedCtorRun.rightType_ofChecked /-- -info: 'Lean4Lean.VInductDecl.CandidateNormalizedCtorRun.viewTel_eq' depends on axioms: [propext, - sorryAx, - Classical.choice, - Quot.sound] +info: 'Lean4Lean.VInductDecl.CandidateNormalizedCtorRun.viewTel_eq' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms CandidateNormalizedCtorRun.viewTel_eq @@ -6813,7 +6826,6 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.wf' depends on axioms: [prop /-- info: 'Lean4Lean.VInductDecl.CandidateConstructorListRun.sameHeaders' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6855,7 +6867,6 @@ info: 'Lean4Lean.VInductDecl.CandidateConstructorListRun.evidence' depends on ax /-- info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.normalization' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6962,17 +6973,13 @@ info: 'Lean4Lean.VInductDecl.GenerationRun.wf' depends on axioms: [propext, #print axioms GenerationRun.wf /-- -info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.package' depends on axioms: [propext, - sorryAx, - Classical.choice, - Quot.sound] +info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.package' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms GenerationCandidateRun.package /-- info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.producedPackage' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ diff --git a/Lean4Lean/Verify/Environment/NormalizationMatrix.lean b/Lean4Lean/Verify/Environment/NormalizationMatrix.lean index d9b4ce14..d90eb1f8 100644 --- a/Lean4Lean/Verify/Environment/NormalizationMatrix.lean +++ b/Lean4Lean/Verify/Environment/NormalizationMatrix.lean @@ -723,12 +723,12 @@ theorem normalizationMatrix_rec_lookup_unique : normalizationMatrixFinalEnv_rec_lookup /-! The semantic generation helpers used above are guarded in -`Theory.Typing.InductiveLemmas`; these two guards pin the separate transitional -Verify closure of metadata translation and final environment replay. -/ +`Theory.Typing.InductiveLemmas`; these two guards pin the separate, now +`sorryAx`-free Verify closure of metadata translation and final environment +replay. -/ /-- info: 'Lean4Lean.InductiveReplayFixtures.normalizationMatrixInfo_tr' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -737,7 +737,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.normalizationMatrixInfo_tr' depends on /-- info: 'Lean4Lean.InductiveReplayFixtures.normalizationMatrix_trEnv'' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, diff --git a/Lean4Lean/Verify/Environment/SingletonParityReplay.lean b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean index 2a5c6c21..8501ee68 100644 --- a/Lean4Lean/Verify/Environment/SingletonParityReplay.lean +++ b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean @@ -22,6 +22,7 @@ structure SingletonReplayArtifact where source : VInductDecl inputMap : ConstMap inputEnv : VEnv + inputMapWF : inputMap.WF outputMap : ConstMap outputEnv : VEnv inputOrdered : inputEnv.Ordered @@ -150,6 +151,7 @@ def natReplay07 : SingletonReplayArtifact where source := natDecl inputMap := {} inputEnv := .empty + inputMapWF := SMap.WF.empty outputMap := natMap outputEnv := natFinalEnv inputOrdered := .empty @@ -161,6 +163,7 @@ def eqReplay07 : SingletonReplayArtifact where source := eqDecl inputMap := {} inputEnv := .empty + inputMapWF := SMap.WF.empty outputMap := eqMap outputEnv := eqFinalEnv inputOrdered := .empty @@ -172,6 +175,7 @@ def accReplay07 : SingletonReplayArtifact where source := accDecl inputMap := {} inputEnv := .empty + inputMapWF := SMap.WF.empty outputMap := accMap outputEnv := accFinalEnv inputOrdered := .empty @@ -183,6 +187,7 @@ def aliasFormerReplay07 : SingletonReplayArtifact where source := aliasFormerRawDecl inputMap := typeFamilyAliasMap inputEnv := typeFamilyAliasEnv + inputMapWF := typeFamilyAliasMap_wf outputMap := aliasFormerMap outputEnv := aliasFormerFinalEnv inputOrdered := typeFamilyAliasEnv_ordered @@ -194,6 +199,7 @@ def aliasRecReplay07 : SingletonReplayArtifact where source := aliasRecRawDecl inputMap := recAliasMap inputEnv := recAliasEnv + inputMapWF := recAliasMap_wf outputMap := aliasRecMap outputEnv := aliasRecFinalEnv inputOrdered := recAliasEnv_ordered @@ -205,17 +211,19 @@ def normalizationMatrixReplay07 : SingletonReplayArtifact where source := normalizationMatrixRawDecl inputMap := matrixAliasMap inputEnv := normalizationMatrixAliasEnv + inputMapWF := matrixAliasMap_wf outputMap := normalizationMatrixMap outputEnv := normalizationMatrixFinalEnv inputOrdered := normalizationMatrixAliasEnv_ordered transaction := normalizationMatrix_addInduct aligned := normalizationMatrix_aligned -noncomputable def annotatedPiReplay07 : SingletonReplayArtifact where +def annotatedPiReplay07 : SingletonReplayArtifact where label := ``AnnotatedPi source := annotatedPiRawDecl inputMap := _ inputEnv := outParamEnv + inputMapWF := annotatedReplayInputMap_wf outputMap := _ outputEnv := annotatedPiFinalEnv inputOrdered := outParamEnv_ordered @@ -227,6 +235,7 @@ def annotatedParamReplay07 : SingletonReplayArtifact where source := annotatedParamRawDecl inputMap := _ inputEnv := outParamEnv + inputMapWF := annotatedReplayInputMap_wf outputMap := _ outputEnv := annotatedParamFinalEnv inputOrdered := outParamEnv_ordered @@ -431,6 +440,7 @@ def boolReplay07 : SingletonReplayArtifact where source := boolDecl inputMap := {} inputEnv := .empty + inputMapWF := SMap.WF.empty outputMap := boolMap07 outputEnv := boolFinalEnv07 inputOrdered := .empty @@ -655,6 +665,7 @@ def listReplay07 : SingletonReplayArtifact where source := listDecl inputMap := {} inputEnv := .empty + inputMapWF := SMap.WF.empty outputMap := listMap07 outputEnv := listFinalEnv07 inputOrdered := .empty @@ -877,6 +888,7 @@ def optionReplay07 : SingletonReplayArtifact where source := optionDecl inputMap := {} inputEnv := .empty + inputMapWF := SMap.WF.empty outputMap := optionMap07 outputEnv := optionFinalEnv07 inputOrdered := .empty @@ -1051,6 +1063,7 @@ def prodReplay07 : SingletonReplayArtifact where source := prodDecl inputMap := {} inputEnv := .empty + inputMapWF := SMap.WF.empty outputMap := prodMap07 outputEnv := prodFinalEnv07 inputOrdered := .empty @@ -1219,6 +1232,7 @@ def andReplay07 : SingletonReplayArtifact where source := andDecl inputMap := {} inputEnv := .empty + inputMapWF := SMap.WF.empty outputMap := andMap07 outputEnv := andFinalEnv07 inputOrdered := .empty @@ -1437,6 +1451,7 @@ def orReplay07 : SingletonReplayArtifact where source := orDecl inputMap := {} inputEnv := .empty + inputMapWF := SMap.WF.empty outputMap := orMap07 outputEnv := orFinalEnv07 inputOrdered := .empty @@ -1602,6 +1617,7 @@ def heqReplay07 : SingletonReplayArtifact where source := heqDecl inputMap := {} inputEnv := .empty + inputMapWF := SMap.WF.empty outputMap := heqMap07 outputEnv := heqFinalEnv07 inputOrdered := .empty @@ -2053,6 +2069,7 @@ def finReplay07 : SingletonReplayArtifact where source := finDecl inputMap := finInputMap07 inputEnv := finInputEnv07 + inputMapWF := finInputMapWF07 outputMap := finMap07 outputEnv := finFinalEnv07 inputOrdered := finInputEnv_ordered07 @@ -2430,6 +2447,7 @@ def vectorReplay07 : SingletonReplayArtifact where source := vectorDecl inputMap := vectorInputMap07 inputEnv := vectorInputEnv07 + inputMapWF := vectorInputMapWF07 outputMap := vectorMap07 outputEnv := vectorFinalEnv07 inputOrdered := vectorInputEnv_ordered07 @@ -2570,6 +2588,7 @@ def punitReplay07 : SingletonReplayArtifact where source := punitDecl inputMap := {} inputEnv := .empty + inputMapWF := SMap.WF.empty outputMap := punitMap07 outputEnv := punitFinalEnv07 inputOrdered := .empty @@ -2669,6 +2688,7 @@ def emptyReplay07 : SingletonReplayArtifact where source := emptyDecl inputMap := {} inputEnv := .empty + inputMapWF := SMap.WF.empty outputMap := emptyMap07 outputEnv := emptyFinalEnv07 inputOrdered := .empty @@ -2686,13 +2706,13 @@ def singletonFixedReplays : List SingletonReplayArtifact := /-- The focused non-identity normalization rows use the same public replay artifact as the standard-library matrix. -/ -noncomputable def singletonNormalizationReplays : +def singletonNormalizationReplays : List SingletonReplayArtifact := [aliasFormerReplay07, aliasRecReplay07, normalizationMatrixReplay07, annotatedPiReplay07, annotatedParamReplay07] /-- The sole public L4L-07 environment replay inventory. -/ -noncomputable def singletonReplayMatrix : List SingletonReplayArtifact := +def singletonReplayMatrix : List SingletonReplayArtifact := singletonFixedReplays ++ singletonNormalizationReplays example : singletonFixedReplays.map (·.label) = @@ -2719,7 +2739,6 @@ example : singletonReplayMatrix.length = 19 := rfl /-- info: 'Lean4Lean.InductiveReplayFixtures.SingletonReplayArtifact.outputOrdered' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -2728,7 +2747,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.SingletonReplayArtifact.outputOrdered' /-- info: 'Lean4Lean.InductiveReplayFixtures.singletonFixedReplays' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, diff --git a/Lean4Lean/Verify/TypeChecker.lean b/Lean4Lean/Verify/TypeChecker.lean index 858cb755..4a4d98ae 100644 --- a/Lean4Lean/Verify/TypeChecker.lean +++ b/Lean4Lean/Verify/TypeChecker.lean @@ -16,6 +16,7 @@ structure VEnvs.WF (env : Environment) (ves : VEnvs) where safePrimitives : env.find? n = some ci → Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = [] mono : safety ≤ safety' → ves.venv safety' ≤ ves.venv safety + projectionReady : ProjectionReady env (ves.venv safety) namespace TypeChecker @@ -45,6 +46,7 @@ def VContext.mk' {env : Environment} {ves : VEnvs} (wf : ves.WF env) hasPrimitives := wf.hasPrimitives safePrimitives := wf.safePrimitives trenv := wf.tr + projectionReady := wf.projectionReady mlctx := .nil mlctx_wf := trivial lctx_eq := rfl diff --git a/Lean4Lean/Verify/TypeChecker/Basic.lean b/Lean4Lean/Verify/TypeChecker/Basic.lean index 6252d896..629d8b8f 100644 --- a/Lean4Lean/Verify/TypeChecker/Basic.lean +++ b/Lean4Lean/Verify/TypeChecker/Basic.lean @@ -101,6 +101,37 @@ theorem WF.weak' (wf : WF env Us Δ m) : WF env Us Δ' m where end EquivManager +/-- Exact alignment between one host structure record and the registered +Theory artifact used to interpret primitive projections. The positional +metadata is retained explicitly because ordinary constant translation checks +types but does not identify the kernel's parameter/constructor roles. -/ +structure ProjectionArtifact (env : Environment) (name : Name) + (info : InductiveVal) (venv : VEnv) where + view : VStructureView + name_eq : view.name = name + viewWF : view.WF venv + constructorInfo : ConstructorVal + constructor_find : env.find? view.constructorName = + some (.ctorInfo constructorInfo) + constructor_numParams_eq : constructorInfo.numParams = view.nparams + constructor_numFields_eq : constructorInfo.numFields = view.fields.length + levelParams_length : info.levelParams.length = view.uvars + numParams_eq : info.numParams = view.nparams + numIndices_eq : info.numIndices = 0 + ctors_eq : info.ctors = [view.constructorName] + rawResult_sort : ∃ resultLevel, + view.generation.block.rawResult = .sort resultLevel + programsWF : view.ProgramsWF venv + +/-- Every complete host structure accepted by projection inference is backed +by one coherent registered Theory artifact. This is deliberately separate +from constant translation: individually translated family, constructor, and +recursor constants do not by themselves identify one generation artifact. -/ +def ProjectionReady (env : Environment) (venv : VEnv) : Prop := + ∀ name info, env.find? name = some (.inductInfo info) → + env.isProjectionReadyStructure name = true → + Nonempty (ProjectionArtifact env name info venv) + namespace TypeChecker inductive MLCtx where @@ -193,6 +224,7 @@ structure VContext extends Context where safePrimitives : env.find? n = some ci → Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = [] trenv : TrEnv safety env venv + projectionReady : ProjectionReady env venv mlctx : MLCtx mlctx_wf : mlctx.WF venv lparams lctx_eq : mlctx.lctx = lctx @@ -954,3 +986,19 @@ theorem ensureSortCore.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : · let .sort _ := e exact .pure ⟨⟨_, rfl⟩, he, hb⟩ exact .getEnv <| .getLCtx .throw + +theorem getSortLevel.WF + (he : c.TrExprS e e') : (getSortLevel e).WF c s fun l _ => + ∃ u', VLevel.ofLevel c.lparams l = some u' ∧ c.HasType e' (.sort u') := by + refine (inferType.WF he).bind fun ty _ le ⟨ty', _, _, h1, h2⟩ => ?_ + refine (ensureSortCore.WF h1).bind fun ty _ le h => ?_ + obtain ⟨⟨u, rfl⟩, ⟨ty₂, h3, h4⟩, _⟩ := h + let .sort hu := h3 + exact .pure ⟨_, hu, h2.defeqU_r c.Ewf c.Δwf h4.symm⟩ + +theorem isProp.WF + (he : c.TrExprS e e') : (isProp e).WF c s fun b _ => + b → c.HasType e' (.sort .zero) := by + refine (getSortLevel.WF he).bind fun l _ le ⟨u', hu, h⟩ => .pure fun H => ?_ + exact h.defeqU_r c.Ewf c.Δwf + ⟨_, .sortDF (.of_ofLevel hu) trivial (ofLevel_isAlwaysZero hu H)⟩ diff --git a/Lean4Lean/Verify/TypeChecker/InferType.lean b/Lean4Lean/Verify/TypeChecker/InferType.lean index da5b6f01..075338e8 100644 --- a/Lean4Lean/Verify/TypeChecker/InferType.lean +++ b/Lean4Lean/Verify/TypeChecker/InferType.lean @@ -385,10 +385,571 @@ theorem inferLet.WF refine (c.withMLC_self ▸ inferLet.loop.WF (Nat.zero_le _) [] rfl rfl rfl rfl rfl ?_ hr) hinf exact fun P hP he => ⟨(AllAbove.wf wf.trctx.wf.fvwf).2 hP, he.mono fun _ h _ => h, fun _ => id⟩ +theorem AppStack.toSpineWF {c : VContext} + (H : AppStack c.venv c.lparams c.vlctx f f' args) + (hf : c.HasType f' (VExpr.forallN As C)) + (hlen : args.length = As.length) : + ∃ args', args.Forall₂ (c.TrExprS · ·) args' ∧ + c.venv.SpineWF c.lparams.length c.vlctx.toCtx + (VExpr.forallN As C) args' (VExpr.instRev C args') ∧ + c.TrExprS (f.mkAppList args) (VExpr.appN f' args') := by + induction args generalizing f f' As C with + | nil => + cases As with + | nil => + let .head hfull := H + exact ⟨[], .nil, rfl, by simpa⟩ + | cons _ _ => simp at hlen + | cons arg args ih => + cases As with + | nil => simp at hlen + | cons A As => + let .app hfun harg hf' harg' Hrest := H + have htypes := hf.uniqU c.Ewf c.Δwf hfun + have ⟨⟨_, hA⟩, _⟩ := htypes.forallE_inv c.Ewf c.Δwf + have hargA := harg.defeqU_r c.Ewf c.Δwf ⟨_, hA.symm⟩ + have hlen' : args.length = As.length := by simpa using hlen + have htailType : c.HasType (.app f' _) ((VExpr.forallN As C).inst _) := + hf.app hargA + rw [VExpr.instN_forallN] at htailType + obtain ⟨args', hargs', hspine, hfull⟩ := + ih Hrest htailType (by simpa [VExpr.instTelN_length] using hlen') + refine ⟨_ :: args', .cons harg' hargs', ⟨A, VExpr.forallN As C, + rfl, hargA, ?_⟩, ?_⟩ + have hlenArgsAs : args'.length = As.length := + hargs'.length_eq.symm.trans hlen' + rw [VExpr.instN_forallN] + simpa [VExpr.instRev, hlenArgsAs] using hspine + simpa [Expr.mkAppList, VExpr.appN] using hfull + +theorem invalidProj.WF {c : VContext} {s : VState} : + (invalidProj e : RecM α).WF c s Q := by + unfold invalidProj + exact .getEnv <| .getLCtx .throw + +theorem inferProjParams.WF {c : VContext} {s : VState} + (hargs : args.Forall₂ (c.TrExprS · ·) args') + (hrBelow : c.FVarsBelow proj r) + (hargsBelow : ∀ arg ∈ args, c.FVarsBelow proj arg) + (hr : c.TrExpr r R) + (hspine : c.venv.SpineWF c.lparams.length c.vlctx.toCtx + R args' T) : + (inferProjParams proj args r).WF c s fun out _ => + c.FVarsBelow proj out ∧ c.TrExpr out T := by + induction hargs generalizing r R s with + | nil => + simp [inferProjParams] at hspine ⊢ + exact hspine ▸ .pure ⟨hrBelow, hr⟩ + | @cons arg arg' args args' harg hargs ih => + simp only [inferProjParams] + have hargBelow := hargsBelow arg (by simp) + have hargsBelow' : ∀ arg ∈ args, c.FVarsBelow proj arg := by + intro arg harg + exact hargsBelow arg (by simp [harg]) + obtain ⟨A, B, rfl, hargType, hrest⟩ := hspine + obtain ⟨r', hrS, hrEq⟩ := hr + refine (whnf.WF hrS).bind fun out s' _ + ⟨houtBelow, ⟨out', hout, houtEq⟩⟩ => ?_ + have houtEq := houtEq.trans c.Ewf c.Δwf hrEq + cases out with + | forallE name dom body bi => + let .forallE hdomTy hbodyTy hdom hbody := hout + have hforallEq := houtEq.forallE_inv c.Ewf c.Δwf + obtain ⟨⟨_, hdomEq⟩, _, hbodyEq⟩ := hforallEq + have hargType' := hargType.defeqU_r c.Ewf c.Δwf + ⟨_, hdomEq.symm⟩ + have hnext : c.TrExpr (body.instantiate1 arg) (B.inst arg') := by + simpa only [Expr.instantiate1_eq] using + (.inst c.Ewf c.Δwf hargType' + ⟨_, hbody, _, hbodyEq⟩ (harg.trExpr c.Ewf c.Δwf)) + have hnextBelow : c.FVarsBelow proj (body.instantiate1 arg) := by + intro P hP hproj + have houtFVars := (hrBelow.trans houtBelow) P hP hproj + simpa only [Expr.instantiate1_eq] using + houtFVars.2.instantiate1 (hargBelow P hP hproj) + exact ih hnextBelow hargsBelow' hnext hrest + | bvar | fvar | mvar | sort | const | app | lam | letE | lit | + mdata | proj => exact invalidProj.WF + +theorem inferProjFields.WF {c : VContext} {s : VState} + {view : VStructureView} {levels : List VLevel} + {params : List VExpr} {major : VExpr} {tailResult cursor : VExpr} + (hstruct : c.TrExprS struct major) + (hview : view.WF c.venv) + (hlevels : ∀ level ∈ levels, level.WF c.lparams.length) + (hlevelsLength : levels.length = view.uvars) + (hparamsLength : params.length = view.nparams) + (hparamsSpine : ∃ resultLevel, + c.venv.SpineWF c.lparams.length c.vlctx.toCtx + (view.familyType.instL levels) params (.sort resultLevel)) + (hprograms : view.ProgramsWF c.venv) + (hname : view.name = typeName) + (hmajor : c.HasType major (view.structureType levels params)) + (hrBelow : c.FVarsBelow proj r) + (hstructBelow : c.FVarsBelow proj struct) + (hbound : fieldIdx + count < + (view.specializedFields levels params).length) + (hr : c.TrExpr r cursor) + (hcursor : VExpr.consumeForalls? + (VExpr.forallN (view.specializedFields levels params) tailResult) + (view.projectionArgs levels params fieldIdx major) = some cursor) : + (inferProjFields proj typeName struct maybePropType fieldIdx count r).WF + c s fun out _ => + ∃ cursor', + VExpr.consumeForalls? + (VExpr.forallN (view.specializedFields levels params) tailResult) + (view.projectionArgs levels params (fieldIdx + count) major) = + some cursor' ∧ + c.FVarsBelow proj out ∧ c.TrExpr out cursor' := by + induction count generalizing s r cursor fieldIdx with + | zero => + simp only [inferProjFields, Nat.add_zero] + exact .pure ⟨cursor, hcursor, hrBelow, hr⟩ + | succ count ih => + simp only [inferProjFields] + have hfieldIdx : fieldIdx < + (view.specializedFields levels params).length := by omega + have hcodeIdx : fieldIdx < + (view.projectionCodes levels params).length := by + simpa using hfieldIdx + let code := (view.projectionCodes levels params)[fieldIdx] + have hcode : + (view.projectionCodes levels params)[fieldIdx]? = some code := + List.getElem?_eq_getElem hcodeIdx + have hargsLength : + (view.projectionArgs levels params fieldIdx major).length = + fieldIdx := + view.projectionArgs_length levels params fieldIdx major + (Nat.le_of_lt hcodeIdx) + obtain ⟨field, semanticBody, hfield, hconsume⟩ := + VExpr.consumeForalls?_forallN_domain + (view.specializedFields levels params) tailResult + (view.projectionArgs levels params fieldIdx major) + (by simpa [hargsLength] using hfieldIdx) + rw [hargsLength] at hfield + have hcursorShape : cursor = + .forallE + (field.instRevAt + (view.projectionArgs levels params fieldIdx major) 0) + semanticBody := + Option.some.inj (hcursor.symm.trans hconsume) + subst cursor + obtain ⟨field', typeBody, hfield', htypeFn, + hprojectorField⟩ := + hprograms.projector_hasType_field c.Ewf c.Δwf hlevels + hlevelsLength hparamsLength hparamsSpine hcode hmajor + have hfieldEq : field' = field := + Option.some.inj (hfield'.symm.trans hfield) + subst field' + have hprojector := hprograms c.Δwf hlevels hlevelsLength + hparamsLength hparamsSpine hcode + have hprojSem : c.venv.TrProj c.lparams.length c.vlctx.toCtx + view levels params fieldIdx major (.app code.projector major) := { + viewWF := hview + levelsWF := hlevels + levels_length := hlevelsLength + params_length := hparamsLength + paramsSpine := hparamsSpine + majorType := hmajor + program := ⟨code, hcode, rfl, hprojector⟩ } + have hprojStrict : c.TrExprS (.proj typeName fieldIdx struct) + (.app code.projector major) := + .proj hstruct ⟨view, levels, params, hname, hprojSem⟩ + obtain ⟨r', hrS, hrEq⟩ := hr + refine (whnf.WF hrS).bind fun out nextState _ + ⟨houtBelow, ⟨out', hout, houtEq⟩⟩ => ?_ + have houtEq := houtEq.trans c.Ewf c.Δwf hrEq + cases out with + | forallE name dom body bi => + let .forallE hdomTy hbodyTy hdom hbody := hout + have hforallEq := houtEq.forallE_inv c.Ewf c.Δwf + obtain ⟨⟨_, hdomEq⟩, _, hbodyEq⟩ := hforallEq + have hprojectorField' := hprojectorField.defeqU_r + c.Ewf c.Δwf ⟨_, hdomEq.symm⟩ + have hnext : c.TrExpr + (body.instantiate1 (.proj typeName fieldIdx struct)) + (semanticBody.inst (.app code.projector major)) := by + simpa only [Expr.instantiate1_eq] using + (.inst c.Ewf c.Δwf hprojectorField' + ⟨_, hbody, _, hbodyEq⟩ + (hprojStrict.trExpr c.Ewf.ordered c.Δwf)) + have hnextBelow : c.FVarsBelow proj + (body.instantiate1 (.proj typeName fieldIdx struct)) := by + intro P hP hproj + have houtFVars := (hrBelow.trans houtBelow) P hP hproj + have hfieldProj : FVarsIn P + (.proj typeName fieldIdx struct) := by + simpa [FVarsIn] using hstructBelow P hP hproj + simpa only [Expr.instantiate1_eq] using + houtFVars.2.instantiate1 hfieldProj + have hconsumeNext : VExpr.consumeForalls? + (VExpr.forallN (view.specializedFields levels params) tailResult) + (view.projectionArgs levels params (fieldIdx + 1) major) = + some (semanticBody.inst (.app code.projector major)) := by + rw [view.projectionArgs_succ levels params fieldIdx major hcode] + rw [VExpr.consumeForalls?_append, hconsume] + rfl + have hbound' : fieldIdx + 1 + count < + (view.specializedFields levels params).length := by omega + have hrec (recState : VState) := + ih (s := recState) hnextBelow hbound' hnext hconsumeNext + simp only + split + · refine (isProp.WF hdom).bind fun _ propState _ _ => ?_ + split + · exact invalidProj.WF + · simpa only [pure_bind, Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using hrec propState + · simpa only [pure_bind, Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using hrec nextState + | bvar | fvar | mvar | sort | const | app | lam | letE | lit | + mdata | proj => exact invalidProj.WF + theorem inferProj.WF - (he : c.TrExprS e e') (hty : c.TrExprS ety ety') (hasty : c.HasType e' ty') : + (heBelow : c.FVarsBelow e ety) + (he : c.TrExprS e e') (hty : c.TrExprS ety ety') + (hasty : c.HasType e' ety') : (inferProj st i e ety).WF c s fun ty _ => - ∃ ty', c.TrTyping (.proj st i e) ty e' ty' := sorry + ∃ proj' ty', c.TrTyping (.proj st i e) ty proj' ty' := by + unfold inferProj + refine (whnf.WF hty).bind fun type _ _ ⟨htypeBelow, htype⟩ => ?_ + have hprojBelowType : c.FVarsBelow (.proj st i e) type := by + intro P hP hproj + exact htypeBelow P hP (heBelow P hP (by simpa [FVarsIn] using hproj)) + obtain ⟨type', htypeS, htypeEq⟩ := htype + rw [Expr.withApp_eq] + have ⟨family', hstack⟩ := AppStack.build + (type.mkAppList_getAppArgsList ▸ htypeS) + simp only + split + · rename_i familyName familyLevels hfamilyShape + refine .getEnv ?_ + split + · exact invalidProj.WF + · simp only [pure_bind] + rename_i hname + refine (M.WF.liftExcept envGet.WF).lift.bind fun ci _ _ hfind => ?_ + split + · rename_i info + split + · rename_i constructor hctors + split + · rename_i hready + split + · exact invalidProj.WF + · rename_i hargs + obtain ⟨artifact⟩ := + c.projectionReady familyName info hfind hready + have hhead := hstack.tr + rw [hfamilyShape] at hhead + let .const (us' := levels') hfamilyConst hlevelsMap + hlevelsLength := hhead + have hviewFamily := artifact.viewWF.family + rw [artifact.name_eq] at hviewFamily + rw [hviewFamily] at hfamilyConst + cases hfamilyConst + have hlevelsWF : ∀ level ∈ levels', + level.WF c.lparams.length := + VLevel.WF.of_mapM_ofLevel hlevelsMap + have hlevelsSourceLength : levels'.length = + artifact.view.generation.block.sourceType.uvars := + (List.mapM_eq_some.1 hlevelsMap).length_eq.symm.trans + hlevelsLength + have hlevelsLength' : levels'.length = artifact.view.uvars := by + exact hlevelsSourceLength.trans + artifact.view.generation.block.sourceType_uvars_eq + have hargsSize : type.getAppArgs.size = + info.numParams + info.numIndices := by + simpa using hargs + have hargsLength : type.getAppArgsList.length = + artifact.view.nparams := by + rw [← Expr.getAppArgs_toList] + simp [hargsSize, + artifact.numParams_eq, artifact.numIndices_eq] + have hfamilyType : c.HasType (.const familyName levels') + (artifact.view.familyType.instL levels') := by + exact VEnv.HasType.const hviewFamily hlevelsWF + hlevelsSourceLength + have hfamilyTypeShape : c.HasType (.const familyName levels') + (VExpr.forallN + (artifact.view.generation.block.rawParams.map + (VExpr.instL levels')) + (artifact.view.generation.block.rawResult.instL + levels')) := by + simpa [VStructureView.familyType, + VInductDecl.NormalizedChecked.rawType_eq, + artifact.view.raw_indices_eq, + VExpr.instL_forallN, VExpr.forallN] using hfamilyType + have hargsRawLength : type.getAppArgsList.length = + (artifact.view.generation.block.rawParams.map + (VExpr.instL levels')).length := by + simpa [artifact.view.generation.shape.1] using hargsLength + obtain ⟨params', hparamsTr, hparamsSpineRaw, htypeFull⟩ := + AppStack.toSpineWF hstack hfamilyTypeShape hargsRawLength + rw [type.mkAppList_getAppArgsList] at htypeFull + have htypeAppliedEq := htypeFull.uniq c.Ewf + (.refl c.Ewf c.Δwf) htypeS + have hmajorType : c.HasType e' + (artifact.view.structureType levels' params') := by + apply hasty.defeqU_r c.Ewf c.Δwf + have := (htypeAppliedEq.trans c.Ewf c.Δwf htypeEq).symm + simpa [VStructureView.structureType, + artifact.name_eq] using this + have hparamsLength : params'.length = + artifact.view.nparams := + hparamsTr.length_eq.symm.trans hargsLength + have hparamsRawLength : params'.length = + (artifact.view.generation.block.rawParams.map + (VExpr.instL levels')).length := + hparamsTr.length_eq.symm.trans hargsRawLength + have hparamsSpine : ∃ resultLevel, + c.venv.SpineWF c.lparams.length c.vlctx.toCtx + (artifact.view.familyType.instL levels') params' + (.sort resultLevel) := by + obtain ⟨resultLevel, hresultLevel⟩ := artifact.rawResult_sort + refine ⟨resultLevel.inst levels', ?_⟩ + rw [hresultLevel] at hparamsSpineRaw + rw [VExpr.instRev_closedN params' (by trivial)] at hparamsSpineRaw + simpa [VStructureView.familyType, + VInductDecl.NormalizedChecked.rawType_eq, + artifact.view.raw_indices_eq, hresultLevel, + VExpr.instL_forallN, VExpr.forallN, + VExpr.instRev, VExpr.instL] using hparamsSpineRaw + have hconstructorName : + constructor = artifact.view.constructorName := by + have := hctors.symm.trans artifact.ctors_eq + simpa using this + refine (M.WF.liftExcept envGet.WF).lift.bind + fun c_info _ _ hctorFind => ?_ + cases c_info with + | ctorInfo ctorInfo => + simp only + split + · rename_i hidxHost + have hctorInfoEq : + ctorInfo = artifact.constructorInfo := by + rw [hconstructorName, artifact.constructor_find] at hctorFind + exact ConstantInfo.ctorInfo.inj + (Option.some.inj hctorFind.symm) + have hiFields : i < + (artifact.view.specializedFields levels' params').length := by + rw [hctorInfoEq, + artifact.constructor_numFields_eq] at hidxHost + simpa [VStructureView.specializedFields, + VStructureView.fields] using hidxHost + have hviewConstructor : c.venv.constants constructor = + some artifact.view.constructor.raw.toVConstant := by + simpa [hconstructorName] using + artifact.viewWF.toRegistered.constructor + obtain ⟨_, hctorTr⟩ := + c.trenv.find?_uniq hctorFind hviewConstructor + have hrawCtorUvars : + artifact.view.constructor.raw.uvars = + artifact.view.uvars := by + exact artifact.view.generation.ctor_uvars_eq + (by simp [artifact.view.constructor_eq]) + have hctorLevelLength : + ctorInfo.levelParams.length = familyLevels.length := + hctorTr.2.1.trans <| hrawCtorUvars.trans <| + hlevelsLength'.symm.trans + (List.mapM_eq_some.1 hlevelsMap).length_eq.symm + have hctorType₀ := hctorTr.2.2.instL c.Ewf + (Us := c.lparams) (ls' := levels') (Δ := []) + trivial hlevelsMap hctorLevelLength + have hctorType := hctorType₀.weakFV c.Ewf + (.from_nil c.mlctx.noBV) c.Δwf + rw [(c.Ewf.ordered.closedC + hviewConstructor).instL.liftN_eq + (Nat.le_refl _)] at hctorType + let ctorTail := VExpr.forallN + (artifact.view.fields.map (VExpr.instL levels')) + ((artifact.view.constructor.rawResult + artifact.view.nparams).instL levels') + rw [artifact.view.constructor.rawType_eq] at hctorType + have hinstantiate : + ((.ctorInfo ctorInfo : ConstantInfo) + |>.instantiateTypeLevelParams familyLevels) = + ctorInfo.type.instantiateLevelParams + ctorInfo.levelParams familyLevels := rfl + have hctorTypeShape : c.TrExpr + ((.ctorInfo ctorInfo : ConstantInfo) + |>.instantiateTypeLevelParams familyLevels) + (VExpr.forallN + (artifact.view.constructorParams.map + (VExpr.instL levels')) ctorTail) := by + simpa [ConstantInfo.instantiateTypeLevelParams, + ConstantVal.instantiateTypeLevelParams, + ConstantInfo.type, ConstantInfo.toConstantVal, ctorTail, + VInductDecl.NormalizedCtor.declaredBinders, + VStructureView.nparams, + VStructureView.constructorParams, + VStructureView.fields, + VExpr.instL_forallN, VExpr.forallN_append, + List.map_append] using hctorType + have hctorTypeBelow : c.FVarsBelow (.proj st i e) + ((.ctorInfo ctorInfo : ConstantInfo) + |>.instantiateTypeLevelParams familyLevels) := by + intro P _ _ + simpa [ConstantInfo.instantiateTypeLevelParams, + ConstantVal.instantiateTypeLevelParams, + ConstantInfo.type, ConstantInfo.toConstantVal] using + hctorType₀.fvarsIn.mono nofun + have hparamArgsEq : + List.take info.numParams type.getAppArgs.toList = + type.getAppArgsList := by + simp [Expr.getAppArgs_toList, artifact.numParams_eq, + ← hargsLength] + have hparamArgsTr : + (List.take info.numParams + type.getAppArgs.toList).Forall₂ + (c.TrExprS · ·) params' := by + simpa [hparamArgsEq] using hparamsTr + have hparamArgsBelow : ∀ arg ∈ + List.take info.numParams type.getAppArgs.toList, + c.FVarsBelow (.proj st i e) arg := by + intro arg harg P hP hproj + apply FVarsIn.getAppArgsList + (hprojBelowType P hP hproj) + simpa [hparamArgsEq] using harg + have hctorParamsSpine := + artifact.viewWF.constructorParamsSpine c.Ewf.ordered + levels' hlevelsWF hlevelsLength' params' hparamsLength + hparamsSpine ctorTail + refine (inferProjParams.WF hparamArgsTr hctorTypeBelow + hparamArgsBelow hctorTypeShape hctorParamsSpine).bind + fun r _ _ hr => ?_ + obtain ⟨hrBelow, hr⟩ := hr + let tailResult := + ((artifact.view.constructor.rawResult + artifact.view.nparams).instL levels').instRevAt + params' artifact.view.fields.length + have hctorTailInst : ctorTail.instRev params' = + VExpr.forallN + (artifact.view.specializedFields levels' params') + tailResult := by + simp [ctorTail, tailResult, + VExpr.instRev_forallN_projection, + VStructureView.specializedFields, + VExpr.instRevAt_map_instL_zipIdx] + rw [hctorTailInst] at hr + refine (getSortLevel.WF htypeS).bind + fun sortLevel nextState _ _ => ?_ + have hstructBelow : c.FVarsBelow (.proj st i e) e := by + intro P _ hproj + simpa [FVarsIn] using hproj + have hcursorZero : VExpr.consumeForalls? + (VExpr.forallN + (artifact.view.specializedFields levels' params') + tailResult) + (artifact.view.projectionArgs levels' params' 0 e') = + some (VExpr.forallN + (artifact.view.specializedFields levels' params') + tailResult) := by + rfl + refine (inferProjFields.WF he artifact.viewWF hlevelsWF + hlevelsLength' hparamsLength hparamsSpine + artifact.programsWF artifact.name_eq hmajorType + hrBelow hstructBelow (by simpa using hiFields) hr + hcursorZero).bind + fun r _ _ hr => ?_ + obtain ⟨cursor, hcursor, hrBelow, hr⟩ := hr + have hcursor' : VExpr.consumeForalls? + (VExpr.forallN + (artifact.view.specializedFields levels' params') + tailResult) + (artifact.view.projectionArgs levels' params' i e') = + some cursor := by + simpa using hcursor + have hcodeIdx : i < + (artifact.view.projectionCodes levels' params').length := by + simpa using hiFields + let code := + (artifact.view.projectionCodes levels' params')[i] + have hcode : + (artifact.view.projectionCodes levels' params')[i]? = + some code := + List.getElem?_eq_getElem hcodeIdx + have hprojectionArgsLength : + (artifact.view.projectionArgs levels' params' i e').length = + i := + artifact.view.projectionArgs_length levels' params' i e' + (Nat.le_of_lt hcodeIdx) + obtain ⟨field, semanticBody, hfield, hconsume⟩ := + VExpr.consumeForalls?_forallN_domain + (artifact.view.specializedFields levels' params') + tailResult + (artifact.view.projectionArgs levels' params' i e') + (by simpa [hprojectionArgsLength] using hiFields) + rw [hprojectionArgsLength] at hfield + have hcursorShape : cursor = + .forallE + (field.instRevAt + (artifact.view.projectionArgs levels' params' i e') 0) + semanticBody := + Option.some.inj (hcursor'.symm.trans hconsume) + subst cursor + have hprograms : artifact.view.ProgramsWF c.venv := + artifact.programsWF + obtain ⟨field', typeBody, hfield', htypeFn, + hprojectorField⟩ := + hprograms.projector_hasType_field + c.Ewf c.Δwf hlevelsWF hlevelsLength' hparamsLength + hparamsSpine hcode hmajorType + have hfieldEq : field' = field := + Option.some.inj (hfield'.symm.trans hfield) + subst field' + have hprojector := hprograms c.Δwf hlevelsWF + hlevelsLength' hparamsLength hparamsSpine hcode + have hprojSem : c.venv.TrProj c.lparams.length + c.vlctx.toCtx artifact.view levels' params' i e' + (.app code.projector e') := { + viewWF := artifact.viewWF + levelsWF := hlevelsWF + levels_length := hlevelsLength' + params_length := hparamsLength + paramsSpine := hparamsSpine + majorType := hmajorType + program := ⟨code, hcode, rfl, hprojector⟩ } + have hst : st = familyName := by + simpa using hname + have hprojStrict : c.TrExprS (.proj st i e) + (.app code.projector e') := + .proj he ⟨artifact.view, levels', params', + artifact.name_eq.trans hst.symm, hprojSem⟩ + obtain ⟨r', hrS, hrEq⟩ := hr + refine (whnf.WF hrS).bind fun out _ _ + ⟨houtBelow, ⟨out', hout, houtEq⟩⟩ => ?_ + have houtEq := houtEq.trans c.Ewf c.Δwf hrEq + cases out with + | forallE name dom body bi => + let .forallE hdomTy hbodyTy hdom hbody := hout + have hforallEq := houtEq.forallE_inv c.Ewf c.Δwf + obtain ⟨⟨_, hdomEq⟩, _, hbodyEq⟩ := hforallEq + have hprojectorField' := hprojectorField.defeqU_r + c.Ewf c.Δwf ⟨_, hdomEq.symm⟩ + have hdomBelow : c.FVarsBelow (.proj st i e) dom := by + intro P hP hproj + exact ((hrBelow.trans houtBelow) P hP hproj).1 + have hresult : ∃ proj' ty', + c.TrTyping (.proj st i e) dom proj' ty' := + ⟨.app code.projector e', _, hdomBelow, hprojStrict, + hdom, hprojectorField'⟩ + simp only + split + · refine (isProp.WF hdom).bind fun _ _ _ _ => ?_ + split + · exact invalidProj.WF + · exact .pure hresult + · exact .pure hresult + | bvar | fvar | mvar | sort | const | app | lam | letE | + lit | mdata | proj => exact invalidProj.WF + · exact invalidProj.WF + | axiomInfo | defnInfo | thmInfo | opaqueInfo | quotInfo | + inductInfo | recInfo => exact invalidProj.WF + · exact invalidProj.WF + · exact invalidProj.WF + · exact invalidProj.WF + · exact invalidProj.WF theorem literal_is_primitive (H : n = ``Nat ∨ n = ``Char.ofNat ∨ n = ``String.ofList) : Environment.primitives.contains n := by @@ -457,7 +1018,7 @@ theorem inferType'.WF exact hF ⟨hb, .mdata h1, h⟩ · refine (inferType'.WF (by exact h1) ?_).bind fun _ _ _ ⟨_, _, hb, h1, h2, h3⟩ => ?_ · exact fun h => let ⟨_, .proj h ..⟩ := hinf h; ⟨_, h⟩ - exact (inferProj.WF h1 h2 h3).bind fun ty _ _ ⟨ty', h⟩ => hF h + exact (inferProj.WF hb h1 h2 h3).bind fun ty _ _ ⟨_, ty', h⟩ => hF h · exact .readThe <| (M.WF.liftExcept inferFVar.WF).lift.bind fun _ _ _ ⟨_, _, h⟩ => hF h · exact .throw · rename_i h _; simp [Expr.hasLooseBVars, Expr.looseBVarRange'] at h @@ -498,3 +1059,23 @@ theorem inferType'.WF subst hP; refine hF ⟨?_, .app hf3 ha3 hf1 ha1, hl4.inst c.Ewf ha3 ha1, .app hf3 ha3⟩ exact fun _ hP he => (hfb.trans hb _ hP he.1).2.instantiate1 he.2 · exact (inferLet.WF h1 hinf).bind fun _ _ _ ⟨_, _, h⟩ => hF h + +/-- +info: 'Lean4Lean.TypeChecker.Inner.inferProj.WF' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + Expr.instantiate1_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms inferProj.WF diff --git a/Lean4Lean/Verify/TypeChecker/IsDefEq.lean b/Lean4Lean/Verify/TypeChecker/IsDefEq.lean index 7eddbada..992ae6a1 100644 --- a/Lean4Lean/Verify/TypeChecker/IsDefEq.lean +++ b/Lean4Lean/Verify/TypeChecker/IsDefEq.lean @@ -281,21 +281,6 @@ theorem isDefEqApp.WF {c : VContext} {s : VState} simp [Expr.getAppArgs_toList, Expr.mkAppList_getAppArgsList] at h2 exact h2 hb _ he₁ _ he₂ -theorem getSortLevel.WF - (he : c.TrExprS e e') : (getSortLevel e).WF c s fun l _ => - ∃ u', VLevel.ofLevel c.lparams l = some u' ∧ c.HasType e' (.sort u') := by - refine (inferType.WF he).bind fun ty _ le ⟨ty', _, _, h1, h2⟩ => ?_ - refine (ensureSortCore.WF h1).bind fun ty _ le h => ?_ - obtain ⟨⟨u, rfl⟩, ⟨ty₂, h3, h4⟩, _⟩ := h - let .sort hu := h3 - exact .pure ⟨_, hu, h2.defeqU_r c.Ewf c.Δwf h4.symm⟩ - -theorem isProp.WF - (he : c.TrExprS e e') : (isProp e).WF c s fun b _ => b → c.HasType e' (.sort .zero) := by - refine (getSortLevel.WF he).bind fun l _ le ⟨u', hu, h⟩ => .pure fun H => ?_ - exact h.defeqU_r c.Ewf c.Δwf - ⟨_, .sortDF (.of_ofLevel hu) trivial (ofLevel_isAlwaysZero hu H)⟩ - theorem isDefEqProofIrrel.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : RecM.WF c s (isDefEqProofIrrel e₁ e₂) fun b _ => b = .true → c.IsDefEqU e₁' e₂' := by diff --git a/Lean4Lean/Verify/Typing/Expr.lean b/Lean4Lean/Verify/Typing/Expr.lean index a572fabd..26132245 100644 --- a/Lean4Lean/Verify/Typing/Expr.lean +++ b/Lean4Lean/Verify/Typing/Expr.lean @@ -1,4 +1,6 @@ import Lean4Lean.Theory.Typing.Basic +import Lean4Lean.Theory.Literals +import Lean4Lean.Theory.Projection import Lean4Lean.Verify.NameGenerator import Lean4Lean.Verify.VLCtx import Lean4Lean.Verify.Axioms @@ -44,10 +46,6 @@ def FVarsIn : Expr → Prop nonrec abbrev _root_.Lean.Expr.FVarsIn := @FVarsIn -def VLocalDecl.WF (env : VEnv) (U : Nat) (Γ : List VExpr) : VLocalDecl → Prop - | .vlam type => env.IsType U Γ type - | .vlet type value => env.HasType U Γ value type - def VLCtx.FVWF : VLCtx → Prop | [] => True | (ofv, _) :: (Δ : VLCtx) => @@ -64,11 +62,15 @@ def VLCtx.WF.fvwf : ∀ {Δ}, VLCtx.WF env U Δ → Δ.FVWF | [], h => h | _ :: _, ⟨h1, h2, _⟩ => ⟨h1.fvwf, h2⟩ -def TrProj : ∀ (Γ : List VExpr) (structName : Name) (idx : Nat) (e : VExpr), VExpr → Prop := sorry - -def VEnv.ContainsLits (env : VEnv) : Literal → Prop - | .natVal _ => env.contains ``Nat - | .strVal _ => env.contains ``Char.ofNat ∧ env.contains ``String.ofList +/-- Verify compatibility surface for Theory's environment-indexed projection +semantics. The view, universe instantiation, and parameter spine are hidden +from existing expression-translation consumers, but each witness is fully +constrained by `VEnv.TrProj`; no metadata is existentially invented. -/ +def TrProj (env : VEnv) (U : Nat) (Γ : List VExpr) + (structName : Name) (idx : Nat) (e result : VExpr) : Prop := + ∃ view levels params, + view.name = structName ∧ + env.TrProj U Γ view levels params idx e result variable (env : VEnv) (Us : List Name) in inductive TrExprS : VLCtx → Expr → VExpr → Prop @@ -100,73 +102,37 @@ inductive TrExprS : VLCtx → Expr → VExpr → Prop TrExprS Δ (.letE name ty val body nd) body' | lit : env.ContainsLits l → TrExprS Δ l.toConstructor e → TrExprS Δ (.lit l) e | mdata : TrExprS Δ e e' → TrExprS Δ (.mdata d e) e' - | proj : TrExprS Δ e e' → TrProj Δ.toCtx s i e' e'' → TrExprS Δ (.proj s i e) e'' + | proj : TrExprS Δ e e' → + TrProj env Us.length Δ.toCtx s i e' e'' → + TrExprS Δ (.proj s i e) e'' def TrExpr (env : VEnv) (Us : List Name) (Δ : VLCtx) (e : Expr) (e' : VExpr) : Prop := ∃ e₂, TrExprS env Us Δ e e₂ ∧ env.IsDefEqU Us.length Δ.toCtx e₂ e' -def VExpr.bool : VExpr := .const ``Bool [] -def VExpr.boolTrue : VExpr := .const ``Bool.true [] -def VExpr.boolFalse : VExpr := .const ``Bool.false [] -def VExpr.boolLit : Bool → VExpr - | .false => .boolFalse - | .true => .boolTrue - -def VExpr.nat : VExpr := .const ``Nat [] -def VExpr.natZero : VExpr := .const ``Nat.zero [] -def VExpr.natSucc : VExpr := .const ``Nat.succ [] -def VExpr.natLit : Nat → VExpr - | 0 => .natZero - | n+1 => .app .natSucc (.natLit n) - -def VExpr.char : VExpr := .const ``Char [] -def VExpr.string : VExpr := .const ``String [] -def VExpr.stringOfList : VExpr := .const ``String.ofList [] -def VExpr.listChar : VExpr := .app (.const ``List [.zero]) .char -def VExpr.listCharNil : VExpr := .app (.const ``List.nil [.zero]) .char -def VExpr.listCharCons : VExpr := .app (.const ``List.cons [.zero]) .char -def VExpr.charOfNat : VExpr := .const ``Char.ofNat [] -def VExpr.listCharLit : List Char → VExpr - | [] => .listCharNil - | a :: as => .app (.app .listCharCons (.app .charOfNat (.natLit a.toNat))) (.listCharLit as) - -def VExpr.trLiteral : Literal → VExpr - | .natVal n => .natLit n - | .strVal s => .app .stringOfList (.listCharLit s.toList) - -def VEnv.ReflectsNatNatNat (env : VEnv) (fc : Name) (f : Nat → Nat → Nat) := - env.contains fc → - ∀ a b, env.IsDefEqU 0 [] (.app (.app (.const fc []) (.natLit a)) (.natLit b)) (.natLit (f a b)) - -def VEnv.ReflectsNatNatBool (env : VEnv) (fc : Name) (f : Nat → Nat → Bool) := - env.contains fc → - ∀ a b, env.IsDefEqU 0 [] (.app (.app (.const fc []) (.natLit a)) (.natLit b)) (.boolLit (f a b)) - -structure VEnv.HasPrimitives (env : VEnv) : Prop where - bool : env.contains ``Bool → env.contains ``Bool.false ∧ env.contains ``Bool.true - boolFalse : env.constants ``Bool.false = some ci → ci = { uvars := 0, type := .bool } - boolTrue : env.constants ``Bool.true = some ci → ci = { uvars := 0, type := .bool } - nat : env.contains ``Nat → env.contains ``Nat.zero ∧ env.contains ``Nat.succ - natZero : env.constants ``Nat.zero = some ci → ci = { uvars := 0, type := .nat } - natSucc : env.constants ``Nat.succ = some ci → - ci = { uvars := 0, type := .forallE .nat .nat } - natAdd : env.ReflectsNatNatNat ``Nat.add Nat.add - natSub : env.ReflectsNatNatNat ``Nat.sub Nat.sub - natMul : env.ReflectsNatNatNat ``Nat.mul Nat.mul - natPow : env.ReflectsNatNatNat ``Nat.pow Nat.pow - natGcd : env.ReflectsNatNatNat ``Nat.gcd Nat.gcd - natMod : env.ReflectsNatNatNat ``Nat.mod Nat.mod - natDiv : env.ReflectsNatNatNat ``Nat.div Nat.div - natBEq : env.ReflectsNatNatBool ``Nat.beq Nat.beq - natBLE : env.ReflectsNatNatBool ``Nat.ble Nat.ble - natLAnd : env.ReflectsNatNatNat ``Nat.land Nat.land - natLOr : env.ReflectsNatNatNat ``Nat.lor Nat.lor - natXor : env.ReflectsNatNatNat ``Nat.xor Nat.xor - natShiftLeft : env.ReflectsNatNatNat ``Nat.shiftLeft Nat.shiftLeft - natShiftRight : env.ReflectsNatNatNat ``Nat.shiftRight Nat.shiftRight - charOfNat : env.constants ``Char.ofNat = some ci → - ci = { uvars := 0, type := .forallE .nat .char } - stringOfList : env.constants ``String.ofList = some ci → - ci = { uvars := 0, type := .forallE .listChar .string } ∧ - env.HasType 0 [] .listCharNil .listChar ∧ - env.HasType 0 [] .listCharCons (.forallE .char <| .forallE .listChar .listChar) +/-- Deterministic shadow of `TrExprS`: compute the strict Theory translation +of an expression syntactically. Every semantic premise of `TrExprS` only +validates a translation, it never selects between candidates, so on the +`TrExprS.IsUnique` fragment this function returns exactly the translation of +any derivation (`TrExprS.trExprS?_eq`). The function checks nothing +semantic: it is meaningful only through that agreement theorem. The pushed +`vlet` type is a dummy because `TrExprS` never reads it — `VLCtx.find?` +returns a let's value, and the type component is existentially discarded. -/ +def trExprS? (Us : List Name) : VLCtx → Expr → Option VExpr + | Δ, .bvar i => (Δ.find? (.inl i)).map (·.1) + | Δ, .fvar fv => (Δ.find? (.inr fv)).map (·.1) + | _, .sort u => (VLevel.ofLevel Us u).map .sort + | _, .const c us => (us.mapM (VLevel.ofLevel Us)).map (VExpr.const c) + | Δ, .app f a => do return .app (← trExprS? Us Δ f) (← trExprS? Us Δ a) + | Δ, .lam _ ty body _ => do + let ty' ← trExprS? Us Δ ty + return .lam ty' (← trExprS? Us ((none, .vlam ty') :: Δ) body) + | Δ, .forallE _ ty body _ => do + let ty' ← trExprS? Us Δ ty + return .forallE ty' (← trExprS? Us ((none, .vlam ty') :: Δ) body) + | Δ, .letE _ _ val body _ => do + let val' ← trExprS? Us Δ val + trExprS? Us ((none, .vlet (.sort .zero) val') :: Δ) body + | _, .lit l => some (.trLiteral l) + | Δ, .mdata _ e => trExprS? Us Δ e + | _, .proj .. => none + | _, .mvar .. => none diff --git a/Lean4Lean/Verify/Typing/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean index 11f51804..f982a9ad 100644 --- a/Lean4Lean/Verify/Typing/Lemmas.lean +++ b/Lean4Lean/Verify/Typing/Lemmas.lean @@ -136,6 +136,17 @@ theorem Closed.getAppArgsList {e} (h : Closed e) {{a}} (ha : a ∈ e.getAppArgsList) : Closed a := h.getAppArgsRevList (by simpa [← Expr.getAppArgsList_reverse]) +theorem FVarsIn.getAppArgsRevList {e} (h : FVarsIn P e) + {{a}} (ha : a ∈ e.getAppArgsRevList) : FVarsIn P a := by + revert a + unfold Expr.getAppArgsRevList + split <;> simp + exact ⟨h.2, FVarsIn.getAppArgsRevList h.1⟩ + +theorem FVarsIn.getAppArgsList {e} (h : FVarsIn P e) + {{a}} (ha : a ∈ e.getAppArgsList) : FVarsIn P a := + h.getAppArgsRevList (by simpa [← Expr.getAppArgsList_reverse]) + theorem Closed.looseBVarRange_le : Closed e k → e.looseBVarRange' ≤ k := by induction e generalizing k <;> simp +contextual [*, Closed, Expr.looseBVarRange', Nat.max_le] @@ -144,57 +155,16 @@ theorem Closed.looseBVarRange_le : Closed e k → e.looseBVarRange' ≤ k := by theorem Closed.looseBVarRange_zero (H : Closed e) : e.looseBVarRange' = 0 := by simpa using H.looseBVarRange_le -theorem VLocalDecl.lift'_consN_skipN {d : VLocalDecl} : - d.lift' (.consN (.skipN .refl n) k) = d.liftN n k := by - cases d <;> simp [VLocalDecl.lift', VLocalDecl.liftN, VExpr.lift'_consN_skipN] - theorem VLocalDecl.WF.hasType : ∀ {d}, VLocalDecl.WF env U (VLCtx.toCtx Δ) d → env.HasType U (VLCtx.toCtx ((ofv, d) :: Δ)) d.value d.type | .vlam _, _ => .bvar .zero | .vlet .., hA => hA -nonrec theorem VLocalDecl.WF.weakN (henv : env.Ordered) (W : Ctx.LiftN n k Γ Γ') : - ∀ {d}, WF env U Γ d → WF env U Γ' (d.liftN n k) - | .vlam _, H | .vlet .., H => H.weakN henv W - -nonrec theorem VLocalDecl.WF.instN (henv : env.Ordered) (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) - (h₀ : env.HasType U Γ₀ e₀ A₀) : ∀ {d}, WF env U Γ₁ d → WF env U Γ (d.inst e₀ k) - | .vlam _, H | .vlet .., H => H.instN henv W h₀ - -nonrec theorem VLocalDecl.WF.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U') : - ∀ {d}, WF env ls.length Γ d → WF env U' (Γ.map (·.instL ls)) (d.instL ls) - | .vlam _, H | .vlet .., H => H.instL hls - theorem VLocalDecl.is_liftN {Δ : VLCtx} : ∀ {d}, Ctx.LiftN (VLocalDecl.depth d) 0 Δ.toCtx (VLCtx.toCtx ((ofv, d) :: Δ)) | .vlam _ => .one | .vlet .. => .zero [] -variable! (env : VEnv) (U : Nat) (Γ : List VExpr) in -inductive VLocalDecl.IsDefEq : VLocalDecl → VLocalDecl → Prop - | vlam : env.IsDefEq U Γ type₁ type₂ (.sort u) → VLocalDecl.IsDefEq (.vlam type₁) (.vlam type₂) - | vlet : - env.IsDefEq U Γ value₁ value₂ type₁ → env.IsDefEq U Γ type₁ type₂ (.sort u) → - VLocalDecl.IsDefEq (.vlet type₁ value₁) (.vlet type₂ value₂) - -@[simp] theorem VLocalDecl.lift'_depth {d : VLocalDecl} : (d.lift' n).depth = d.depth := by - cases d <;> rfl - -theorem VLocalDecl.lift'_comp {d : VLocalDecl} : d.lift' (.comp l₁ l₂) = (d.lift' l₁).lift' l₂ := by - cases d <;> simp [VLocalDecl.lift', VExpr.lift'_comp] - -variable! (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U)) (W : Ctx.Lift' n Γ Γ') in -theorem VLocalDecl.weak'_iff : VLocalDecl.WF env U Γ' (d.lift' n) ↔ VLocalDecl.WF env U Γ d := - match d with - | .vlam .. => IsType.weak'_iff henv hΓ' W - | .vlet .. => HasType.weak'_iff henv hΓ' W - -variable! (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U)) (W : Ctx.LiftN n k Γ Γ') in -theorem VLocalDecl.weakN_iff : VLocalDecl.WF env U Γ' (d.liftN n k) ↔ VLocalDecl.WF env U Γ d := - match d with - | .vlam .. => IsType.weakN_iff henv hΓ' W - | .vlet .. => HasType.weakN_iff henv hΓ' W - namespace VLCtx variable! (henv : Ordered env) in @@ -565,12 +535,18 @@ inductive SortList : VLCtx → List VLevel → Prop end VLCtx -theorem TrProj.weak' (W : Ctx.Lift' n Γ Γ') - (H : TrProj Γ s i e e') : TrProj Γ' s i (e.lift' n) (e'.lift' n) := sorry +theorem TrProj.weak' (henv : env.Ordered) (W : Ctx.Lift' n Γ Γ') + (H : TrProj env U Γ s i e e') : + TrProj env U Γ' s i (e.lift' n) (e'.lift' n) := by + obtain ⟨view, levels, params, hname, hproj⟩ := H + exact ⟨view, levels, params.map (fun param => param.lift' n), + hname, hproj.weak' henv W⟩ -theorem TrProj.weakN (W : Ctx.LiftN n k Γ Γ') - (H : TrProj Γ s i e e') : TrProj Γ' s i (e.liftN n k) (e'.liftN n k) := by - simpa [VExpr.lift'_consN_skipN] using H.weak' <| Ctx.liftN_iff_lift'.1 W +theorem TrProj.weakN (henv : env.Ordered) (W : Ctx.LiftN n k Γ Γ') + (H : TrProj env U Γ s i e e') : + TrProj env U Γ' s i (e.liftN n k) (e'.liftN n k) := by + simpa [VExpr.lift'_consN_skipN] using + H.weak' henv (Ctx.liftN_iff_lift'.1 W) /-! ## Replaying closed metadata types -/ @@ -620,10 +596,8 @@ theorem TrTypeExpr.to_trExprS exact .forallE ⟨u, hty⟩ ⟨v, hbody⟩ (ihty hΔ ⟨_, hty⟩) (ihbody ⟨hΔ, ⟨u, hty⟩⟩ ⟨_, hbody⟩) -/- `TrExprS` still contains the sorried `TrProj` branch, so even this -projection-free fragment inherits that dependency through its result type. -/ /-- -info: 'Lean4Lean.TrTypeExpr.to_trExprS' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.TrTypeExpr.to_trExprS' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TrTypeExpr.to_trExprS @@ -650,7 +624,7 @@ theorem TrExprS.weakFV' (W : VLCtx.FVLift' Δ Δ' dk n k) (hΔ' : Δ'.WF env Us. exact .letE h1 (ih1 W hΔ') (ih2 W hΔ') (ih3 (W.cons_bvar _) ⟨hΔ', nofun, h1⟩) | lit h1 _ ih => exact .lit h1 (ih W hΔ') | mdata _ ih => exact .mdata (ih W hΔ') - | proj _ h2 ih => exact .proj (ih W hΔ') (h2.weak' W.toCtx) + | proj _ h2 ih => exact .proj (ih W hΔ') (h2.weak' henv W.toCtx) variable! (henv : WF env) in theorem TrExpr.weakFV' (W : VLCtx.FVLift' Δ Δ' dk n k) (hΔ' : Δ'.WF env Us.length) @@ -689,7 +663,7 @@ theorem TrExprS.weakBV (W : VLCtx.BVLift Δ Δ' dn dk n k) refine .lit h1 (Expr.liftLooseBVars_eq_self ?_ ▸ ih W :) exact Closed.toConstructor.looseBVarRange_le | mdata _ ih => exact .mdata (ih W) - | proj _ h2 ih => exact .proj (ih W) (h2.weakN W.toCtx) + | proj _ h2 ih => exact .proj (ih W) (h2.weakN henv W.toCtx) variable! (henv : WF env) in theorem TrExpr.weakBV (W : VLCtx.BVLift Δ Δ' dn dk n k) @@ -703,16 +677,30 @@ theorem HasType.skips (W : Ctx.LiftN n k Γ Γ') IsDefEq.skips henv hΓ' W h1 h2 h2 theorem TrProj.weak'_inv (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U)) - (W : Ctx.Lift' l Γ Γ') : TrProj Γ' s i (e.lift' l) e' → ∃ e', TrProj Γ s i e e' := sorry + (W : Ctx.Lift' l Γ Γ') : + TrProj env U Γ' s i (e.lift' l) e' → + ∃ e', TrProj env U Γ s i e e' := by + rintro ⟨view, levels, params, hname, hproj⟩ + obtain ⟨params', result, hresult⟩ := + henv.registeredStructureHeadInversion.weak'_inv hΓ' W hproj + exact ⟨result, view, levels, params', hname, hresult⟩ theorem TrProj.defeqDFC (henv : VEnv.WF env) (hΓ : env.IsDefEqCtx U [] Γ₁ Γ₂) - (he : env.IsDefEqU U Γ₁ e₁ e₂) (H : TrProj Γ₁ s i e₁ e') : - ∃ e', TrProj Γ₂ s i e₂ e' := sorry - -variable! {env env' : VEnv} (henv : env ≤ env') in -nonrec theorem VEnv.ContainsLits.mono : ∀ {l}, env.ContainsLits l → env'.ContainsLits l - | .natVal _, ⟨_, H⟩ => ⟨_, henv.1 H⟩ - | .strVal _, ⟨⟨_, H1⟩, ⟨_, H2⟩⟩ => ⟨⟨_, henv.1 H1⟩, ⟨_, henv.1 H2⟩⟩ + (he : env.IsDefEqU U Γ₁ e₁ e₂) (H : TrProj env U Γ₁ s i e₁ e') : + ∃ e', TrProj env U Γ₂ s i e₂ e' := by + obtain ⟨view, levels, params, hname, hproj⟩ := H + have he₂ : env.HasType U Γ₂ e₂ + (view.structureType levels params) := + (hproj.majorType.defeqU_l henv hΓ.isType he).defeqDFC + henv.ordered hΓ + obtain ⟨result, hresult⟩ := + hproj.defeqDFC henv.ordered hΓ he₂ + exact ⟨result, view, levels, params, hname, hresult⟩ + +theorem TrProj.mono {env env' : VEnv} (henv : env ≤ env') + (H : TrProj env U Γ s i e e') : TrProj env' U Γ s i e e' := by + obtain ⟨view, levels, params, hname, hproj⟩ := H + exact ⟨view, levels, params, hname, hproj.mono henv⟩ variable! {env env' : VEnv} (henv : env ≤ env') in theorem TrExprS.mono (H : TrExprS env Us Δ e e') : TrExprS env' Us Δ e e' := by @@ -727,7 +715,7 @@ theorem TrExprS.mono (H : TrExprS env Us Δ e e') : TrExprS env' Us Δ e e' := b | letE h1 _ _ _ ih1 ih2 ih3 => exact .letE (h1.mono henv) ih1 ih2 ih3 | lit h1 _ ih => refine .lit (h1.mono henv) ih | mdata _ ih => exact .mdata ih - | proj _ h2 ih => exact .proj ih h2 + | proj _ h2 ih => exact .proj ih (h2.mono henv) variable! {env env' : VEnv} (henv : env ≤ env') in theorem TrExpr.mono (H : TrExpr env Us Δ e e') : TrExpr env' Us Δ e e' := @@ -742,11 +730,6 @@ inductive VLCtx.IsDefEq : VLCtx → VLCtx → Prop VLocalDecl.IsDefEq env U Δ₁.toCtx d₁ d₂ → VLCtx.IsDefEq ((ofv, d₁) :: Δ₁) ((ofv, d₂) :: Δ₂) -variable! (henv : Ordered env) (hΓ : OnCtx Γ (IsType env U)) in -theorem VLocalDecl.IsDefEq.refl : ∀ {d}, VLocalDecl.WF env U Γ d → VLocalDecl.IsDefEq env U Γ d d - | .vlam _, ⟨_, h1⟩ => .vlam h1 - | .vlet .., h1 => let ⟨_, h2⟩ := h1.isType henv hΓ; .vlet h1 h2 - variable! (henv : Ordered env) in theorem VLCtx.IsDefEq.refl : ∀ {Δ}, VLCtx.WF env U Δ → VLCtx.IsDefEq env U Δ Δ | [], _ => .nil @@ -771,20 +754,10 @@ theorem VLCtx.IsDefEq.bvars : VLCtx.IsDefEq env U Δ₁ Δ₂ → Δ₁.bvars = | .cons (ofv := some _) h1 _ _ => by simp only [VLCtx.bvars, h1.bvars] -theorem VLocalDecl.IsDefEq.wf : VLocalDecl.IsDefEq env U Γ d₁ d₂ → VLocalDecl.WF env U Γ d₁ - | .vlam h3 => ⟨_, h3.hasType.1⟩ - | .vlet h3 _ => h3.hasType.1 - theorem VLCtx.IsDefEq.wf : VLCtx.IsDefEq env U Δ₁ Δ₂ → VLCtx.WF env U Δ₁ | .nil => ⟨⟩ | .cons h1 h2 h3 => ⟨h1.wf, h2, h3.wf⟩ -theorem VLocalDecl.IsDefEq.mono (henv : env ≤ env') : - VLocalDecl.IsDefEq env U Γ d₁ d₂ → - VLocalDecl.IsDefEq env' U Γ d₁ d₂ - | .vlam h => .vlam (h.mono henv) - | .vlet h₁ h₂ => .vlet (h₁.mono henv) (h₂.mono henv) - theorem VLCtx.IsDefEq.mono (henv : env ≤ env') : VLCtx.IsDefEq env U Δ₁ Δ₂ → VLCtx.IsDefEq env' U Δ₁ Δ₂ | .nil => .nil @@ -872,16 +845,6 @@ theorem VLCtx.IsDefEqFVars.find?_uniq (henv : VEnv.WF env) | vlam => exact ⟨h₂.weakN henv .one, h₃.weak henv⟩ | vlet => simpa [VLocalDecl.depth] using ⟨h₂, h₃⟩ -theorem VLocalDecl.IsDefEq.symm : - VLocalDecl.IsDefEq env U Δ d₁ d₂ → VLocalDecl.IsDefEq env U Δ d₂ d₁ - | .vlam h1 => .vlam h1.symm - | .vlet h1 h2 => .vlet (h2.defeqDF h1.symm) h2.symm - -theorem VLocalDecl.IsDefEq.defeqDFC (henv : Ordered env) (hΓ : IsDefEqCtx env U Γ₀ Γ₁ Γ₂) - : VLocalDecl.IsDefEq env U Γ₁ d₁ d₂ → VLocalDecl.IsDefEq env U Γ₂ d₁ d₂ - | .vlam h1 => .vlam (h1.defeqDFC henv hΓ) - | .vlet h1 h2 => .vlet (h1.defeqDFC henv hΓ) (h2.defeqDFC henv hΓ) - variable! (henv : Ordered env) in theorem VLCtx.IsDefEq.symm : VLCtx.IsDefEq env U Δ₁ Δ₂ → VLCtx.IsDefEq env U Δ₂ Δ₁ | .nil => .nil @@ -975,7 +938,11 @@ theorem TrExpr.fvarsIn (H : TrExpr env Us Δ e e') : FVarsIn (· ∈ Δ.fvars) e theorem TrExpr.fvarsList (H : TrExpr env Us Δ e e') : e.fvarsList ⊆ Δ.fvars := (fvarsIn_iff.1 H.fvarsIn).1 -theorem TrProj.wf (H1 : TrProj Δ s i e e') (H2 : VExpr.WF env U Γ e) : VExpr.WF env U Γ e' := sorry +theorem TrProj.wf (H1 : TrProj env U Γ s i e e') + (_H2 : VExpr.WF env U Γ e) : VExpr.WF env U Γ e' := by + obtain ⟨view, levels, params, _hname, hproj⟩ := H1 + obtain ⟨code, _hcode, rfl, hprojector⟩ := hproj.program + exact ⟨_, hprojector.app hproj.majorType⟩ theorem TrExpr.wf (H : TrExpr env Us Δ e e') : VExpr.WF env Us.length Δ.toCtx e' := let ⟨_, _, _, H⟩ := H; ⟨_, H.hasType.2⟩ @@ -1018,9 +985,14 @@ theorem TrExpr.app (henv : VEnv.WF env) (hΔ : OnCtx Δ.toCtx (env.IsType Us.len ⟨_, .app h3.hasType.1 h4.hasType.1 s3 s4, _, h3.appDF h4⟩ variable! (henv : VEnv.WF env) (hΓ : IsDefEqCtx env U [] Γ₁ Γ₂) in -theorem TrProj.uniq (H1 : TrProj Γ₁ s₁ i e₁ e₁') (H2 : TrProj Γ₂ s₂ i e₂ e₂') +theorem TrProj.uniq (H1 : TrProj env U Γ₁ s₁ i e₁ e₁') + (H2 : TrProj env U Γ₂ s₂ i e₂ e₂') (H : env.IsDefEqU U Γ₁ e₁ e₂) : - env.IsDefEqU U Γ₁ e₁' e₂' := sorry + env.IsDefEqU U Γ₁ e₁' e₂' := by + obtain ⟨view₁, levels₁, params₁, _hname₁, hproj₁⟩ := H1 + obtain ⟨view₂, levels₂, params₂, _hname₂, hproj₂⟩ := H2 + exact henv.registeredStructureHeadInversion.unique + hΓ hproj₁ hproj₂ H variable! (henv : VEnv.WF env) {Us : List Name} (hΔ : VLCtx.IsDefEq env Us.length Δ₁ Δ₂) in theorem TrExprS.uniq (H1 : TrExprS env Us Δ₁ e e₁) (H2 : TrExprS env Us Δ₂ e e₂) : @@ -1253,7 +1225,8 @@ theorem TrExpr.mdata (h : TrExpr env Us Δ e e') : TrExpr env Us Δ (.mdata d e) let ⟨_, s2, h2⟩ := h; ⟨_, .mdata s2, h2⟩ theorem TrExpr.proj {env Us Δ e e' s i e''} (henv : VEnv.WF env) (hΔ : VLCtx.WF env Us.length Δ) - (H : TrExpr env Us Δ e e') (H2 : TrProj Δ.toCtx s i e' e'') : + (H : TrExpr env Us Δ e e') + (H2 : TrProj env Us.length Δ.toCtx s i e' e'') : TrExpr env Us Δ (.proj s i e) e'' := let ⟨_, s2, h2⟩ := H have ⟨_, H2'⟩ := H2.defeqDFC henv (.refl hΔ) h2.symm @@ -1386,8 +1359,14 @@ theorem TrExprS.instN_var (W : VLCtx.InstN Δ₀ e₀' A₀ dk k Δ₁ Δ) (H : refine ⟨_, _, h, ?_, rfl⟩ cases d <;> simp [VLocalDecl.depth, VLocalDecl.inst, VExpr.lift_instN_lo] -theorem TrProj.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) - (H : TrProj Γ₁ s i e e') : TrProj Γ s i (e.inst e₀ k) (e'.inst e₀ k) := sorry +theorem TrProj.instN (henv : env.Ordered) + (h₀ : env.HasType U Γ₀ e₀ A₀) + (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) + (H : TrProj env U Γ₁ s i e e') : + TrProj env U Γ s i (e.inst e₀ k) (e'.inst e₀ k) := by + obtain ⟨view, levels, params, hname, hproj⟩ := H + exact ⟨view, levels, params.map (fun param => param.inst e₀ k), + hname, hproj.instN henv W h₀⟩ variable! (henv : Ordered env) (h₀ : TrExprS env Us Δ₀ e₀ e₀') (t₀ : env.HasType Us.length Δ₀.toCtx e₀' A₀) in @@ -1410,7 +1389,7 @@ theorem TrExprS.instN (W : VLCtx.InstN Δ₀ e₀' A₀ dk k Δ₁ Δ) (H : TrEx refine .lit h1 (Expr.instantiate1'_eq_self ?_ ▸ ih W :) exact Closed.toConstructor.looseBVarRange_le | mdata _ ih => exact .mdata (ih W) - | proj _ h2 ih => exact .proj (ih W) (h2.instN W.toCtx) + | proj _ h2 ih => exact .proj (ih W) (h2.instN henv t₀ W.toCtx) theorem TrExprS.inst {Δ : VLCtx} (henv : Ordered env) (t₀ : env.HasType Us.length Δ.toCtx e₀' A₀) @@ -1654,9 +1633,114 @@ theorem ofLevel_mkLevelIMax' · simp_all; exact VLevel.imax_self.symm simp [VLevel.ofLevel]; exact ⟨_, ⟨_, h1, _, h2, rfl⟩, rfl⟩ -variable! {ls : List VLevel} (hls : ∀ l ∈ ls, l.WF U') in -theorem TrProj.instL (H : TrProj Γ s i e e') : - TrProj (Γ.map (VExpr.instL ls)) s i (e.instL ls) (e'.instL ls) := sorry +variable! {ls : List VLevel} (hls : ∀ l ∈ ls, l.WF U') + (hU : U = ls.length) in +theorem TrProj.instL (H : TrProj env U Γ s i e e') : + TrProj env U' (Γ.map (VExpr.instL ls)) s i + (e.instL ls) (e'.instL ls) := by + obtain ⟨view, levels, params, hname, hproj⟩ := H + exact ⟨view, levels.map (VLevel.inst ls), + params.map (VExpr.instL ls), hname, hproj.instL hls⟩ + +/-- The structural interface of Verify's projection translation. The bundle +keeps the seven laws available as one coherent capability while the named +theorems above remain the compatibility surface for existing callers. -/ +structure TrProj.StructuralLaws (env : VEnv) : Prop where + weakening : ∀ {U n Γ Γ' s i e e'}, + Ctx.Lift' n Γ Γ' → TrProj env U Γ s i e e' → + TrProj env U Γ' s i (e.lift' n) (e'.lift' n) + inverseWeakening : ∀ {U l Γ Γ' s i e e'}, + OnCtx Γ' (env.IsType U) → Ctx.Lift' l Γ Γ' → + TrProj env U Γ' s i (e.lift' l) e' → + ∃ result, TrProj env U Γ s i e result + contextDefEq : ∀ {U Γ₁ Γ₂ s i e₁ e₂ result}, + env.IsDefEqCtx U [] Γ₁ Γ₂ → env.IsDefEqU U Γ₁ e₁ e₂ → + TrProj env U Γ₁ s i e₁ result → + ∃ result', TrProj env U Γ₂ s i e₂ result' + wellFormed : ∀ {U Γ s i e result}, + TrProj env U Γ s i e result → VExpr.WF env U Γ e → + VExpr.WF env U Γ result + unique : ∀ {U Γ₁ Γ₂ s₁ s₂ i e₁ e₂ result₁ result₂}, + env.IsDefEqCtx U [] Γ₁ Γ₂ → + TrProj env U Γ₁ s₁ i e₁ result₁ → + TrProj env U Γ₂ s₂ i e₂ result₂ → + env.IsDefEqU U Γ₁ e₁ e₂ → + env.IsDefEqU U Γ₁ result₁ result₂ + termSubstitution : ∀ {U Γ₀ Γ₁ Γ s i e e' e₀ A₀ k}, + env.HasType U Γ₀ e₀ A₀ → Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ → + TrProj env U Γ₁ s i e e' → + TrProj env U Γ s i (e.inst e₀ k) (e'.inst e₀ k) + universeInstantiation : ∀ {U U' Γ s i e e'} {ls : List VLevel}, + (∀ level ∈ ls, level.WF U') → U = ls.length → + TrProj env U Γ s i e e' → + TrProj env U' (Γ.map (VExpr.instL ls)) s i + (e.instL ls) (e'.instL ls) + +/-- Every well-formed environment supplies the complete projection structural +interface. -/ +theorem TrProj.structuralLaws (henv : VEnv.WF env) : + TrProj.StructuralLaws env where + weakening W H := H.weak' henv.ordered W + inverseWeakening hΓ' W H := H.weak'_inv henv hΓ' W + contextDefEq hΓ he H := H.defeqDFC henv hΓ he + wellFormed H he := H.wf he + unique hΓ H1 H2 he := H1.uniq henv hΓ H2 he + termSubstitution h₀ W H := H.instN henv.ordered h₀ W + universeInstantiation hls hU H := H.instL hls hU + +/-! +The guards below pin both the proved laws and the inherited Tier-R boundary. +In particular, they distinguish local proof closure from the remaining public +registered-head inversion dependency. +-/ + +/-- +info: 'Lean4Lean.TrProj.weak'' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms TrProj.weak' + +/-- +info: 'Lean4Lean.TrProj.weak'_inv' depends on axioms: [propext, sorryAx, Quot.sound] +-/ +#guard_msgs in +#print axioms TrProj.weak'_inv + +/-- +info: 'Lean4Lean.TrProj.defeqDFC' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms TrProj.defeqDFC + +/-- +info: 'Lean4Lean.TrProj.wf' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms TrProj.wf + +/-- +info: 'Lean4Lean.TrProj.uniq' depends on axioms: [propext, sorryAx, Quot.sound] +-/ +#guard_msgs in +#print axioms TrProj.uniq + +/-- +info: 'Lean4Lean.TrProj.instN' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms TrProj.instN + +/-- +info: 'Lean4Lean.TrProj.instL' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms TrProj.instL + +/-- +info: 'Lean4Lean.TrProj.structuralLaws' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms TrProj.structuralLaws section @@ -1764,7 +1848,7 @@ theorem TrExprS.instL (H : TrExprS env ps Δ e e') : | mdata _ ih => exact .mdata (ih hΔ) | proj _ h2 ih => exact .proj henv (hΔ.instL Hls') (ih hΔ) - (VLCtx.instL_toCtx _ ▸ h2.instL Hls') + (VLCtx.instL_toCtx _ ▸ h2.instL Hls' eq') theorem TrExpr.instL (H : TrExpr env ps Δ e e') : TrExpr env Us (Δ.instL ls') (e.instantiateLevelParams ps ls) (e'.instL ls') := @@ -1874,6 +1958,186 @@ theorem TrExprS.unique' (hΔ : IsUniqueCtx Δ₁ Δ₂) (H : IsUnique e) theorem TrExprS.unique (H : IsUnique e) (H1 : TrExprS env Us Δ e e₁) (H2 : TrExprS env Us Δ e e₂) : e₁ = e₂ := H1.unique' .base H H2 +/-- A successful lookup transfers along value-preserving context alignment: +the found value is identical and only the (discarded) type component may +differ. -/ +theorem TrExprS.IsUniqueCtx.find?_transfer (hΔ : IsUniqueCtx Δ₁ Δ₂) + (H : Δ₁.find? v = some (e, A)) : ∃ A₂, Δ₂.find? v = some (e, A₂) := by + induction hΔ generalizing v e A with + | base => exact ⟨A, H⟩ + | @cons Δ₁' Δ₂' d₁ d₂ ofv _ hd ih => + revert H; simp only [VLCtx.find?]; split + next heq => + simp only [Option.some.injEq, Prod.mk.injEq] + rintro ⟨rfl, rfl⟩ + cases hd <;> exact ⟨_, rfl, rfl⟩ + next v' heq => + rintro h + simp only [Bind.bind, Option.bind_eq_some_iff] at h + obtain ⟨⟨e₁, A₁⟩, h1, h2⟩ := h + simp only [Option.some.injEq, Prod.mk.injEq] at h2 + obtain ⟨rfl, rfl⟩ := h2 + obtain ⟨A₂, h₂⟩ := ih h1 + have hdep : d₁.depth = d₂.depth := by cases hd <;> rfl + refine ⟨VExpr.liftN d₂.depth A₂, ?_⟩ + simp only [Bind.bind, Option.bind_eq_some_iff] + exact ⟨(e₁, A₂), h₂, by rw [hdep]⟩ + +/-- Every strict translation of an unfolded natural-number literal is the +canonical numeral: the constructor spine pins the Theory value +syntactically. -/ +theorem TrExprS.natLitToConstructor_eq : + ∀ {n : Nat} {w}, TrExprS env Us Δ (Expr.natLitToConstructor n) w → + w = VExpr.natLit n + | 0, w, h => by + have h : TrExprS env Us Δ (.const ``Nat.zero []) w := h + cases h with + | const h1 h2 h3 => + obtain rfl : _ = ([] : List VLevel) := by simpa using h2.symm + rfl + | n+1, w, h => by + have h : TrExprS env Us Δ (.app (.const ``Nat.succ []) (.lit (.natVal n))) w := h + cases h with + | app h1 h2 hf ha => + cases hf with + | const hf1 hf2 hf3 => + obtain rfl : _ = ([] : List VLevel) := by simpa using hf2.symm + cases ha with + | lit ha1 ha2 => + cases natLitToConstructor_eq ha2 + rfl + +/-- Every strict translation of an unfolded character-list literal is the +canonical Theory list. -/ +theorem TrExprS.strLitToConstructor_chars_eq : + ∀ {cs : List Char} {w}, + TrExprS env Us Δ + (cs.foldr (init := .app (.const ``List.nil [.zero]) (.const ``Char [])) + fun c e => + .app (.app (.app (.const ``List.cons [.zero]) (.const ``Char [])) + (.app (.const ``Char.ofNat []) (.lit (.natVal c.toNat)))) e) w → + w = VExpr.listCharLit cs + | [], w, h => by + cases h with + | app h1 h2 hf ha => + cases hf with + | const hf1 hf2 hf3 => + simp [VLevel.ofLevel] at hf2 + obtain rfl := hf2 + cases ha with + | const ha1 ha2 ha3 => + obtain rfl : _ = ([] : List VLevel) := by simpa using ha2.symm + rfl + | c :: cs, w, h => by + cases h with + | app h1 h2 hf ha => + cases strLitToConstructor_chars_eq ha + cases hf with + | app hg1 hg2 hgf hga => + cases hgf with + | app hh1 hh2 hhf hha => + cases hhf with + | const hi1 hi2 hi3 => + simp [VLevel.ofLevel] at hi2 + obtain rfl := hi2 + cases hha with + | const hj1 hj2 hj3 => + obtain rfl : _ = ([] : List VLevel) := by simpa using hj2.symm + cases hga with + | app hk1 hk2 hkf hka => + cases hkf with + | const hl1 hl2 hl3 => + obtain rfl : _ = ([] : List VLevel) := by simpa using hl2.symm + cases hka with + | lit hm1 hm2 => + cases natLitToConstructor_eq hm2 + rfl + +/-- Every strict translation of a literal's constructor unfolding is the +canonical `VExpr.trLiteral` value. -/ +theorem TrExprS.toConstructor_eq {l : Literal} {w} + (h : TrExprS env Us Δ l.toConstructor w) : w = VExpr.trLiteral l := by + match l with + | .natVal n => exact natLitToConstructor_eq h + | .strVal s => + have h : TrExprS env Us Δ (.app (.const ``String.ofList []) + (s.toList.foldr (init := .app (.const ``List.nil [.zero]) (.const ``Char [])) + fun c e => + .app (.app (.app (.const ``List.cons [.zero]) (.const ``Char [])) + (.app (.const ``Char.ofNat []) (.lit (.natVal c.toNat)))) e)) w := h + cases h with + | app h1 h2 hf ha => + cases strLitToConstructor_chars_eq ha + cases hf with + | const hf1 hf2 hf3 => + obtain rfl : _ = ([] : List VLevel) := by simpa using hf2.symm + rfl + +/-- The Verify traversal of `Literal.toConstructor` and the direct Theory +encoding form one ready, well-formed literal value. -/ +theorem TrExprS.toConstructor_ready {l : Literal} {w} + (hready : env.PreludeReady) (hcontains : env.ContainsLits l) + (h : TrExprS env Us Δ l.toConstructor w) : + w = VExpr.trLiteral l ∧ VExpr.WF env U [] w := by + have heq := h.toConstructor_eq + refine ⟨heq, ?_⟩ + rw [heq] + exact hready.trLiteral_wf l hcontains + +/-- The deterministic translator agrees with every strict-translation +derivation over any value-preserving context alignment: on the `IsUnique` +fragment, `trExprS?` computes exactly the derivation's Theory value. This +is the replay engine for choice-free semantic packaging — a `Nonempty` +translation witness plus this agreement pins the computed value. -/ +theorem TrExprS.trExprS?_eq' (hΔ : IsUniqueCtx Δ₁ Δ₂) + (H : TrExprS env Us Δ₁ e e') (hu : IsUnique e) : + trExprS? Us Δ₂ e = some e' := by + induction H generalizing Δ₂ with + | bvar h1 => + obtain ⟨A₂, h2⟩ := hΔ.find?_transfer h1 + simp [trExprS?, h2] + | fvar h1 => + obtain ⟨A₂, h2⟩ := hΔ.find?_transfer h1 + simp [trExprS?, h2] + | sort h1 => simp [trExprS?, h1] + | const h1 h2 h3 => simp [trExprS?, h2] + | app h1 h2 _ _ ih1 ih2 => + simp [trExprS?, ih1 hΔ hu.1, ih2 hΔ hu.2] + | lam h1 _ _ ih1 ih2 => + simp [trExprS?, ih1 hΔ hu.1, ih2 (hΔ.cons .vlam) hu.2] + | forallE h1 h2 _ _ ih1 ih2 => + simp [trExprS?, ih1 hΔ hu.1, ih2 (hΔ.cons .vlam) hu.2] + | letE h1 _ _ _ ih1 ih2 ih3 => + simp [trExprS?, ih2 hΔ hu.1, ih3 (hΔ.cons .vlet) hu.2] + | lit h1 h2 ih => + cases h2.toConstructor_eq + simp [trExprS?] + | mdata _ ih => simpa [trExprS?] using ih hΔ hu + | proj h1 h2 => cases hu + +/-- Deterministic-translator agreement in a fixed context. -/ +theorem TrExprS.trExprS?_eq (H : TrExprS env Us Δ e e') (hu : IsUnique e) : + trExprS? Us Δ e = some e' := + H.trExprS?_eq' .base hu + +/-- Executable totality on the unique fragment: any translation witness +guarantees the deterministic translator succeeds. -/ +theorem TrExprS.trExprS?_isSome (hex : ∃ e', TrExprS env Us Δ e e') + (hu : IsUnique e) : (trExprS? Us Δ e).isSome := by + obtain ⟨e', H⟩ := hex + simp [H.trExprS?_eq hu] + +/-- Replay transfer: an existential translation witness holds of the computed +translation itself. Choice-free packagers pin their Theory data with this: +compute by `trExprS?`, then transfer the `Nonempty`-level witness onto the +computed value. -/ +theorem TrExprS.of_trExprS?_eq (hex : ∃ e', TrExprS env Us Δ e e') + (hu : IsUnique e) (h : trExprS? Us Δ e = some v) : + TrExprS env Us Δ e v := by + obtain ⟨e', H⟩ := hex + cases Option.some.inj ((H.trExprS?_eq hu).symm.trans h) + exact H + theorem TrExprS.boolFalse (henv : env.HasPrimitives) (H : env.contains ``Bool) : TrExprS env Us Δ (toExpr false) .boolFalse ∧ env.HasType Us.length Δ.toCtx .boolFalse .bool := by @@ -1881,9 +2145,6 @@ theorem TrExprS.boolFalse (henv : env.HasPrimitives) (H : env.contains ``Bool) : cases henv.boolFalse H exact ⟨.const H rfl rfl, .const H nofun rfl⟩ -@[simp] theorem VExpr.instL_boolFalse : VExpr.boolFalse.instL ls = VExpr.boolFalse := by - simp [boolFalse, instL] - theorem TrExprS.boolTrue (henv : env.HasPrimitives) (H : env.contains ``Bool) : TrExprS env Us Δ (toExpr true) .boolTrue ∧ env.HasType Us.length Δ.toCtx .boolTrue .bool := by @@ -1891,9 +2152,6 @@ theorem TrExprS.boolTrue (henv : env.HasPrimitives) (H : env.contains ``Bool) : cases henv.boolTrue H exact ⟨.const H rfl rfl, .const H nofun rfl⟩ -@[simp] theorem VExpr.instL_boolTrue : VExpr.boolTrue.instL ls = VExpr.boolTrue := by - simp [boolTrue, instL] - theorem TrExprS.boolLit (henv : env.HasPrimitives) (H : env.contains ``Bool) (b : Bool) : TrExprS env Us Δ (toExpr b) (.boolLit b) ∧ env.HasType Us.length Δ.toCtx (.boolLit b) .bool := by @@ -1901,9 +2159,6 @@ theorem TrExprS.boolLit (henv : env.HasPrimitives) (H : env.contains ``Bool) (b | false => exact TrExprS.boolFalse henv H | true => exact TrExprS.boolTrue henv H -@[simp] theorem VExpr.instL_boolLit : (VExpr.boolLit b).instL ls = VExpr.boolLit b := by - cases b <;> simp [boolLit] - theorem FVarsIn.boolLit {b : Bool} : FVarsIn P (toExpr b) := by cases b <;> exact nofun theorem VExpr.WF.boolLit_has_type (wf : env.Ordered) (henv : env.HasPrimitives) @@ -1932,9 +2187,6 @@ theorem TrExprS.natZero (henv : env.HasPrimitives) (H : env.contains ``Nat) : cases henv.natZero H exact ⟨.const H rfl rfl, .const H nofun rfl⟩ -@[simp] theorem VExpr.instL_natZero : VExpr.natZero.instL ls = .natZero := by - simp [natZero, instL] - theorem TrExprS.natSucc (henv : env.HasPrimitives) (H : env.contains ``Nat) : TrExprS env Us Δ .natSucc .natSucc ∧ env.HasType Us.length Δ.toCtx .natSucc (.forallE .nat .nat) := by @@ -1942,9 +2194,6 @@ theorem TrExprS.natSucc (henv : env.HasPrimitives) (H : env.contains ``Nat) : cases henv.natSucc H exact ⟨.const H rfl rfl, .const H nofun rfl⟩ -@[simp] theorem VExpr.instL_natSucc : VExpr.natSucc.instL ls = .natSucc := by - simp [natSucc, instL] - theorem TrExprS.natLit (henv : env.HasPrimitives) (H : env.contains ``Nat) (n) : TrExprS env Us Δ (.lit (.natVal n)) (.natLit n) ∧ env.HasType Us.length Δ.toCtx (.natLit n) .nat := by @@ -1952,9 +2201,6 @@ theorem TrExprS.natLit (henv : env.HasPrimitives) (H : env.contains ``Nat) (n) : | zero => exact let ⟨h1, h2⟩ := natZero henv H; ⟨.lit H h1, h2⟩ | succ n ih => exact let ⟨h1, h2⟩ := natSucc henv H; ⟨.lit H (.app h2 ih.2 h1 ih.1), .app h2 ih.2⟩ -@[simp] theorem VExpr.instL_natLit : (VExpr.natLit n).instL ls = VExpr.natLit n := by - induction n <;> simp [*, natLit, instL] - theorem TrExprS.stringOfList (henv : env.HasPrimitives) (H : env.contains ``String.ofList) : TrExprS env Us Δ (.const ``String.ofList []) .stringOfList ∧ env.HasType Us.length Δ.toCtx .stringOfList (.forallE .listChar .string) := by @@ -1969,14 +2215,6 @@ theorem TrExprS.charOfNat (henv : env.HasPrimitives) (H : env.contains ``Char.of cases henv.charOfNat H exact ⟨.const H rfl rfl, .const H nofun rfl⟩ -theorem VEnv.HasPrimitives.nat_of_charOfNat (wf : Ordered env) (henv : env.HasPrimitives) - (H : env.contains ``Char.ofNat) : env.contains ``Nat := by - let ⟨_, H⟩ := H - have ⟨_, H⟩ := wf.constWF (henv.charOfNat H ▸ H) - let ⟨⟨_, H⟩, _⟩ := H.forallE_inv wf - let ⟨_, H, _⟩ := H.const_inv wf trivial - exact ⟨_, H⟩ - theorem TrExprS.listChar (wf : env.Ordered) (henv : env.HasPrimitives) (H : env.contains ``String.ofList) : TrExprS env Us Δ (.app (.const ``List [.zero]) (.const ``Char [])) .listChar ∧ @@ -2047,10 +2285,6 @@ theorem TrExprS.trLiteral (wf : env.Ordered) (henv : env.HasPrimitives) have b := TrExprS.listCharLit wf henv H (Us := Us) (Δ := Δ) s.toList exact ⟨.lit H (.app a.2 b.2 a.1 (String.foldr_eq .. ▸ b.1)), a.2.app b.2⟩ -def VLocalDecl.ClosedN : VLocalDecl → (k : Nat := 0) → Prop - | .vlam A, k => A.ClosedN k - | .vlet A e, k => A.ClosedN k ∧ e.ClosedN k - def VLCtx.Closed : VLCtx → Prop | [] => True | (none, _) :: _ => False @@ -2396,3 +2630,9 @@ theorem AppStack.append {e : Expr} (H : AppStack env Us Δ (e.mkAppList as) e' b theorem AppStack.build {e : Expr} (H : TrExprS env Us Δ (e.mkAppList as) e') : ∃ e', AppStack env Us Δ e e' as := by simpa using AppStack.append (.head H) + +/-- +info: 'Lean4Lean.TrExprS.toConstructor_ready' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms TrExprS.toConstructor_ready diff --git a/Lean4Lean/Verify/VLCtx.lean b/Lean4Lean/Verify/VLCtx.lean index f6c6d08c..3eb52f37 100644 --- a/Lean4Lean/Verify/VLCtx.lean +++ b/Lean4Lean/Verify/VLCtx.lean @@ -1,46 +1,10 @@ import Lean4Lean.Verify.Expr -import Lean4Lean.Theory.VExpr +import Lean4Lean.Theory.LocalContext namespace Lean4Lean open Lean (FVarId Expr) -inductive VLocalDecl where - | vlam (type : VExpr) - | vlet (type value : VExpr) - -def VLocalDecl.depth : VLocalDecl → Nat - | .vlam .. => 1 - | .vlet .. => 0 - -def VLocalDecl.value : VLocalDecl → VExpr - | .vlam .. => .bvar 0 - | .vlet _ e => e - -def VLocalDecl.type' : VLocalDecl → VExpr - | .vlam A - | .vlet A _ => A - -def VLocalDecl.type : VLocalDecl → VExpr - | .vlam A => A.lift - | .vlet A _ => A - -def VLocalDecl.lift' : VLocalDecl → Lift → VLocalDecl - | .vlam A, n => .vlam (A.lift' n) - | .vlet A e, n => .vlet (A.lift' n) (e.lift' n) - -def VLocalDecl.liftN : VLocalDecl → Nat → Nat → VLocalDecl - | .vlam A, n, k => .vlam (A.liftN n k) - | .vlet A e, n, k => .vlet (A.liftN n k) (e.liftN n k) - -def VLocalDecl.inst : VLocalDecl → VExpr → (k : Nat := 0) → VLocalDecl - | .vlam A, e₀, k => .vlam (A.inst e₀ k) - | .vlet A e, e₀, k => .vlet (A.inst e₀ k) (e.inst e₀ k) - -def VLocalDecl.instL : VLocalDecl → List VLevel → VLocalDecl - | .vlam A, ls => .vlam (A.instL ls) - | .vlet A e, ls => .vlet (A.instL ls) (e.instL ls) - def VLCtx := List (Option (FVarId × List FVarId) × VLocalDecl) namespace VLCtx diff --git a/plans/roadmap.md b/plans/roadmap.md index 0692fcda..6827637a 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -1,6 +1,6 @@ # Lean4Lean completion roadmap -**Status:** authoritative local roadmap, audited 2026-08-07 against the +**Status:** authoritative local roadmap, audited 2026-08-10 against the committed fork and the current `jcb/formalization` development bookmark; publication to `jcb/induct` remains a separate boundary. @@ -67,274 +67,290 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| Ladder position | **L4L-09A active**; L4L-08C and everything above it are complete and pruned from §5; everything below L4L-09A is queued | -| Current formalization source | L4L-08C mutual generation/preservation/replay implementation through `aa10005d`, built on the L4L-08A checked representation `79e1ae4f` and L4L-08B validation semantics; this closure checkpoint adds the migration shim and completion audit at `jcb/formalization`, with publication to `argumentcomputer/lean4lean` `jcb/induct` pending | +| Ladder position | **L4L-14 active**; L4L-13A/B and everything above it are complete and pruned from §5; everything below L4L-14 is queued | +| Current formalization source | the L4L-13A/B projection-semantics checkpoint `de7eef78` at `jcb/formalization2` (lineage: L4L-12B `a6ea75fc` ← L4L-12A `958d03b7` ← L4L-11 `0587b91a`), 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 | +| Trust frontier | exactly 19 live source `sorry` tokens across 18 proof declarations, plus six kernel-rejection recovery declarations (24 compiled allowlist entries total), and 29 custom-axiom declarations; all are pinned by exact audits | +| Gates | the full §6 gate is green on the current L4L-13A/B closure checkpoint: focused/aggregate/default Lake builds, Nix proof and dependency builds, clean-source `nix flake check`, the 24-entry sorry frontier, Theory import-boundary and exact-axiom audits, formatter and whitespace checks | ### 2.1 What is green -**Theory.** Dependent `VInductDecl.Checked`/`checked?` analysis with -environment-free closure/universe/name/anatomy checks and an -environment-indexed `Checked.WF env` (including Lean's impredicative Prop -exception `l = .zero ∨ u ≤ l`); the raw/view `Normalization source` boundary -with computed `normalizationShape` and semantic `Normalization.WF env`; -`NormalizedChecked` and `GenerationChecked` paired raw/view blocks; mixed -motive/minor/recursor/rule generation that retains raw binder syntax while -consulting the checked view for recursive classification, proved well formed -through the complete ordered rule fold. The one-family transaction -`VEnv.addInductGeneration` and its proof-carrying -`GenerationCertificate`/`addInductCertified` boundary remain available. -`BlockGenerationChecked` generalizes the same artifact path: it emits one -motive and recursor per family, globally flattens constructor minors and rules -in family/source order, and routes recursive hypotheses and rule calls by the -checked target-family ordinal. `VEnv.addInductBlockGeneration` inserts all -families, then all constructors, then all recursors, then all rules; its exact -trace supplies atomicity, freshness, lookups/membership, monotonicity, and -`Ordered` preservation through every phase. The raw public `addInduct` now -selects this block descriptor without singleton projection. A deprecated -`addInductSingleton` wrapper retains the former raw one-family transaction for -the migration window without becoming a competing block path. The shared -checked/generation artifact retains the exact K-target decision separately -from its elimination mode. The slice covers parameters, per-family indices, -direct and sibling recursion, recursive targets below Pi telescopes, small -elimination, subsingleton large elimination, K-target metadata, and exact -zero-/one-constructor generation. - -**Mutual validation, generation, and replay.** `VInductDecl.CheckedBlock` and -`checkedBlock?` analyze an arbitrary nonempty `decl.types` list without -singleton destructuring. Shared parameters are retained once, while -`CheckedFamilies source params ordinal types` is indexed simultaneously by -the exact remaining source-family list and its starting ordinal. Each -`CheckedFamily` retains its per-family indices, result level, and ordered -constructors; every `RecArg.targetType` is computed from the block-wide family -header order, including targets beneath positive Pi telescopes. Block-family -mentions are excluded from family formers, recursive domains, and recursive -indices, and generated-name uniqueness is checked across all families, -constructors, and future recursor names. - -`Normalization.BlockWF`, `CheckedBlock.WF`, `ValidatedBlock.WF`, and -`ValidationCertificate` give the arbitrary-block representation an exact -environment-indexed semantic package. Family validation retains shared -parameter agreement and one semantic result universe, then all raw family -constants are staged before constructor validation. The block constructor -trace records every family/constructor/ordinary-field target in source order, -including sibling recursion and recursion beneath Pi binders. The real -Tree/TreeList and indexed IndexedTree/IndexedTreeList fixtures execute the -ordinary kernel validators, compute the exact target matrices, and inhabit -complete normalization, checked-block, and block-generation WF certificates. -Their generated inventories have respectively two motives, five/four globally -ordered minors, two recursors, and five/four rules. Exact kernel comparisons -cover every `InductiveVal`, `ConstructorVal`, `RecursorVal`, and -`RecursorRule` field represented by the Theory boundary, including constructor -indices, block-wide recursion/reflexivity flags, recursor motives/minors/K, -translated types in metadata universe order, rule ownership/field counts, and -every RHS. Both raw `addInduct` and the proof-carrying block transaction produce -the same final Theory environments. The four phase boundaries replay through -`AddInductBlockTrace`, `TrEnv'.inductBlock`, and `Aligned.addInductBlock` to -actual implementation `ConstMap`s, with exact final ordering, lookup, rule -membership, and guarded trust closures. Exact negatives still pin the -parameter-mismatch, result-universe-mismatch, and reordered-family validation -phases, including host Lean diagnostics and transparent validator errors. - -**Kernel parity fixtures.** One integrated 14-row matrix covers Nat, Bool, -List, Option, Prod, Unit (honestly represented by the kernel's `PUnit`), Empty, -Or, And, Eq, HEq, Fin, Vector, and Acc. Every row reruns the ordinary producer -and definitionally compares the stored family/constructor types in their -metadata universe order, names, parameter/index/field counts, recursive rule -metadata, elimination/K behavior, recursor type, rule count, and every iota -RHS. The consolidated 32-row rejection matrix covers closure, internal and -pre-existing name collisions, universe and result-shape failures, parameter -and universe-count mismatches, raw/view incoherence, non-defeq normalization, -nested negativity and illegal recursive targets, field-universe boundaries, -and invalid elimination/K expectations. The earlier `IndexedVec` regression -remains as a supporting indexed two-constructor fixture outside this fixed -singleton inventory. `AliasFormer` and `AliasRec` prove normalization is -necessary, not hypothetical: real metadata -retains reducible aliases at the family result and around a recursive field; -their raw declarations fail `checked?` while their certified views succeed. -`NormalizationMatrix` closes the differential breadth for reducible aliases -in family, parameter/index, ordinary-field, direct-recursive, and -Pi-hidden-recursive positions, including retained beta/let bodies. Its exact -kernel candidate succeeds at fuel 10 and fails at 9, opaque and non-defeq -variants reject, and the actual family/constructor/recursor/rule metadata -replays through the final aligned Theory environment. -The edge fixtures additionally pin every `PUnit` and `Empty` inductive, -constructor, and recursor metadata field, exact motive/minor/major order, -zero-field recursive-argument data, rule counts, and every available iota RHS. -They record `Unit` itself as the reducible `PUnit` definition metadata Lean -actually supplies, rather than inventing alias-level inductive metadata. - -**Elimination and K-target parity.** The ordinary large-eliminator decision, -elimination-level run, and independent K-target decision now retain exact -operational traces, including inferred singleton field sorts, occurrence -tests, the K constructor walk, the fresh elimination parameter, and both -recursor level orders. Theory generation constructs both elimination modes and -the K flag and is differentially aligned with those executions. Exact kernel -fixtures pin `Eq` as K/large with fresh-first parameters `[u, u_1]`; `And` as -non-K yet legitimately large through its singleton proof fields; `Or` and a -source-universe-bearing family as non-K/small; and `Nat` as non-K/large through -the never-zero branch. The source-universe fixture retains its source -parameter without adding a fresh one. Their exact kernel K flags, recursor -metadata, universe order, and every focused rule RHS match Theory generation. -Verify's `RecursorKMatches` makes a type-correct recursor with the wrong K -metadata fail environment alignment. -The `PUnit`/`Empty` executions close the one-/zero-constructor boundary: -`PUnit` traverses a singleton with no parameter, proof, or data fields and -retains fresh-first recursor levels, while `Empty` takes the ordinary -never-zero large-elimination branch with no singleton, minor, or rule. Both -align with the shared checked generation and remain non-K. - -**Verify.** A checker-run certificate layer (`WhnfRun`, `CheckTypeRun`, -`IsDefEqRun`, `DefEqEvidence`, `TelDefEqEvidence`, `NormalizedCtorRun`, -`GenerationRun`) turns exact ordinary-checker executions into Theory typing -and definitional equality through the existing refinement theorems. Level -subsumption is evaluation-preserving for every raw `NormLevel`: active-path -witnesses now guard constant removal, and the proof follows both nested map -folds. Valid normalizer output remains unchanged under the differential audit; -the theorem's exact closure is only `propext`, `Classical.choice`, and -`Quot.sound`, with no project-specific axiom. Level equivalence soundness now -closes the typechecker sort and dependent constant-level-list paths through -the verified project comparator: a transparent structural fast path reflects -equality, canonical ordered-entry comparison gives `NormLevel` evaluator -congruence, and `isEquiv_wf` plus its list theorem have the same standard-only -axiom closure. The executable normalizer is unchanged, and a generated -differential compares the former map-extensional equality with ordered-entry -equality across normalized zero, successor, max, imax, and parameter forms. The -executable candidate producer (`AddInductive.normalizeCandidateExpr`, -`buildNormalizationCandidate`) retains recursively context- and source-indexed -traces with exact full-check/WHNF/binder-equality runs at every node, -structurally certified annotation consumption (agreement with Lean's opaque -`consumeTypeAnnotations` is runtime producer validation, never a semantic -proof field), a `storedSpine` invariant, and arbitrary-length dependent -`Produced` list witnesses. Semantic-hierarchy assembly is automatic under -`Nonempty`; the consolidated generation-readiness gate plus exact dependent -analysis and analyzer-owned view WF derive checked WF and every per-position -shape record, so fixtures supply no component equations. The generic singleton -closure combines that staged owner, the exact dependent analysis, and the -produced generation shape into an exact package while deriving its public -package; no caller supplies a view, view-WF proof, or per-component equation. -The staged semantic-input owner, family-validation semantics with post-family -staging, and the complete retained constructor-validation trace (with -source-list inversion and phase-local failure theorems) are in place. The -source-ordered constructor-universe audit admits structural order and the -impredicative-Prop exception directly; its normalized non-Prop branch requires -both Lean's unchanged core `Level.geq` decision and the verified project -`geq'` decision. `NormLevel.le_eval` and `geq'_wf` prove the project half -semantically, while the core half keeps every accepted audit node inside the -ordinary validator's existing acceptance boundary. The exact proof closure is -only `propext`, `Classical.choice`, and `Quot.sound`; an all-pairs mvar-free -core/project differential covers zero, successor, max, imax, parameters, and -nested combinations, and the former max/parameter exclusion is now a positive -regression. The post-family constructor owner -aligns the retained validator and candidate telescopes by source position, -independent of their fresh-FVar identities, and interprets root, parameter, -field, positivity, and terminal checks in the actual verified post-family -context without claiming pre-family `fieldsWF`. -The executable pre-family owner instantiates the retained family parameters -and replays every analyzer-owned constructor in the exact verified pre-family -context. Ordinary fields are rechecked and retained; recursive outer locals -are omitted while nested Pi binders and recursive/result index spines receive -verified semantic interpretations and proved prefix weakening. Independent -ordinary fields may now follow an omitted recursive outer field and continue -through the generalized semantic replay. The actual `ConstructorValidityMatrix` -metadata now closes this path structurally across its two parameters and six -fields: dependent data/proof fields, direct recursion, recursive-function -recursion, and an independent dependent data/proof suffix after both omitted -recursive locals. The proof derives the retained constructor-validation trace, -universe run, post-family alignment, exact fresh-name independence, zero-index -terminal spine, and final pre-family safety result without a stage-local -decision oracle. Its guarded axiom closure contains only the pre-existing -verified-checker frontier and the single exact L4L-01E producer-execution -witness. `PropRecursiveBoundary` separately pins the impredicative-Prop branch -with recursive-function and index structure. Nearest-kernel negatives reject -nested negativity, family occurrences in nonrecursive and proof fields, -dependency on an omitted recursive local, and an excessive constructor -universe with the exact ordinary-producer errors; the omitted-local case also -reaches and pins the strengthened pre-family rejection. - -**Three positive regressions, end to end.** AliasFormer (terminal alias), -AnnotatedPi (nested recursive-Π with retained `outParam Prop`, generated -recursor and iota rule), and `IndexedVec` (one parameter, one index, ordered -`nil`/`cons`, identity normalization) each prove the exact successful whole -`buildNormalizationCandidate` call, inhabit -`ExactProducedGenerationCandidatePackage` through the generic closure, erase -it to `ProducedGenerationCandidatePackage`, and route both the certified -Theory transaction and the checked replay through that package. All three also -pass the strengthened constructor-universe gate and inhabit both produced -post-family and pre-family semantic owners. `IndexedVec` additionally proves -that validator and candidate field FVars differ while their Theory positions -still align. Negatives stay sharp: opaque-`outParam` whole-candidate rejection, -truncated and reordered views, missing/extra constructors, recursive-local -dependency, and the environment-free +Completed-milestone narratives, hashes, and gate evidence live in this +file's git history and the checkpoint commit messages; this section keeps +only the current claim surface and where each piece lives. + +**Inductive Theory: analysis, generation, transactions.** One artifact +path runs from the raw/view `Normalization` boundary (computed shape plus +semantic `Normalization.WF env`) through dependent `Checked`/`CheckedBlock` +analysis — arbitrary nonempty non-nested mutual blocks, block-wide +target-family ordinals, generated-name uniqueness, the impredicative-Prop +exception — into mixed generation and the four-phase block transaction: +the public raw `addInduct` selects the block descriptor, its exact trace +supplies atomicity, freshness, lookups, monotonicity, and `Ordered`/WF +preservation, and the proof-carrying `GenerationCertificate`/ +`addInductCertified` and `ValidationCertificate` boundaries remain +available (`addInductSingleton` survives only as a deprecated migration +wrapper). The accepted slice covers parameters, per-family indices, +direct and sibling recursion, recursive targets below Pi telescopes, +small and subsingleton-large elimination, exact K-target metadata, and +zero-/one-constructor generation. The consumer-neutral local-context +core lives in `Theory/LocalContext.lean`; `Theory/Literals.lean` owns +literal encodings, containment, primitive descriptors, and +`VEnv.PreludeReady` — an ordered exact Bool/Nat/Char/List/String +contract (generated recursors and iota rules for Bool/Nat/List; +`Char`/`String` opaque behind `Char.ofNat`/`String.ofList`) that derives +direct literal WF, is stable under ordered extension and fresh +constants, and stays independent of `Lean.Expr`; Verify retains only +traversal and proves its constructor result equal to the direct Theory +encoding. + +**Mutual blocks.** `Normalization.BlockWF`, `CheckedBlock.WF`, +`ValidatedBlock.WF`, and `ValidationCertificate` give arbitrary blocks an +exact environment-indexed semantic package: shared-parameter agreement, +one semantic result universe, staged family constants, and a complete +source-order constructor trace including sibling recursion and recursion +beneath Pi binders. The real Tree/TreeList and IndexedTree/IndexedTreeList +fixtures run the ordinary kernel validators, inhabit every WF certificate, +compare all generated metadata with the kernel field by field, and replay +the four phase boundaries through `AddInductBlockTrace`, +`TrEnv'.inductBlock`, and `Aligned.addInductBlock` to actual +implementation `ConstMap`s; exact negatives pin the parameter-mismatch, +result-universe-mismatch, and reordered-family validation phases. + +**Kernel parity and differential fixtures.** One integrated 14-row +positive matrix (Nat, Bool, List, Option, Prod, Unit — honestly +represented by the kernel's `PUnit` — Empty, Or, And, Eq, HEq, Fin, +Vector, Acc) reruns the ordinary producer and definitionally compares +every represented metadata field, recursor type, rule count, and iota +RHS; the consolidated 32-row rejection matrix covers the closure, +collision, universe/result-shape, raw/view-incoherence, normalization, +negativity/recursive-target, field-universe, and elimination/K failure +space. `AliasFormer`, `AliasRec`, and `NormalizationMatrix` prove +normalization is necessary and exactly aligned across alias positions, +with fuel-boundary, opaque, and non-defeq rejections. Elimination and +K-target decisions retain exact operational traces differentially +aligned with Theory generation, pinned by the +`Eq`/`And`/`Or`/`Nat`/source-universe fixtures and the `PUnit`/`Empty` +one-/zero-constructor boundary; Verify's `RecursorKMatches` makes a +type-correct recursor with wrong K metadata fail alignment. + +**Verify refinement layer.** Checker-run certificates (`WhnfRun`, +`CheckTypeRun`, `IsDefEqRun`, `DefEqEvidence`, `TelDefEqEvidence`, +`NormalizedCtorRun`, `GenerationRun`) turn exact ordinary-checker +executions into Theory typing and definitional equality. The level +normalizer, subsumption, and equivalence layer is proved sound through +the verified project comparator (`NormLevel.le_eval`, `geq'_wf`, +`isEquiv_wf`) at standard-only closures with all-pairs core/project +differentials; the constructor-universe audit's non-Prop branch keeps +Lean's core `Level.geq` decision inside the ordinary validator's +existing acceptance boundary. The executable candidate producer +(`buildNormalizationCandidate`) retains recursively indexed traces, +structurally certified annotation consumption (runtime producer +validation, never a semantic proof field), and arbitrary-length +dependent `Produced` witnesses. Semantic-hierarchy assembly is automatic +under `Nonempty`: the staged owners — generation readiness, post-family +alignment independent of fresh-FVar identities, and the executable +pre-family replay with omitted recursive locals — close structurally on +real metadata (`ConstructorValidityMatrix`, `PropRecursiveBoundary`) +with nearest-kernel negatives, at the guarded transitional closure plus +the single exact L4L-01E producer-execution witness. + +**End-to-end producer regressions.** AliasFormer, AnnotatedPi, and +`IndexedVec` each prove the exact successful whole +`buildNormalizationCandidate` call, inhabit the exact produced package +through the generic closure, and route both the certified Theory +transaction and the checked replay through it; `AnnotatedParam` closes +constructor-parameter parity against real kernel metadata, with a +well-typed but genuinely non-defeq prefix rejected at the exact +kernel-facing error. The operational L4L-01E package authority remains +the exact AnnotatedPi producer case. Negatives stay sharp: opaque +annotations, truncated/reordered views, missing/extra constructors, +recursive-local dependency, and the environment-free closure/universe/name/result/collision matrix. -**Constructor-parameter parity.** `AnnotatedParam` is built from Lean's actual -kernel family, constructor, recursor, and rule metadata. Its complete ordinary -metadata call accepts the stored `outParam Type` constructor prefix against the -annotation-consumed `Type` family local by definitional equality; a closed, -well-typed but genuinely non-defeq prefix reaches the same check and is -rejected with the exact kernel-facing error. Mixed generation retains the raw -constructor surface while using checked family parameters for emitted recursor -binders, and the resulting recursor and iota RHS are definitionally equal to -kernel metadata. The proof-carrying transaction and real-`ConstantInfo` replay -then establish final lookup, WF, alignment, uniqueness, and rule membership. -The operational L4L-01E package authority remains the exact AnnotatedPi -producer case; the parameter fixture deliberately does not claim a second -independently assembled produced package. - -**Environment replay.** The sole public L4L-07 inventory contains 19 -actual-metadata transactions: all 14 fixed rows plus AliasFormer, AliasRec, -NormalizationMatrix, AnnotatedPi, and AnnotatedParam. Every -`SingletonReplayArtifact` carries its exact input/output `ConstMap` and `VEnv`, -input ordering, the proof-carrying `AddInduct` transaction, final alignment, -and derived output ordering. Fin replays over the real Nat/LT dependency -slice; Vector replays over Nat/Eq/Array/`Array.size`, including the stored -metadata annotation on `Array.size`'s borrowed argument. The fixed and -normalization inventories are definitionally tied to the Theory inventories, -and their 14/5/19 cardinalities are executable. The older `IndexedVec` -fixture still spells indices as `Nat.zero`/`Nat.succ`, deliberately excluding -notation's `OfNat`/`HAdd` instance closure — a reduced dependency claim, not -full prelude replay. - -**Not claimed.** Nested blocks, generated patterns, projections, and the -remaining metatheory/checker roots. The mutual fixtures prove the current -non-nested block boundary; they do not claim the kernel's nested flattening or -auxiliary-family transformation. -Bare producer success is never generation-shape authority or Theory semantics. +**Replay and the consumer certificate API.** The supported replay matrix +executes 25 actual-metadata transactions: the 19-row L4L-07 singleton +inventory (the 14 fixed rows plus the alias/normalization/annotation +fixtures, with Fin and Vector replaying over their real dependency +slices) plus the two-parameter `BiBox` dependency, both mutual tree +blocks, and three nested blocks. Every row retains its exact +input/output `ConstMap` and `VEnv`, input-map WF and dependency +ordering, data-bearing transaction trace, final roles, and recursor +lookup uniqueness. The consumer-neutral Theory API +`VInductDecl.BlockCertificate`/`NestedBlockCertificate` reconstructs the +raw `addInduct` result, `addInduct_le`, `addInduct_WF`, exact lookups, +freshness, uniqueness, registered rule membership/WF, rule closure, and +the L4L-10 recursor-pattern facts from one checked transaction; it +imports no Verify state, `Lean.Expr`, normalization oracle, or kernel +object, its WF root closes at the standard baseline (the rule/pattern +root adds `Classical.choice`), and neither reaches `sorryAx`. Verify's +unified matrix keeps one exact guarded `sorryAx`, solely through the +separately tracked projection/refinement frontier. A separate fresh +replay loads the 296-declaration compiled dependency closure of the +notation-heavy fixture into an empty kernel environment and checks every +declaration, so numerals, notation, lists, arrays, products, +conditionals, and strings exercise real compiled prelude dependencies. + +**Nested inductives.** The stored Theory payload is the source +`VInductDecl` unchanged; nested support is additive. +`VInductDecl.nestedElimination?` (`Theory/NestedInductive.lean`) mirrors +`ElimNestedInductive` phase for phase against caller-supplied +environment-free target metadata, and `nestedStage3` gates acceptance by +flattening success plus generation readiness of the flattened block +through the unchanged block analyzers. The restoration σ (`restoreExpr`) +rebuilds the flattened block's generation artifacts onto the +`appendIndexAfter` inventory (`NestedBlockChecked`), +`VEnv.addInductNested` inserts source families/constructors plus +restored recursors/rules through the four block phases, and +`AddInductNestedTrace`, `NestedBlockChecked.WF`, and +`addInductNested_WF` mirror the block transaction's lemma suite through +`Ordered` preservation. Verify proves the Theory flattening equal to the +port's on the rose-tree, nested-indexed, and `DeepBi`/`BiBox` fixtures, +matches kernel accept/reject on four nearest negatives, and round-trips +the port's complete `Environment.addInductive` output against the Theory +artifacts (payload constants, recursors, K flags, rule RHSs, +`numNested`). + +All three nested fixtures also replay from real stored metadata through +`TrEnv'.inductNested` (`Verify/Environment/NestedReplay.lean`), with +exact freshness chains, K-flag agreement, the literal rule fold, and +complete `NestedBlockChecked.WF` packages proved by direct concrete +typing derivations; the package closures are the standard baseline plus +the persistent-map container axioms and named `native_decide` +observations — no `sorryAx` — while the full `TrEnv'` roots carry the +usual guarded transitional checker closure. The generic σ̂ typed +transport (`Theory/Typing/NestedTransport.lean`: the `ConstInterp` +environment morphism and `IsDefEq.substConst` with its +`HasType`/`IsType`/`VConstant.WF`/`VDefEq.WF` corollaries) is proved as +the justification layer; its β-collapse bridge to the spine-collapsed +artifact substitution on generated artifacts remains available future +work, not a nested-coverage gap. Source nested declarations remain +rejected by the non-nested raw analyzer; the dedicated nested analyzer +and transaction own their flattened/restored recursors, rules, and +replay. + +**Patterns.** Every certified block's iota rules are exact +`SimplePattern.iota` patterns with RHS templates, check lists, and +`RuleClosure` payload closedness (`Theory/Typing/InductivePattern.lean`; +implementation-independent shape layer in `Theory/Typing/Pattern.lean`). +The complete generic `Params` obligations — `pat_simple`, match inversion +with rule-index/constructor recovery, rule distinctness, and the +`pat_uniq`/`pat_app_l`/`pat_app_l_uniq`/`pat_app_uniq` non-intersection +laws — are proved for one certified block from the certified inventories +at guarded `propext`/`Quot.sound`-level closures. The typed β-collapse +layer (`Theory/Typing/InductivePatternWF.lean`: `IsDefEq.appN_lamN`, +`varN_matches_paths`) is sorry-free, and `pat_wf` composes it into +pattern soundness: a successful match whose parameter and index checks +hold is definitionally equal to the instantiated RHS template, derived +from the exact rule defeq registered by `addInduct`, with the redex +arriving decomposed into recursor and constructor spines — precisely +what a verified reduction site holds — at exactly the Church–Rosser +development's transitional unique-typing closure, shedding `sorryAx` +automatically when L4L-16/17 land. The block-local assembler +(`Theory/Typing/InductivePatternEnv.lean`) builds environments whose +defeq set is exactly one certified block's generated rules plus +separately certified extension rules over a constant base +(`assembleEnv_defeqs`, `assembleEnv_WF`), and the union pattern set +`AssembledPat` couples the block's facts with each +`CertifiedExtension`'s payload and spine-level `extra_pat` coverage +equation. No open-environment `Params` instance is installed; both +fixture blocks assemble over the empty base with their defeq sets pinned +to their generated rules. + +**Projections.** `Theory/Projection.lean` is the consumer-neutral +projection boundary decided at L4L-13A/B. `VStructureView` restricts the +same one-family `GenerationChecked` artifact used by inductive +generation to the kernel structure class — exactly one constructor, no +indices, no recursive fields — and retains per-field sort levels. +Projections are recursor-encoded: `projectionCodes` computes, per field, +a dependent motive (`typeFn`, with earlier projections substituted into +later field types), the selecting minor, and the projector program, +with `projectionType?`/`project?` derived. `Registered`/`WF` tie a view +to exact environment lookups and generated iota rules, and +`VEnv.TrProj env U Γ view levels params idx major result` demands level +WF and arities, a well-formed parameter spine, the exact instantiated +major type, and the computed program; syntactic determinism +(`result_eq`) and environment extension (`mono`) are proved at +`propext`/`Quot.sound`. Verify's `TrProj` is now a fully constrained +compatibility wrapper (existential view/levels/params with +`view.name = structName`; no invented metadata), so the former Tier S +specification sorry is gone and roots that merely mention `TrExprS` no +longer inherit `sorryAx` through the projection branch. The +`DependentRecord` fixture — simultaneously parameterized, +universe-polymorphic, and dependent — pins the complete encoding +(`Tests/ProjectionExpressibility.lean`). + +**Not claimed.** The seven projection structural laws and the +projection/eta checker proofs (L4L-14–L4L-15B), and the remaining +metatheory/checker roots. +The upstream `Params.extra_pat` field demands that registered defeqs match +patterns syntactically, which lambda-tower registrations (including +`quotDefEq`) never do; the assembler therefore exposes spine-level coverage +and `pat_wf`-derived reduction rather than claiming a `Params` instance for +tower-registered environments. The nested fixtures prove the current +single-target, indexed, and queued deep two-parameter boundaries; nesting +classes beyond the accepted flattened-block analyzer remain rejected. The +296-declaration notation replay is a real fresh prelude prefix, not a claim +that an arbitrary whole kernel environment replays. Bare producer success is +never generation-shape authority or Theory semantics. ### 2.2 Live debt The sorry audit (`Lean4Lean/Audit/SorryFrontier.lean`, a declaration-level `sorryAx` allowlist over the compiled Theory/Verify surface) currently -accepts exactly 20 live sorries across 19 declarations (`NormalEq.parRed` +accepts exactly 19 live sorries across 18 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` | +| Projection structural laws (L4L-14) | seven sites in `Verify/Typing/Lemmas.lean`: `weak'`, inverse weakening, `defeqDFC`, `wf`, `uniq`, `instN`, `instL` | | Core metatheory | `Injectivity.lean` x3, `UniqueTyping.lean` x1, `ChurchRosser.lean` x2 | | Checker verification | `Verify/Environment.lean` x1; `InferType.lean` x1; `WHNF.lean` x2; `IsDefEq.lean` x2 | The remaining v4.31-added sorry is classified: `Lean4Lean.addDecl.WF` → L4L-19B. Non-sorry debt: -- The public inductive spec has complete one-family and non-nested mutual - generation, preservation, metadata parity, and environment replay, but - remains a growing subset rather than kernel-complete; nested, - generated-pattern, and projection coverage remain queued. -- Consumer-neutral APIs (`VLocalDecl` core, literal encodings, - `ContainsLits`, `HasPrimitives`, `TrProj`) still live under `Verify/`, - forcing downstream checkers to import that layer (L4L-12A/L4L-15C). +- The public inductive spec has complete one-family, non-nested mutual, + and nested generation, preservation, metadata parity, environment + replay, generic iota-pattern facts, pattern soundness (`pat_wf`), and + the block-local pattern environment assembler. The complete supported + replay matrix and consumer certificate API are now closed, but the accepted + inductive language remains a growing subset rather than kernel-complete; + projection semantics landed at L4L-13A/B while the seven structural laws + and the checker proofs remain queued (L4L-14–L4L-15B). `pat_wf` carries + the Church–Rosser + development's transitional unique-typing closure until L4L-16/17 close it. +- The projection structural laws, checker verification, and a final audit + of consumer-neutral lemmas remain under `Verify/` (L4L-14–L4L-15C). The + local-context + and literal/prelude APIs now have Theory-only homes. - 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. + v4.31 fixed the underlying cache bug. A 2026-08-10 reachability audit + added: four axioms are dead — `TreeMap.all_eq_all_toList`, + `Level.mkLevelIMaxCore_eq`, `Expr.liftLooseBVars_eq`, `Expr.equal_eq` + have zero uses and appear in none of the 436 pinned closures — and are + removable at the next checkpoint; 19 of the 27 still carry `@[simp]`, + so §3's simp ban is containment work not yet done. The L4L-13A/B + `sorryAx` shed then moved a large population of candidate/fixture + roots into the sorry-free set with the cached-field trio (and other + reference equations) still in their closures — hundreds of sorry-free + guard lines now name the trio — so the pre-L4L-13 "clear two roots" + shortcut is gone: enforcing the "no forbidden axiom in a sorry-free + supported root" CI rule now waits on the actual L4L-20A retirement + (prove the equations for the pinned implementation or take them off + the trace-proof simp path). +- `addInductSingleton` (deprecated 2026-08-07) has zero callers outside + its own shim block and is deletable as one self-contained block; the + deprecation has not yet appeared in any published checkpoint, so time + the removal against the consumer window. +- `NestedBlockCertificate` exposes the full lookup/freshness/WF/rule + surface but no `ruleClosure`/`IotaPat` pattern facts; pattern facts are + block-certificate-only until the σ̂ β-collapse bridge lands (L4L-19A). - The 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. @@ -498,148 +514,51 @@ 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 +### Projections and structures (L4L-14–L4L-15C) + +The L4L-13A/B design gate is resolved: the env-indexed +`VEnv.TrProj`/`VStructureView` recursor-encoded semantics landed, the +seven frozen structural-law statements were restated against it, and +Verify's `TrProj` is a fully constrained compatibility wrapper. The +operational facts recorded during that decision stay binding on the +proofs below: `reduceProj` never consults the projection's structure +name — it whnfs to a constructor application and indexes by that +constructor's `numParams + idx`; `isDefEq` projection congruence +compares only indices; `inferProj` substitutes earlier projections into +dependent field types under Prop/proof-irrelevance guards. + +**L4L-14 — projection structural laws (active).** 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. +fixtures. The concrete relation splits the work: `weak'`, `instN`, and +`instL` are commutation of `projectionCodes` with lift/inst/instL plus +transport of the WF components (`SpineWF`, `OnSortTel`, `OnTel`, +`HasType`); `wf` is the real content — typing the projector program from +the registered recursor's generated type; `weak'_inv`, `defeqDFC`, and +`uniq` need inversion facts (`weakN_iff`, and constant-head injectivity +to recover the view and instantiation from a defeq major type) and +should be proved now against the public Tier R statements, inheriting +the transitional closure that sheds automatically when L4L-16/17 land — +the `pat_wf` precedent. `TrProj.mono` and syntactic `result_eq` are +already proved. +*Exit:* 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. +absence of a local sorry also removes it from every exported root. String +branch input: `reduceProj` whnfs `.lit (.strVal s)` through +`Expr.strLitToConstructor`, whose `String.ofList` head must delta-unfold +before the constructor guard succeeds, and `VEnv.PreludeReady` +deliberately keeps `Char`/`String` opaque (function constants only, no +constructor/recursor/iota) — the string case therefore needs either a +certified structure artifact for `String` consistent with the literal +encoding or a route through checker defeq evidence. The L4L-13B +representation left this open; decide it at the start of this milestone. *Exit:* focused structure/string fixtures and enclosing checker roots pass with exact axiom closures; eta/unit-like roots remain queued. @@ -654,8 +573,15 @@ this is a metatheory change, not a local checker lemma. 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 +lemmas still living under Verify after the literal migration and L4L-15B; give each a Theory home and deprecate the corresponding Verify compatibility shims. +A 2026-08-10 scan already identified first candidates: the `VEnv.SpineWF` +weakening/inversion cluster in +`Verify/Environment/ConstructorValidation.lean`; the +`VEnv.HasPrimitives.of_avoids`/`addConst`/`addConst_other` cluster in +`Verify/Environment/Normalization.lean` (natural home +`Theory/Literals.lean`); `VEnv.HasType.hasConst_false_of_absent`; +`VExpr.WF.boolLit_has_type`; and the `checkerElimMode` shim. *Exit:* no consumer-neutral lemma requires a `Lean4Lean.Verify` import; compatibility re-exports are removable without loss. @@ -689,7 +615,18 @@ affected Theory and checker roots have exact accepted closures. 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]`. +commuting diagrams, keeping the theorem generic in `[Params]`. Both holes +are provable without inhabiting `Params` (the theorem is generic, and +`extra_pat` is consumed only by `IsDefEq.church_rosser`); +`ParRed.triangle`'s `.extra` case is the working template. The concrete +missing lemmas: (1) `NormalEq` match inversion/spine descent — the `≡ₚ` +analogue of the existing `ParRed` inversion, with proof irrelevance at a +pattern-spine head the genuinely open sub-case; (2) `Check.OK` transport +along `≡ₚ` and `≈`-equivalent level lists, extending `Check.OK.map`; +(3) level-congruence for `RHS.apply` on closed templates under +`Forall₂ (· ≈ ·)` — bridge `EqUpToLevels.instL` into a +`NormalEq`/`IsDefEq` congruence; (4) routine typing side conditions at +the transported match. *Exit:* `ParRed.church_rosser`, normal-form uniqueness, and the live standardization/head-reduction endpoints contain no hidden placeholder assumptions. @@ -698,7 +635,16 @@ assumptions. 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. +what lean4lean does not trust automatically. This milestone also owns the +`Params` interface decision: `extra_pat` demands a syntactic `Matches` on +`df.lhs`, which no lambda-tower registration (generated iota rules, +`quotDefEq`) can satisfy, and `Params.pat_wf` takes a bare `HasType` +where the proved `pat_wf` needs the redex pre-decomposed into typed +spines. Resolve both by weakening the interface to spine-level/ +β-collapsed obligations (the shape `CertifiedExtension.covers` plus +`IsDefEq.appN_lamN` already provide) or by re-keying `.extra` on the +collapsed redex — coordinate with upstream, since this edits the +Church–Rosser hypotheses. *Exit:* generic lemmas build; the consumer extension contract is documented; no external defeq is trusted automatically or smuggled through generated `Params`. @@ -708,7 +654,12 @@ no external defeq is trusted automatically or smuggled through generated **L4L-19A — recursor reduction verification.** Prove `reduceRecursor.WF` for Quot and certified inductive rules, obtaining the selected rule, match, checks, RHS translation, and result typing from the generated/translated -metadata — not from a global oracle. +metadata — not from a global oracle. For nested blocks this requires the +σ̂ β-collapse bridge left open in `NestedTransport` — transporting the +flattened block's rule defeqs and pattern facts onto the restored +`appendIndexAfter` artifacts — and extending the certificate pattern +surface accordingly (`NestedBlockCertificate` currently exposes no +`ruleClosure`/`IotaPat` facts). *Exit:* Quot, singleton, mutual, and nested recursor reductions pass; enclosing WHNF roots have exact guards. @@ -749,7 +700,14 @@ stated, manifested, version-pinned, tested, absent from Theory roots; silent release assumption; (4) forbidden — known false on a supported toolchain or unproved after the implementation changed. -Retire in risk order: the three remaining cached-field equations; the +Immediate pre-work is already scoped by the 2026-08-10 audit: delete the +four dead axioms (`TreeMap.all_eq_all_toList`, `Level.mkLevelIMaxCore_eq`, +`Expr.liftLooseBVars_eq`, `Expr.equal_eq`). After the L4L-13A/B `sorryAx` +shed the forbidden cached-field trio sits in many sorry-free closures, so +the forbidden-axiom CI rule waits on their actual retirement rather than +a two-root cleanup. Then retire in risk order: the three remaining +cached-field +equations; the 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 @@ -874,12 +832,16 @@ assume an oracle or axiom. - **Raw de Bruijn scaling.** Indexed, mutual, and recursive-Pi rules multiply lift/inst arithmetic. Keep moving normalized evidence into the descriptor and telescope lemmas rather than duplicating index calculations. -- **Projection API insufficiency.** The present `TrProj` signature may make a - faithful semantics impossible. Resolve L4L-13A explicitly instead of hiding - metadata in an oracle or preserving a false “frozen statement” rule. - **Structure eta may change Theory.** A new defeq constructor would affect injectivity, confluence, standardization, and downstream consumers. Require a design proof and upstream agreement first. +- **Pattern-interface mismatch.** The upstream `Params` fields + (`extra_pat`'s syntactic match, `pat_wf`'s bare-`HasType` premise) + cannot be satisfied by tower-registered environments, including + `quotDefEq`. If upstream declines an interface change, instantiating + the Church–Rosser development for real environments stays blocked even + with every block-local fact proved. Raise the L4L-18B design early with + Mario. - **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. diff --git a/upstream-divergence.md b/upstream-divergence.md index 72006f13..48fef911 100644 --- a/upstream-divergence.md +++ b/upstream-divergence.md @@ -4,8 +4,8 @@ This file tracks every deliberate semantic, API, build, or verification delta from `upstream/master` that must either be upstreamed or explicitly retained. It is the tracked counterpart to `plans/roadmap.md`. -Audit baseline after the complete L4L-08C mutual generation/preservation/replay -checkpoint (2026-08-07): +Audit baseline after the complete L4L-12B literal-readiness checkpoint +(2026-08-10): - current upstream reconciliation parent: digama `upstream/master` `ef849dfbd94a` @@ -116,9 +116,27 @@ checkpoint (2026-08-07): `eeae5282`; the block-wide public raw transaction in `1159c655`; and the metadata/trust audit in `aa10005d`; this closure checkpoint adds the deprecated singleton migration shim and completion records. +- local-committed nested-inductive checkpoints at `jcb/formalization2`: + representation and flattening from `e0ee54e` through `b8899c7`, restored + generation/real-output alignment from `4b3d449` through `3475370`, typed + constant-interpretation transport in `b71ab5c`, and the two real replay + closures `a77e358` and `e297560`. +- local-committed generated-pattern checkpoints at `jcb/formalization2`: + the certified-block iota-pattern core `3689b11` and typed pattern soundness + plus the block-local environment assembler `bc51f98`. +- L4L-11 closure checkpoint: the consumer-neutral block/nested + certificates, complete 25-row actual-metadata replay matrix, real queued + two-parameter nested replay, and 296-declaration notation-prelude replay + described in D013. Publication is pending. +- L4L-12A extraction checkpoint `958d03b7`: the Theory-only local-context and + literal encoding APIs plus Verify compatibility re-exports described in + D014, based on `0587b91a`. +- L4L-12B readiness checkpoint: the exact prelude contract, derived literal + WF, and Verify/direct translation agreement described in D014, layered on + `958d03b7`. Publication of both checkpoints is pending. - fixed fork master: `1fb7d6ef9042c5a80b2de9320c88ac0f3ce404cb` on local and `origin/master` -- current audited semantic checkpoint: the L4L-08C closure extends the +- audited L4L-08C semantic base: the L4L-08C closure extends the `jcb/formalization` L4L-07 base, which integrates Nat, Bool, List, Option, Prod, Unit/`PUnit`, Empty, Or, And, Eq, HEq, Fin, Vector, and Acc into one executable kernel @@ -287,10 +305,10 @@ to the replacement. ## D006 — staged computational inductive semantics -- **Status:** remote-development (the earlier checkpoints are published-fork; - the elimination/K/edge, complete L4L-07 singleton-parity, and L4L-08C - mutual-generation extensions are pushed at `jcb/formalization`, while - publication to `jcb/induct` remains pending) +- **Status:** remote-development (the earlier checkpoints are published-fork + or pushed to `jcb/formalization`; the L4L-09 through L4L-11 extensions are + checkpointed at `jcb/formalization2`, while publication to `jcb/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 @@ -318,9 +336,13 @@ to the replacement. checked/validated certificates. L4L-08C adds block-wide motive, minor, recursor, and rule generation; proves every artifact well formed and the exact four-phase transaction ordered; and replays both real mutual fixtures - through the implementation environment. This remains an underapproximation - of the full kernel: nested inductives and the later - generated-pattern/projection corpus are not implemented. + through the implementation environment. L4L-09 adds flattening/restoration, + generation, preservation, and real-metadata replay for the accepted nested + class; L4L-10 adds generated iota patterns, typed pattern soundness, and the + block-local assembler; L4L-11 adds the consumer certificates and complete + supported replay matrix recorded in D013. This remains an underapproximation + of the full kernel: unsupported nesting classes, projections, and the + remaining metatheory/checker roots are still open. - **Ix impact:** discharges ix gap A1's three upstream `sorryAx` origins and is the semantic basis for constructing `InductiveOracle`; current breadth is not yet enough for all ix blocks. @@ -344,8 +366,10 @@ to the replacement. ## D007 — consumer-facing inductive transaction API -- **Status:** remote-development (the one-family base is published-fork; the - L4L-08C block transaction is pushed at `jcb/formalization`) +- **Status:** remote-development (the one-family base is published-fork, the + L4L-08C block transaction is pushed at `jcb/formalization`, and the nested + transaction plus L4L-11 certificate façade are checkpointed at + `jcb/formalization2`) - **Commits:** the normalized core in `472a6f0`, the proof-carrying non-identity API in `6a77882`, and the block transaction/public migration through `12040b3e`, `48882b9c`, `67d65928`, `1159c655`, and `aa10005d` @@ -359,7 +383,9 @@ to the replacement. The raw `VEnv.addInduct` now selects the same block artifact and no longer performs singleton projection. The former one-family raw computation remains available as deprecated `addInductSingleton`; the normalized - `addInductGeneration`/`addInductCertified` APIs remain unchanged. + `addInductGeneration`/`addInductCertified` APIs remain unchanged. The + L4L-09 nested transaction and L4L-11 `BlockCertificate`/ + `NestedBlockCertificate` consumer façade are tracked in D013. - **Ix impact:** lets `InductiveOracle` consume checked block results without unfolding `Option` binds or `foldlM`, and gives ix a Theory-only non-identity certificate boundary without importing Verify. @@ -374,9 +400,9 @@ to the replacement. ## D008 — Verify inductive-environment alignment -- **Status:** remote-development (the earlier checkpoints are published-fork; - complete L4L-07 actual-metadata execution alignment and L4L-08C mutual - replay are pushed at `jcb/formalization`) +- **Status:** remote-development (the earlier checkpoints are published-fork + or pushed at `jcb/formalization`, and the L4L-09 nested replays plus complete + L4L-11 matrix are checkpointed at `jcb/formalization2`) - **Commits:** initial alignment in `472a6f0`, extended through `a1d8943`, `6a77882`, `bc37d43`, `37e2ada6`, `41e1126b`, `0c6b178c`, `df58a3a0`, `bb39cb2a`, `cc132cdd`, `fefb93fe`, the L4L-07 closure, and the L4L-08C @@ -401,12 +427,16 @@ to the replacement. list-wide constant phases, proves fold realization and monotonicity, and extends `TrEnv'`/`Aligned` with an atomic mutual-block case. Both real mutual maps replay every family, constructor, and recursor in kernel order before - installing the globally flattened rules. + installing the globally flattened rules. L4L-09 adds the corresponding + restored nested trace/alignment path and two actual-metadata replays; L4L-11 + adds final-map translated role/uniqueness lemmas, the third deep replay, and + the unified matrix in D013. - **Ix impact:** establishes the implementation-to-Theory environment bridge needed to translate checked inductive blocks and eventually construct - `InductiveOracle`; non-nested mutual replay is now closed, while nested and - generated-pattern/projection work is still required before that oracle is - constructible for the full kernel surface. + `InductiveOracle`. The supported singleton, mutual, and nested replay matrix + and generated-pattern consequences are now closed; projection semantics and + unsupported inductive forms still prevent construction for the full kernel + surface. - **Tests:** `lake build Lean4Lean.Verify.Environment.SingletonParityReplay`; executable 14/5/19 inventory equalities; every actual-metadata transaction, final alignment, and derived output ordering; exact Fin/Vector dependency @@ -853,6 +883,94 @@ to the replacement. mvar-free level-order theorem and constructor semantic validation consumes it without a fork-only comparator. +## D013 — complete inductive replay and consumer certificates + +- **Status:** remote-development at `jcb/formalization2`; publication to + `jcb/induct` is pending. +- **Commit:** this L4L-11 closure checkpoint, based on `bc51f980`. +- **Delta:** add the Theory-only `VInductDecl.BlockCertificate` and + `NestedBlockCertificate` façades over successful proof-carrying + transactions. They export raw transaction recovery, environment growth/WF, + exact family/constructor/recursor lookups and freshness, lookup uniqueness, + registered rule membership/WF, derived rule closure, and generated-recursion + pattern facts without carrying Verify state or implementation metadata. + Verify now preserves old implementation-map lookups across inductive folds + and exports exact final-map translated roles. A single 25-row inventory + combines 20 ordinary singleton candidate executions, both real mutual + blocks, and three analyzer-produced nested blocks with explicit dependency + maps/environments, data-bearing traces, every constructor role, and recursor + uniqueness. The new `DeepBi` row replays actual stored metadata over the + two-parameter `BiBox` dependency and exercises a queued second nested + occurrence, three restored recursors, and all three kernel rule RHSs. A + separate executable test freshly replays the real compiled dependency + closure of a notation-heavy fixture (296 declarations) instead of using a + hand-built Theory prelude. +- **Ix impact:** downstream checkers can consume one implementation-independent + block certificate for growth, preservation, metadata lookup, registered + rules, and L4L-10 pattern consequences. The matrix demonstrates that the + supported singleton/mutual/nested class is constructible from actual kernel + metadata with dependencies kept explicit. +- **Tests:** focused deep-nested and unified-matrix builds; aggregate + Theory/Verify/Tests/sorry-frontier and default Lake builds; exact 20/2/3/25 + inventory counts and the 296-declaration fresh replay; default Nix proof and + dependency builds; clean-source `nix flake check`; formatter, whitespace, + and Theory import-boundary checks; exact compile-time axiom manifests. +- **Axiom note:** the Theory certificate WF roots close over only `propext` and + `Quot.sound`; rule closure/pattern facts additionally use + `Classical.choice`, never `sorryAx` or a project-specific axiom. Verify's + translated matrix retains the already classified projection `sorryAx`, + pointer/expression/persistent-container contracts, existing mutual/nested + observations, and six narrowly named native observations for selecting the + singleton matrix and pinning the new deep fixture. No new `axiom` + declaration or source `sorry` was added, and the compiled frontier remains + exactly 25 allowlisted entries. +- **Upstream issue/PR:** TBD; submit the Theory façade independently of the + implementation replay corpus where practical. +- **Removal condition:** upstream exposes equivalent consumer-neutral block + consequences and actual-metadata replay breadth, all downstream users move + to it, and the fork-only certificate/matrix can be deleted. + +## D014 — Theory local-context and literal readiness API + +- **Status:** local-committed at `jcb/formalization2`; publication to + `jcb/induct` is pending. +- **Commit:** L4L-12A extraction is `958d03b7`, based on `0587b91a`; this + L4L-12B readiness checkpoint is its independently gated child. +- **Delta:** move the consumer-neutral `VLocalDecl` core and its VExpr-only + structural, WF, and defeq laws to `Theory/LocalContext.lean`. Move literal + encodings, containment, primitive descriptors, and lift/substitution laws + to `Theory/Literals.lean`, while keeping `Lean.Expr` traversal in Verify as + a compatibility surface. Add exact Bool/Nat/Char/List/String descriptors, + including generated recursors and iota rules, and package them with + `Ordered` as `VEnv.PreludeReady`. Derive typed literal expressions from + readiness plus the actual containment witness, preserve readiness across + ordered environment growth and successful fresh constant/defeq additions, + and connect Verify's `Literal.toConstructor` traversal to the direct Theory + encoding and WF result. +- **Ix impact:** Theory-only consumers can use local declarations and typed + literals without importing implementation expressions or relying on name + containment as a type oracle. Existing Verify import paths continue to + re-export the moved declarations. +- **Tests:** L4L-12A independently passed focused local-context/literal and + complete Verify builds plus the full release gate. L4L-12B independently + passes focused literal, Verify-bridge, and readiness fixture builds; exact + descriptor equality against kernel-checked Bool, Nat, List, Char, and String + metadata (including every required recursor and iota rule); large-nat and + Unicode-string notation fixtures; aggregate and default Lake builds; + unchanged 25-entry compiled sorry frontier; Nix proof and dependency builds; + clean-source `nix flake check`; formatter, whitespace, and Theory + import-boundary checks. +- **Axiom note:** no project axiom or source `sorry` was added. New Theory + readiness preservation closes over only `propext` and `Quot.sound`; direct + literal WF additionally uses `Classical.choice`. The Verify traversal bridge + retains the already classified `sorryAx` inherited from its expression + translation frontier and is guarded separately. +- **Upstream issue/PR:** TBD; submit the Theory extraction and exact readiness + contract independently from consumer-specific traversal where practical. +- **Removal condition:** upstream provides equivalent Theory-only local-context + and exact typed-literal readiness APIs, Verify consumers migrate to them, + and the compatibility-only fork delta can be deleted. + ## Review checklist At each publish or ix pin boundary: