From c0b04d7446aa081ec27dbbc16927eb4010db18e1 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Sat, 8 Aug 2026 08:04:13 -0400 Subject: [PATCH 01/27] verify: drop spurious noncomputable markers on singleton replay rows annotatedPiReplay07 and the two aggregator lists it feeds compile fine without the marker; every data field is a plain def. Leftover from an earlier revision where the annotatedPi environment chain was still choice-based. --- Lean4Lean/Verify/Environment/SingletonParityReplay.lean | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Lean4Lean/Verify/Environment/SingletonParityReplay.lean b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean index 2a5c6c2..f4e914c 100644 --- a/Lean4Lean/Verify/Environment/SingletonParityReplay.lean +++ b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean @@ -211,7 +211,7 @@ def normalizationMatrixReplay07 : SingletonReplayArtifact where transaction := normalizationMatrix_addInduct aligned := normalizationMatrix_aligned -noncomputable def annotatedPiReplay07 : SingletonReplayArtifact where +def annotatedPiReplay07 : SingletonReplayArtifact where label := ``AnnotatedPi source := annotatedPiRawDecl inputMap := _ @@ -2686,13 +2686,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) = From 48b9980de6541e2e1325825e6ddedf1193977959 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Sat, 8 Aug 2026 08:04:13 -0400 Subject: [PATCH 02/27] inductive: compute of_run by replaying the transparent decomposition Add buildExecution totality lemmas at every trace level (positivity, positivity mode, constructor telescope, constructor list, singleton run): a successful checker execution guarantees the transparent decomposition returns .ok. ConstructorValidationRun.of_run now replays buildExecution and discharges the impossible error branch with the totality lemma, replacing its Classical.choice selection. Axiom guards are unchanged; the singleton fixture layer loses its only value-level choice root. --- Lean4Lean/Inductive/ValidationTrace.lean | 317 ++++++++++++++++++++++- 1 file changed, 312 insertions(+), 5 deletions(-) diff --git a/Lean4Lean/Inductive/ValidationTrace.lean b/Lean4Lean/Inductive/ValidationTrace.lean index 314c604..16ede05 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. -/ From 731d0f98eca3c4f25241bc7f51f4d51ffb0b5b0f Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Sat, 8 Aug 2026 08:29:51 -0400 Subject: [PATCH 03/27] verify: compute staged ofRun packagers by replaying their builders ConstructorCandidateAlignmentTrace.build and buildConstructorPreFamilySafety already execute the exact audits their check wrappers erase, so give each a totality lemma (a successful check guarantees the builder returns .ok) and let the staged D2/D3 owners match on the builder, discharging the impossible error branch with the lemma. Both StagedNormalizationCandidate{Post,Pre}FamilyInput.ofRun drop their Classical.choice selections and become computable. --- .../Environment/ConstructorValidation.lean | 82 +++++++++++++++++-- 1 file changed, 73 insertions(+), 9 deletions(-) diff --git a/Lean4Lean/Verify/Environment/ConstructorValidation.lean b/Lean4Lean/Verify/Environment/ConstructorValidation.lean index 305bde7..4b0463c 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 From ff5ffc74c0b762f7df3c53f806b8f630f10f8ea8 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Sat, 8 Aug 2026 08:31:13 -0400 Subject: [PATCH 04/27] verify: drop noncomputable markers freed by computable staged owners With of_run and the staged D2/D3 ofRun packagers now replaying their builders, every fixture definition rooted in them compiles: the staged universe/post-family/pre-family inputs, their positivity-alignment helpers, and the cvm/prb test aliases across IndexedVecSemanticReplay, InductiveFixtures, and ConstructorValidityReplay. The definitions still selected through Classical.choice ..._exists generation packages keep their markers; making those computable needs a pure verified Expr-to- VExpr translator. --- .../ConstructorValidityReplay.lean | 52 +++++++++---------- .../Environment/IndexedVecSemanticReplay.lean | 12 ++--- .../Verify/Environment/InductiveFixtures.lean | 12 ++--- 3 files changed, 38 insertions(+), 38 deletions(-) diff --git a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean index 9e096ec..d4ed93b 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean @@ -3628,14 +3628,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 +3712,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 +3766,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 +3940,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 +5457,7 @@ theorem prbSafetyRun : VInductDecl.StagedNormalizationCandidatePostFamilyInput.ofRun] using prbSafetyRunDirect -noncomputable def prbStagedPreFamilyInput : +def prbStagedPreFamilyInput : VInductDecl.StagedNormalizationCandidatePreFamilyInput prbFamilyContext prbConstructorContext VEnv.empty [`u] prbCandidate propRecursiveBoundaryDecl := @@ -6716,7 +6716,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 +8402,7 @@ def cvmValidationFunctionPosBodyCheckedTest : rw [cvmValidationPFindInFunctionPosTest] rfl) cvmValidationFunctionPosBodyCheckTest -noncomputable def cvmStagedUniverseInputTest : +def cvmStagedUniverseInputTest : VInductDecl.StagedNormalizationCandidateUniverseInput cvmFamilyContext cvmConstructorContext VEnv.empty [`u] cvmCandidate constructorValidityMatrixDecl where @@ -8673,7 +8673,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 +8701,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 +8729,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 +8750,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 +8771,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 +8781,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 +8792,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 +8803,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 +8814,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 +8850,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 +9061,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 +11234,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 +11254,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 +11278,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 +11362,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 := @@ -11557,7 +11557,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 := diff --git a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean index b7eeac2..da2c282 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean @@ -213,7 +213,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 +786,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 +816,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 +849,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 +926,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 +2595,7 @@ private theorem indexedVecPreFamilySafetyRun : rw [constructorListRun] rfl -private noncomputable def indexedVecStagedPreFamilyInput : +private def indexedVecStagedPreFamilyInput : VInductDecl.StagedNormalizationCandidatePreFamilyInput indexedVecFamilyCandidateContext ctorContext natFinalEnv [`u] indexedVecNormalizationCandidate indexedVecDecl := diff --git a/Lean4Lean/Verify/Environment/InductiveFixtures.lean b/Lean4Lean/Verify/Environment/InductiveFixtures.lean index 330016e..ab97a3a 100644 --- a/Lean4Lean/Verify/Environment/InductiveFixtures.lean +++ b/Lean4Lean/Verify/Environment/InductiveFixtures.lean @@ -7703,7 +7703,7 @@ private def aliasFormerCandidateFamilyRun : aliasFormerFamilyListCandidate aliasFormerRawType := aliasFormerCandidateFamilySemanticRun.root -private noncomputable def aliasFormerStagedUniverseInput : +private def aliasFormerStagedUniverseInput : VInductDecl.StagedNormalizationCandidateUniverseInput aliasFormerCandidateContext aliasFormerCtorCandidateContext typeFamilyAliasEnv [] aliasFormerNormalizationCandidate @@ -7811,7 +7811,7 @@ private theorem aliasFormerAlignmentRun : ConstantInfo.toConstantVal] rfl -private noncomputable def aliasFormerStagedPostFamilyInput : +private def aliasFormerStagedPostFamilyInput : VInductDecl.StagedNormalizationCandidatePostFamilyInput aliasFormerCandidateContext aliasFormerCtorCandidateContext typeFamilyAliasEnv [] aliasFormerNormalizationCandidate @@ -7930,7 +7930,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 @@ -8769,7 +8769,7 @@ private def annotatedPiCandidateFamilyRun : annotatedPiFamilyListCandidate annotatedPiRawType := annotatedPiCandidateFamilySemanticRun.root -private noncomputable def annotatedPiStagedUniverseInput : +private def annotatedPiStagedUniverseInput : VInductDecl.StagedNormalizationCandidateUniverseInput annotatedPiFamilyCandidateContext annotatedPiCtorCandidateContext outParamEnv [] annotatedPiNormalizationCandidate @@ -9333,7 +9333,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 +10094,7 @@ private theorem annotatedPiPreFamilySafetyRun : rw [listRun] rfl -private noncomputable def annotatedPiStagedPreFamilyInput : +private def annotatedPiStagedPreFamilyInput : VInductDecl.StagedNormalizationCandidatePreFamilyInput annotatedPiFamilyCandidateContext annotatedPiCtorCandidateContext outParamEnv [] annotatedPiNormalizationCandidate annotatedPiRawDecl := From ffe2cd41008e33c4075629927e2f0cc171dd8368 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Sat, 8 Aug 2026 09:29:39 -0400 Subject: [PATCH 05/27] verify: add trExprS?, the deterministic shadow of strict translation TrExprS's semantic premises only validate a translation, they never select between candidates, so the strict Theory translation of any IsUnique-fragment expression is computable syntactically. trExprS? is that computation: an env-free structural function over VLCtx that fails only on proj (whose Theory endpoint is an open design decision) and mvar. Agreement replaces soundness: TrExprS.trExprS?_eq proves any derivation's value is exactly the computed one, generalized over the existing value-preserving context alignment so let-bound types stay unconstrained, with literal spines pinned by new toConstructor_eq inversions. The trExprS?_isSome/of_trExprS?_eq wrappers are the replay API for de-choicing the semantic packagers: compute the translation, then transfer the Nonempty witness onto it. --- Lean4Lean/Verify/Typing/Expr.lean | 28 +++++ Lean4Lean/Verify/Typing/Lemmas.lean | 169 ++++++++++++++++++++++++++++ 2 files changed, 197 insertions(+) diff --git a/Lean4Lean/Verify/Typing/Expr.lean b/Lean4Lean/Verify/Typing/Expr.lean index a572fab..f6acd64 100644 --- a/Lean4Lean/Verify/Typing/Expr.lean +++ b/Lean4Lean/Verify/Typing/Expr.lean @@ -134,6 +134,34 @@ def VExpr.trLiteral : Literal → VExpr | .natVal n => .natLit n | .strVal s => .app .stringOfList (.listCharLit s.toList) +/-- 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 + 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)) diff --git a/Lean4Lean/Verify/Typing/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean index 11f5180..9fe95a1 100644 --- a/Lean4Lean/Verify/Typing/Lemmas.lean +++ b/Lean4Lean/Verify/Typing/Lemmas.lean @@ -1874,6 +1874,175 @@ 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 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 From ea7330177bd9bd190315f220acf4cd0a7d253385 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Sat, 8 Aug 2026 15:13:50 -0400 Subject: [PATCH 06/27] verify: compute the generation packages through the deterministic translator Assemble the singleton semantic hierarchy choice-free: semanticOfUnique lifts thread trExprS?-computed views from the candidate-expression leaf through constructor, list, family, and normalization layers, with the executable D3 strict-view gate supplying the uniqueness certificates from the staged owner's safety trace. ProducedGenerationShapeCandidate.exactProducedPackage closes the package as data, and all five fixture packages (indexedVec, aliasFormer, annotatedPi, cvm, prb) replay it instead of choosing from their _exists theorems. IndexedVecSemanticReplay, InductiveFixtures, and ConstructorValidityReplay drop every remaining noncomputable marker; the project's survivors are the Experimental classical developments and the recursor-defined spec shims. --- .../Environment/ConstructorValidation.lean | 131 ++++++++++++++++++ .../ConstructorValidityReplay.lean | 29 ++-- .../Environment/IndexedVecSemanticReplay.lean | 17 +-- .../Verify/Environment/InductiveFixtures.lean | 36 ++--- .../Verify/Environment/Normalization.lean | 40 ++++++ 5 files changed, 219 insertions(+), 34 deletions(-) diff --git a/Lean4Lean/Verify/Environment/ConstructorValidation.lean b/Lean4Lean/Verify/Environment/ConstructorValidation.lean index 4b0463c..733a373 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidation.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidation.lean @@ -8641,6 +8641,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 @@ -8677,6 +8773,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. -/ diff --git a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean index d4ed93b..322c5b5 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean @@ -11466,19 +11466,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 @@ -11661,19 +11666,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 +11832,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 +12073,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/IndexedVecSemanticReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean index da2c282..e1d6853 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean @@ -2862,31 +2862,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 +2912,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 diff --git a/Lean4Lean/Verify/Environment/InductiveFixtures.lean b/Lean4Lean/Verify/Environment/InductiveFixtures.lean index ab97a3a..0760087 100644 --- a/Lean4Lean/Verify/Environment/InductiveFixtures.lean +++ b/Lean4Lean/Verify/Environment/InductiveFixtures.lean @@ -8114,21 +8114,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 +8139,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 +8177,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 @@ -10214,22 +10216,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 +10241,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 +10258,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 +10376,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 +10784,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 := diff --git a/Lean4Lean/Verify/Environment/Normalization.lean b/Lean4Lean/Verify/Environment/Normalization.lean index b5a87ea..94396d7 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. From e0ee54ee7835db0ec6af4ee4fc52ffb679a50b41 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 07:39:05 -0400 Subject: [PATCH 07/27] verify: decide the nested inductive representation L4L-09A checkpoint. Audit how the implementation stores nested inductives, commit the design decision, and pin both with build-failing probes in Lean4Lean/Verify/Environment/NestedRepresentation.lean; no acceptance behavior changes. The audit: Environment.addInductive flattens nested occurrences into auxiliary families, runs the ordinary mutual path, then restores - the final environment keeps only source families (all = source names, numNested = auxiliary count), restored constructor types, and one recursor per source family plus one per auxiliary family named by appendIndexAfter, all with flattened motive/minor counts and auxiliary rules keyed by previously declared inductives' constructors. No _nested.* constant survives, and the final metadata is independent of auxiliary-name collisions. The decision: the stored Theory payload stays the source VInductDecl with no new field; nested support is an additive artifact coupling the flattened block - which probes show the existing arbitrary-block machinery already accepts - with per-auxiliary specifications (the Theory analog of aux2nested) and a restoration substitution sigma. Probes verify on rose-tree, nested-indexed, and constant-universe fixtures that the port's nested path reproduces Lean's stored metadata exactly and that sigma over the existing flat-block generation artifacts reproduces every stored recursor type and rule RHS, using declaration-world values for constructor types and an instL elimination-offset splice for recursor-world artifacts. Source declarations remain rejected by every current analyzer. Gates: focused, aggregate, and default Lake builds, sorry frontier unchanged (25 known entries), Theory import boundary empty, whitespace clean; Nix proof/dependency build and flake checks run on this committed checkpoint. --- .../Environment/NestedRepresentation.lean | 710 ++++++++++++++++++ plans/roadmap.md | 48 +- 2 files changed, 740 insertions(+), 18 deletions(-) create mode 100644 Lean4Lean/Verify/Environment/NestedRepresentation.lean diff --git a/Lean4Lean/Verify/Environment/NestedRepresentation.lean b/Lean4Lean/Verify/Environment/NestedRepresentation.lean new file mode 100644 index 0000000..63b84c7 --- /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/plans/roadmap.md b/plans/roadmap.md index 0692fcd..d59d96b 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -67,12 +67,12 @@ 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-09B active**; L4L-09A and everything above it are complete and pruned from §5; everything below L4L-09B is queued | +| Current formalization source | L4L-09A nested representation decision on top of the L4L-08C closure `ea733017` (itself built on the L4L-08A checked representation `79e1ae4f` and L4L-08B validation semantics); this checkpoint adds the committed design note and executable nested-metadata probes in `Lean4Lean/Verify/Environment/NestedRepresentation.lean` at `jcb/formalization2`, 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 | +| Gates | the full §6 gate is green on the L4L-09A checkpoint source, including focused, aggregate, and default Lake builds, the Nix proof/dependency build, all native flake checks, sorry-frontier and Theory import-boundary audits, formatter check, and whitespace check | ### 2.1 What is green @@ -299,6 +299,27 @@ 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. +**Nested representation decision.** The committed design note and +executable metadata probes in +`Lean4Lean/Verify/Environment/NestedRepresentation.lean` pin how the +implementation stores nested inductives (restored source families carrying +`numNested`, auxiliary recursors named by `appendIndexAfter` whose rules +are keyed by previously declared inductives' constructors, flattened +motive/minor counts, no surviving `_nested.*` constant) and fix the L4L-09 +representation: the stored Theory payload is the source `VInductDecl` +unchanged, and nested support is an additive artifact coupling the +flattened block (already accepted by the existing arbitrary-block +machinery, per probe) with per-auxiliary specifications — the Theory +analog of `aux2nested` — and a restoration substitution σ. Probes verify +on rose-tree, nested-indexed, and constant-universe fixtures that the +port's nested path reproduces Lean's stored metadata exactly, that final +metadata is independent of auxiliary-name collisions, and that σ over the +existing flat-block generation artifacts reproduces every stored recursor +type and rule RHS, with declaration-world values for constructor types and +an `instL` elimination-offset splice for recursor-world artifacts. The +source declarations remain rejected by every current analyzer; acceptance +behavior is unchanged at this checkpoint. + **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 @@ -498,21 +519,12 @@ 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 +### Nested inductives (L4L-09B–L4L-09C) + +**L4L-09B — nested transformation and positivity (active).** Implement the +chosen pre-flattening/auxiliary relation from the committed L4L-09A design +(flattened block plus per-auxiliary specifications and the restoration +substitution), 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 From b8899c7dc3f3ef6f67b3fd04218128ea0a78d252 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 07:57:39 -0400 Subject: [PATCH 08/27] theory: flatten nested inductives against target metadata L4L-09B checkpoint. Implement the Theory mirror of the kernel's ElimNestedInductive transformation per the committed L4L-09A design. VInductDecl.nestedElimination? (Theory/NestedInductive.lean) flattens a source declaration against caller-supplied, environment-free copies of the nested-into blocks (NestedTargetBlock; NestedTargetBlock.WF ties a copy to a VEnv): target recognition on application spines, the kernel's local-variable rejection for parametric arguments, rewrite without descending into replacements, value-keyed deduplication, auxiliary creation for every family of the target block with level instantiation and simultaneous parameter substitution, canonical appendIndexAfter naming, and a fueled fixpoint over queued auxiliary constructors. nestedStage3 gates acceptance by flattening success plus generation readiness of the flattened block through the unchanged L4L-08 block analyzers; no generated recursor, rule, or replay is claimed. Theory fixtures pin the exact flattened blocks and auxiliary specifications for the rose-tree and nested-indexed fixtures plus four structural negatives. The Verify differential (Verify/Environment/NestedTransformation.lean) proves the Theory flattening equal to the port's ElimNestedInductive output on the three real fixtures - families, constructors, specifications, and stored numNested - ties the hand-written List target block to Lean's stored metadata, and matches kernel accept/reject on the four nearest negatives, pinning the kernel's exact local-variable diagnostic. Gates: focused, aggregate, and default Lake builds, sorry frontier unchanged (25 known entries), Theory import boundary empty, whitespace clean; Nix proof/dependency build and flake checks run on this committed checkpoint. --- Lean4Lean/Theory/NestedInductive.lean | 302 ++++++++++++++++++ Lean4Lean/Theory/NestedInductiveFixtures.lean | 263 +++++++++++++++ .../Environment/NestedTransformation.lean | 261 +++++++++++++++ plans/roadmap.md | 69 ++-- 4 files changed, 867 insertions(+), 28 deletions(-) create mode 100644 Lean4Lean/Theory/NestedInductive.lean create mode 100644 Lean4Lean/Theory/NestedInductiveFixtures.lean create mode 100644 Lean4Lean/Verify/Environment/NestedTransformation.lean diff --git a/Lean4Lean/Theory/NestedInductive.lean b/Lean4Lean/Theory/NestedInductive.lean new file mode 100644 index 0000000..efe60c0 --- /dev/null +++ b/Lean4Lean/Theory/NestedInductive.lean @@ -0,0 +1,302 @@ +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 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 + +end VInductDecl + +end Lean4Lean diff --git a/Lean4Lean/Theory/NestedInductiveFixtures.lean b/Lean4Lean/Theory/NestedInductiveFixtures.lean new file mode 100644 index 0000000..ceb004f --- /dev/null +++ b/Lean4Lean/Theory/NestedInductiveFixtures.lean @@ -0,0 +1,263 @@ +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 + +end Lean4Lean.NestedInductiveFixtures diff --git a/Lean4Lean/Verify/Environment/NestedTransformation.lean b/Lean4Lean/Verify/Environment/NestedTransformation.lean new file mode 100644 index 0000000..f460a13 --- /dev/null +++ b/Lean4Lean/Verify/Environment/NestedTransformation.lean @@ -0,0 +1,261 @@ +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" + +end Lean4Lean.NestedTransformation diff --git a/plans/roadmap.md b/plans/roadmap.md index d59d96b..a52f8ac 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -67,12 +67,12 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| Ladder position | **L4L-09B active**; L4L-09A and everything above it are complete and pruned from §5; everything below L4L-09B is queued | -| Current formalization source | L4L-09A nested representation decision on top of the L4L-08C closure `ea733017` (itself built on the L4L-08A checked representation `79e1ae4f` and L4L-08B validation semantics); this checkpoint adds the committed design note and executable nested-metadata probes in `Lean4Lean/Verify/Environment/NestedRepresentation.lean` at `jcb/formalization2`, with publication to `argumentcomputer/lean4lean` `jcb/induct` pending | +| Ladder position | **L4L-09C active**; L4L-09B and everything above it are complete and pruned from §5; everything below L4L-09C is queued | +| Current formalization source | L4L-09B nested transformation on top of the L4L-09A design checkpoint `e0ee54ee` and the L4L-08C closure `ea733017`; this checkpoint adds the Theory flattening `nestedElimination?`/`nestedStage3` (`Lean4Lean/Theory/NestedInductive.lean`), its fixture pins, and the port/kernel differential (`Lean4Lean/Verify/Environment/NestedTransformation.lean`) at `jcb/formalization2`, 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-09A checkpoint 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 | +| Gates | the full §6 gate is green on the L4L-09B checkpoint source, including focused, aggregate, and default Lake builds, the Nix proof/dependency build, all native flake checks, sorry-frontier and Theory import-boundary audits, formatter check, and whitespace check | ### 2.1 What is green @@ -299,7 +299,7 @@ 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. -**Nested representation decision.** The committed design note and +**Nested representation and flattening.** The committed design note and executable metadata probes in `Lean4Lean/Verify/Environment/NestedRepresentation.lean` pin how the implementation stores nested inductives (restored source families carrying @@ -308,17 +308,38 @@ are keyed by previously declared inductives' constructors, flattened motive/minor counts, no surviving `_nested.*` constant) and fix the L4L-09 representation: the stored Theory payload is the source `VInductDecl` unchanged, and nested support is an additive artifact coupling the -flattened block (already accepted by the existing arbitrary-block -machinery, per probe) with per-auxiliary specifications — the Theory -analog of `aux2nested` — and a restoration substitution σ. Probes verify -on rose-tree, nested-indexed, and constant-universe fixtures that the -port's nested path reproduces Lean's stored metadata exactly, that final -metadata is independent of auxiliary-name collisions, and that σ over the -existing flat-block generation artifacts reproduces every stored recursor -type and rule RHS, with declaration-world values for constructor types and -an `instL` elimination-offset splice for recursor-world artifacts. The -source declarations remain rejected by every current analyzer; acceptance -behavior is unchanged at this checkpoint. +flattened block (accepted by the unchanged arbitrary-block machinery) with +per-auxiliary specifications — the Theory analog of `aux2nested` — and a +restoration substitution σ. Probes verify on rose-tree, nested-indexed, +and constant-universe fixtures that the port's nested path reproduces +Lean's stored metadata exactly, that final metadata is independent of +auxiliary-name collisions, and that σ over the existing flat-block +generation artifacts reproduces every stored recursor type and rule RHS, +with declaration-world values for constructor types and an `instL` +elimination-offset splice for recursor-world artifacts. + +The Theory flattening itself is implemented: +`VInductDecl.nestedElimination?` (`Theory/NestedInductive.lean`) mirrors +`ElimNestedInductive` phase for phase — target-block recognition against +caller-supplied environment-free metadata copies (`NestedTargetBlock`, +with `NestedTargetBlock.WF` tying the copy to a `VEnv`), the +local-variable rejection, replace-without-descending rewriting, +value-keyed deduplication, whole-target-block auxiliary creation with +level instantiation and simultaneous parameter substitution, canonical +`appendIndexAfter` naming, and the fixpoint over queued auxiliary +constructors. `nestedStage3` gates acceptance by flattening success plus +generation readiness of the flattened block through the unchanged L4L-08 +analyzers. Theory fixtures pin the exact flattened blocks and +specifications for the rose-tree and nested-indexed fixtures, and the +Verify differential (`Verify/Environment/NestedTransformation.lean`) +proves the Theory flattening equal to the port's on all three real +fixtures (families, constructors, specifications, `numNested`), ties the +hand-written `List` target to stored metadata, and matches kernel +accept/reject on four nearest negatives: local-variable parametric +arguments (with the kernel's exact diagnostic), off-spine parametric +applications, canonical-auxiliary-name collisions, and missing target +declarations. Source declarations remain rejected by every raw analyzer; +no generated recursor, rule, or replay is claimed for nested blocks yet. **Not claimed.** Nested blocks, generated patterns, projections, and the remaining metatheory/checker roots. The mutual fixtures prove the current @@ -519,20 +540,12 @@ 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-09B–L4L-09C) +### Nested inductives (L4L-09C) -**L4L-09B — nested transformation and positivity (active).** Implement the -chosen pre-flattening/auxiliary relation from the committed L4L-09A design -(flattened block plus per-auxiliary specifications and the restoration -substitution), 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. +**L4L-09C — nested generation and replay (active).** Generate every +auxiliary declaration, recursor, and rule through the restoration +substitution over the flattened block's generation artifacts; 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. From 4b3d4498b3ba7e775239bc06b12abeafcd071eff Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 08:02:20 -0400 Subject: [PATCH 09/27] theory+verify: restore nested generation artifacts and align the transaction First L4L-09C sub-checkpoint: the complete generic nested layer. Theory: the total restoration substitution restoreExpr fires bottom-up at each auxiliary spine that completes its block-parameter count - coinciding with restoreNested's top-down pass on generated artifacts - with recursor renaming checked before the constructor-prefix case. NestedBlockChecked.recursors/generatedRules restore the flattened block's generation artifacts onto the appendIndexAfter inventory with declaration-world values instL-spliced by the elimination offset. VEnv.addInductNested inserts source families, source constructors, restored recursors, and restored rules in the four block phases; AddInductNestedTrace pins the exact phase boundaries, and the lemma suite (trace recovery, atomicity, le, freshness, family/ctor/rec lookup, rule membership) mirrors the block transaction through ctorFold_spec/rulesFold_spec. NestedBlockChecked.WF chains per-insertion constant and rule well-formedness along the deterministic phase folds; addInductNested_WF folds it into Ordered preservation, and the new VDecl.WF.inductNested case discharges through VEnv.WF.ordered. Verify: AddInductNestedTrace/AddInductNested alignment mirrors the block trace (real ConstantInfo insertions, TrConstVal translation, RecursorMapKMatches, rule fold), TrEnv' gains the inductNested case, and TrEnv'.wf/aligned/of_value/map_wf/sf_mono are extended. The restoration-parity differential proves the product sigma equal to Lean's stored metadata - every restored recursor name, universe count, and type, and every rule RHS in globally flattened order - on the rose-tree, nested-indexed, and constant-universe fixtures, and the Theory fixtures pin restored names, cleanliness (no auxiliary constant survives), rule counts, and the transaction's final lookups. Environment replay of real Inductive.Add.run output through the new alignment trace remains the open L4L-09C obligation. Gates: focused, aggregate, and default Lake builds, sorry frontier unchanged (25 known entries), Theory import boundary empty, whitespace clean; Nix proof/dependency build and flake checks run on this committed checkpoint. --- Lean4Lean/Theory/NestedInductive.lean | 223 ++++++++++++++++++ Lean4Lean/Theory/NestedInductiveFixtures.lean | 60 +++++ Lean4Lean/Theory/Typing/Env.lean | 5 + Lean4Lean/Theory/Typing/EnvLemmas.lean | 2 + .../Theory/Typing/NestedInductiveLemmas.lean | 164 +++++++++++++ Lean4Lean/Verify/Environment/Basic.lean | 57 +++++ Lean4Lean/Verify/Environment/Lemmas.lean | 33 +++ .../Environment/NestedTransformation.lean | 55 +++++ 8 files changed, 599 insertions(+) create mode 100644 Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean diff --git a/Lean4Lean/Theory/NestedInductive.lean b/Lean4Lean/Theory/NestedInductive.lean index efe60c0..6be562f 100644 --- a/Lean4Lean/Theory/NestedInductive.lean +++ b/Lean4Lean/Theory/NestedInductive.lean @@ -297,6 +297,229 @@ 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 index ceb004f..4bcbd0e 100644 --- a/Lean4Lean/Theory/NestedInductiveFixtures.lean +++ b/Lean4Lean/Theory/NestedInductiveFixtures.lean @@ -260,4 +260,64 @@ def collisionSource : VInductDecl where #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/Typing/Env.lean b/Lean4Lean/Theory/Typing/Env.lean index de6f89c..0e957ba 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 cedcfc1..eba779d 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/NestedInductiveLemmas.lean b/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean new file mode 100644 index 0000000..44c12a9 --- /dev/null +++ b/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean @@ -0,0 +1,164 @@ +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 + +/-- 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 + +/-- 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/Verify/Environment/Basic.lean b/Lean4Lean/Verify/Environment/Basic.lean index c5102ea..ea7674f 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,6 +338,20 @@ theorem AddInductBlock.le rcases VEnv.addInductBlockGeneration_trace hadd with ⟨trace⟩ exact trace.le +/-- 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 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`. -/ @@ -390,6 +439,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,6 +476,10 @@ 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] diff --git a/Lean4Lean/Verify/Environment/Lemmas.lean b/Lean4Lean/Verify/Environment/Lemmas.lean index 0af803b..fea5ad7 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' := @@ -158,6 +160,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,6 +216,16 @@ 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] -/ @@ -218,6 +248,7 @@ 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] @@ -325,6 +356,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/NestedTransformation.lean b/Lean4Lean/Verify/Environment/NestedTransformation.lean index f460a13..5cbee5d 100644 --- a/Lean4Lean/Verify/Environment/NestedTransformation.lean +++ b/Lean4Lean/Verify/Environment/NestedTransformation.lean @@ -258,4 +258,59 @@ run_meta do 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] + end Lean4Lean.NestedTransformation From 347537067a9cda0ec7531dbba3ec7533f2de7d1b Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 08:22:34 -0400 Subject: [PATCH 10/27] verify: round-trip real nested addInductive output through the artifacts Second L4L-09C sub-checkpoint. The real-output round-trip runs the port's complete Environment.addInductive on dependency-only kernel environments and compares its entire output - not the ambient elaborator metadata - against the Theory nested artifacts: stored payload families and constructors (universe counts and translated types), numNested against the artifact's auxiliary count, and every emitted recursor's name, universe count, type, K flag, and rule RHSs against the restored inventory in order, on the rose-tree, nested-indexed, and constant-universe fixtures. Nothing on either side is hand-authored: the left side is real Inductive.Add.run-derived output and the right side is computed by nestedBlockChecked?. The roadmap records the L4L-09C position: the generic layer and the metadata round-trip are landed; inhabiting NestedBlockChecked.WF for both ladder fixtures (checker-run certificates on restored artifacts or the general sigma-transport theorem) and driving the replay through TrEnv'.inductNested remain open. Gates: focused, aggregate, and default Lake builds, sorry frontier unchanged (25 known entries), Theory import boundary empty, whitespace clean; Nix proof/dependency build and flake checks run on this committed checkpoint. --- .../Environment/NestedTransformation.lean | 67 +++++++++++++++++++ plans/roadmap.md | 32 ++++++++- 2 files changed, 97 insertions(+), 2 deletions(-) diff --git a/Lean4Lean/Verify/Environment/NestedTransformation.lean b/Lean4Lean/Verify/Environment/NestedTransformation.lean index 5cbee5d..320fed6 100644 --- a/Lean4Lean/Verify/Environment/NestedTransformation.lean +++ b/Lean4Lean/Verify/Environment/NestedTransformation.lean @@ -313,4 +313,71 @@ run_meta do 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/plans/roadmap.md b/plans/roadmap.md index a52f8ac..4b5edb4 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -67,8 +67,8 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| Ladder position | **L4L-09C active**; L4L-09B and everything above it are complete and pruned from §5; everything below L4L-09C is queued | -| Current formalization source | L4L-09B nested transformation on top of the L4L-09A design checkpoint `e0ee54ee` and the L4L-08C closure `ea733017`; this checkpoint adds the Theory flattening `nestedElimination?`/`nestedStage3` (`Lean4Lean/Theory/NestedInductive.lean`), its fixture pins, and the port/kernel differential (`Lean4Lean/Verify/Environment/NestedTransformation.lean`) at `jcb/formalization2`, with publication to `argumentcomputer/lean4lean` `jcb/induct` pending | +| Ladder position | **L4L-09C active** (generic generation, transaction, preservation, alignment, and metadata round-trip landed through the `4b3d4498` sub-checkpoint; the WF-inhabited environment replay of both fixtures remains); L4L-09B and everything above it are complete and pruned from §5; everything below L4L-09C is queued | +| Current formalization source | L4L-09C work in progress on top of the L4L-09B transformation checkpoint `b8899c7d`, the L4L-09A design checkpoint `e0ee54ee`, and the L4L-08C closure `ea733017`; the latest sub-checkpoint adds the total restoration substitution, restored generation artifacts, `addInductNested` with trace/preservation, and the `TrEnv'.inductNested` alignment layer at `jcb/formalization2`, 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 | @@ -318,6 +318,34 @@ generation artifacts reproduces every stored recursor type and rule RHS, with declaration-world values for constructor types and an `instL` elimination-offset splice for recursor-world artifacts. +The restoration and its transaction are implemented and preserved: +`restoreExpr` is the total bottom-up σ (firing where an auxiliary spine +completes its parameter count, recursor renames checked before the +constructor-prefix case), `NestedBlockChecked.recursors`/`generatedRules` +restore the flattened block's generation artifacts onto the +`appendIndexAfter` inventory, and `VEnv.addInductNested` inserts source +families/constructors plus restored recursors/rules in the four block +phases. `AddInductNestedTrace` and its lemma suite (recovery, atomicity, +monotonicity, freshness, lookups, rule membership) mirror the block +transaction; `NestedBlockChecked.WF` chains per-insertion constant and +rule well-formedness along the deterministic phase folds and +`addInductNested_WF` folds it into `Ordered` preservation, discharged +through the new `VDecl.WF.inductNested` case and `VEnv.WF.ordered`. +Verify's `AddInductNested`/`AddInductNestedTrace` and `TrEnv'.inductNested` +extend the alignment layer (with `aligned`, `of_value`, `map_wf`, +`sf_mono` cases). The restoration-parity differential proves the product +σ equal to Lean's stored metadata — every restored recursor name, +universe count, and type, and every rule RHS in globally flattened +order — and the real-output round-trip runs the port's complete +`Environment.addInductive` on dependency-only environments and compares +its entire output against the Theory artifacts (payload constants, +recursors, K flags, rule RHSs, and `numNested`), on the rose-tree, +nested-indexed, and constant-universe fixtures. Outstanding for L4L-09C: +inhabiting `NestedBlockChecked.WF` for both ladder fixtures (via +checker-run certificates on the restored artifacts or the general +σ-transport theorem) and driving the real replay through +`TrEnv'.inductNested` into aligned final environments. + The Theory flattening itself is implemented: `VInductDecl.nestedElimination?` (`Theory/NestedInductive.lean`) mirrors `ElimNestedInductive` phase for phase — target-block recognition against From b71ab5c26e8a0642c52796d15e32b8e092f5c967 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 08:34:14 -0400 Subject: [PATCH 11/27] theory: prove typed transport along constant interpretations Third L4L-09C sub-checkpoint: the sigma-transport core from the L4L-09A design note. Theory/Typing/NestedTransport.lean defines the clean compositional substitution substConst (each interpreted constant replaced by a closed value, level-instantiated per occurrence) with its full commutation calculus against liftN, inst, and instL, plus context-lookup transport. The ConstInterp environment morphism packages what nested restoration provides: interpreted constants become closed values typed at their sigma-image types in the target environment, surviving constants and registered defeqs are sigma-imaged, and the target is Ordered. IsDefEq.substConst proves the typed transport: every Theory judgment of the interpreted environment holds of the sigma-images in the target, with the interpreted-constant case discharged through IsDefEq.instL_r and closed-term weakening, and the extra case through the defeq clause. HasType/IsType/VConstant.WF/VDefEq.WF corollaries give exactly the field shapes of NestedBlockChecked.WF. Remaining transport obligations, recorded in the module docstring and plans/l4l-09c-replay-plan.md: the beta-collapse bridge from substConst to the spine-collapsed restoreExpr on generated artifacts, the per-phase morphism construction for a staged flattened block, and the fixture replays through TrEnv'.inductNested. Gates: focused, aggregate, and default Lake builds, sorry frontier unchanged (25 known entries), Theory import boundary empty, whitespace clean; Nix proof/dependency build and flake checks run on this committed checkpoint. --- Lean4Lean/Theory/Typing/NestedTransport.lean | 222 +++++++++++++++++++ 1 file changed, 222 insertions(+) create mode 100644 Lean4Lean/Theory/Typing/NestedTransport.lean diff --git a/Lean4Lean/Theory/Typing/NestedTransport.lean b/Lean4Lean/Theory/Typing/NestedTransport.lean new file mode 100644 index 0000000..b51751a --- /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 From a77e358b5243f1956fa92c648cd8c7b8e99b0ee6 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 09:12:00 -0400 Subject: [PATCH 12/27] verify: replay the rose nested declaration through TrEnv'.inductNested Fourth L4L-09C sub-checkpoint: the first real nested environment replay. Verify/Environment/NestedReplay.lean replays the stored rose-tree metadata (RoseTree, RoseTree.node, RoseTree.rec, RoseTree.rec_1) over the completed List replay environment. The NestedBlockChecked.WF package is proved outright: every phase constant and every restored rule is typed by direct concrete derivations (type_tac over the staged environments), with the printed artifact literals tied to the computed nestedBlockChecked? artifact by native_decide observations, so the package closure is the standard logical baseline plus the persistent-map container axioms and the named native observations - no sorryAx. The alignment trace inserts the real ConstantInfos with tr_type_expr_tac translations, exact freshness chains, the K-flag agreement, and the literal rule fold, and TrEnv'.inductNested drives the final map and environment into alignment, with Ordered derived and the exact transitional closure guarded. The nested-indexed fixture replay and the milestone close-out remain. Gates: focused, aggregate, and default Lake builds, sorry frontier unchanged (25 known entries), whitespace clean; Nix gates run on this committed checkpoint. --- Lean4Lean/Theory/NestedInductive.lean | 1 + .../Verify/Environment/NestedReplay.lean | 1758 +++++++++++++++++ 2 files changed, 1759 insertions(+) create mode 100644 Lean4Lean/Verify/Environment/NestedReplay.lean diff --git a/Lean4Lean/Theory/NestedInductive.lean b/Lean4Lean/Theory/NestedInductive.lean index 6be562f..b8d6a38 100644 --- a/Lean4Lean/Theory/NestedInductive.lean +++ b/Lean4Lean/Theory/NestedInductive.lean @@ -52,6 +52,7 @@ 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 diff --git a/Lean4Lean/Verify/Environment/NestedReplay.lean b/Lean4Lean/Verify/Environment/NestedReplay.lean new file mode 100644 index 0000000..6fd081b --- /dev/null +++ b/Lean4Lean/Verify/Environment/NestedReplay.lean @@ -0,0 +1,1758 @@ +import Lean4Lean.Verify.Environment.SingletonParityReplay +import Lean4Lean.Verify.Environment.NestedTransformation + +/-! +# Nested environment replay (L4L-09C) + +The rose-tree nested declaration replayed over the completed `List` +environment: the real stored metadata is inserted through +`AddInductNestedTrace`, with the `NestedBlockChecked.WF` package proved by +direct concrete typing derivations, and the final environments driven +through `TrEnv'.inductNested`. +-/ + +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 transitional closure (the checker-refinement frontier plus the +compiler-trust axiom introduced by the `native_decide` observations). -/ + +#guard roseNestedC.elim.numNested == 1 +#guard roseRecV == roseRecVL && roseRec1V == roseRec1VL + +/-- +info: 'Lean4Lean.NestedReplayFixtures.roseTrEnv09' depends on axioms: [propext, + sorryAx, + 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 + +end Lean4Lean.NestedReplayFixtures From e297560d92eb48e293f53416496e685ea11d0541 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 09:20:15 -0400 Subject: [PATCH 13/27] verify: replay the nested-indexed fixture and close nested generation L4L-09C closure checkpoint. The second ladder fixture - the nested-indexed family through PVec - replays from real stored metadata: the PVec family and constructors are staged over the completed Nat replay through TrEnv'.inductStaging (with concrete WF and tr_type_expr_tac translations), and the stored NVTree metadata then drives TrEnv'.inductNested with the complete NestedBlockChecked.WF package proved by direct concrete typing derivations over the exact phase environments, printed artifact literals tied to the computed nestedBlockChecked? artifact by named native_decide observations, exact freshness chains, K-flag agreement, and the literal rule fold. Both package closures carry no sorryAx; the TrEnv' roots carry the usual transitional checker closure, exactly guarded. With both fixtures round-tripping real Inductive.Add.run output through generic packaging and environment replay - comparing every family, constructor, and recursor type and every rule RHS against stored metadata rather than hand-authored declarations - the L4L-09C exit is met and the milestone is pruned from the roadmap ladder: L4L-10A is active. The roadmap records the nested coverage boundary (single-target nesting; breadth belongs to L4L-11) and the proved sigma-hat transport as the generic justification layer. Gates: focused, aggregate, and default Lake builds, sorry frontier unchanged (25 known entries), Theory import boundary empty, whitespace clean; Nix proof/dependency build and flake checks run on this committed checkpoint. --- .../Verify/Environment/NestedReplay.lean | 1658 ++++++++++++++++- plans/roadmap.md | 68 +- 2 files changed, 1693 insertions(+), 33 deletions(-) diff --git a/Lean4Lean/Verify/Environment/NestedReplay.lean b/Lean4Lean/Verify/Environment/NestedReplay.lean index 6fd081b..f261734 100644 --- a/Lean4Lean/Verify/Environment/NestedReplay.lean +++ b/Lean4Lean/Verify/Environment/NestedReplay.lean @@ -4,11 +4,13 @@ import Lean4Lean.Verify.Environment.NestedTransformation /-! # Nested environment replay (L4L-09C) -The rose-tree nested declaration replayed over the completed `List` -environment: the real stored metadata is inserted through -`AddInductNestedTrace`, with the `NestedBlockChecked.WF` package proved by -direct concrete typing derivations, and the final environments driven -through `TrEnv'.inductNested`. +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 @@ -1755,4 +1757,1650 @@ info: 'Lean4Lean.NestedReplayFixtures.roseNestedWF09' depends on axioms: [propex #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, + sorryAx, + 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/plans/roadmap.md b/plans/roadmap.md index 4b5edb4..f4c7a2b 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -67,12 +67,12 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| Ladder position | **L4L-09C active** (generic generation, transaction, preservation, alignment, and metadata round-trip landed through the `4b3d4498` sub-checkpoint; the WF-inhabited environment replay of both fixtures remains); L4L-09B and everything above it are complete and pruned from §5; everything below L4L-09C is queued | -| Current formalization source | L4L-09C work in progress on top of the L4L-09B transformation checkpoint `b8899c7d`, the L4L-09A design checkpoint `e0ee54ee`, and the L4L-08C closure `ea733017`; the latest sub-checkpoint adds the total restoration substitution, restored generation artifacts, `addInductNested` with trace/preservation, and the `TrEnv'.inductNested` alignment layer at `jcb/formalization2`, with publication to `argumentcomputer/lean4lean` `jcb/induct` pending | +| Ladder position | **L4L-10A active**; L4L-09C and everything above it are complete and pruned from §5; everything below L4L-10A is queued | +| Current formalization source | L4L-09C nested generation and replay closure on top of its sub-checkpoints (`4b3d4498` generic layer, `34753706` round-trip, `b71ab5c2` σ̂ transport, `a77e358b` rose replay), the L4L-09B transformation checkpoint `b8899c7d`, the L4L-09A design checkpoint `e0ee54ee`, and the L4L-08C closure `ea733017`; the closing checkpoint adds the nested-indexed replay over a staged `PVec` boundary in `Lean4Lean/Verify/Environment/NestedReplay.lean` at `jcb/formalization2`, 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-09B checkpoint 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 | +| Gates | the full §6 gate is green on the L4L-09C closure source, including focused, aggregate, and default Lake builds, the Nix proof/dependency build, all native flake checks, sorry-frontier and Theory import-boundary audits, formatter check, and whitespace check | ### 2.1 What is green @@ -340,11 +340,29 @@ order — and the real-output round-trip runs the port's complete `Environment.addInductive` on dependency-only environments and compares its entire output against the Theory artifacts (payload constants, recursors, K flags, rule RHSs, and `numNested`), on the rose-tree, -nested-indexed, and constant-universe fixtures. Outstanding for L4L-09C: -inhabiting `NestedBlockChecked.WF` for both ladder fixtures (via -checker-run certificates on the restored artifacts or the general -σ-transport theorem) and driving the real replay through -`TrEnv'.inductNested` into aligned final environments. +nested-indexed, and constant-universe fixtures. + +**Nested environment replay.** Both ladder fixtures replay from real +stored metadata through `TrEnv'.inductNested` +(`Verify/Environment/NestedReplay.lean`): the rose tree over the +completed `List` replay environment, and the nested-indexed family over +a `PVec` boundary staged by `TrEnv'.inductStaging` on the completed +`Nat` replay. Each replay inserts the stored `ConstantInfo`s with +`tr_type_expr_tac` translations, exact freshness chains, K-flag +agreement, and the literal rule fold, and proves the complete +`NestedBlockChecked.WF` package by direct concrete typing derivations +(`type_tac`) over the exact phase environments, with the printed +artifact literals tied to the computed `nestedBlockChecked?` artifacts +by named `native_decide` observations. The package closures are the +standard logical baseline plus the persistent-map container axioms and +those named observations — no `sorryAx`; the full `TrEnv'` roots carry +the usual transitional checker closure, exactly guarded. The general σ̂ +typed transport (`Theory/Typing/NestedTransport.lean`: the `ConstInterp` +environment morphism and `IsDefEq.substConst` with +`HasType`/`IsType`/`VConstant.WF`/`VDefEq.WF` corollaries) is proved as +the generic justification layer; its β-collapse bridge to the +spine-collapsed artifact substitution on generated artifacts remains +available future work, not a nested-coverage gap. The Theory flattening itself is implemented: `VInductDecl.nestedElimination?` (`Theory/NestedInductive.lean`) mirrors @@ -369,11 +387,14 @@ applications, canonical-auxiliary-name collisions, and missing target declarations. Source declarations remain rejected by every raw analyzer; no generated recursor, rule, or replay is claimed for nested blocks yet. -**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. +**Not claimed.** Generated patterns, projections, and the remaining +metatheory/checker roots. The nested fixtures prove the current +single-target nesting boundary (one auxiliary block per occurrence class, +`nparams ≤ 1` exercised by the ladder fixtures); nesting classes beyond +the accepted flattened-block analyzer remain rejected, and deep +multi-parameter nesting breadth belongs to the L4L-11 replay-breadth +matrix. Bare producer success is never generation-shape authority or +Theory semantics. ### 2.2 Live debt @@ -393,10 +414,11 @@ are not proof debt: 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. +- The public inductive spec has complete one-family, non-nested mutual, + and nested generation, preservation, metadata parity, and environment + replay, but remains a growing subset rather than kernel-complete; + generated-pattern and projection coverage remain queued, and nested + replay breadth beyond the two ladder fixtures belongs to L4L-11. - 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). @@ -568,19 +590,9 @@ 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-09C) - -**L4L-09C — nested generation and replay (active).** Generate every -auxiliary declaration, recursor, and rule through the restoration -substitution over the flattened block's generation artifacts; 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 +**L4L-10A — generated iota pattern core (active).** 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 From 3689b115f15629470deaf1a7a182f2fe611de918 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 11:05:33 -0400 Subject: [PATCH 14/27] theory: prove the generated iota pattern core for certified blocks L4L-10A. Every certified mutual block's iota rules are exact SimplePattern.iota patterns, and the block supplies the complete generic Params pattern facts at standard Theory axiom closure. Theory/Typing/Pattern.lean gains the implementation-independent shape layer: HeadConstN/HeadConst spines, of_varN_matches and HeadConstN.matches (varN-tower match inversion/construction), varNPaths capture paths, RecursorIotaPattern with matches_shape/matches_of, bounded subpattern classification (Subpattern.varN_const_le, subpattern_inv, app_subpattern), tower intersection laws (varN_const_inter_some/none, app_inter_varN_const_some, RecursorIotaPattern.inter_some/ inter_varN_const_some), component injectivity (varN_const_inj, RecursorIotaPattern.inj), and Pattern.RHS.appN. Theory/Typing/InductivePattern.lean names the generated rule anatomy (ruleBinders/ruleLhsBody/ruleCtorApp/ruleIdx, rule_lhs by rfl), defines rulePattern (major arity: parameters, motives, minors, and the constructor's result indices; argument arity: parameters plus fields), and matches the exact generated left body against it at the rule's recursor levels (ruleLhsBody_matches). The name-freshness inputs come from the certified blockGeneratedNames nodup bit transported across the normalization boundary (sameTypeHeaders name transport); the major-arity agreement between same-recursor rules is extracted from the analyzer's terminal blockTarget? arity equation through the checked family spine (view_resultIndices_length, env-free). IotaPat couples each rule 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), closed under a decidable RuleClosure bundle. pat_simple, recover, rule distinctness (rulePattern_inj), pat_uniq, pat_app_l, pat_app_l_uniq, and pat_app_uniq are exactly the Params obligations for the block set, with guarded propext/Quot.sound closures (pat_uniq additionally Classical.choice). No open-environment Params instance is installed. Theory/Typing/InductivePatternFixtures.lean pins two literal-name certified blocks by kernel evaluation: a mutual tree/forest pair (majors 6/6/6, arguments 3/1/3) and a Nat-indexed vector (majors 5/5, arguments 1/4), including RuleClosure by decide and exact pattern inventories. Gates: lake build Lean4Lean.Theory Lean4Lean.Verify, SorryFrontier (25 known, unchanged), and the default build are green; nix gates run on this checkpoint before the bookmark advances. plans/roadmap.md moves the ladder to L4L-10B (pattern soundness and environment assembler). --- Lean4Lean/Theory/Typing/InductivePattern.lean | 774 ++++++++++++++++++ .../Typing/InductivePatternFixtures.lean | 123 +++ Lean4Lean/Theory/Typing/Pattern.lean | 212 +++++ plans/roadmap.md | 69 +- 4 files changed, 1152 insertions(+), 26 deletions(-) create mode 100644 Lean4Lean/Theory/Typing/InductivePattern.lean create mode 100644 Lean4Lean/Theory/Typing/InductivePatternFixtures.lean diff --git a/Lean4Lean/Theory/Typing/InductivePattern.lean b/Lean4Lean/Theory/Typing/InductivePattern.lean new file mode 100644 index 0000000..26c1901 --- /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/InductivePatternFixtures.lean b/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean new file mode 100644 index 0000000..4b8354a --- /dev/null +++ b/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean @@ -0,0 +1,123 @@ +import Lean4Lean.Theory.Typing.InductivePattern + +/-! # 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 + +end Lean4Lean.InductivePatternFixtures diff --git a/Lean4Lean/Theory/Typing/Pattern.lean b/Lean4Lean/Theory/Typing/Pattern.lean index 87e7749..2c2c537 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/plans/roadmap.md b/plans/roadmap.md index f4c7a2b..f59c666 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -67,8 +67,8 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| Ladder position | **L4L-10A active**; L4L-09C and everything above it are complete and pruned from §5; everything below L4L-10A is queued | -| Current formalization source | L4L-09C nested generation and replay closure on top of its sub-checkpoints (`4b3d4498` generic layer, `34753706` round-trip, `b71ab5c2` σ̂ transport, `a77e358b` rose replay), the L4L-09B transformation checkpoint `b8899c7d`, the L4L-09A design checkpoint `e0ee54ee`, and the L4L-08C closure `ea733017`; the closing checkpoint adds the nested-indexed replay over a staged `PVec` boundary in `Lean4Lean/Verify/Environment/NestedReplay.lean` at `jcb/formalization2`, with publication to `argumentcomputer/lean4lean` `jcb/induct` pending | +| Ladder position | **L4L-10B active**; L4L-10A and everything above it are complete and pruned from §5; everything below L4L-10B is queued | +| Current formalization source | the L4L-10A generated-iota-pattern checkpoint (`Theory/Typing/Pattern.lean` shape helpers, `Theory/Typing/InductivePattern.lean` block pattern facts, `Theory/Typing/InductivePatternFixtures.lean`) on top of the L4L-09 line (`e297560d` nested closure, `4b3d4498`/`34753706`/`b71ab5c2`/`a77e358b` sub-checkpoints, `b8899c7d` transformation, `e0ee54ee` design) and the L4L-08C closure `ea733017`, at `jcb/formalization2`, 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 | @@ -387,8 +387,34 @@ applications, canonical-auxiliary-name collisions, and missing target declarations. Source declarations remain rejected by every raw analyzer; no generated recursor, rule, or replay is claimed for nested blocks yet. -**Not claimed.** Generated patterns, projections, and the remaining -metatheory/checker roots. The nested fixtures prove the current +**Generated iota patterns.** Every certified block's iota rules are exact +`SimplePattern.iota` patterns (`Theory/Typing/InductivePattern.lean`): the +generated left body is the owning recursor applied to the shared parameters, +all motives, all minors, and the constructor's result indices with a +constructor-headed major premise, and `ruleLhsBody_matches` matches it +against `rulePattern` at the rule's recursor levels. The block's pattern set +`IotaPat` couples each rule's pattern with an RHS template — the registered +right tower applied to the captured common arguments and fields — and a +check list demanding parameter and result-index agreement between the +recursor spine and the major premise, with payload closedness carried by a +`RuleClosure` bundle that fixtures discharge by evaluation. 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 +`blockGeneratedNames` inventory (nodup transported across the normalization +boundary) and the analyzer's terminal `blockTarget?` arity equation, at +guarded `propext`/`Quot.sound`-level closures. The implementation-independent +shape layer (`HeadConstN`, `HeadConst`, `of_varN_matches`, +`RecursorIotaPattern`, `matches_shape`, tower intersection laws, +`varNPaths`) lives in `Theory/Typing/Pattern.lean`; a mutual tree/forest +block and a `Nat`-indexed vector fixture pin the pattern inventories and +closedness by kernel evaluation. No open-environment `Params` instance is +installed; `pat_wf` and the block-local environment assembler belong to +L4L-10B. + +**Not claimed.** Pattern soundness (`pat_wf`), the pattern-form environment +assembler, projections, and the remaining metatheory/checker roots. The nested fixtures prove the current single-target nesting boundary (one auxiliary block per occurrence class, `nparams ≤ 1` exercised by the ladder fixtures); nesting classes beyond the accepted flattened-block analyzer remain rejected, and deep @@ -415,10 +441,12 @@ The remaining v4.31-added sorry is classified: `Lean4Lean.addDecl.WF` → L4L-19B. Non-sorry debt: - The public inductive spec has complete one-family, non-nested mutual, - and nested generation, preservation, metadata parity, and environment - replay, but remains a growing subset rather than kernel-complete; - generated-pattern and projection coverage remain queued, and nested - replay breadth beyond the two ladder fixtures belongs to L4L-11. + and nested generation, preservation, metadata parity, environment + replay, and generic iota-pattern facts, but remains a growing subset + rather than kernel-complete; pattern soundness (`pat_wf`), the + pattern-form assembler, and projection coverage remain queued, and + nested replay breadth beyond the two ladder fixtures belongs to + L4L-11. - 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). @@ -590,24 +618,13 @@ 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. -### Generated patterns (L4L-10A–L4L-10B) - -**L4L-10A — generated iota pattern core (active).** 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. +### Generated patterns (L4L-10B) + +**L4L-10B — pattern soundness and environment assembler (active).** 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. From bc51f980d24d0f9f3a8e2637e5eac6e98d3ea4e2 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 12:00:48 -0400 Subject: [PATCH 15/27] theory: prove pattern soundness and add the block-local assembler MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit L4L-10B. A successful match of a certified block rule whose checks hold is definitionally equal to its instantiated RHS template, through the exact rule defeq registered by addInduct, and a block-local assembler builds environments whose defeq sets are exactly generated rules plus separately certified extensions. Theory/Typing/InductivePatternWF.lean builds the typed β-collapse layer at a sorry-free propext/Quot.sound closure: IsDefEq.appN_lamN collapses a lambda telescope applied to a full well-typed spine to the iterated instantiation (instRev) of its body, via instN_lamN/instL_lamN pushes, Ctx.InstN.consTel, OnTel.instN, SpineDefEq with appN_defEq/appN_congr pointwise application congruence, SpineWF.defEq_of_pointwise, and the lamN_wf/forallN_wf tower inversions (clean lam_inv/forallE_inv only). varN_matches_paths reads a match's captures back as the spine arguments; instRev_bvar_lt and map_instRev_bvarRevRange_seg compute instantiation images of reverse bound-variable segments. pat_wf then derives pattern soundness: the redex, decomposed into recursor and constructor spines with spine-form typing and source-pinned major levels (exactly what a verified reduction site holds), is defeq to the applied right tower — by the registered defeq (.extra), spine congruence along the capture spine, per-index tower collapses composed with the parameter/index agreement checks, and the capture computation of the L4L-10A templates. Its guarded closure is exactly the Church-Rosser development's transitional unique-typing closure (propext, sorryAx, Classical.choice, Quot.sound), shedding sorryAx automatically when L4L-16/17 land. Theory/Typing/InductivePatternEnv.lean adds the assembler: CertifiedExtension couples a defeq with its simple pattern, payload, and the spine-level extra_pat coverage equation; assembleEnv runs the block's four insertion phases over a base and folds the extension defeqs; assembleEnv_defeqs/assembleEnv_defeq_cases invert the assembled defeq set exactly (constant phases preserve defeqs, rule and extension folds add exactly their lists); assembleEnv_WF preserves ordering via the block preservation theorem and the rule-fold WF lemma; AssembledPat is the union pattern set with pat_simple and per-extension ext_covers. No global open-environment Params instance is installed: upstream extra_pat demands syntactic pattern matches of registered defeqs, which lambda-tower registrations (including quotDefEq) never satisfy, so the assembler exposes spine-level coverage and pat_wf-derived reduction instead. Fixtures assemble both L4L-10A blocks over the empty base and pin their defeq sets to the generated rules. Gates: lake build Lean4Lean.Theory Lean4Lean.Verify, SorryFrontier (25 known, unchanged), and the default build are green; nix gates run on this checkpoint before the bookmark advances. plans/roadmap.md prunes L4L-10 and moves the ladder to L4L-11. --- .../Theory/Typing/InductivePatternEnv.lean | 239 +++++ .../Typing/InductivePatternFixtures.lean | 20 +- .../Theory/Typing/InductivePatternWF.lean | 872 ++++++++++++++++++ plans/roadmap.md | 69 +- 4 files changed, 1175 insertions(+), 25 deletions(-) create mode 100644 Lean4Lean/Theory/Typing/InductivePatternEnv.lean create mode 100644 Lean4Lean/Theory/Typing/InductivePatternWF.lean diff --git a/Lean4Lean/Theory/Typing/InductivePatternEnv.lean b/Lean4Lean/Theory/Typing/InductivePatternEnv.lean new file mode 100644 index 0000000..d5c3471 --- /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 index 4b8354a..ed0c957 100644 --- a/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean +++ b/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean @@ -1,4 +1,4 @@ -import Lean4Lean.Theory.Typing.InductivePattern +import Lean4Lean.Theory.Typing.InductivePatternEnv /-! # Pattern facts for concrete certified blocks @@ -120,4 +120,22 @@ axiom closure recorded below. -/ #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 0000000..519253d --- /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/plans/roadmap.md b/plans/roadmap.md index f59c666..f39a965 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -67,8 +67,8 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| Ladder position | **L4L-10B active**; L4L-10A and everything above it are complete and pruned from §5; everything below L4L-10B is queued | -| Current formalization source | the L4L-10A generated-iota-pattern checkpoint (`Theory/Typing/Pattern.lean` shape helpers, `Theory/Typing/InductivePattern.lean` block pattern facts, `Theory/Typing/InductivePatternFixtures.lean`) on top of the L4L-09 line (`e297560d` nested closure, `4b3d4498`/`34753706`/`b71ab5c2`/`a77e358b` sub-checkpoints, `b8899c7d` transformation, `e0ee54ee` design) and the L4L-08C closure `ea733017`, at `jcb/formalization2`, with publication to `argumentcomputer/lean4lean` `jcb/induct` pending | +| Ladder position | **L4L-11 active**; L4L-10B and everything above it are complete and pruned from §5; everything below L4L-11 is queued | +| Current formalization source | the L4L-10B pattern-soundness checkpoint (`Theory/Typing/InductivePatternWF.lean` typed β-collapse and `pat_wf`, `Theory/Typing/InductivePatternEnv.lean` block-local assembler) on top of the L4L-10A pattern-core checkpoint `3689b115`, the L4L-09 line (`e297560d` nested closure and its sub-checkpoints), and the L4L-08C closure `ea733017`, at `jcb/formalization2`, 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 | @@ -410,11 +410,42 @@ shape layer (`HeadConstN`, `HeadConst`, `of_varN_matches`, `varNPaths`) lives in `Theory/Typing/Pattern.lean`; a mutual tree/forest block and a `Nat`-indexed vector fixture pin the pattern inventories and closedness by kernel evaluation. No open-environment `Params` instance is -installed; `pat_wf` and the block-local environment assembler belong to -L4L-10B. - -**Not claimed.** Pattern soundness (`pat_wf`), the pattern-form environment -assembler, projections, and the remaining metatheory/checker roots. The nested fixtures prove the current +installed. + +**Pattern soundness and the assembler.** The typed β-collapse layer +(`Theory/Typing/InductivePatternWF.lean`) proves, at a sorry-free +`propext`/`Quot.sound` closure, that applying a lambda telescope to a full +well-typed spine is definitionally equal to the iterated instantiation of +its body (`IsDefEq.appN_lamN` over `instRev`, with `SpineDefEq` pointwise +application congruence, telescope instantiation, and lambda/pi tower +inversions `lamN_wf`/`forallN_wf`), and that a matched pattern's captures +are exactly the spine arguments (`varN_matches_paths`). `pat_wf` composes +these into pattern soundness for one certified block: a successful match of +a rule's pattern whose parameter and index checks hold is definitionally +equal to the instantiated RHS template, derived from the exact rule defeq +registered by `addInduct` — the redex arrives decomposed into its recursor +and constructor spines with spine-form typing and pinned source levels, +which is precisely what a verified reduction site holds, and the theorem's +guarded closure is exactly the Church–Rosser development's own transitional +unique-typing closure, shedding `sorryAx` automatically when L4L-16/17 +land. The block-local assembler +(`Theory/Typing/InductivePatternEnv.lean`) builds an environment whose +defeq set is exactly one certified block's generated rules plus separately +certified extension rules over a constant base: `assembleEnv_defeqs` +inverts the defeq set exactly, `assembleEnv_WF` preserves ordering through +the block phases and the extension fold, and the union pattern set +`AssembledPat` couples the block's L4L-10A facts with each +`CertifiedExtension`'s payload and spine-level `extra_pat` coverage +equation. No global open-environment `Params` instance is installed; both +fixture blocks assemble over the empty base with their defeq sets pinned to +their generated rules. + +**Not claimed.** Projections, 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 nesting boundary (one auxiliary block per occurrence class, `nparams ≤ 1` exercised by the ladder fixtures); nesting classes beyond the accepted flattened-block analyzer remain rejected, and deep @@ -442,11 +473,12 @@ The remaining v4.31-added sorry is classified: - The public inductive spec has complete one-family, non-nested mutual, and nested generation, preservation, metadata parity, environment - replay, and generic iota-pattern facts, but remains a growing subset - rather than kernel-complete; pattern soundness (`pat_wf`), the - pattern-form assembler, and projection coverage remain queued, and - nested replay breadth beyond the two ladder fixtures belongs to - L4L-11. + replay, generic iota-pattern facts, pattern soundness (`pat_wf`), and + the block-local pattern environment assembler, but remains a growing + subset rather than kernel-complete; projection coverage remains queued, + and nested replay breadth beyond the two ladder fixtures belongs to + L4L-11. `pat_wf` carries the Church–Rosser development's transitional + unique-typing closure until L4L-16/17 close it. - 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). @@ -618,20 +650,9 @@ 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. -### Generated patterns (L4L-10B) - -**L4L-10B — pattern soundness and environment assembler (active).** 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 +**L4L-11 — consumer block-certificate API (active).** 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 From 0587b91aa3c61beee9bff934d945f3e83dd1a972 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 14:55:23 -0400 Subject: [PATCH 16/27] theory+verify: close L4L-11 replay and certificate API --- Lean4Lean/Audit/SorryFrontier.lean | 3 + Lean4Lean/Tests.lean | 1 + Lean4Lean/Tests/NotationPreludeFixture.lean | 32 + Lean4Lean/Tests/NotationPreludeReplay.lean | 54 ++ Lean4Lean/Theory.lean | 1 + .../Theory/Typing/InductiveCertificate.lean | 517 ++++++++++++ .../Theory/Typing/NestedInductiveLemmas.lean | 20 + Lean4Lean/Verify.lean | 1 + .../Verify/Environment/DeepNestedReplay.lean | 791 ++++++++++++++++++ .../Verify/Environment/InductiveFixtures.lean | 5 + .../Environment/InductiveReplayMatrix.lean | 765 +++++++++++++++++ Lean4Lean/Verify/Environment/Lemmas.lean | 188 +++++ .../Environment/SingletonParityReplay.lean | 20 + plans/roadmap.md | 96 ++- upstream-divergence.md | 111 ++- 15 files changed, 2543 insertions(+), 62 deletions(-) create mode 100644 Lean4Lean/Tests/NotationPreludeFixture.lean create mode 100644 Lean4Lean/Tests/NotationPreludeReplay.lean create mode 100644 Lean4Lean/Theory/Typing/InductiveCertificate.lean create mode 100644 Lean4Lean/Verify/Environment/DeepNestedReplay.lean create mode 100644 Lean4Lean/Verify/Environment/InductiveReplayMatrix.lean diff --git a/Lean4Lean/Audit/SorryFrontier.lean b/Lean4Lean/Audit/SorryFrontier.lean index c5be36d..489b62e 100644 --- a/Lean4Lean/Audit/SorryFrontier.lean +++ b/Lean4Lean/Audit/SorryFrontier.lean @@ -11,6 +11,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 +32,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 +48,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 diff --git a/Lean4Lean/Tests.lean b/Lean4Lean/Tests.lean index dc420f9..18089ba 100644 --- a/Lean4Lean/Tests.lean +++ b/Lean4Lean/Tests.lean @@ -1 +1,2 @@ import Lean4Lean.Tests.Toolchain +import Lean4Lean.Tests.NotationPreludeReplay diff --git a/Lean4Lean/Tests/NotationPreludeFixture.lean b/Lean4Lean/Tests/NotationPreludeFixture.lean new file mode 100644 index 0000000..4e1e82d --- /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 0000000..0ceb0f2 --- /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/Theory.lean b/Lean4Lean/Theory.lean index 67c3c0f..3892e02 100644 --- a/Lean4Lean/Theory.lean +++ b/Lean4Lean/Theory.lean @@ -1,4 +1,5 @@ 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 diff --git a/Lean4Lean/Theory/Typing/InductiveCertificate.lean b/Lean4Lean/Theory/Typing/InductiveCertificate.lean new file mode 100644 index 0000000..f7ea85e --- /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/NestedInductiveLemmas.lean b/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean index 44c12a9..095bc53 100644 --- a/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean +++ b/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean @@ -79,6 +79,16 @@ theorem family_lookup (H : AddInductNestedTrace env env' nested) (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) @@ -105,6 +115,16 @@ theorem rec_lookup (H : AddInductNestedTrace env env' nested) (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) : diff --git a/Lean4Lean/Verify.lean b/Lean4Lean/Verify.lean index d9faa29..5e47676 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/DeepNestedReplay.lean b/Lean4Lean/Verify/Environment/DeepNestedReplay.lean new file mode 100644 index 0000000..1db0c7d --- /dev/null +++ b/Lean4Lean/Verify/Environment/DeepNestedReplay.lean @@ -0,0 +1,791 @@ +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 sole `sorryAx` is the already tracked Verify projection relation; +the Theory certificate exported from this trace has the stricter guards in +`InductiveCertificate`. -/ +/-- +info: 'Lean4Lean.DeepNestedReplayFixtures.deepTrEnv' depends on axioms: [propext, + sorryAx, + 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/InductiveFixtures.lean b/Lean4Lean/Verify/Environment/InductiveFixtures.lean index 0760087..768cd2e 100644 --- a/Lean4Lean/Verify/Environment/InductiveFixtures.lean +++ b/Lean4Lean/Verify/Environment/InductiveFixtures.lean @@ -2530,6 +2530,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 diff --git a/Lean4Lean/Verify/Environment/InductiveReplayMatrix.lean b/Lean4Lean/Verify/Environment/InductiveReplayMatrix.lean new file mode 100644 index 0000000..f4c8d3d --- /dev/null +++ b/Lean4Lean/Verify/Environment/InductiveReplayMatrix.lean @@ -0,0 +1,765 @@ +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, + sorryAx, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms Lean4Lean.CompleteInductiveReplay.BlockReplayArtifact.certificate + +/-- +info: 'Lean4Lean.CompleteInductiveReplay.NestedReplayArtifact.certificate' depends on axioms: [propext, + sorryAx, + 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 fea5ad7..c8f7f82 100644 --- a/Lean4Lean/Verify/Environment/Lemmas.lean +++ b/Lean4Lean/Verify/Environment/Lemmas.lean @@ -96,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 @@ -121,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 @@ -128,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⟩ diff --git a/Lean4Lean/Verify/Environment/SingletonParityReplay.lean b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean index f4e914c..392b4bb 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,6 +211,7 @@ def normalizationMatrixReplay07 : SingletonReplayArtifact where source := normalizationMatrixRawDecl inputMap := matrixAliasMap inputEnv := normalizationMatrixAliasEnv + inputMapWF := matrixAliasMap_wf outputMap := normalizationMatrixMap outputEnv := normalizationMatrixFinalEnv inputOrdered := normalizationMatrixAliasEnv_ordered @@ -216,6 +223,7 @@ def annotatedPiReplay07 : SingletonReplayArtifact where 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 diff --git a/plans/roadmap.md b/plans/roadmap.md index f39a965..7606ef2 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,12 +67,12 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| Ladder position | **L4L-11 active**; L4L-10B and everything above it are complete and pruned from §5; everything below L4L-11 is queued | -| Current formalization source | the L4L-10B pattern-soundness checkpoint (`Theory/Typing/InductivePatternWF.lean` typed β-collapse and `pat_wf`, `Theory/Typing/InductivePatternEnv.lean` block-local assembler) on top of the L4L-10A pattern-core checkpoint `3689b115`, the L4L-09 line (`e297560d` nested closure and its sub-checkpoints), and the L4L-08C closure `ea733017`, at `jcb/formalization2`, with publication to `argumentcomputer/lean4lean` `jcb/induct` pending | +| Ladder position | **L4L-12A active**; L4L-11 and everything above it are complete and pruned from §5; everything below L4L-12A is queued | +| Current formalization source | the L4L-11 replay/certificate checkpoint (`Theory/Typing/InductiveCertificate.lean`, `Verify/Environment/InductiveReplayMatrix.lean`, the two-parameter deep-nested replay, and the notation-heavy fresh replay) on top of the L4L-10B pattern-soundness checkpoint `bc51f980`, the L4L-09 line (`e297560d` nested closure and its sub-checkpoints), and the L4L-08C closure `ea733017`, at `jcb/formalization2`, 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-09C 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 | +| Gates | the full §6 gate is green on the L4L-11 closure source, including focused, aggregate, and default Lake builds, the Nix proof/dependency build, a clean-source `nix flake check`, the unchanged 25-entry sorry frontier, Theory import-boundary and exact-axiom audits, formatter check, and whitespace check | ### 2.1 What is green @@ -299,6 +299,36 @@ 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. +**Complete replay matrix and consumer certificates.** The supported replay +matrix now executes 25 actual-metadata transactions rather than merely +packaging abstract witnesses: 20 automatically constructed singleton +candidates (the L4L-07 inventory 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, +producer result, data-bearing transaction trace, final translated +type/constructor/recursor roles, and recursor lookup uniqueness. The mutual +and nested rows expose the same +metadata-completeness predicate through one sum artifact, while their +certificates separately derive environment growth and block WF. + +The consumer-neutral Theory API is +`VInductDecl.BlockCertificate`/`NestedBlockCertificate`. It reconstructs the +raw `addInduct` result, `addInduct_le`, `addInduct_WF`, exact family and every +constructor/recursor lookup, freshness, lookup uniqueness, registered rule +membership/WF, rule closure, and L4L-10 recursor-pattern facts from one checked +transaction. The API imports no Verify state, `Lean.Expr`, normalization +oracle, or kernel implementation object. Its WF root has only the standard +logical baseline, and its rule/pattern root additionally uses +`Classical.choice`; in particular neither reaches `sorryAx`. Verify's unified +matrix has one exact guarded `sorryAx`, solely through the separately tracked +projection/refinement frontier. + +A separate fresh replay loads the compiled dependency closure of the +notation-heavy fixture into an empty kernel environment and checks all 296 +declarations. Numerals, arithmetic and comparison notation, lists, arrays, +products, conditionals, and strings therefore exercise their real compiled +prelude dependencies rather than a hand-built Theory environment. + **Nested representation and flattening.** The committed design note and executable metadata probes in `Lean4Lean/Verify/Environment/NestedRepresentation.lean` pin how the @@ -342,12 +372,16 @@ its entire output against the Theory artifacts (payload constants, recursors, K flags, rule RHSs, and `numNested`), on the rose-tree, nested-indexed, and constant-universe fixtures. -**Nested environment replay.** Both ladder fixtures replay from real +**Nested environment replay.** All three ladder fixtures replay from real stored metadata through `TrEnv'.inductNested` (`Verify/Environment/NestedReplay.lean`): the rose tree over the completed `List` replay environment, and the nested-indexed family over a `PVec` boundary staged by `TrEnv'.inductStaging` on the completed -`Nat` replay. Each replay inserts the stored `ConstantInfo`s with +`Nat` replay, plus `DeepBi α β` over the actual two-parameter `BiBox α β` +dependency. `DeepBi.node` contains two queued nested occurrences, +`BiBox (DeepBi α β) (BiBox α (DeepBi α β))`; the analyzer produces all +three auxiliary recursors/rules and their RHSs agree with the real stored +kernel metadata. Each replay inserts the stored `ConstantInfo`s with `tr_type_expr_tac` translations, exact freshness chains, K-flag agreement, and the literal rule fold, and proves the complete `NestedBlockChecked.WF` package by direct concrete typing derivations @@ -384,8 +418,9 @@ hand-written `List` target to stored metadata, and matches kernel accept/reject on four nearest negatives: local-variable parametric arguments (with the kernel's exact diagnostic), off-spine parametric applications, canonical-auxiliary-name collisions, and missing target -declarations. Source declarations remain rejected by every raw analyzer; -no generated recursor, rule, or replay is claimed for nested blocks yet. +declarations. Source declarations remain rejected by the non-nested raw +analyzer; the dedicated nested analyzer and transaction own their +flattened/restored recursors, rules, and replay. **Generated iota patterns.** Every certified block's iota rules are exact `SimplePattern.iota` patterns (`Theory/Typing/InductivePattern.lean`): the @@ -446,12 +481,11 @@ 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 nesting boundary (one auxiliary block per occurrence class, -`nparams ≤ 1` exercised by the ladder fixtures); nesting classes beyond -the accepted flattened-block analyzer remain rejected, and deep -multi-parameter nesting breadth belongs to the L4L-11 replay-breadth -matrix. Bare producer success is never generation-shape authority or -Theory semantics. +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 @@ -474,11 +508,11 @@ The remaining v4.31-added sorry is classified: - 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, but remains a growing - subset rather than kernel-complete; projection coverage remains queued, - and nested replay breadth beyond the two ladder fixtures belongs to - L4L-11. `pat_wf` carries the Church–Rosser development's transitional - unique-typing closure until L4L-16/17 close it. + 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 coverage remains queued. `pat_wf` carries the Church–Rosser + development's transitional unique-typing closure until L4L-16/17 close it. - 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). @@ -650,31 +684,9 @@ 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. -### Replay breadth and the block-certificate API (L4L-11) - -**L4L-11 — consumer block-certificate API (active).** 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 +**L4L-12A — Theory API extraction (active).** 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 diff --git a/upstream-divergence.md b/upstream-divergence.md index 72006f1..bf1fb0a 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-11 replay/certificate checkpoint +(2026-08-10): - current upstream reconciliation parent: digama `upstream/master` `ef849dfbd94a` @@ -116,9 +116,21 @@ 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. - 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 +299,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 +330,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 +360,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 +377,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 +394,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 +421,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 +877,53 @@ 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. + ## Review checklist At each publish or ix pin boundary: From 958d03b7af903a6465a58250066d126943427008 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 15:38:55 -0400 Subject: [PATCH 17/27] theory+verify: close L4L-12A API extraction --- Lean4Lean/Audit/SorryFrontier.lean | 2 + Lean4Lean/Theory.lean | 2 + Lean4Lean/Theory/Literals.lean | 172 ++++++++++++++++++++++++++++ Lean4Lean/Theory/LocalContext.lean | 149 ++++++++++++++++++++++++ Lean4Lean/Verify/Typing/Expr.lean | 75 +----------- Lean4Lean/Verify/Typing/Lemmas.lean | 101 ---------------- Lean4Lean/Verify/VLCtx.lean | 38 +----- plans/roadmap.md | 34 +++--- upstream-divergence.md | 33 +++++- 9 files changed, 375 insertions(+), 231 deletions(-) create mode 100644 Lean4Lean/Theory/Literals.lean create mode 100644 Lean4Lean/Theory/LocalContext.lean diff --git a/Lean4Lean/Audit/SorryFrontier.lean b/Lean4Lean/Audit/SorryFrontier.lean index 489b62e..019d1ae 100644 --- a/Lean4Lean/Audit/SorryFrontier.lean +++ b/Lean4Lean/Audit/SorryFrontier.lean @@ -2,6 +2,8 @@ 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.Quot diff --git a/Lean4Lean/Theory.lean b/Lean4Lean/Theory.lean index 3892e02..617a433 100644 --- a/Lean4Lean/Theory.lean +++ b/Lean4Lean/Theory.lean @@ -4,3 +4,5 @@ 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 diff --git a/Lean4Lean/Theory/Literals.lean b/Lean4Lean/Theory/Literals.lean new file mode 100644 index 0000000..045ea03 --- /dev/null +++ b/Lean4Lean/Theory/Literals.lean @@ -0,0 +1,172 @@ +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 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⟩⟩ + +@[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⟩ + +end Lean4Lean diff --git a/Lean4Lean/Theory/LocalContext.lean b/Lean4Lean/Theory/LocalContext.lean new file mode 100644 index 0000000..a196f31 --- /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/Verify/Typing/Expr.lean b/Lean4Lean/Verify/Typing/Expr.lean index f6acd64..aadebcf 100644 --- a/Lean4Lean/Verify/Typing/Expr.lean +++ b/Lean4Lean/Verify/Typing/Expr.lean @@ -1,4 +1,5 @@ import Lean4Lean.Theory.Typing.Basic +import Lean4Lean.Theory.Literals import Lean4Lean.Verify.NameGenerator import Lean4Lean.Verify.VLCtx import Lean4Lean.Verify.Axioms @@ -44,10 +45,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) => @@ -66,10 +63,6 @@ def VLCtx.WF.fvwf : ∀ {Δ}, VLCtx.WF env U Δ → Δ.FVWF 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 - variable (env : VEnv) (Us : List Name) in inductive TrExprS : VLCtx → Expr → VExpr → Prop | bvar : Δ.find? (.inl i) = some (e, A) → TrExprS Δ (.bvar i) e @@ -105,35 +98,6 @@ inductive TrExprS : VLCtx → Expr → VExpr → Prop 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) - /-- 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 @@ -161,40 +125,3 @@ def trExprS? (Us : List Name) : VLCtx → Expr → Option VExpr | Δ, .mdata _ e => trExprS? Us Δ e | _, .proj .. => none | _, .mvar .. => none - -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) diff --git a/Lean4Lean/Verify/Typing/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean index 9fe95a1..305886c 100644 --- a/Lean4Lean/Verify/Typing/Lemmas.lean +++ b/Lean4Lean/Verify/Typing/Lemmas.lean @@ -144,57 +144,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 @@ -709,11 +668,6 @@ 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⟩⟩ - variable! {env env' : VEnv} (henv : env ≤ env') in theorem TrExprS.mono (H : TrExprS env Us Δ e e') : TrExprS env' Us Δ e e' := by induction H with @@ -742,11 +696,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 +720,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 +811,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 @@ -2050,9 +1979,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 @@ -2060,9 +1986,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 @@ -2070,9 +1993,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) @@ -2101,9 +2021,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 @@ -2111,9 +2028,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 @@ -2121,9 +2035,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 @@ -2138,14 +2049,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 ∧ @@ -2216,10 +2119,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 diff --git a/Lean4Lean/Verify/VLCtx.lean b/Lean4Lean/Verify/VLCtx.lean index f6c6d08..3eb52f3 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 7606ef2..93294cd 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -67,12 +67,12 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| Ladder position | **L4L-12A active**; L4L-11 and everything above it are complete and pruned from §5; everything below L4L-12A is queued | -| Current formalization source | the L4L-11 replay/certificate checkpoint (`Theory/Typing/InductiveCertificate.lean`, `Verify/Environment/InductiveReplayMatrix.lean`, the two-parameter deep-nested replay, and the notation-heavy fresh replay) on top of the L4L-10B pattern-soundness checkpoint `bc51f980`, the L4L-09 line (`e297560d` nested closure and its sub-checkpoints), and the L4L-08C closure `ea733017`, at `jcb/formalization2`, with publication to `argumentcomputer/lean4lean` `jcb/induct` pending | +| Ladder position | **L4L-12B active**; L4L-12A and everything above it are complete and pruned from §5; everything below L4L-12B is queued | +| Current formalization source | the complete L4L-12A Theory API extraction checkpoint (`Theory/LocalContext.lean`, `Theory/Literals.lean`, and the Verify compatibility imports) based on the L4L-11 closure `0587b91a`, at `jcb/formalization2`, 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-11 closure source, including focused, aggregate, and default Lake builds, the Nix proof/dependency build, a clean-source `nix flake check`, the unchanged 25-entry sorry frontier, Theory import-boundary and exact-axiom audits, formatter check, and whitespace check | +| Gates | the full §6 gate is green on the L4L-12A closure source, including focused, aggregate, and default Lake builds, the Nix proof/dependency build, a clean-source `nix flake check`, the unchanged 25-entry sorry frontier, Theory import-boundary and exact-axiom audits, formatter check, and whitespace check | ### 2.1 What is green @@ -103,6 +103,13 @@ direct and sibling recursion, recursive targets below Pi telescopes, small elimination, subsingleton large elimination, K-target metadata, and exact zero-/one-constructor generation. +The consumer-neutral `VLocalDecl` core now lives in +`Theory/LocalContext.lean`. Literal encodings, containment, primitive +descriptors, and their VExpr-only structural laws live in +`Theory/Literals.lean`; Verify retains `FVarId`, `Lean.Expr`, and +`Literal.toConstructor` traversal while its former import paths re-export the +same declaration names. Exact typed-prelude readiness remains L4L-12B. + **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 @@ -513,9 +520,10 @@ The remaining v4.31-added sorry is classified: inductive language remains a growing subset rather than kernel-complete; projection coverage remains queued. `pat_wf` carries the Church–Rosser development's transitional unique-typing closure until L4L-16/17 close it. -- 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). +- Exact typed-prelude readiness remains to be derived in L4L-12B, and + projection semantics plus the final consumer-neutral structure/checker + audit remain under `Verify/` (L4L-13A--L4L-15C). The local-context and + literal encoding 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 @@ -684,19 +692,9 @@ 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. -### Theory API extraction and literals (L4L-12A–L4L-12B) - -**L4L-12A — Theory API extraction (active).** 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. +### Theory literals (L4L-12B) -**L4L-12B — literal and prelude readiness.** `ContainsLits` says only that +**L4L-12B — literal and prelude readiness (active).** `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 diff --git a/upstream-divergence.md b/upstream-divergence.md index bf1fb0a..edb4d5e 100644 --- a/upstream-divergence.md +++ b/upstream-divergence.md @@ -4,7 +4,7 @@ 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-11 replay/certificate checkpoint +Audit baseline after the complete L4L-12A Theory API extraction checkpoint (2026-08-10): - current upstream reconciliation parent: digama `upstream/master` @@ -128,6 +128,9 @@ Audit baseline after the complete L4L-11 replay/certificate checkpoint 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 closure checkpoint: the Theory-only local-context and literal + encoding APIs plus Verify compatibility re-exports described in D014. It is + based on `0587b91a`; publication is pending. - fixed fork master: `1fb7d6ef9042c5a80b2de9320c88ac0f3ce404cb` on local and `origin/master` - audited L4L-08C semantic base: the L4L-08C closure extends the @@ -924,6 +927,34 @@ to the replacement. 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 API extraction + +- **Status:** local-committed at `jcb/formalization2`; publication to + `jcb/induct` is pending. +- **Commit:** this L4L-12A extraction checkpoint, based on `0587b91a`. +- **Delta:** move the consumer-neutral `VLocalDecl` data, VExpr-only + operations, WF/closure predicate, and structural/defeq laws to + `Theory/LocalContext.lean`. Move literal encodings, `ContainsLits`, the + implementation-independent primitive contracts, and lift/substitution laws + to `Theory/Literals.lean`. Keep `FVarId`, `VLCtx`, `Lean.Expr`, `TrExprS`, + and `Literal.toConstructor` traversal in Verify, whose old import paths + continue to expose the moved names. +- **Ix impact:** Theory-only consumers can use local declarations and literal + syntax without importing consumer-specific implementation expressions; + existing Verify consumers retain source compatibility. +- **Tests:** focused Theory local-context/literal and complete Verify builds; + aggregate and default Lake builds; unchanged exact sorry frontier; Nix + proof/dependency and flake checks; formatter, whitespace, exact-axiom, and + Theory import-boundary checks. +- **Axiom note:** no project axiom or source `sorry` is added. Moved roots + retain their exact pre-existing closures; the named LocalContext guards make + the inherited unique-typing frontier explicit without widening it. +- **Upstream issue/PR:** TBD; submit the consumer-neutral extraction before + the readiness extension where practical. +- **Removal condition:** upstream owns equivalent Theory modules, downstream + users import them directly, and the Verify compatibility imports can be + retired after their deprecation window. + ## Review checklist At each publish or ix pin boundary: From a6ea75fc34ced4fdc9b3b9c43d1a43794c3b43b1 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 15:47:24 -0400 Subject: [PATCH 18/27] theory+verify: close L4L-12B literal readiness --- Lean4Lean/Tests.lean | 1 + Lean4Lean/Tests/LiteralReadiness.lean | 99 +++++++++ Lean4Lean/Theory/Literals.lean | 302 ++++++++++++++++++++++++++ Lean4Lean/Verify/Typing/Lemmas.lean | 17 ++ plans/roadmap.md | 44 ++-- upstream-divergence.md | 72 +++--- 6 files changed, 479 insertions(+), 56 deletions(-) create mode 100644 Lean4Lean/Tests/LiteralReadiness.lean diff --git a/Lean4Lean/Tests.lean b/Lean4Lean/Tests.lean index 18089ba..e69d2ba 100644 --- a/Lean4Lean/Tests.lean +++ b/Lean4Lean/Tests.lean @@ -1,2 +1,3 @@ import Lean4Lean.Tests.Toolchain +import Lean4Lean.Tests.LiteralReadiness import Lean4Lean.Tests.NotationPreludeReplay diff --git a/Lean4Lean/Tests/LiteralReadiness.lean b/Lean4Lean/Tests/LiteralReadiness.lean new file mode 100644 index 0000000..fae0db6 --- /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/Theory/Literals.lean b/Lean4Lean/Theory/Literals.lean index 045ea03..ae8afee 100644 --- a/Lean4Lean/Theory/Literals.lean +++ b/Lean4Lean/Theory/Literals.lean @@ -1,3 +1,4 @@ +import Lean4Lean.Theory.Inductive import Lean4Lean.Theory.Typing.Strong /-! # Theory encodings of Lean literals and primitive reflection @@ -43,6 +44,163 @@ 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 [] @@ -88,6 +246,126 @@ theorem VEnv.ContainsLits.mono : ∀ {l}, env.ContainsLits l → env'.ContainsLi | .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] @@ -169,4 +447,28 @@ theorem VEnv.HasPrimitives.nat_of_charOfNat (wf : Ordered env) 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/Verify/Typing/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean index 305886c..cae1e39 100644 --- a/Lean4Lean/Verify/Typing/Lemmas.lean +++ b/Lean4Lean/Verify/Typing/Lemmas.lean @@ -1918,6 +1918,17 @@ theorem TrExprS.toConstructor_eq {l : Literal} {w} 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 @@ -2464,3 +2475,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, sorryAx, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms TrExprS.toConstructor_ready diff --git a/plans/roadmap.md b/plans/roadmap.md index 93294cd..9a19b44 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -67,12 +67,12 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| Ladder position | **L4L-12B active**; L4L-12A and everything above it are complete and pruned from §5; everything below L4L-12B is queued | -| Current formalization source | the complete L4L-12A Theory API extraction checkpoint (`Theory/LocalContext.lean`, `Theory/Literals.lean`, and the Verify compatibility imports) based on the L4L-11 closure `0587b91a`, at `jcb/formalization2`, with publication to `argumentcomputer/lean4lean` `jcb/induct` pending | +| Ladder position | **L4L-13A active**; L4L-12 and everything above it are complete and pruned from §5; everything below L4L-13A is queued | +| Current formalization source | the complete L4L-12B literal-readiness checkpoint (`Theory/Literals.lean`, the Verify literal bridge, and `Tests/LiteralReadiness.lean`) layered on the independently gated L4L-12A extraction checkpoint `958d03b7` (itself based on the L4L-11 closure `0587b91a`), at `jcb/formalization2`, 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-12A closure source, including focused, aggregate, and default Lake builds, the Nix proof/dependency build, a clean-source `nix flake check`, the unchanged 25-entry sorry frontier, Theory import-boundary and exact-axiom audits, formatter check, and whitespace check | +| Gates | the full §6 gate is green independently on the L4L-12A extraction checkpoint and the L4L-12B readiness checkpoint, including focused, aggregate, and default Lake builds, the Nix proof/dependency build, clean-source `nix flake check`, the unchanged 25-entry sorry frontier, Theory import-boundary and exact-axiom audits, formatter check, and whitespace check | ### 2.1 What is green @@ -103,12 +103,14 @@ direct and sibling recursion, recursive targets below Pi telescopes, small elimination, subsingleton large elimination, K-target metadata, and exact zero-/one-constructor generation. -The consumer-neutral `VLocalDecl` core now lives in -`Theory/LocalContext.lean`. Literal encodings, containment, primitive -descriptors, and their VExpr-only structural laws live in -`Theory/Literals.lean`; Verify retains `FVarId`, `Lean.Expr`, and -`Literal.toConstructor` traversal while its former import paths re-export the -same declaration names. Exact typed-prelude readiness remains L4L-12B. +The consumer-neutral local-context core now 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 including generated recursors and iota +rules. Readiness derives direct literal WF, is stable under ordered +environment extension and fresh constants, and remains independent of +`Lean.Expr`; Verify retains only traversal and proves its constructor result +equal to the direct Theory encoding. **Mutual validation, generation, and replay.** `VInductDecl.CheckedBlock` and `checkedBlock?` analyze an arbitrary nonempty `decl.types` list without @@ -520,10 +522,9 @@ The remaining v4.31-added sorry is classified: inductive language remains a growing subset rather than kernel-complete; projection coverage remains queued. `pat_wf` carries the Church–Rosser development's transitional unique-typing closure until L4L-16/17 close it. -- Exact typed-prelude readiness remains to be derived in L4L-12B, and - projection semantics plus the final consumer-neutral structure/checker - audit remain under `Verify/` (L4L-13A--L4L-15C). The local-context and - literal encoding APIs now have Theory-only homes. +- Projection semantics and a final audit of consumer-neutral structure and + checker lemmas remain under `Verify/` (L4L-13A--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 @@ -692,19 +693,6 @@ 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. -### Theory literals (L4L-12B) - -**L4L-12B — literal and prelude readiness (active).** `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 @@ -712,7 +700,7 @@ 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 +**L4L-13A — projection expressibility decision (active).** 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, @@ -767,7 +755,7 @@ 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. *Exit:* no consumer-neutral lemma requires a `Lean4Lean.Verify` import; compatibility re-exports are removable without loss. diff --git a/upstream-divergence.md b/upstream-divergence.md index edb4d5e..48fef91 100644 --- a/upstream-divergence.md +++ b/upstream-divergence.md @@ -4,7 +4,7 @@ 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-12A Theory API extraction checkpoint +Audit baseline after the complete L4L-12B literal-readiness checkpoint (2026-08-10): - current upstream reconciliation parent: digama `upstream/master` @@ -128,9 +128,12 @@ Audit baseline after the complete L4L-12A Theory API extraction checkpoint 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 closure checkpoint: the Theory-only local-context and literal - encoding APIs plus Verify compatibility re-exports described in D014. It is - based on `0587b91a`; 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` - audited L4L-08C semantic base: the L4L-08C closure extends the @@ -927,33 +930,46 @@ to the replacement. 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 API extraction +## D014 — Theory local-context and literal readiness API - **Status:** local-committed at `jcb/formalization2`; publication to `jcb/induct` is pending. -- **Commit:** this L4L-12A extraction checkpoint, based on `0587b91a`. -- **Delta:** move the consumer-neutral `VLocalDecl` data, VExpr-only - operations, WF/closure predicate, and structural/defeq laws to - `Theory/LocalContext.lean`. Move literal encodings, `ContainsLits`, the - implementation-independent primitive contracts, and lift/substitution laws - to `Theory/Literals.lean`. Keep `FVarId`, `VLCtx`, `Lean.Expr`, `TrExprS`, - and `Literal.toConstructor` traversal in Verify, whose old import paths - continue to expose the moved names. -- **Ix impact:** Theory-only consumers can use local declarations and literal - syntax without importing consumer-specific implementation expressions; - existing Verify consumers retain source compatibility. -- **Tests:** focused Theory local-context/literal and complete Verify builds; - aggregate and default Lake builds; unchanged exact sorry frontier; Nix - proof/dependency and flake checks; formatter, whitespace, exact-axiom, and - Theory import-boundary checks. -- **Axiom note:** no project axiom or source `sorry` is added. Moved roots - retain their exact pre-existing closures; the named LocalContext guards make - the inherited unique-typing frontier explicit without widening it. -- **Upstream issue/PR:** TBD; submit the consumer-neutral extraction before - the readiness extension where practical. -- **Removal condition:** upstream owns equivalent Theory modules, downstream - users import them directly, and the Verify compatibility imports can be - retired after their deprecation window. +- **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 From de7eef78d3c0b9c553dd9952c7098dd5e7b6b1ac Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 16:03:28 -0400 Subject: [PATCH 19/27] theory+verify: close L4L-13A/B projection semantics --- Lean4Lean/Audit/SorryFrontier.lean | 7 +- Lean4Lean/Tests.lean | 1 + Lean4Lean/Tests/ProjectionExpressibility.lean | 391 ++++++++++++++++++ Lean4Lean/Theory.lean | 1 + Lean4Lean/Theory/Projection.lean | 295 +++++++++++++ Lean4Lean/Verify/Environment/Basic.lean | 23 +- .../Environment/ConstructorValidation.lean | 2 - .../Verify/Environment/DeepNestedReplay.lean | 7 +- .../Environment/IndexedVecCandidate.lean | 4 - .../Environment/IndexedVecOuterReplay.lean | 1 - .../Environment/IndexedVecSemanticReplay.lean | 2 - .../Verify/Environment/InductiveFixtures.lean | 53 +-- .../Environment/InductiveReplayMatrix.lean | 2 - Lean4Lean/Verify/Environment/Lemmas.lean | 6 +- .../Environment/MutualInductiveFixtures.lean | 8 +- .../Verify/Environment/NestedReplay.lean | 6 +- .../Verify/Environment/Normalization.lean | 69 +--- .../Environment/NormalizationMatrix.lean | 7 +- .../Environment/SingletonParityReplay.lean | 2 - Lean4Lean/Verify/Typing/Expr.lean | 15 +- Lean4Lean/Verify/Typing/Lemmas.lean | 49 ++- 21 files changed, 783 insertions(+), 168 deletions(-) create mode 100644 Lean4Lean/Tests/ProjectionExpressibility.lean create mode 100644 Lean4Lean/Theory/Projection.lean diff --git a/Lean4Lean/Audit/SorryFrontier.lean b/Lean4Lean/Audit/SorryFrontier.lean index 019d1ae..fe11665 100644 --- a/Lean4Lean/Audit/SorryFrontier.lean +++ b/Lean4Lean/Audit/SorryFrontier.lean @@ -6,6 +6,7 @@ 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 @@ -131,9 +132,7 @@ 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 + -- Tier P — projection structural laws (L4L-14) `Lean4Lean.TrProj.weak', `Lean4Lean.TrProj.weak'_inv, `Lean4Lean.TrProj.defeqDFC, @@ -141,7 +140,7 @@ private def allowlist : Array Lean.Name := #[ `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, diff --git a/Lean4Lean/Tests.lean b/Lean4Lean/Tests.lean index e69d2ba..540a95e 100644 --- a/Lean4Lean/Tests.lean +++ b/Lean4Lean/Tests.lean @@ -1,3 +1,4 @@ import Lean4Lean.Tests.Toolchain import Lean4Lean.Tests.LiteralReadiness import Lean4Lean.Tests.NotationPreludeReplay +import Lean4Lean.Tests.ProjectionExpressibility diff --git a/Lean4Lean/Tests/ProjectionExpressibility.lean b/Lean4Lean/Tests/ProjectionExpressibility.lean new file mode 100644 index 0000000..d8d9d29 --- /dev/null +++ b/Lean4Lean/Tests/ProjectionExpressibility.lean @@ -0,0 +1,391 @@ +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 dependentRecordType : VInductiveType where + name := ``DependentRecord + uvars := 2 + type := vconst(type_of% @DependentRecord).type + ctors := [⟨vconst(type_of% @DependentRecord.mk), ``DependentRecord.mk⟩] + +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 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 + parameters := ?_ + 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 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⟩ } + +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⟩ } + +/-- 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 emptyRecordType : VInductiveType where + name := ``EmptyRecord + uvars := 1 + type := vconst(type_of% @EmptyRecord).type + ctors := [⟨vconst(type_of% @EmptyRecord.mk), ``EmptyRecord.mk⟩] + +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 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 + parameters := ⟨⟨_, by type_tac⟩, trivial⟩ + 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, + 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 617a433..2a063b5 100644 --- a/Lean4Lean/Theory.lean +++ b/Lean4Lean/Theory.lean @@ -6,3 +6,4 @@ 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/Projection.lean b/Lean4Lean/Theory/Projection.lean new file mode 100644 index 0000000..d2151dd --- /dev/null +++ b/Lean4Lean/Theory/Projection.lean @@ -0,0 +1,295 @@ +import Lean4Lean.Theory.Inductive +import Lean4Lean.Theory.Typing.Lemmas + +/-! +# 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 + +/-- 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 + +/-- 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 + +/-- 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 + +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 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] + let code := { fieldSort, typeFn, minor, projector } + code :: projectionCodes.go view levels params allFields structType + fields fieldSorts (i + 1) (previous ++ [code]) + | _, _, _, _ => [] + +/-- 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 0 [] + +/-- 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 + +/-- 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 + +/-- 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 + parameters : env.OnTel view.uvars [] view.constructorParams + fieldTelescope : env.OnSortTel view.uvars + view.constructorParams.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 WF.mono {env env' : VEnv} (henv : env ≤ env') + (self : VStructureView.WF view env) : VStructureView.WF view env' where + toRegistered := self.toRegistered.mono henv + parameters := self.parameters.monoProjection henv + fieldTelescope := self.fieldTelescope.mono henv + smallFields := self.smallFields + +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⟩ + +/-- 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 + +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 + +/-- +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/Verify/Environment/Basic.lean b/Lean4Lean/Verify/Environment/Basic.lean index ea7674f..1c921cb 100644 --- a/Lean4Lean/Verify/Environment/Basic.lean +++ b/Lean4Lean/Verify/Environment/Basic.lean @@ -352,44 +352,41 @@ theorem AddInductNested.le obtain ⟨nested, -, hadd⟩ := H.to_addInductNested exact VEnv.addInductNested_le hadd -/- 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`. -/ +/- 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 @@ -482,7 +479,7 @@ theorem TrEnv'.wf (H : TrEnv' safety C Q venv) : venv.WF := by 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 733a373..45df045 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidation.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidation.lean @@ -9147,7 +9147,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] -/ @@ -9156,7 +9155,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/DeepNestedReplay.lean b/Lean4Lean/Verify/Environment/DeepNestedReplay.lean index 1db0c7d..39a7680 100644 --- a/Lean4Lean/Verify/Environment/DeepNestedReplay.lean +++ b/Lean4Lean/Verify/Environment/DeepNestedReplay.lean @@ -768,12 +768,11 @@ theorem deepAddInductNested_success : biBoxFinalEnv.addInductNested deepNestedC = some deepFinalEnv := deepTrace.to_addInductNested -/- The sole `sorryAx` is the already tracked Verify projection relation; -the Theory certificate exported from this trace has the stricter guards in -`InductiveCertificate`. -/ +/- 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, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, diff --git a/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean b/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean index 30465a2..f963b5e 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 4cd4666..00c3600 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 e1d6853..81c5e56 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean @@ -3121,7 +3121,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, @@ -3153,7 +3152,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 768cd2e..27cdeb7 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, @@ -10839,12 +10831,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, @@ -10860,7 +10850,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidateTrace' depen /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_candidateTrace' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -10876,7 +10865,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerCtor_candidateTrace' depends /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerFamily_candidate' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -10925,7 +10913,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, @@ -11046,7 +11033,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerTruncatedView_rejected' depe /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasRecField_checkType' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -11100,7 +11086,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, @@ -11115,7 +11100,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, @@ -11130,7 +11114,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, @@ -11149,7 +11132,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, @@ -11165,7 +11147,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, @@ -11544,7 +11525,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationCandidatePackage' /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerNormalizationCandidate_produced' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -11562,7 +11542,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerNormalizationCandidate_produ /-- info: 'Lean4Lean.InductiveReplayFixtures.aliasFormerGenerationShapeCandidate_produced' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -11908,13 +11887,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, @@ -11926,7 +11903,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, @@ -11938,7 +11914,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, @@ -11950,7 +11925,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, @@ -11962,7 +11936,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, @@ -11974,7 +11947,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, @@ -12217,7 +12189,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationCandidatePackage' /-- info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiCtor_candidateTrace' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -12256,7 +12227,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiFamily_candidateTrace' depen /-- info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiNormalizationCandidate_produced' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -12283,7 +12253,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiNormalizationCandidate_produ /-- info: 'Lean4Lean.InductiveReplayFixtures.annotatedPiGenerationShapeCandidate_produced' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -12525,7 +12494,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.annotatedParam_addInductCertified' depe /-- info: 'Lean4Lean.InductiveReplayFixtures.annotatedParamAddInductTraceChecked' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -12537,7 +12505,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 index f4c8d3d..0daafb2 100644 --- a/Lean4Lean/Verify/Environment/InductiveReplayMatrix.lean +++ b/Lean4Lean/Verify/Environment/InductiveReplayMatrix.lean @@ -699,7 +699,6 @@ end Lean4Lean /-- info: 'Lean4Lean.CompleteInductiveReplay.BlockReplayArtifact.certificate' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -708,7 +707,6 @@ info: 'Lean4Lean.CompleteInductiveReplay.BlockReplayArtifact.certificate' depend /-- info: 'Lean4Lean.CompleteInductiveReplay.NestedReplayArtifact.certificate' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ diff --git a/Lean4Lean/Verify/Environment/Lemmas.lean b/Lean4Lean/Verify/Environment/Lemmas.lean index c8f7f82..fd6a9a6 100644 --- a/Lean4Lean/Verify/Environment/Lemmas.lean +++ b/Lean4Lean/Verify/Environment/Lemmas.lean @@ -415,13 +415,13 @@ theorem Aligned.addInductNested 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 @@ -439,7 +439,7 @@ theorem TrEnv'.aligned (H : TrEnv' safety C Q venv) : Aligned safety C venv := b | 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 diff --git a/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean b/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean index 32f09cb..fd1b8bb 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 index f261734..c31f091 100644 --- a/Lean4Lean/Verify/Environment/NestedReplay.lean +++ b/Lean4Lean/Verify/Environment/NestedReplay.lean @@ -1724,15 +1724,14 @@ theorem roseFinalOrdered09 : roseFinalEnv09.Ordered := The stored-metadata surface inserted by the trace is tied to the Theory artifact inventory, and the final map/environment pair carries the -documented transitional closure (the checker-refinement frontier plus the -compiler-trust axiom introduced by the `native_decide` observations). -/ +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, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -3389,7 +3388,6 @@ theorem nvFinalOrdered09 : nvFinalEnv09.Ordered := /-- info: 'Lean4Lean.NestedReplayFixtures.nvTrEnv09' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, diff --git a/Lean4Lean/Verify/Environment/Normalization.lean b/Lean4Lean/Verify/Environment/Normalization.lean index 94396d7..77d2462 100644 --- a/Lean4Lean/Verify/Environment/Normalization.lean +++ b/Lean4Lean/Verify/Environment/Normalization.lean @@ -5462,7 +5462,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, @@ -5473,46 +5472,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 @@ -5585,7 +5569,6 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.source_isType_of_termi /-- info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.viewParameters' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -5594,7 +5577,6 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.viewParameters' depend /-- info: 'Lean4Lean.TypeChecker.CandidateExprSemanticRootRun.viewIndices' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -5602,7 +5584,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 @@ -6020,7 +6002,6 @@ info: 'Lean4Lean.VInductDecl.normalizationCandidateGenerationShape' depends on a /-- info: 'Lean4Lean.VInductDecl.CandidateConstructorSemanticGenerationShapeList.ofCheck' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6029,7 +6010,6 @@ info: 'Lean4Lean.VInductDecl.CandidateConstructorSemanticGenerationShapeList.ofC /-- info: 'Lean4Lean.VInductDecl.NormalizationCandidateSemanticRun.generationShape' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6115,7 +6095,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, @@ -6136,7 +6115,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, @@ -6148,7 +6126,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, @@ -6195,7 +6172,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 @@ -6241,7 +6218,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] -/ @@ -6315,19 +6291,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 @@ -6432,7 +6408,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 @@ -6537,7 +6513,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 @@ -6643,7 +6619,6 @@ info: 'Lean4Lean.TypeChecker.CandidateExprSpineRun.evidenceAt' depends on axioms /-- info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.normalization_eq' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6652,7 +6627,6 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.normalization_eq' depends on /-- info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.sourceType_eq' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6661,7 +6635,6 @@ info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.sourceType_eq' depends on /-- info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.familyViewType_eq' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6669,10 +6642,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 @@ -6777,10 +6747,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 @@ -6853,7 +6820,6 @@ info: 'Lean4Lean.VInductDecl.GenerationCandidateRun.wf' depends on axioms: [prop /-- info: 'Lean4Lean.VInductDecl.CandidateConstructorListRun.sameHeaders' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -6895,7 +6861,6 @@ info: 'Lean4Lean.VInductDecl.CandidateConstructorListRun.evidence' depends on ax /-- info: 'Lean4Lean.VInductDecl.NormalizationCandidateRun.normalization' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -7002,17 +6967,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 d9b4ce1..d90eb1f 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 392b4bb..8501ee6 100644 --- a/Lean4Lean/Verify/Environment/SingletonParityReplay.lean +++ b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean @@ -2739,7 +2739,6 @@ example : singletonReplayMatrix.length = 19 := rfl /-- info: 'Lean4Lean.InductiveReplayFixtures.SingletonReplayArtifact.outputOrdered' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -2748,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/Typing/Expr.lean b/Lean4Lean/Verify/Typing/Expr.lean index aadebcf..2613224 100644 --- a/Lean4Lean/Verify/Typing/Expr.lean +++ b/Lean4Lean/Verify/Typing/Expr.lean @@ -1,5 +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 @@ -61,7 +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 +/-- 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 @@ -93,7 +102,9 @@ 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' diff --git a/Lean4Lean/Verify/Typing/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean index cae1e39..ab3ecbf 100644 --- a/Lean4Lean/Verify/Typing/Lemmas.lean +++ b/Lean4Lean/Verify/Typing/Lemmas.lean @@ -525,10 +525,12 @@ 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 + (H : TrProj env U Γ s i e e') : + TrProj env U Γ' s i (e.lift' n) (e'.lift' n) := sorry 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 + (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' <| Ctx.liftN_iff_lift'.1 W /-! ## Replaying closed metadata types -/ @@ -579,10 +581,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 @@ -662,11 +662,18 @@ 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' := sorry 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 + (he : env.IsDefEqU U Γ₁ e₁ e₂) (H : TrProj env U Γ₁ s i e₁ e') : + ∃ e', TrProj env U Γ₂ s i e₂ e' := sorry + +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 @@ -681,7 +688,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' := @@ -904,7 +911,8 @@ 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' := sorry theorem TrExpr.wf (H : TrExpr env Us Δ e e') : VExpr.WF env Us.length Δ.toCtx e' := let ⟨_, _, _, H⟩ := H; ⟨_, H.hasType.2⟩ @@ -947,7 +955,8 @@ 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 @@ -1182,7 +1191,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 @@ -1316,7 +1326,8 @@ theorem TrExprS.instN_var (W : VLCtx.InstN Δ₀ e₀' A₀ dk k Δ₁ Δ) (H : 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 + (H : TrProj env U Γ₁ s i e e') : + TrProj env U Γ s i (e.inst e₀ k) (e'.inst e₀ k) := sorry variable! (henv : Ordered env) (h₀ : TrExprS env Us Δ₀ e₀ e₀') (t₀ : env.HasType Us.length Δ₀.toCtx e₀' A₀) in @@ -1583,9 +1594,11 @@ 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) := sorry section @@ -1693,7 +1706,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') := @@ -2477,7 +2490,7 @@ 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, sorryAx, Classical.choice, Quot.sound] +info: 'Lean4Lean.TrExprS.toConstructor_ready' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms TrExprS.toConstructor_ready From c62085da9a7e5c9f2136418fb855a089d8520cd4 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 17:00:47 -0400 Subject: [PATCH 20/27] theory+verify: close L4L-14 projection structural laws --- Lean4Lean/Audit/SorryFrontier.lean | 9 +- Lean4Lean/Tests/ProjectionExpressibility.lean | 925 +++++++- Lean4Lean/Theory/Projection.lean | 1912 ++++++++++++++++- Lean4Lean/Verify/Typing/Lemmas.lean | 159 +- 4 files changed, 2957 insertions(+), 48 deletions(-) diff --git a/Lean4Lean/Audit/SorryFrontier.lean b/Lean4Lean/Audit/SorryFrontier.lean index fe11665..75c3d5a 100644 --- a/Lean4Lean/Audit/SorryFrontier.lean +++ b/Lean4Lean/Audit/SorryFrontier.lean @@ -132,14 +132,6 @@ 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 P — projection structural laws (L4L-14) - `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 Tier P -- (NormLevel.subsumption_eval and Level.isEquiv_wf were proved on the -- formalization line, 2026-08-05/07, and left the frontier.) @@ -154,6 +146,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/Tests/ProjectionExpressibility.lean b/Lean4Lean/Tests/ProjectionExpressibility.lean index d8d9d29..349b682 100644 --- a/Lean4Lean/Tests/ProjectionExpressibility.lean +++ b/Lean4Lean/Tests/ProjectionExpressibility.lean @@ -21,11 +21,14 @@ 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 := [⟨vconst(type_of% @DependentRecord.mk), ``DependentRecord.mk⟩] + ctors := [dependentRecordCtor] def dependentRecordDecl : VInductDecl := ⟨2, 2, [dependentRecordType]⟩ @@ -61,6 +64,55 @@ theorem dependentRecord_trace : 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⟩ @@ -83,7 +135,9 @@ 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⟩⟩ @@ -200,6 +254,830 @@ def symbolicKeyCode : VStructureView.ProjectionCode := 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 @@ -216,7 +1094,8 @@ theorem key_representable : params_length := rfl paramsSpine := symbolicParams_spine majorType := symbolicMajor_hasType - program := ⟨symbolicKeyCode, rfl, rfl⟩ } + program := ⟨symbolicKeyCode, rfl, rfl, + symbolicKeyProjector_hasType⟩ } theorem value_representable : dependentRecordEnv.TrProj 2 symbolicContext dependentRecordView @@ -228,7 +1107,8 @@ theorem value_representable : params_length := rfl paramsSpine := symbolicParams_spine majorType := symbolicMajor_hasType - program := ⟨symbolicValueCode, rfl, rfl⟩ } + program := ⟨symbolicValueCode, rfl, rfl, + symbolicValueProjector_hasType⟩ } /-- The one generated iota equation used by both projection programs is actually registered in the final Theory environment. -/ @@ -282,11 +1162,14 @@ 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 := [⟨vconst(type_of% @EmptyRecord.mk), ``EmptyRecord.mk⟩] + ctors := [emptyRecordCtor] def emptyRecordDecl : VInductDecl := ⟨1, 1, [emptyRecordType]⟩ @@ -322,6 +1205,37 @@ theorem emptyRecord_trace : 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 { @@ -342,7 +1256,9 @@ theorem emptyRecord_registered : emptyRecordView.Registered emptyRecordEnv := by 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 @@ -374,6 +1290,7 @@ info: 'Lean4Lean.Tests.ProjectionExpressibility.key_representable' depends on ax /-- info: 'Lean4Lean.Tests.ProjectionExpressibility.value_representable' depends on axioms: [propext, + sorryAx, Classical.choice, Quot.sound] -/ diff --git a/Lean4Lean/Theory/Projection.lean b/Lean4Lean/Theory/Projection.lean index d2151dd..501dd38 100644 --- a/Lean4Lean/Theory/Projection.lean +++ b/Lean4Lean/Theory/Projection.lean @@ -1,5 +1,4 @@ -import Lean4Lean.Theory.Inductive -import Lean4Lean.Theory.Typing.Lemmas +import Lean4Lean.Theory.Typing.InductivePatternWF /-! # Structure projections @@ -30,6 +29,380 @@ def VExpr.instRevAt : VExpr → List VExpr → Nat → VExpr | e, [], _ => e | e, a :: as, k => instRevAt (e.inst a (k + as.length)) as k +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] + +@[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 @@ -52,6 +425,158 @@ theorem VEnv.OnSortTel.mono {env env' : VEnv} (henv : env ≤ env') | 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) + +private 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 @@ -108,6 +633,82 @@ def specializedFields (view : VStructureView) 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) @@ -125,35 +726,406 @@ structure ProjectionCode where 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 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] - let code := { fieldSort, typeFn, minor, projector } + 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 0 [] + (view.structureType levels params) fields + (view.fieldSorts.map (VLevel.inst levels)) 0 [] + +@[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) @@ -181,14 +1153,40 @@ structure Registered (view : VStructureView) (env : VEnv) : Prop where 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 - parameters : env.OnTel view.uvars [] view.constructorParams + 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.constructorParams.reverse view.fields view.fieldSorts + view.generation.block.checked.params.reverse + view.fields view.fieldSorts smallFields : view.generation.elimination = .small → ∀ level ∈ view.fieldSorts, level = .zero @@ -205,13 +1203,213 @@ theorem Registered.mono {env env' : VEnv} (henv : env ≤ env') 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 @@ -223,6 +1421,477 @@ private theorem SpineWF.monoProjection {env env' : VEnv} | _, _ :: _, _, ⟨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. -/ +private theorem TelDefEq.spine_sort_viewProjection + {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_viewProjection henv + hTinst hrest' hlenInst + refine ⟨A', VExpr.forallN As' (.sort l), rfl, heView, ?_⟩ + simpa [VExpr.instN_forallN, VExpr.inst] using hout + +theorem _root_.Lean4Lean.VStructureView.WF.specializedFields_onSortTel + (self : VStructureView.WF view env) (henv : env.Ordered) + {U : Nat} {Γ : List VExpr} (levels : List VLevel) + (hlevels : ∀ level ∈ levels, level.WF U) + (hlevelsLength : levels.length = view.uvars) + (params : List VExpr) (hparamsLength : params.length = view.nparams) + (paramsSpine : ∃ resultLevel, + env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel)) : + env.OnSortTel U Γ (view.specializedFields levels params) + (view.fieldSorts.map (VLevel.inst levels)) := by + let S := self.toGenerationEnv henv + obtain ⟨resultLevel, hspine⟩ := paramsSpine + have hrawLength : + view.generation.block.rawParams.length = view.nparams := + view.generation.shape.1 + have hspineShape : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.rawParams.map (VExpr.instL levels)) + (view.generation.block.rawResult.instL levels)) + params (.sort resultLevel) := by + simpa [VStructureView.familyType, + VInductDecl.NormalizedChecked.rawType_eq, + view.raw_indices_eq, VExpr.instL_forallN, + VExpr.forallN] using hspine + have hparamsRaw : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.rawParams.map (VExpr.instL levels)) + (.sort resultLevel)) params (.sort resultLevel) := by + have hout := hspineShape.retarget + (by simpa [hrawLength] using hparamsLength) + (.sort resultLevel) + rw [VExpr.instRev_closedN params (by trivial)] at hout + exact hout + have hrawChecked := S.rawParams_defeq.instL hlevels + have hrawLift := VEnv.OnTel.liftTelN_eq henv + hrawChecked.raw_onTel (by trivial) Γ.length + have hcheckedLift := VEnv.OnTel.liftTelN_eq henv + (hrawChecked.view_onTel henv) (by trivial) Γ.length + have hrawLift' : VExpr.liftTelN Γ.length + (view.generation.block.rawParams.map (VExpr.instL levels)) 0 = + view.generation.block.rawParams.map (VExpr.instL levels) := by + simpa using hrawLift + have hcheckedLift' : VExpr.liftTelN Γ.length + (view.generation.block.checked.params.map (VExpr.instL levels)) 0 = + view.generation.block.checked.params.map (VExpr.instL levels) := by + simpa using hcheckedLift + have hrawCheckedΓ := hrawChecked.weakN henv + (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ) + rw [hrawLift', hcheckedLift'] at hrawCheckedΓ + simp only [List.append_nil] at hrawCheckedΓ + have hparamsChecked : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.checked.params.map + (VExpr.instL levels)) (.sort resultLevel)) + params (.sort resultLevel) := by + exact TelDefEq.spine_sort_viewProjection 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_viewProjection 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 @@ -241,12 +1910,15 @@ structure TrProj (env : VEnv) (U : Nat) (Γ : List VExpr) 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 + 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 + obtain ⟨code, hcode, rfl, -⟩ := self.program simp [VStructureView.project?, hcode] theorem TrProj.type_eq @@ -254,7 +1926,7 @@ theorem TrProj.type_eq ∃ code : VStructureView.ProjectionCode, VStructureView.projectionType? view levels params idx major = some (VExpr.app code.typeFn major) := by - obtain ⟨code, hcode, _⟩ := self.program + obtain ⟨code, hcode, _, -⟩ := self.program exact ⟨code, by simp [VStructureView.projectionType?, hcode]⟩ /-- A fixed checked view, universe/parameter instantiation, field index, and @@ -276,7 +1948,203 @@ theorem TrProj.mono {env env' : VEnv} (henv : env ≤ env') params_length := self.params_length paramsSpine := self.paramsSpine.imp fun _ h => h.monoProjection henv majorType := self.majorType.mono henv - program := self.program + 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] diff --git a/Lean4Lean/Verify/Typing/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean index ab3ecbf..85d2d84 100644 --- a/Lean4Lean/Verify/Typing/Lemmas.lean +++ b/Lean4Lean/Verify/Typing/Lemmas.lean @@ -524,14 +524,18 @@ inductive SortList : VLCtx → List VLevel → Prop end VLCtx -theorem TrProj.weak' (W : Ctx.Lift' n Γ Γ') +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) := sorry + 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 Γ Γ') +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' <| Ctx.liftN_iff_lift'.1 W + simpa [VExpr.lift'_consN_skipN] using + H.weak' henv (Ctx.liftN_iff_lift'.1 W) /-! ## Replaying closed metadata types -/ @@ -609,7 +613,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) @@ -648,7 +652,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) @@ -664,11 +668,23 @@ theorem HasType.skips (W : Ctx.LiftN n k Γ Γ') theorem TrProj.weak'_inv (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U)) (W : Ctx.Lift' l Γ Γ') : TrProj env U Γ' s i (e.lift' l) e' → - ∃ e', TrProj env U Γ s i e e' := sorry + ∃ 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 env U Γ₁ s i e₁ e') : - ∃ e', TrProj env U Γ₂ s i e₂ e' := sorry + ∃ 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 @@ -912,7 +928,10 @@ theorem TrExpr.fvarsList (H : TrExpr env Us Δ e e') : e.fvarsList ⊆ Δ.fvars (fvarsIn_iff.1 H.fvarsIn).1 theorem TrProj.wf (H1 : TrProj env U Γ s i e e') - (H2 : VExpr.WF env U Γ e) : VExpr.WF env U Γ e' := sorry + (_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⟩ @@ -958,7 +977,11 @@ variable! (henv : VEnv.WF env) (hΓ : IsDefEqCtx env U [] Γ₁ Γ₂) in 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₂) : @@ -1325,9 +1348,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 Γ₁ Γ) +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) := sorry + 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 @@ -1350,7 +1378,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₀) @@ -1598,7 +1626,110 @@ 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) := sorry + (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 From b2bf43e7ff6f154e5b28390cb94719e8f209e2d6 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 21:17:27 -0400 Subject: [PATCH 21/27] docs: refresh formalization roadmap for L4L-14 --- plans/roadmap.md | 783 +++++++++++++++++++---------------------------- 1 file changed, 322 insertions(+), 461 deletions(-) diff --git a/plans/roadmap.md b/plans/roadmap.md index 9a19b44..6827637 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -67,424 +67,223 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| Ladder position | **L4L-13A active**; L4L-12 and everything above it are complete and pruned from §5; everything below L4L-13A is queued | -| Current formalization source | the complete L4L-12B literal-readiness checkpoint (`Theory/Literals.lean`, the Verify literal bridge, and `Tests/LiteralReadiness.lean`) layered on the independently gated L4L-12A extraction checkpoint `958d03b7` (itself based on the L4L-11 closure `0587b91a`), at `jcb/formalization2`, 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 independently on the L4L-12A extraction checkpoint and the L4L-12B readiness checkpoint, including focused, aggregate, and default Lake builds, the Nix proof/dependency build, clean-source `nix flake check`, the unchanged 25-entry sorry frontier, Theory import-boundary and exact-axiom 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. - -The consumer-neutral local-context core now 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 including generated recursors and iota -rules. Readiness derives direct literal WF, is stable under ordered -environment extension and fresh constants, and remains independent of -`Lean.Expr`; Verify retains only traversal and proves its constructor result -equal to the direct Theory encoding. - -**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. - -**Complete replay matrix and consumer certificates.** The supported replay -matrix now executes 25 actual-metadata transactions rather than merely -packaging abstract witnesses: 20 automatically constructed singleton -candidates (the L4L-07 inventory 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, -producer result, data-bearing transaction trace, final translated -type/constructor/recursor roles, and recursor lookup uniqueness. The mutual -and nested rows expose the same -metadata-completeness predicate through one sum artifact, while their -certificates separately derive environment growth and block WF. - -The consumer-neutral Theory API is -`VInductDecl.BlockCertificate`/`NestedBlockCertificate`. It reconstructs the -raw `addInduct` result, `addInduct_le`, `addInduct_WF`, exact family and every -constructor/recursor lookup, freshness, lookup uniqueness, registered rule -membership/WF, rule closure, and L4L-10 recursor-pattern facts from one checked -transaction. The API imports no Verify state, `Lean.Expr`, normalization -oracle, or kernel implementation object. Its WF root has only the standard -logical baseline, and its rule/pattern root additionally uses -`Classical.choice`; in particular neither reaches `sorryAx`. Verify's unified -matrix has one exact guarded `sorryAx`, solely through the separately tracked -projection/refinement frontier. - -A separate fresh replay loads the compiled dependency closure of the -notation-heavy fixture into an empty kernel environment and checks all 296 -declarations. Numerals, arithmetic and comparison notation, lists, arrays, -products, conditionals, and strings therefore exercise their real compiled -prelude dependencies rather than a hand-built Theory environment. - -**Nested representation and flattening.** The committed design note and -executable metadata probes in -`Lean4Lean/Verify/Environment/NestedRepresentation.lean` pin how the -implementation stores nested inductives (restored source families carrying -`numNested`, auxiliary recursors named by `appendIndexAfter` whose rules -are keyed by previously declared inductives' constructors, flattened -motive/minor counts, no surviving `_nested.*` constant) and fix the L4L-09 -representation: the stored Theory payload is the source `VInductDecl` -unchanged, and nested support is an additive artifact coupling the -flattened block (accepted by the unchanged arbitrary-block machinery) with -per-auxiliary specifications — the Theory analog of `aux2nested` — and a -restoration substitution σ. Probes verify on rose-tree, nested-indexed, -and constant-universe fixtures that the port's nested path reproduces -Lean's stored metadata exactly, that final metadata is independent of -auxiliary-name collisions, and that σ over the existing flat-block -generation artifacts reproduces every stored recursor type and rule RHS, -with declaration-world values for constructor types and an `instL` -elimination-offset splice for recursor-world artifacts. - -The restoration and its transaction are implemented and preserved: -`restoreExpr` is the total bottom-up σ (firing where an auxiliary spine -completes its parameter count, recursor renames checked before the -constructor-prefix case), `NestedBlockChecked.recursors`/`generatedRules` -restore the flattened block's generation artifacts onto the -`appendIndexAfter` inventory, and `VEnv.addInductNested` inserts source -families/constructors plus restored recursors/rules in the four block -phases. `AddInductNestedTrace` and its lemma suite (recovery, atomicity, -monotonicity, freshness, lookups, rule membership) mirror the block -transaction; `NestedBlockChecked.WF` chains per-insertion constant and -rule well-formedness along the deterministic phase folds and -`addInductNested_WF` folds it into `Ordered` preservation, discharged -through the new `VDecl.WF.inductNested` case and `VEnv.WF.ordered`. -Verify's `AddInductNested`/`AddInductNestedTrace` and `TrEnv'.inductNested` -extend the alignment layer (with `aligned`, `of_value`, `map_wf`, -`sf_mono` cases). The restoration-parity differential proves the product -σ equal to Lean's stored metadata — every restored recursor name, -universe count, and type, and every rule RHS in globally flattened -order — and the real-output round-trip runs the port's complete -`Environment.addInductive` on dependency-only environments and compares -its entire output against the Theory artifacts (payload constants, -recursors, K flags, rule RHSs, and `numNested`), on the rose-tree, -nested-indexed, and constant-universe fixtures. - -**Nested environment replay.** All three ladder fixtures replay from real -stored metadata through `TrEnv'.inductNested` -(`Verify/Environment/NestedReplay.lean`): the rose tree over the -completed `List` replay environment, and the nested-indexed family over -a `PVec` boundary staged by `TrEnv'.inductStaging` on the completed -`Nat` replay, plus `DeepBi α β` over the actual two-parameter `BiBox α β` -dependency. `DeepBi.node` contains two queued nested occurrences, -`BiBox (DeepBi α β) (BiBox α (DeepBi α β))`; the analyzer produces all -three auxiliary recursors/rules and their RHSs agree with the real stored -kernel metadata. Each replay inserts the stored `ConstantInfo`s with -`tr_type_expr_tac` translations, exact freshness chains, K-flag -agreement, and the literal rule fold, and proves the complete -`NestedBlockChecked.WF` package by direct concrete typing derivations -(`type_tac`) over the exact phase environments, with the printed -artifact literals tied to the computed `nestedBlockChecked?` artifacts -by named `native_decide` observations. The package closures are the -standard logical baseline plus the persistent-map container axioms and -those named observations — no `sorryAx`; the full `TrEnv'` roots carry -the usual transitional checker closure, exactly guarded. The general σ̂ -typed transport (`Theory/Typing/NestedTransport.lean`: the `ConstInterp` -environment morphism and `IsDefEq.substConst` with -`HasType`/`IsType`/`VConstant.WF`/`VDefEq.WF` corollaries) is proved as -the generic justification layer; its β-collapse bridge to the -spine-collapsed artifact substitution on generated artifacts remains -available future work, not a nested-coverage gap. - -The Theory flattening itself is implemented: +**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 — target-block recognition against -caller-supplied environment-free metadata copies (`NestedTargetBlock`, -with `NestedTargetBlock.WF` tying the copy to a `VEnv`), the -local-variable rejection, replace-without-descending rewriting, -value-keyed deduplication, whole-target-block auxiliary creation with -level instantiation and simultaneous parameter substitution, canonical -`appendIndexAfter` naming, and the fixpoint over queued auxiliary -constructors. `nestedStage3` gates acceptance by flattening success plus -generation readiness of the flattened block through the unchanged L4L-08 -analyzers. Theory fixtures pin the exact flattened blocks and -specifications for the rose-tree and nested-indexed fixtures, and the -Verify differential (`Verify/Environment/NestedTransformation.lean`) -proves the Theory flattening equal to the port's on all three real -fixtures (families, constructors, specifications, `numNested`), ties the -hand-written `List` target to stored metadata, and matches kernel -accept/reject on four nearest negatives: local-variable parametric -arguments (with the kernel's exact diagnostic), off-spine parametric -applications, canonical-auxiliary-name collisions, and missing target -declarations. Source declarations remain rejected by the non-nested raw -analyzer; the dedicated nested analyzer and transaction own their -flattened/restored recursors, rules, and replay. - -**Generated iota patterns.** Every certified block's iota rules are exact -`SimplePattern.iota` patterns (`Theory/Typing/InductivePattern.lean`): the -generated left body is the owning recursor applied to the shared parameters, -all motives, all minors, and the constructor's result indices with a -constructor-headed major premise, and `ruleLhsBody_matches` matches it -against `rulePattern` at the rule's recursor levels. The block's pattern set -`IotaPat` couples each rule's pattern with an RHS template — the registered -right tower applied to the captured common arguments and fields — and a -check list demanding parameter and result-index agreement between the -recursor spine and the major premise, with payload closedness carried by a -`RuleClosure` bundle that fixtures discharge by evaluation. The complete -generic `Params` obligations — `pat_simple`, match inversion with -rule-index/constructor recovery, rule distinctness, and the +`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 -`blockGeneratedNames` inventory (nodup transported across the normalization -boundary) and the analyzer's terminal `blockTarget?` arity equation, at -guarded `propext`/`Quot.sound`-level closures. The implementation-independent -shape layer (`HeadConstN`, `HeadConst`, `of_varN_matches`, -`RecursorIotaPattern`, `matches_shape`, tower intersection laws, -`varNPaths`) lives in `Theory/Typing/Pattern.lean`; a mutual tree/forest -block and a `Nat`-indexed vector fixture pin the pattern inventories and -closedness by kernel evaluation. No open-environment `Params` instance is -installed. - -**Pattern soundness and the assembler.** The typed β-collapse layer -(`Theory/Typing/InductivePatternWF.lean`) proves, at a sorry-free -`propext`/`Quot.sound` closure, that applying a lambda telescope to a full -well-typed spine is definitionally equal to the iterated instantiation of -its body (`IsDefEq.appN_lamN` over `instRev`, with `SpineDefEq` pointwise -application congruence, telescope instantiation, and lambda/pi tower -inversions `lamN_wf`/`forallN_wf`), and that a matched pattern's captures -are exactly the spine arguments (`varN_matches_paths`). `pat_wf` composes -these into pattern soundness for one certified block: a successful match of -a rule's pattern whose parameter and index checks hold is definitionally -equal to the instantiated RHS template, derived from the exact rule defeq -registered by `addInduct` — the redex arrives decomposed into its recursor -and constructor spines with spine-form typing and pinned source levels, -which is precisely what a verified reduction site holds, and the theorem's -guarded closure is exactly the Church–Rosser development's own transitional -unique-typing closure, shedding `sorryAx` automatically when L4L-16/17 -land. The block-local assembler -(`Theory/Typing/InductivePatternEnv.lean`) builds an environment whose -defeq set is exactly one certified block's generated rules plus separately -certified extension rules over a constant base: `assembleEnv_defeqs` -inverts the defeq set exactly, `assembleEnv_WF` preserves ordering through -the block phases and the extension fold, and the union pattern set -`AssembledPat` couples the block's L4L-10A facts with each +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 global open-environment `Params` instance is installed; both -fixture blocks assemble over the empty base with their defeq sets pinned to -their generated rules. - -**Not claimed.** Projections, and the remaining metatheory/checker roots. +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 @@ -500,14 +299,13 @@ never generation-shape authority or Theory semantics. 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 | @@ -520,16 +318,39 @@ The remaining v4.31-added sorry is classified: 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 coverage remains queued. `pat_wf` carries the Church–Rosser + 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. -- Projection semantics and a final audit of consumer-neutral structure and - checker lemmas remain under `Verify/` (L4L-13A--L4L-15C). The local-context +- 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. @@ -693,54 +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. -### 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 (active).** 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. @@ -757,6 +575,13 @@ 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 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. @@ -790,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. @@ -799,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`. @@ -809,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. @@ -850,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 @@ -975,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. From 97cab5d52270409d0cf2882d6247aa0ec3a26001 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Tue, 11 Aug 2026 05:12:36 -0400 Subject: [PATCH 22/27] theory+verify: certify projection inference --- Lean4Lean/Audit/SorryFrontier.lean | 1 - Lean4Lean/Environment/Basic.lean | 56 ++ Lean4Lean/Theory/Projection.lean | 429 ++++++++++++- Lean4Lean/TypeChecker.lean | 52 +- .../Environment/ConstructorValidation.lean | 15 - .../ConstructorValidityReplay.lean | 108 ++++ .../Environment/IndexedVecSemanticReplay.lean | 62 ++ .../Verify/Environment/InductiveFixtures.lean | 62 ++ .../Verify/Environment/Normalization.lean | 6 + Lean4Lean/Verify/TypeChecker.lean | 2 + Lean4Lean/Verify/TypeChecker/Basic.lean | 48 ++ Lean4Lean/Verify/TypeChecker/InferType.lean | 587 +++++++++++++++++- Lean4Lean/Verify/TypeChecker/IsDefEq.lean | 15 - Lean4Lean/Verify/Typing/Lemmas.lean | 11 + 14 files changed, 1396 insertions(+), 58 deletions(-) diff --git a/Lean4Lean/Audit/SorryFrontier.lean b/Lean4Lean/Audit/SorryFrontier.lean index 75c3d5a..f3c9906 100644 --- a/Lean4Lean/Audit/SorryFrontier.lean +++ b/Lean4Lean/Audit/SorryFrontier.lean @@ -136,7 +136,6 @@ private def allowlist : Array Lean.Name := #[ -- (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, diff --git a/Lean4Lean/Environment/Basic.lean b/Lean4Lean/Environment/Basic.lean index 7ed24cd..44bfd3f 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/Theory/Projection.lean b/Lean4Lean/Theory/Projection.lean index 501dd38..199c3f6 100644 --- a/Lean4Lean/Theory/Projection.lean +++ b/Lean4Lean/Theory/Projection.lean @@ -29,6 +29,14 @@ 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 @@ -80,6 +88,86 @@ private theorem VExpr.instRevAt_forallN_projection 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 = @@ -480,7 +568,7 @@ private theorem VExpr.instRevAt_instTelN_cons · congr 2 <;> omega · exact ih (start + 1) (as.length + start + 1) (by omega) -private theorem VExpr.instRevAt_map_instL_zipIdx +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 @@ -1118,6 +1206,169 @@ def projectionCodes (view : VStructureView) (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 @@ -1141,6 +1392,78 @@ def project? (view : VStructureView) 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. -/ @@ -1424,7 +1747,7 @@ private theorem SpineWF.monoProjection {env env' : VEnv} /-- The view-facing direction of `TelDefEq.spine_sort`: arguments checked against the retained raw telescope also consume its definitionally equal view telescope. -/ -private theorem TelDefEq.spine_sort_viewProjection +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) → @@ -1450,11 +1773,107 @@ private theorem TelDefEq.spine_sort_viewProjection es.length = (VExpr.instTelN e As 0).length := by rw [VExpr.instTelN_length] exact hlen' - have hout := TelDefEq.spine_sort_viewProjection henv + 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) @@ -1511,7 +1930,7 @@ theorem _root_.Lean4Lean.VStructureView.WF.specializedFields_onSortTel (view.generation.block.checked.params.map (VExpr.instL levels)) (.sort resultLevel)) params (.sort resultLevel) := by - exact TelDefEq.spine_sort_viewProjection henv hrawCheckedΓ hparamsRaw + 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 @@ -1594,7 +2013,7 @@ private theorem _root_.Lean4Lean.VStructureView.WF.generationParamsSpine (view.generation.block.checked.params.map (VExpr.instL levels)) (.sort fieldSort)) params (.sort fieldSort) := - TelDefEq.spine_sort_viewProjection henv hrawCheckedΓ hparamsRaw + TelDefEq.spine_sort_view henv hrawCheckedΓ hparamsRaw (by simpa [hrawLength] using hparamsLength) have hgenerationChecked := S.generationParams_defeq.instL hlevels have hgenerationLift : VExpr.liftTelN Γ.length diff --git a/Lean4Lean/TypeChecker.lean b/Lean4Lean/TypeChecker.lean index c71b1d6..cf9a2b0 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/Environment/ConstructorValidation.lean b/Lean4Lean/Verify/Environment/ConstructorValidation.lean index 45df045..3a46672 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidation.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidation.lean @@ -5215,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 diff --git a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean index 322c5b5..58606b7 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 diff --git a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean index 81c5e56..48c9069 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 diff --git a/Lean4Lean/Verify/Environment/InductiveFixtures.lean b/Lean4Lean/Verify/Environment/InductiveFixtures.lean index 27cdeb7..2fc2d0e 100644 --- a/Lean4Lean/Verify/Environment/InductiveFixtures.lean +++ b/Lean4Lean/Verify/Environment/InductiveFixtures.lean @@ -2569,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 -/ @@ -3428,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 @@ -3542,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 @@ -7440,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 @@ -8379,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 diff --git a/Lean4Lean/Verify/Environment/Normalization.lean b/Lean4Lean/Verify/Environment/Normalization.lean index 77d2462..b3a5f5b 100644 --- a/Lean4Lean/Verify/Environment/Normalization.lean +++ b/Lean4Lean/Verify/Environment/Normalization.lean @@ -3625,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 } @@ -3688,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 @@ -3805,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 = diff --git a/Lean4Lean/Verify/TypeChecker.lean b/Lean4Lean/Verify/TypeChecker.lean index 858cb75..4a4d98a 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 6252d89..629d8b8 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 da5b6f0..075338e 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 7eddbad..992ae6a 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/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean index 85d2d84..f982a9a 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] From f1ad7c6db5bf1e4afd4a4d09b3a1f1c8e2a233ad Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Tue, 11 Aug 2026 08:36:08 -0400 Subject: [PATCH 23/27] theory: certify generated projector iota --- Lean4Lean/Theory/Projection.lean | 622 ++++++++++++++++++- Lean4Lean/Theory/Typing/InductiveLemmas.lean | 13 +- 2 files changed, 626 insertions(+), 9 deletions(-) diff --git a/Lean4Lean/Theory/Projection.lean b/Lean4Lean/Theory/Projection.lean index 199c3f6..fef14e2 100644 --- a/Lean4Lean/Theory/Projection.lean +++ b/Lean4Lean/Theory/Projection.lean @@ -500,6 +500,30 @@ inductive VEnv.OnSortTel (env : VEnv) (U : Nat) : OnSortTel env U (A :: Γ) As us → OnSortTel env U Γ (A :: As) (u :: us) +private theorem onCtx_levelWFProjection {env : VEnv} {U : Nat} : + ∀ {Γ : List VExpr}, OnCtx Γ (env.IsType U) → + OnCtx Γ fun _ A => A.LevelWF U + | [], _ => trivial + | _ :: _, ⟨hΓ, ⟨_, hA⟩⟩ => + let hΓ' := onCtx_levelWFProjection hΓ + ⟨hΓ', (hA.levelWF hΓ').1⟩ + +/-- Every retained sort selected from a checked sort telescope is a +well-formed universe at the ambient universe bound. -/ +theorem VEnv.OnSortTel.sortWF {env : VEnv} {U : Nat} + : ∀ {Γ : List VExpr} {As : List VExpr} {us : List VLevel}, + OnCtx Γ (env.IsType U) → env.OnSortTel U Γ As us → + ∀ {i : Nat} {u : VLevel}, us[i]? = some u → u.WF U + | _, [], [], _, .nil, _, _, h => by simp at h + | _, _ :: _, _ :: _, hΓ, .cons hA hT, 0, _, h => by + injection h with h + subst h + exact (hA.levelWF (onCtx_levelWFProjection hΓ)).2.2 + | Γ, A :: As, u₀ :: us, hΓ, .cons hA hT, i + 1, u, h => by + exact VEnv.OnSortTel.sortWF (env := env) (U := U) + (Γ := A :: Γ) (As := As) (us := us) + ⟨hΓ, ⟨u₀, hA⟩⟩ hT (by simpa using h) + private theorem VEnv.OnTel.monoProjection {env env' : VEnv} (henv : env ≤ env') (H : env.OnTel U Γ As) : env'.OnTel U Γ As := by induction As generalizing Γ with @@ -513,6 +537,15 @@ theorem VEnv.OnSortTel.mono {env env' : VEnv} (henv : env ≤ env') | nil => exact .nil | cons hA _ ih => exact .cons (hA.mono henv) ih +/-- Forget the retained sort labels, preserving the underlying telescope +well-formedness judgment. -/ +theorem VEnv.OnSortTel.toOnTel {env : VEnv} : + ∀ {U : Nat} {Γ As : List VExpr} {us : List VLevel}, + env.OnSortTel U Γ As us → env.OnTel U Γ As + | _, _, [], [], .nil => trivial + | _, _, _ :: _, _ :: _, .cons hA hT => + ⟨⟨_, hA⟩, VEnv.OnSortTel.toOnTel hT⟩ + theorem VEnv.OnSortTel.instL {env : VEnv} {U U' : Nat} (hlevels : ∀ level ∈ levels, level.WF U') : ∀ {Γ As us}, env.OnSortTel U Γ As us → @@ -1333,6 +1366,72 @@ theorem projectionCodes_get?_typeFn (view : VStructureView) (view.specializedFields levels params) (view.structureType levels params) hcode +private theorem projectionCodes.go_get?_program_shape + (view : VStructureView) (levels : List VLevel) + (params allFields : List VExpr) (structType : VExpr) : + ∀ {fields : List VExpr} {fieldSorts : List VLevel} + {i : Nat} {previous : List ProjectionCode} {j : Nat} + {code : ProjectionCode}, + (projectionCodes.go view levels params allFields structType + fields fieldSorts i previous)[j]? = some code → + ∃ fieldSort, + fieldSorts[j]? = some fieldSort ∧ + code.fieldSort = fieldSort ∧ + code.minor = VExpr.lamN allFields + (.bvar (allFields.length - 1 - (i + j))) ∧ + code.projector = .lam structType + (VExpr.appN + (.const view.recursorName + (view.projectionLevels code.fieldSort levels)) + (params.map (VExpr.liftN 1) ++ + [code.typeFn.lift, code.minor.lift, .bvar 0])) := by + intro fields + induction fields with + | nil => + intro fieldSorts i previous j code h + cases fieldSorts <;> simp [projectionCodes.go] at h + | cons field fields ih => + intro fieldSorts i previous j code h + cases fieldSorts with + | nil => simp [projectionCodes.go] at h + | cons fieldSort fieldSorts => + let head := projectionCode view levels params allFields structType + field fieldSort i previous + cases j with + | zero => + change some head = some code at h + injection h with hcode + subst code + simp [head, projectionCode] + | succ j => + simp only [projectionCodes.go, List.getElem?_cons_succ] at h + have hout := ih (fieldSorts := fieldSorts) (i := i + 1) + (previous := previous ++ [head]) h + simpa only [List.getElem?_cons_succ, Nat.add_assoc, Nat.add_comm, + Nat.add_left_comm] using hout + +/-- A selected projection code retains the exact selecting minor and +recursor program emitted by `projectionCodes`. -/ +theorem projectionCodes_get?_program_shape (view : VStructureView) + (levels : List VLevel) (params : List VExpr) {idx : Nat} + {code : ProjectionCode} + (hcode : (view.projectionCodes levels params)[idx]? = some code) : + ∃ fieldSort, + (view.fieldSorts.map (VLevel.inst levels))[idx]? = some fieldSort ∧ + code.fieldSort = fieldSort ∧ + code.minor = VExpr.lamN (view.specializedFields levels params) + (.bvar ((view.specializedFields levels params).length - 1 - idx)) ∧ + code.projector = .lam (view.structureType levels params) + (VExpr.appN + (.const view.recursorName + (view.projectionLevels code.fieldSort levels)) + (params.map (VExpr.liftN 1) ++ + [code.typeFn.lift, code.minor.lift, .bvar 0])) := by + unfold projectionCodes at hcode + simpa using projectionCodes.go_get?_program_shape view levels params + (view.specializedFields levels params) + (view.structureType levels params) hcode + /-- Applying a generated projection's type function to its major premise substitutes that major into every earlier generated projector. -/ theorem projectionCodes_get?_typeFn_beta (view : VStructureView) @@ -2311,6 +2410,434 @@ theorem SpineWF.instNProjection {env : VEnv} {U k : Nat} have := SpineWF.instNProjection henv W h₀ (es := es) hrest rwa [VExpr.inst0_inst_hi] at this⟩ +/-- A generated projector computes on the matching generated constructor +once the registered rule's capture spine has been checked. This is the +exact iota layer; constructor-head and parameter-prefix alignment are kept +outside this theorem. -/ +theorem _root_.Lean4Lean.VStructureView.WF.projector_constructor_exact + (self : VStructureView.WF view env) (henv : env.WF) + {U : Nat} {Γ : List VExpr} (hΓ : OnCtx Γ (env.IsType U)) + {levels : List VLevel} (hlevels : ∀ level ∈ levels, level.WF U) + (hlevelsLength : levels.length = view.uvars) + {params : List VExpr} (hparamsLength : params.length = view.nparams) + (hparamsSpine : ∃ resultLevel, + env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel)) + {idx : Nat} {code : VStructureView.ProjectionCode} + (hcode : (view.projectionCodes levels params)[idx]? = some code) + (hprojector : env.HasType U Γ code.projector + (.forallE (view.structureType levels params) + (.app code.typeFn.lift (.bvar 0)))) + {fields : List VExpr} (hfieldsLength : + fields.length = (view.specializedFields levels params).length) + {field : VExpr} (hfield : fields[idx]? = some field) + (hctorType : env.HasType U Γ + (VExpr.appN (.const view.constructorName levels) (params ++ fields)) + (view.structureType levels params)) + (hfieldsSpine : env.SpineWF U Γ + (VExpr.forallN (view.specializedFields levels params) (.sort .zero)) + fields (.sort .zero)) + {B : VExpr} + (hcaps : env.SpineWF U Γ + ((view.generation.rule 0 view.constructor).type.instL + (view.projectionLevels code.fieldSort levels)) + (params ++ [code.typeFn, code.minor] ++ fields) B) : + env.IsDefEqU U Γ + (.app code.projector + (VExpr.appN (.const view.constructorName levels) (params ++ fields))) + field := by + obtain ⟨fieldSort, hfieldSort, hcodeSort, hminorShape, + hprojectorShape⟩ := + view.projectionCodes_get?_program_shape levels params hcode + have hsortTel := self.specializedFields_onSortTel henv.ordered + levels hlevels hlevelsLength params hparamsLength hparamsSpine + have hfieldSortWF : code.fieldSort.WF U := by + rw [hcodeSort] + exact hsortTel.sortWF hΓ hfieldSort + let pLevels := view.projectionLevels code.fieldSort levels + have hpLevelsWF : ∀ level ∈ pLevels, level.WF U := + VStructureView.projectionLevels_wf view code.fieldSort levels + hfieldSortWF hlevels + have hpLevelsLength : pLevels.length = view.generation.recUvars := + VStructureView.projectionLevels_length view code.fieldSort levels + hlevelsLength + have hruleMem : view.generation.rule 0 view.constructor ∈ + view.generation.generatedRules := by + simp [VInductDecl.GenerationChecked.generatedRules, + view.constructor_eq] + have hregistered := self.rule_mem hruleMem + have hruleWF := henv.ordered.defEqWF hregistered + rw [hprojectorShape] at hprojector + obtain ⟨_, ⟨projectorBodyType, hprojectorBody⟩⟩ := + hprojector.lam_inv henv.ordered hΓ + have hprojectorBeta := VEnv.IsDefEq.beta hprojectorBody hctorType + have hprojectorToRule : env.IsDefEqU U Γ + (.app code.projector + (VExpr.appN (.const view.constructorName levels) (params ++ fields))) + (VExpr.appN (.const view.recursorName pLevels) + (params ++ [code.typeFn, code.minor, + VExpr.appN (.const view.constructorName levels) + (params ++ fields)])) := by + refine ⟨projectorBodyType.inst + (VExpr.appN (.const view.constructorName levels) (params ++ fields)), ?_⟩ + rw [hprojectorShape] + simpa [pLevels, VExpr.inst, VExpr.instN_appN, VExpr.inst_lift, + VExpr.instVar_zero, + List.map_append, List.map_map, Function.comp_def] using + hprojectorBeta + let gen := view.generation + let Bs := view.constructor.fieldsR view.source.uvars view.source.nparams + gen.elimination + let m := Bs.length + let rs := view.constructor.recArgsR view.source.uvars gen.elimination + let binders := gen.paramsTel ++ gen.motiveType :: gen.minorTypes ++ + VExpr.liftTelN (gen.block.ctorPairs.length + 1) Bs 0 + let recBase := VExpr.appN + (.const (.str gen.block.sourceType.name "rec") gen.recLevels) + (VExpr.bvarRevRange m (view.source.nparams + + gen.block.ctorPairs.length + 1)) + let idxR := view.constructor.resultIndicesR view.source.uvars + gen.elimination |>.map fun expression => + expression.liftN (gen.block.ctorPairs.length + 1) m + let ctorApp := VExpr.appN + (.const view.constructor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange (m + gen.block.ctorPairs.length + 1) + view.source.nparams ++ VExpr.bvarRevRange 0 m) + let ihs := rs.map fun recursive => + recursive.ruleCall m gen.block.ctorPairs.length recBase + let lhsBody := VExpr.appN recBase (idxR ++ [ctorApp]) + let rhsBody := VExpr.appN + (.bvar (gen.block.ctorPairs.length - 1 - 0 + m)) + (VExpr.bvarRevRange 0 m ++ ihs) + let typeBody := VExpr.appN + (.bvar (gen.block.ctorPairs.length + m)) (idxR ++ [ctorApp]) + have hlhs₀ := hruleWF.1 + change env.HasType gen.recUvars [] (VExpr.lamN binders lhsBody) + (VExpr.forallN binders typeBody) at hlhs₀ + have hrhs₀ := hruleWF.2 + change env.HasType gen.recUvars [] (VExpr.lamN binders rhsBody) + (VExpr.forallN binders typeBody) at hrhs₀ + have hlhs : env.HasType U Γ + ((VExpr.lamN binders lhsBody).instL pLevels) + ((VExpr.forallN binders typeBody).instL pLevels) := + (hlhs₀.instL hpLevelsWF).weak0 henv.ordered + have hrhs : env.HasType U Γ + ((VExpr.lamN binders rhsBody).instL pLevels) + ((VExpr.forallN binders typeBody).instL pLevels) := + (hrhs₀.instL hpLevelsWF).weak0 henv.ordered + rw [VExpr.instL_lamN, VExpr.instL_forallN] at hlhs hrhs + have hcaps' : env.SpineWF U Γ + (VExpr.forallN (binders.map (VExpr.instL pLevels)) + (typeBody.instL pLevels)) + (params ++ [code.typeFn, code.minor] ++ fields) B := by + change env.SpineWF U Γ + ((VExpr.forallN binders typeBody).instL pLevels) + (params ++ [code.typeFn, code.minor] ++ fields) B at hcaps + simpa only [VExpr.instL_forallN] using hcaps + let S := self.toGenerationEnv henv.ordered + have hparamsTelLength : gen.paramsTel.length = view.nparams := by + simp [gen, VInductDecl.GenerationChecked.paramsTel, + S.generationParams_length] + have hspecializedLength : + (view.specializedFields levels params).length = + (view.constructor.rawFields view.nparams).length := by + simp [VStructureView.specializedFields, VStructureView.fields] + have hBsLength : Bs.length = + (view.constructor.rawFields view.nparams).length := by + simpa [Bs] using + (VInductDecl.NormalizedCtor.fieldsR_length + (source := view.source) view.constructor + (mode := gen.elimination)) + have hcapturesLength : + (params ++ [code.typeFn, code.minor] ++ fields).length = + (binders.map (VExpr.instL pLevels)).length := by + simp only [List.length_append, List.length_cons, List.length_nil, + List.length_map, VExpr.liftTelN_length, binders] + rw [hparamsLength, hfieldsLength, hspecializedLength, + hparamsTelLength, gen.minorTypes_length, view.constructor_eq, + hBsLength] + simp + obtain ⟨hlhsTel, lhsType, hlhsBody⟩ := + VEnv.HasType.lamN_wf henv.ordered hΓ hlhs + obtain ⟨hrhsTel, rhsType, hrhsBody⟩ := + VEnv.HasType.lamN_wf henv.ordered hΓ hrhs + have hlhsSpine := hcaps'.retarget hcapturesLength lhsType + have hrhsSpine := hcaps'.retarget hcapturesLength rhsType + have hcollapseL := VEnv.IsDefEq.appN_lamN henv.ordered + hlhsTel hlhsBody hlhsSpine hcapturesLength + have hcollapseR := VEnv.IsDefEq.appN_lamN henv.ordered + hrhsTel hrhsBody hrhsSpine hcapturesLength + have hregisteredRule : env.IsDefEq U Γ + ((view.generation.rule 0 view.constructor).lhs.instL pLevels) + ((view.generation.rule 0 view.constructor).rhs.instL pLevels) + ((view.generation.rule 0 view.constructor).type.instL pLevels) := + .extra hregistered hpLevelsWF hpLevelsLength + have happlied := VEnv.IsDefEq.appN_congr hregisteredRule hcaps + rw [show (view.generation.rule 0 view.constructor).lhs = + VExpr.lamN binders lhsBody from rfl, + show (view.generation.rule 0 view.constructor).rhs = + VExpr.lamN binders rhsBody from rfl, + VExpr.instL_lamN] at happlied + simp only [VExpr.instL_lamN] at happlied + have hiotaBodies : env.IsDefEqU U Γ + (VExpr.instRev (lhsBody.instL pLevels) + (params ++ [code.typeFn, code.minor] ++ fields)) + (VExpr.instRev (rhsBody.instL pLevels) + (params ++ [code.typeFn, code.minor] ++ fields)) := + VEnv.IsDefEqU.trans henv hΓ ⟨_, hcollapseL.symm⟩ + (VEnv.IsDefEqU.trans henv hΓ ⟨_, happlied⟩ ⟨_, hcollapseR⟩) + have hconstructorMem : view.constructor ∈ + view.generation.block.ctorPairs := by + simp [view.constructor_eq] + have hresultIndices : view.constructor.view.resultIndices = [] := by + apply List.length_eq_zero_iff.1 + rw [S.viewResultIndices_length hconstructorMem] + simp [view.checked_indices_eq] + have hfieldsLengthRaw : fields.length = m := by + exact hfieldsLength.trans (hspecializedLength.trans hBsLength.symm) + have hprefixLength : + (params ++ [code.typeFn, code.minor]).length = view.nparams + 2 := by + simp [hparamsLength] + have hcapturesLength' : + (params ++ [code.typeFn, code.minor] ++ fields).length = + view.nparams + 2 + m := by + simp [hparamsLength, hfieldsLengthRaw] + omega + have hsegCommon : + (VExpr.bvarRevRange m (view.nparams + 2)).map + (VExpr.instRev · + (params ++ [code.typeFn, code.minor] ++ fields)) = + params ++ [code.typeFn, code.minor] := by + have h := VExpr.map_instRev_bvarRevRange_seg + (params ++ [code.typeFn, code.minor] ++ fields) + (view.nparams + 2) m (by rw [hcapturesLength']; omega) + rw [← hparamsLength] at h ⊢ + rw [show (params ++ [code.typeFn, code.minor] ++ fields).length - + m - (params.length + 2) = 0 by + simp only [List.length_append, List.length_cons, List.length_nil] + rw [hfieldsLengthRaw] + omega, + List.drop_zero] at h + rw [List.take_append, + show params.length + 2 = + (params ++ [code.typeFn, code.minor]).length by simp, + List.take_length] at h + simpa using h + have hsegParams : + (VExpr.bvarRevRange (m + 2) view.nparams).map + (VExpr.instRev · + (params ++ [code.typeFn, code.minor] ++ fields)) = params := by + have h := VExpr.map_instRev_bvarRevRange_seg + (params ++ [code.typeFn, code.minor] ++ fields) + view.nparams (m + 2) (by rw [hcapturesLength']; omega) + rw [← hparamsLength] at h ⊢ + rw [show (params ++ [code.typeFn, code.minor] ++ fields).length - + (m + 2) - params.length = 0 by + simp only [List.length_append, List.length_cons, List.length_nil] + rw [hfieldsLengthRaw] + omega, + List.drop_zero] at h + simpa using h + have hsegFields : + (VExpr.bvarRevRange 0 m).map + (VExpr.instRev · + (params ++ [code.typeFn, code.minor] ++ fields)) = fields := by + have h := VExpr.map_instRev_bvarRevRange_seg + (params ++ [code.typeFn, code.minor] ++ fields) m 0 + (by rw [hcapturesLength']; omega) + rw [show (params ++ [code.typeFn, code.minor] ++ fields).length - + 0 - m = view.nparams + 2 by rw [hcapturesLength']; omega, + show view.nparams + 2 = + (params ++ [code.typeFn, code.minor]).length by + exact hprefixLength.symm, + List.drop_left] at h + have htake : fields.take m = fields := + List.take_of_length_le (Nat.le_of_eq hfieldsLengthRaw) + rw [htake] at h + exact h + have hsourceLevels := VStructureView.sourceLevels_projectionLevels + view code.fieldSort levels hlevelsLength + have hrecLevels : gen.recLevels.map (VLevel.inst pLevels) = pLevels := by + exact VLevel.inst_map_id hpLevelsLength + have hrecConst : + VExpr.instRev + ((.const (.str gen.block.sourceType.name "rec") gen.recLevels : + VExpr).instL pLevels) + (params ++ [code.typeFn, code.minor] ++ fields) = + .const view.recursorName pLevels := by + rw [VExpr.instRev_closedN _ (by trivial)] + simp only [VExpr.instL] + rw [hrecLevels] + rfl + have hsegCommonL : + (VExpr.bvarRevRange m (view.nparams + 2)).map + (fun expression => VExpr.instRev (expression.instL pLevels) + (params ++ [code.typeFn, code.minor] ++ fields)) = + params ++ [code.typeFn, code.minor] := by + calc + _ = ((VExpr.bvarRevRange m (view.nparams + 2)).map + (VExpr.instL pLevels)).map + (VExpr.instRev · + (params ++ [code.typeFn, code.minor] ++ fields)) := by + rw [List.map_map] + exact List.map_congr_left fun _ _ => rfl + _ = _ := by + rw [VExpr.bvarRevRange_map_instL] + exact hsegCommon + have hsegParamsL : + (VExpr.bvarRevRange (m + 2) view.nparams).map + (fun expression => VExpr.instRev (expression.instL pLevels) + (params ++ [code.typeFn, code.minor] ++ fields)) = params := by + calc + _ = ((VExpr.bvarRevRange (m + 2) view.nparams).map + (VExpr.instL pLevels)).map + (VExpr.instRev · + (params ++ [code.typeFn, code.minor] ++ fields)) := by + rw [List.map_map] + exact List.map_congr_left fun _ _ => rfl + _ = _ := by + rw [VExpr.bvarRevRange_map_instL] + exact hsegParams + have hsegFieldsL : + (VExpr.bvarRevRange 0 m).map + (fun expression => VExpr.instRev (expression.instL pLevels) + (params ++ [code.typeFn, code.minor] ++ fields)) = fields := by + calc + _ = ((VExpr.bvarRevRange 0 m).map + (VExpr.instL pLevels)).map + (VExpr.instRev · + (params ++ [code.typeFn, code.minor] ++ fields)) := by + rw [List.map_map] + exact List.map_congr_left fun _ _ => rfl + _ = _ := by + rw [VExpr.bvarRevRange_map_instL] + exact hsegFields + have hidxRNil : idxR = [] := by + simp [idxR, VInductDecl.NormalizedCtor.resultIndicesR, + hresultIndices] + have hrecBaseShape : + VExpr.instRev (recBase.instL pLevels) + (params ++ [code.typeFn, code.minor] ++ fields) = + VExpr.appN (.const view.recursorName pLevels) + (params ++ [code.typeFn, code.minor]) := by + rw [show recBase = VExpr.appN + (.const (.str gen.block.sourceType.name "rec") gen.recLevels) + (VExpr.bvarRevRange m (view.nparams + 2)) by + unfold recBase + rw [view.constructor_eq] + rfl, + VExpr.instL_appN, VExpr.instRev_appN, hrecConst] + rw [List.map_map] + exact congrArg (VExpr.appN (.const view.recursorName pLevels)) + hsegCommonL + have hctorShape : + VExpr.instRev (ctorApp.instL pLevels) + (params ++ [code.typeFn, code.minor] ++ fields) = + VExpr.appN (.const view.constructorName levels) + (params ++ fields) := by + rw [show ctorApp = VExpr.appN + (.const view.constructorName gen.sourceLevels) + (VExpr.bvarRevRange (m + 2) view.nparams ++ + VExpr.bvarRevRange 0 m) by + unfold ctorApp + rw [view.constructor_eq] + rfl, + VExpr.instL_appN, VExpr.instRev_appN] + rw [VExpr.instRev_closedN _ (by trivial)] + simp only [VExpr.instL] + rw [hsourceLevels] + simp only [List.map_append, List.map_map, Function.comp_def] + rw [hsegParamsL, hsegFieldsL] + have hleftShape : + VExpr.instRev (lhsBody.instL pLevels) + (params ++ [code.typeFn, code.minor] ++ fields) = + VExpr.appN (.const view.recursorName pLevels) + (params ++ [code.typeFn, code.minor, + VExpr.appN (.const view.constructorName levels) + (params ++ fields)]) := by + rw [show lhsBody = VExpr.appN recBase (idxR ++ [ctorApp]) by + rfl, + VExpr.instL_appN, VExpr.instRev_appN, hrecBaseShape, hidxRNil, + List.nil_append] + simp only [List.map_cons, List.map_nil, hctorShape] + rw [← VExpr.appN_append] + simp only [List.append_assoc] + rfl + have hminorCapture : + VExpr.instRev (.bvar m) + (params ++ [code.typeFn, code.minor] ++ fields) = + code.minor := by + have h := VExpr.map_instRev_bvarRevRange_seg + (params ++ [code.typeFn, code.minor] ++ fields) 1 m + (by rw [hcapturesLength']; omega) + rw [show (params ++ [code.typeFn, code.minor] ++ fields).length - + m - 1 = params.length + 1 by + rw [hcapturesLength', hparamsLength] + omega] at h + simpa [VExpr.bvarRevRange] using h + have hrightBodyShape : + rhsBody = VExpr.appN (.bvar m) (VExpr.bvarRevRange 0 m) := by + simp [rhsBody, ihs, rs, gen, + VInductDecl.NormalizedCtor.recArgsR, view.recursive_eq, + view.constructor_eq] + have hrightShape : + VExpr.instRev (rhsBody.instL pLevels) + (params ++ [code.typeFn, code.minor] ++ fields) = + VExpr.appN code.minor fields := by + rw [hrightBodyShape, VExpr.instL_appN, + VExpr.bvarRevRange_map_instL, VExpr.instRev_appN] + simp only [VExpr.instL] + rw [hminorCapture, hsegFields] + rw [hleftShape, hrightShape] at hiotaBodies + obtain ⟨selectedType, hselectedType, -⟩ := + view.projectionCodes_get?_typeFn levels params hcode + have hidxLt : idx < (view.specializedFields levels params).length := + (List.getElem?_eq_some_iff.1 hselectedType).1 + let q := (view.specializedFields levels params).length - 1 - idx + have hqLt : q < (view.specializedFields levels params).length := by + simp only [q] + omega + have hselectedReverse : + (view.specializedFields levels params).reverse[q]? = + some selectedType := by + rw [List.getElem?_reverse hqLt, + show (view.specializedFields levels params).length - 1 - q = idx by + simp only [q] + omega, + hselectedType] + have hselectedCtx : + ((view.specializedFields levels params).reverse ++ Γ)[q]? = + some selectedType := by + rw [List.getElem?_append_left (by simpa using hqLt), + hselectedReverse] + have hminorBodyType : env.HasType U + ((view.specializedFields levels params).reverse ++ Γ) + (.bvar q) (selectedType.liftN (q + 1)) := + .bvar (Lookup.of_getElem? hselectedCtx) + have hminorSpine := hfieldsSpine.retarget hfieldsLength + (selectedType.liftN (q + 1)) + have hminorBetaRaw := VEnv.IsDefEq.appN_lamN henv.ordered + hsortTel.toOnTel hminorBodyType hminorSpine hfieldsLength + have hfieldInst : VExpr.instRev (.bvar q) fields = field := by + have h := VExpr.map_instRev_bvarRevRange_seg fields 1 q + (by rw [hfieldsLength]; exact Nat.add_one_le_iff.2 hqLt) + rw [show fields.length - q - 1 = idx by + rw [hfieldsLength] + simp only [q] + omega] at h + obtain ⟨hidxFields, hfieldGet⟩ := + List.getElem?_eq_some_iff.1 hfield + rw [List.drop_eq_getElem_cons hidxFields, hfieldGet, + List.take_succ_cons] at h + simpa [VExpr.bvarRevRange] using h + have hminorBeta : env.IsDefEqU U Γ + (VExpr.appN code.minor fields) field := by + refine ⟨VExpr.instRev (selectedType.liftN (q + 1)) fields, ?_⟩ + rw [hminorShape] + simpa only [hfieldInst] using hminorBetaRaw + exact VEnv.IsDefEqU.trans henv hΓ hprojectorToRule + (VEnv.IsDefEqU.trans henv hΓ hiotaBodies hminorBeta) + /-- Environment-indexed projection semantics. The universe and parameter spines are explicit. The major premise must have @@ -2334,6 +2861,67 @@ structure TrProj (env : VEnv) (U : Nat) (Γ : List VExpr) (.forallE (view.structureType levels params) (.app code.typeFn.lift (.bvar 0))) +/-- The projection-specific output of registered constructor-head inversion. + +This package performs no iota computation. It only aligns a constructor +normal form and one selected runtime argument with the canonical registered +view, and supplies the typed spines needed by +`projector_constructor_exact`. -/ +structure ProjectionConstructorAlignment (env : VEnv) (U : Nat) + (Γ : List VExpr) (view : VStructureView) (levels : List VLevel) + (params : List VExpr) (idx : Nat) + (code : VStructureView.ProjectionCode) + (runtimeMajor runtimeField : VExpr) where + fields : List VExpr + field : VExpr + fields_length : + fields.length = (view.specializedFields levels params).length + field_get : fields[idx]? = some field + constructorType : env.HasType U Γ + (VExpr.appN (.const view.constructorName levels) (params ++ fields)) + (view.structureType levels params) + fieldsSpine : env.SpineWF U Γ + (VExpr.forallN (view.specializedFields levels params) (.sort .zero)) + fields (.sort .zero) + captures : ∃ B, env.SpineWF U Γ + ((view.generation.rule 0 view.constructor).type.instL + (view.projectionLevels code.fieldSort levels)) + (params ++ [code.typeFn, code.minor] ++ fields) B + major_eq : env.IsDefEqU U Γ runtimeMajor + (VExpr.appN (.const view.constructorName levels) (params ++ fields)) + field_eq : env.IsDefEqU U Γ runtimeField field + +/-- Consume registered-head alignment with the separately proved exact iota +theorem. This keeps the transitional injectivity boundary from hiding the +projection computation itself. -/ +theorem TrProj.projector_constructor_aligned + (self : VEnv.TrProj env U Γ view levels params idx major result) + (henv : env.WF) (hΓ : OnCtx Γ (env.IsType U)) + {code : VStructureView.ProjectionCode} + (hcode : (view.projectionCodes levels params)[idx]? = some code) + (hprojector : env.HasType U Γ code.projector + (.forallE (view.structureType levels params) + (.app code.typeFn.lift (.bvar 0)))) + {runtimeMajor runtimeField : VExpr} + (alignment : ProjectionConstructorAlignment env U Γ view levels + params idx code runtimeMajor runtimeField) : + env.IsDefEqU U Γ (.app code.projector runtimeMajor) runtimeField := by + have hmajorEq := alignment.major_eq.of_r henv hΓ + alignment.constructorType + have hmajorCongr : env.IsDefEqU U Γ + (.app code.projector runtimeMajor) + (.app code.projector + (VExpr.appN (.const view.constructorName levels) + (params ++ alignment.fields))) := + ⟨_, hprojector.appDF hmajorEq⟩ + obtain ⟨captureType, hcaptures⟩ := alignment.captures + have hiota := self.viewWF.projector_constructor_exact henv hΓ + self.levelsWF self.levels_length self.params_length self.paramsSpine + hcode hprojector alignment.fields_length alignment.field_get + alignment.constructorType alignment.fieldsSpine hcaptures + exact VEnv.IsDefEqU.trans henv hΓ hmajorCongr + (VEnv.IsDefEqU.trans henv hΓ hiota alignment.field_eq.symm) + theorem TrProj.project_eq (self : VEnv.TrProj env U Γ view levels params idx major result) : VStructureView.project? view levels params idx major = some result := by @@ -2521,15 +3109,19 @@ theorem TrProj.instL {ls : List VLevel} /-- The registered-structure constant-head inversion boundary. -The two conclusions are the projection-specific eliminators supplied by +The three 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 +recovers an instantiation below the inserted context; definitionally equal majors recover the same registered view/instantiation strongly enough for the -generated projector programs to be definitionally equal. 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. -/ +generated projector programs to be definitionally equal; and a runtime +constructor head is aligned with the registered constructor and selected +field. The last conclusion deliberately provides only typed alignment—the +iota step remains the proved `projector_constructor_exact` theorem. + +Its eventual proof uses `IsDefEqU.weakN_iff` together with injectivity of +registered inductive heads. Keeping the boundary in Theory makes the +temporary L4L-16/17 dependency explicit instead of leaving Verify's +structural laws as local holes. -/ structure RegisteredStructureHeadInversion (env : VEnv) : Prop where weak'_inv : ∀ {U : Nat} {Γ Γ' : List VExpr} {view : VStructureView} @@ -2550,6 +3142,22 @@ structure RegisteredStructureHeadInversion (env : VEnv) : Prop where env.TrProj U Γ₂ view₂ levels₂ params₂ idx major₂ result₂ → env.IsDefEqU U Γ₁ major₁ major₂ → env.IsDefEqU U Γ₁ result₁ result₂ + constructor_inv : + ∀ {U : Nat} {Γ : List VExpr} {view : VStructureView} + {levels : List VLevel} {params : List VExpr} {idx : Nat} + {major result : VExpr} {code : VStructureView.ProjectionCode} + {runtimeMajor runtimeField : VExpr} + {constructorName : Name} {constructorLevels : List VLevel} + {constructorArgs : List VExpr}, + OnCtx Γ (env.IsType U) → + env.TrProj U Γ view levels params idx major result → + (view.projectionCodes levels params)[idx]? = some code → + runtimeMajor = VExpr.appN + (.const constructorName constructorLevels) constructorArgs → + constructorArgs[view.nparams + idx]? = some runtimeField → + env.IsDefEqU U Γ runtimeMajor major → + Nonempty (ProjectionConstructorAlignment env U Γ view levels params idx + code runtimeMajor runtimeField) /-- Public Tier-R registered-head inversion statement. L4L-16/17 discharge the underlying constant-head theorem; projection structural laws consume only diff --git a/Lean4Lean/Theory/Typing/InductiveLemmas.lean b/Lean4Lean/Theory/Typing/InductiveLemmas.lean index ce2f768..3984fce 100644 --- a/Lean4Lean/Theory/Typing/InductiveLemmas.lean +++ b/Lean4Lean/Theory/Typing/InductiveLemmas.lean @@ -1704,8 +1704,17 @@ theorem SpineWF.hasType_appN {env : VEnv} {U : Nat} {Γ : List VExpr} : induction es with intro A B f h hf | nil => exact h ▸ hf | cons e es ih => - obtain ⟨A₁, A₂, rfl, he, hrest⟩ := h - exact ih hrest (hf.app he) + obtain ⟨A₁, A₂, rfl, he, hrest⟩ := h + exact ih hrest (hf.app he) + +/-- Concatenate two adjacent, well-typed application spines. -/ +theorem SpineWF.append {env : VEnv} {U : Nat} {Γ : List VExpr} : + ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ A es B → + ∀ {es' : List VExpr} {C : VExpr}, env.SpineWF U Γ B es' C → + env.SpineWF U Γ A (es ++ es') C + | [], _, _, h, _, _, h' => h ▸ h' + | _ :: _, _, _, ⟨A₁, A₂, rfl, he, hrest⟩, _, _, h' => + ⟨A₁, A₂, rfl, he, SpineWF.append hrest h'⟩ /-- Extend a well-typed application spine by one final argument. -/ theorem SpineWF.snoc {env : VEnv} {U : Nat} {Γ : List VExpr} {e D C : VExpr} : From e8ccc70f6df22f18a0be1aaae820bd38deae3aa6 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Tue, 11 Aug 2026 09:20:35 -0400 Subject: [PATCH 24/27] verify: certify primitive projection reduction --- Lean4Lean/Audit/SorryFrontier.lean | 1 - Lean4Lean/Theory/Projection.lean | 33 ++-- .../ConstructorValidityReplay.lean | 78 +++++++--- .../Environment/IndexedVecSemanticReplay.lean | 147 +++++++++++++++++- .../Verify/Environment/InductiveFixtures.lean | 50 +++--- Lean4Lean/Verify/TypeChecker/Basic.lean | 43 ++++- Lean4Lean/Verify/TypeChecker/InferType.lean | 6 +- Lean4Lean/Verify/TypeChecker/WHNF.lean | 98 +++++++++++- Lean4Lean/Verify/Typing/Lemmas.lean | 32 ++++ 9 files changed, 408 insertions(+), 80 deletions(-) diff --git a/Lean4Lean/Audit/SorryFrontier.lean b/Lean4Lean/Audit/SorryFrontier.lean index f3c9906..8cc8036 100644 --- a/Lean4Lean/Audit/SorryFrontier.lean +++ b/Lean4Lean/Audit/SorryFrontier.lean @@ -137,7 +137,6 @@ private def allowlist : Array Lean.Name := #[ -- formalization line, 2026-08-05/07, and left the frontier.) `Lean4Lean.addDecl.WF, `Lean4Lean.TypeChecker.Inner.reduceRecursor.WF, - `Lean4Lean.TypeChecker.Inner.reduceProj.WF, `Lean4Lean.TypeChecker.Inner.tryEtaStructCore.WF, `Lean4Lean.TypeChecker.Inner.isDefEqUnitLike.WF, -- Tier R — research-grade metatheory (upstream-driven, not scheduled) diff --git a/Lean4Lean/Theory/Projection.lean b/Lean4Lean/Theory/Projection.lean index fef14e2..8c27a57 100644 --- a/Lean4Lean/Theory/Projection.lean +++ b/Lean4Lean/Theory/Projection.lean @@ -2871,7 +2871,8 @@ structure ProjectionConstructorAlignment (env : VEnv) (U : Nat) (Γ : List VExpr) (view : VStructureView) (levels : List VLevel) (params : List VExpr) (idx : Nat) (code : VStructureView.ProjectionCode) - (runtimeMajor runtimeField : VExpr) where + (runtimeConstructorName : Name) (runtimeMajor runtimeField : VExpr) where + constructor_name_eq : runtimeConstructorName = view.constructorName fields : List VExpr field : VExpr fields_length : @@ -2903,8 +2904,9 @@ theorem TrProj.projector_constructor_aligned (.forallE (view.structureType levels params) (.app code.typeFn.lift (.bvar 0)))) {runtimeMajor runtimeField : VExpr} - (alignment : ProjectionConstructorAlignment env U Γ view levels - params idx code runtimeMajor runtimeField) : + {runtimeConstructorName : Name} + (alignment : ProjectionConstructorAlignment env U Γ view levels params idx + code runtimeConstructorName runtimeMajor runtimeField) : env.IsDefEqU U Γ (.app code.projector runtimeMajor) runtimeField := by have hmajorEq := alignment.major_eq.of_r henv hΓ alignment.constructorType @@ -3109,14 +3111,15 @@ theorem TrProj.instL {ls : List VLevel} /-- The registered-structure constant-head inversion boundary. -The three conclusions are the projection-specific eliminators supplied by +The four conclusions are the projection-specific eliminators supplied by constant-head injectivity: a type assigned to a syntactically weakened major recovers an instantiation below the inserted context; definitionally equal majors recover the same registered view/instantiation strongly enough for the -generated projector programs to be definitionally equal; and a runtime -constructor head is aligned with the registered constructor and selected -field. The last conclusion deliberately provides only typed alignment—the -iota step remains the proved `projector_constructor_exact` theorem. +generated projector programs to be definitionally equal; a runtime +constructor head recovers the registered constructor name; and that head plus +one selected argument is aligned with the registered constructor and field. +The last conclusion deliberately provides only typed alignment—the iota step +remains the proved `projector_constructor_exact` theorem. Its eventual proof uses `IsDefEqU.weakN_iff` together with injectivity of registered inductive heads. Keeping the boundary in Theory makes the @@ -3142,6 +3145,18 @@ structure RegisteredStructureHeadInversion (env : VEnv) : Prop where env.TrProj U Γ₂ view₂ levels₂ params₂ idx major₂ result₂ → env.IsDefEqU U Γ₁ major₁ major₂ → env.IsDefEqU U Γ₁ result₁ result₂ + constructor_name_inv : + ∀ {U : Nat} {Γ : List VExpr} {view : VStructureView} + {levels : List VLevel} {params : List VExpr} {idx : Nat} + {major result runtimeMajor : VExpr} + {constructorName : Name} {constructorLevels : List VLevel} + {constructorArgs : List VExpr}, + OnCtx Γ (env.IsType U) → + env.TrProj U Γ view levels params idx major result → + runtimeMajor = VExpr.appN + (.const constructorName constructorLevels) constructorArgs → + env.IsDefEqU U Γ runtimeMajor major → + constructorName = view.constructorName constructor_inv : ∀ {U : Nat} {Γ : List VExpr} {view : VStructureView} {levels : List VLevel} {params : List VExpr} {idx : Nat} @@ -3157,7 +3172,7 @@ structure RegisteredStructureHeadInversion (env : VEnv) : Prop where constructorArgs[view.nparams + idx]? = some runtimeField → env.IsDefEqU U Γ runtimeMajor major → Nonempty (ProjectionConstructorAlignment env U Γ view levels params idx - code runtimeMajor runtimeField) + code constructorName runtimeMajor runtimeField) /-- Public Tier-R registered-head inversion statement. L4L-16/17 discharge the underlying constant-head theorem; projection structural laws consume only diff --git a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean index 58606b7..5c2afeb 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean @@ -79,12 +79,10 @@ 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 + projectionReady := ProjectionReady.of_no_ctorInfo <| by + intro name info h + change ({} : ConstMap).find?' name = some (.ctorInfo info) at h + rw [SMap.WF.find?'_eq_find? SMap.WF.empty] at h simp [SMap.find?] at h theorem prbEmptySafePrimitives : @@ -105,12 +103,10 @@ 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 + projectionReady := ProjectionReady.of_no_ctorInfo <| by + intro name info h + change ({} : ConstMap).find?' name = some (.ctorInfo info) at h + rw [SMap.WF.find?'_eq_find? SMap.WF.empty] at h simp [SMap.find?] at h def cvmExecutionResult := @@ -632,6 +628,29 @@ theorem cvmConstructorContext_noProjectionReady (name : Name) : (s := ({} : ConstMap)) SMap.WF.empty] simp [hName, SMap.find?] +theorem cvmConstructorContext_noCtorInfo (name : Name) + (info : ConstructorVal) : + cvmConstructorContext.env.find? name ≠ some (.ctorInfo info) := by + intro h + have hConstants : + cvmConstructorContext.env.constants = + ({} : ConstMap).insert constructorValidityMatrixType.name + cvmDeclaredInfo := by + simp only [cvmConstructorContext] + rw [cvmFamilyMap_add, cvmTerminalEnv_eq] + rfl + have hMap : + (({} : ConstMap).insert constructorValidityMatrixType.name + cvmDeclaredInfo).WF := + SMap.WF.empty.insert _ _ (by simp [SMap.find?]) + change cvmConstructorContext.env.constants.find?' name = + some (.ctorInfo info) at h + rw [hConstants, hMap.find?'_eq_find?, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] at h + split at h + · cases h + · simp [SMap.find?] at h + def cvmTypeEnv : VEnv := (VEnv.empty.addConst constructorValidityMatrixType.name constructorValidityMatrixType.toVConstant).get! @@ -695,10 +714,8 @@ def cvmFamilyStage : validation := cvmFamilyValidationRun typeEnv := cvmTypeEnv addInduct := cvmAddType - projectionReady := by - intro name _ _ h - rw [cvmConstructorContext_noProjectionReady] at h - contradiction + projectionReady := ProjectionReady.of_no_ctorInfo + cvmConstructorContext_noCtorInfo family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := by @@ -1893,6 +1910,29 @@ theorem prbConstructorContext_noProjectionReady (name : Name) : (s := ({} : ConstMap)) SMap.WF.empty] simp [hName, SMap.find?] +theorem prbConstructorContext_noCtorInfo (name : Name) + (info : ConstructorVal) : + prbConstructorContext.env.find? name ≠ some (.ctorInfo info) := by + intro h + have hConstants : + prbConstructorContext.env.constants = + ({} : ConstMap).insert propRecursiveBoundaryType.name + prbDeclaredInfo := by + simp only [prbConstructorContext] + rw [prbFamilyMap_add, prbTerminalEnv_eq] + rfl + have hMap : + (({} : ConstMap).insert propRecursiveBoundaryType.name + prbDeclaredInfo).WF := + SMap.WF.empty.insert _ _ (by simp [SMap.find?]) + change prbConstructorContext.env.constants.find?' name = + some (.ctorInfo info) at h + rw [hConstants, hMap.find?'_eq_find?, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] at h + split at h + · cases h + · simp [SMap.find?] at h + theorem prbDeclaredInfo_tr : TrConstVal .safe VEnv.empty prbDeclaredInfo propRecursiveBoundaryType.toVConstVal := by @@ -1946,10 +1986,8 @@ def prbFamilyStage : validation := prbFamilyValidationRun typeEnv := prbTypeEnv addInduct := prbAddType - projectionReady := by - intro name _ _ h - rw [prbConstructorContext_noProjectionReady] at h - contradiction + projectionReady := ProjectionReady.of_no_ctorInfo + prbConstructorContext_noCtorInfo family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := by diff --git a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean index 48c9069..f32d258 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean @@ -157,6 +157,118 @@ theorem indexedVecTypeEnv_noProjectionReady (name : Name) : simp [hVec, hRec, hSucc, hZero, SMap.find?, natInfo] · simp [hVec, hRec, hSucc, hZero, hNat, SMap.find?] +private theorem addConst_constants {env env' : VEnv} {name : Name} + {ci : VConstant} (hadd : env.addConst name ci = some env') (query : Name) : + env'.constants query = + if name = query then some ci else env.constants query := by + unfold VEnv.addConst at hadd + split at hadd <;> cases hadd + rfl + +private theorem structureView_nparams_eq_zero_of_nat + {env : VEnv} {view : VStructureView} (hview : view.WF env) + (hname : ``Nat = view.name) + (hNat : env.constants ``Nat = some natType.toVConstant) : + view.nparams = 0 := by + have hfamily := hview.family + rw [← hname, hNat] at hfamily + have hsourceType : view.generation.block.sourceType.type = natType.type := + congrArg VConstant.type (Option.some.inj hfamily).symm + have hshape := view.generation.shape_eq + simp only [VInductDecl.NormalizedChecked.generationShape, Bool.and_eq_true, + beq_iff_eq] at hshape + have hrawParamsLength := hshape.1.1.1.1.1 + have hNatType : natType.type = .sort (.succ .zero) := rfl + rw [VInductDecl.NormalizedChecked.rawParams, hsourceType, + hNatType] at hrawParamsLength + cases hnp : view.source.nparams with + | zero => simpa using hnp + | succ _ => + rw [hnp] at hrawParamsLength + simp [VExpr.telN] at hrawParamsLength + +private theorem natFinalEnv_structureView_nparams_eq_zero + {view : VStructureView} (hview : view.WF natFinalEnv) : + view.nparams = 0 := by + have hrec := hview.recursor + change natRecEnv.constants view.recursorName = + some view.generation.recursor at hrec + rw [addConst_constants + (show natCtorEnv.addConst ``Nat.rec + (VInductDecl.recConst 0 ``Nat 0 natType) = some natRecEnv from rfl), + addConst_constants + (show natZeroEnv.addConst natType.ctors[1].name + natType.ctors[1].toVConstant = some natCtorEnv from rfl), + addConst_constants + (show natTypeEnv.addConst natType.ctors[0].name + natType.ctors[0].toVConstant = some natZeroEnv from rfl), + addConst_constants + (show VEnv.empty.addConst natType.name natType.toVConstant = + some natTypeEnv from rfl)] at hrec + have hNatName : natType.name = ``Nat := rfl + have hZeroName : natType.ctors[0].name = ``Nat.zero := rfl + have hSuccName : natType.ctors[1].name = ``Nat.succ := rfl + rw [hNatName, hZeroName, hSuccName] at hrec + simp [VEnv.empty, VStructureView.recursorName] at hrec + exact structureView_nparams_eq_zero_of_nat hview hrec.1 + nat_type_env_lookup + +private theorem indexedVecTypeEnv_structureView_nparams_eq_zero + {view : VStructureView} (hview : view.WF indexedVecTypeEnv) : + view.nparams = 0 := by + have hrec := hview.recursor + rw [addConst_constants + (show natFinalEnv.addConst indexedVecType.name + indexedVecType.toVConstant = some indexedVecTypeEnv from rfl)] at hrec + change (if indexedVecType.name = view.recursorName then + some indexedVecType.toVConstant else + natRecEnv.constants view.recursorName) = + some view.generation.recursor at hrec + rw [addConst_constants + (show natCtorEnv.addConst ``Nat.rec + (VInductDecl.recConst 0 ``Nat 0 natType) = some natRecEnv from rfl), + addConst_constants + (show natZeroEnv.addConst natType.ctors[1].name + natType.ctors[1].toVConstant = some natCtorEnv from rfl), + addConst_constants + (show natTypeEnv.addConst natType.ctors[0].name + natType.ctors[0].toVConstant = some natZeroEnv from rfl), + addConst_constants + (show VEnv.empty.addConst natType.name natType.toVConstant = + some natTypeEnv from rfl)] at hrec + have hVecName : indexedVecType.name = ``IndexedVec := rfl + have hNatName : natType.name = ``Nat := rfl + have hZeroName : natType.ctors[0].name = ``Nat.zero := rfl + have hSuccName : natType.ctors[1].name = ``Nat.succ := rfl + rw [hVecName, hNatName, hZeroName, hSuccName] at hrec + simp [VEnv.empty, VStructureView.recursorName] at hrec + exact structureView_nparams_eq_zero_of_nat hview hrec.1 rfl + +private theorem natMap_constructor_numParams + {view : VStructureView} {info : ConstructorVal} + (hzero : view.nparams = 0) + (hfind : natMap.find? view.constructorName = some (.ctorInfo info)) : + info.numParams = view.nparams := by + rw [natMap, natCtorMap_wf.find?_insert] at hfind + split at hfind + · cases hfind + · rw [natCtorMap, natZeroMap_wf.find?_insert] at hfind + split at hfind + · simp [natSuccInfo] at hfind + cases hfind + exact hzero.symm + · rw [natZeroMap, natTypeMap_wf.find?_insert] at hfind + split at hfind + · simp [natZeroInfo] at hfind + cases hfind + exact hzero.symm + · rw [natTypeMap, + SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] + at hfind + split at hfind + · cases hfind + · simp [SMap.find?] at hfind + def indexedVecSemanticNatVEnvs : VEnvs where venv _ := natFinalEnv @@ -168,10 +280,18 @@ theorem indexedVecSemanticNatVEnvsWF : indexedVecSemanticNatVEnvs.WF indexedVecK hasPrimitives := indexedVecSemanticNatHasPrimitives safePrimitives := indexedVecSemanticNatSafePrimitives mono := fun _ => .rfl - projectionReady := by - intro _ name _ _ h - rw [indexedVecKernelEnv_noProjectionReady] at h - contradiction + projectionReady := { + infer := by + intro name _info _hfind hready + rw [indexedVecKernelEnv_noProjectionReady] at hready + contradiction + constructorNumParams := by + intro view info hview hfind + change natMap.find?' view.constructorName = + some (.ctorInfo info) at hfind + rw [natMap_wf.find?'_eq_find?] at hfind + exact natMap_constructor_numParams + (natFinalEnv_structureView_nparams_eq_zero hview) hfind } def indexedVecSemanticAddType : AddInductConstant .induct natMap natFinalEnv @@ -230,10 +350,21 @@ def indexedVecFamilyStage : validation := indexedVecFamilyValidationRun typeEnv := indexedVecTypeEnv addInduct := indexedVecSemanticAddType - projectionReady := by - intro name _ _ h - rw [indexedVecTypeEnv_noProjectionReady] at h - contradiction + projectionReady := { + infer := by + intro name _info _hfind hready + rw [indexedVecTypeEnv_noProjectionReady] at hready + contradiction + constructorNumParams := by + intro view info hview hfind + change indexedVecTypeMap.find?' view.constructorName = + some (.ctorInfo info) at hfind + rw [indexedVecTypeMap_wf.find?'_eq_find?, indexedVecTypeMap, + natMap_wf.find?_insert] at hfind + split at hfind + · cases hfind + · exact natMap_constructor_numParams + (indexedVecTypeEnv_structureView_nparams_eq_zero hview) hfind } family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := rfl diff --git a/Lean4Lean/Verify/Environment/InductiveFixtures.lean b/Lean4Lean/Verify/Environment/InductiveFixtures.lean index 2fc2d0e..04bfe71 100644 --- a/Lean4Lean/Verify/Environment/InductiveFixtures.lean +++ b/Lean4Lean/Verify/Environment/InductiveFixtures.lean @@ -2569,11 +2569,10 @@ 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 + projectionReady := ProjectionReady.of_no_ctorInfo <| by + intro name _info h + change outParamMap.find?' name = some (.ctorInfo _info) at h + rw [outParamMap_wf.find?'_eq_find?] at h simp only [outParamMap, SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] at h simp [SMap.find?, annotationOutParamInfo] at h @@ -3436,12 +3435,10 @@ 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 + projectionReady := ProjectionReady.of_no_ctorInfo <| by + intro name _info h + change typeFamilyAliasMap.find?' name = some (.ctorInfo _info) at h + rw [typeFamilyAliasMap_wf.find?'_eq_find?] at h simp only [typeFamilyAliasMap, SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] at h simp [SMap.find?, typeFamilyAliasInfo] at h @@ -3559,12 +3556,10 @@ 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 + projectionReady := ProjectionReady.of_no_ctorInfo <| by + intro name _info h + change aliasRecTypeMap.find?' name = some (.ctorInfo _info) at h + rw [aliasRecTypeMap_wf.find?'_eq_find?] at h simp only [aliasRecTypeMap, recAliasMap_wf.find?_insert] at h simp only [recAliasMap, SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] at h @@ -7470,13 +7465,10 @@ 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 + projectionReady := ProjectionReady.of_no_ctorInfo <| by + intro name _info h + change aliasFormerTypeMap.find?' name = some (.ctorInfo _info) at h + rw [aliasFormerTypeMap_wf.find?'_eq_find?] at h simp only [aliasFormerTypeMap, typeFamilyAliasMap_wf.find?_insert] at h simp only [typeFamilyAliasMap, SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] at h @@ -8428,12 +8420,10 @@ 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 + projectionReady := ProjectionReady.of_no_ctorInfo <| by + intro name _info h + change annotatedPiTypeMap.find?' name = some (.ctorInfo _info) at h + rw [annotatedPiTypeMap_wf.find?'_eq_find?] at h simp only [annotatedPiTypeMap, outParamMap_wf.find?_insert] at h simp only [outParamMap, SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] at h diff --git a/Lean4Lean/Verify/TypeChecker/Basic.lean b/Lean4Lean/Verify/TypeChecker/Basic.lean index 629d8b8..a05c736 100644 --- a/Lean4Lean/Verify/TypeChecker/Basic.lean +++ b/Lean4Lean/Verify/TypeChecker/Basic.lean @@ -123,14 +123,38 @@ structure ProjectionArtifact (env : Environment) (name : Name) 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) → +/-- Host/Theory coherence needed by primitive projections. + +Inference obtains one complete registered artifact from ready family +metadata. Reduction additionally relies on the positional host fact that a +constructor's cached `numParams` agrees with the registered Theory view; +ordinary constant translation checks the constructor type but does not +identify which leading binders the host metadata classifies as parameters. -/ +structure ProjectionReady (env : Environment) (venv : VEnv) : Prop where + infer : ∀ name info, env.find? name = some (.inductInfo info) → env.isProjectionReadyStructure name = true → Nonempty (ProjectionArtifact env name info venv) + constructorNumParams : ∀ (view : VStructureView) (info : ConstructorVal), + view.WF venv → + env.find? view.constructorName = some (.ctorInfo info) → + info.numParams = view.nparams + +/-- Environments which contain no constructor metadata satisfy projection +readiness vacuously. This is the common staging case for validation fixtures: +families may already be present, but their constructors have not been +installed yet. -/ +theorem ProjectionReady.of_no_ctorInfo + (hnoCtor : ∀ name info, + env.find? name ≠ some (.ctorInfo info)) : + ProjectionReady env venv where + infer name _info hfind hready := by + have hfalse := + Kernel.Environment.isProjectionReadyStructure_false_of_no_ctorInfo + hfind hnoCtor + rw [hfalse] at hready + contradiction + constructorNumParams _view info _hview hfind := + (hnoCtor _ info hfind).elim namespace TypeChecker @@ -879,6 +903,13 @@ theorem MLCtx.WF.mkLambda_eq {c : MLCtx} (wf : c.WF env Us) (n hn) namespace Inner +/-- A successful host-environment lookup returns exactly the constant found +at the requested name. Kept in the common checker layer so both inference +and WHNF reduction can consume the same lookup certificate. -/ +theorem envGet.WF {c : VContext} : + (c.env.get name).WF fun ci => c.env.find? name = some ci := by + simp [Environment.get]; split <;> [refine .pure ‹_›; exact .throw] + theorem whnf.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : RecM.WF c s (whnf e) fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := fun _ wf => wf.whnf he diff --git a/Lean4Lean/Verify/TypeChecker/InferType.lean b/Lean4Lean/Verify/TypeChecker/InferType.lean index 075338e..0ca0e45 100644 --- a/Lean4Lean/Verify/TypeChecker/InferType.lean +++ b/Lean4Lean/Verify/TypeChecker/InferType.lean @@ -40,10 +40,6 @@ theorem inferFVar.WF {c : VContext} : c.trlctx.find?_of_mem c.Ewf (List.mem_of_find?_eq_some h) exact ⟨_, _, h2, .fvar h1, h3, c.Δwf.find?_wf c.Ewf h1⟩ -theorem envGet.WF {c : VContext} : - (c.env.get name).WF fun ci => c.env.find? name = some ci := by - simp [Environment.get]; split <;> [refine .pure ‹_›; exact .throw] - theorem inferConstant.WF {c : VContext} (H : ∀ l ∈ ls, l.hasMVar' = false) (hinf : inferOnly = true → ∃ e', c.TrExprS (.const name ls) e') : @@ -639,7 +635,7 @@ theorem inferProj.WF · exact invalidProj.WF · rename_i hargs obtain ⟨artifact⟩ := - c.projectionReady familyName info hfind hready + c.projectionReady.infer familyName info hfind hready have hhead := hstack.tr rw [hfamilyShape] at hhead let .const (us' := levels') hfamilyConst hlevelsMap diff --git a/Lean4Lean/Verify/TypeChecker/WHNF.lean b/Lean4Lean/Verify/TypeChecker/WHNF.lean index 9815dcd..5e35666 100644 --- a/Lean4Lean/Verify/TypeChecker/WHNF.lean +++ b/Lean4Lean/Verify/TypeChecker/WHNF.lean @@ -24,7 +24,103 @@ theorem whnfFVar.WF {c : VContext} {s : VState} (he : c.TrExprS (.fvar fv) e') : theorem reduceProj.WF {c : VContext} {s : VState} (he : c.TrExprS (.proj n i e) e') : RecM.WF c s (reduceProj i e cheapRec cheapProj) fun oe _ => - ∀ e₁, oe = some e₁ → c.FVarsBelow (.proj n i e) e₁ ∧ c.TrExpr e₁ e' := sorry + ∀ e₁, oe = some e₁ → c.FVarsBelow (.proj n i e) e₁ ∧ c.TrExpr e₁ e' := by + let .proj (e' := major) heMajor hproj := he + obtain ⟨view, levels, params, _hviewName, hsemantic⟩ := hproj + obtain ⟨code, hcode, hresult, hprojector⟩ := hsemantic.program + have finish {normal : Expr} {state : VState} + (hbelow : c.FVarsBelow e normal) + (htr : c.TrExpr normal major) : + RecM.WF c state + (normal.withApp fun mk args => do + let .const mkC _ := mk | return none + let env ← getEnv + let .ctorInfo mkInfo ← env.get mkC | return none + return args[mkInfo.numParams + i]?) (fun oe _ => + ∀ e₁, oe = some e₁ → + c.FVarsBelow (.proj n i e) e₁ ∧ c.TrExpr e₁ e') := by + rw [Expr.withApp_eq] + split + · rename_i mkC hostLevels hheadShape + obtain ⟨runtimeMajor, hnormalS, hnormalEq⟩ := htr + have ⟨runtimeHead, hstack⟩ := AppStack.build + (normal.mkAppList_getAppArgsList ▸ hnormalS) + have hhead := hstack.tr + rw [hheadShape] at hhead + let .const (us' := runtimeLevels) _hconst _hlevelsMap + _hlevelsLength := hhead + obtain ⟨runtimeArgs, hargsTr, hfull⟩ := hstack.argsTranslation + rw [normal.mkAppList_getAppArgsList] at hfull + have hfullEq := hfull.uniq c.Ewf (.refl c.Ewf c.Δwf) hnormalS + have hmajorEq := hfullEq.trans c.Ewf c.Δwf hnormalEq + refine .getEnv ?_ + refine (M.WF.liftExcept envGet.WF).lift.bind fun _ci _ _ hfind => ?_ + split + · rename_i mkInfo + refine .pure ?_ + intro selected hselected + have hconstructorName : mkC = view.constructorName := + c.Ewf.registeredStructureHeadInversion.constructor_name_inv + c.Δwf hsemantic rfl hmajorEq + have hnumParams : mkInfo.numParams = view.nparams := + c.projectionReady.constructorNumParams view mkInfo + hsemantic.viewWF (by + rw [← hconstructorName] + exact hfind) + have hselectedList : + normal.getAppArgsList[mkInfo.numParams + i]? = some selected := by + rw [← Expr.getAppArgs_toList, Array.getElem?_toList] + exact hselected + obtain ⟨runtimeField, hfieldGet, hfieldTr⟩ := + Lean4Lean.List.Forall₂.getElem?_left hargsTr hselectedList + have hfieldGetCanonical : + runtimeArgs[view.nparams + i]? = some runtimeField := by + rw [← hnumParams] + exact hfieldGet + obtain ⟨alignment⟩ := + c.Ewf.registeredStructureHeadInversion.constructor_inv + c.Δwf hsemantic hcode rfl hfieldGetCanonical hmajorEq + have hiota := hsemantic.projector_constructor_aligned + c.Ewf c.Δwf hcode hprojector alignment + have hmajorTyped := hmajorEq.of_r c.Ewf c.Δwf hsemantic.majorType + have hprojectorCongr : c.IsDefEqU + (.app code.projector + (VExpr.appN (.const mkC runtimeLevels) runtimeArgs)) + (.app code.projector major) := + ⟨_, hprojector.appDF hmajorTyped⟩ + have hfieldTarget : c.IsDefEqU runtimeField e' := by + rw [hresult] + exact hiota.symm.trans c.Ewf c.Δwf hprojectorCongr + refine ⟨?_, ⟨runtimeField, hfieldTr, hfieldTarget⟩⟩ + intro P hP hprojFv + exact FVarsIn.getAppArgsList (hbelow P hP hprojFv) + (List.mem_of_getElem? hselectedList) + · exact .pure nofun + · exact .pure nofun + unfold reduceProj + split + · refine (whnfCore.WF heMajor).bind fun normal _ _ hnormal => ?_ + split + · obtain ⟨literalMajor, hliteralS, hliteralEq⟩ := hnormal.2 + let .lit _ hconstructorS := hliteralS + refine (whnf.WF hconstructorS).bind fun expanded _ _ hexpanded => ?_ + have hbelow' : c.FVarsBelow e expanded := + FVarsBelow.trans (fun _ _ _ => FVarsIn.strLitToConstructor) + hexpanded.1 + have htr' := hexpanded.2.defeq c.Ewf c.Δwf hliteralEq + exact RecM.WF.pureBind (finish hbelow' htr') + · exact RecM.WF.pureBind (finish hnormal.1 hnormal.2) + · refine (whnf.WF heMajor).bind fun normal _ _ hnormal => ?_ + split + · obtain ⟨literalMajor, hliteralS, hliteralEq⟩ := hnormal.2 + let .lit _ hconstructorS := hliteralS + refine (whnf.WF hconstructorS).bind fun expanded _ _ hexpanded => ?_ + have hbelow' : c.FVarsBelow e expanded := + FVarsBelow.trans (fun _ _ _ => FVarsIn.strLitToConstructor) + hexpanded.1 + have htr' := hexpanded.2.defeq c.Ewf c.Δwf hliteralEq + exact RecM.WF.pureBind (finish hbelow' htr') + · exact RecM.WF.pureBind (finish hnormal.1 hnormal.2) theorem whnfCore'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : RecM.WF c s (whnfCore' e cheapRec cheapProj) fun e₁ _ => diff --git a/Lean4Lean/Verify/Typing/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean index f982a9a..178a808 100644 --- a/Lean4Lean/Verify/Typing/Lemmas.lean +++ b/Lean4Lean/Verify/Typing/Lemmas.lean @@ -2631,6 +2631,38 @@ theorem AppStack.append {e : Expr} (H : AppStack env Us Δ (e.mkAppList as) e' b theorem AppStack.build {e : Expr} (H : TrExprS env Us Δ (e.mkAppList as) e') : ∃ e', AppStack env Us Δ e e' as := by simpa using AppStack.append (.head H) +/-- Recover the pointwise strict translations of an application spine and +rebuild the complete translated application. Unlike the checker-facing +`AppStack.toSpineWF`, this purely syntactic projection needs no expected +function type and is therefore available to WHNF reduction. -/ +theorem AppStack.argsTranslation + (H : AppStack env Us Δ f f' args) : + ∃ args', args.Forall₂ (TrExprS env Us Δ) args' ∧ + TrExprS env Us Δ (f.mkAppList args) (VExpr.appN f' args') := by + induction H with + | head h => exact ⟨[], .nil, by simpa⟩ + | app hfun harg hf ha H ih => + obtain ⟨args', hargs, hfull⟩ := ih + refine ⟨_ :: args', .cons ha hargs, ?_⟩ + simpa [Expr.mkAppList, VExpr.appN] using hfull + +/-- A successful lookup on the left side of a pointwise list relation has a +related lookup at the same position on the right. -/ +theorem List.Forall₂.getElem?_left + {α : Type u} {β : Type v} {R : α → β → Prop} + {xs : List α} {ys : List β} {i : Nat} {x : α} + (H : List.Forall₂ R xs ys) (hx : xs[i]? = some x) : + ∃ y : β, ys[i]? = some y ∧ R x y := by + induction H generalizing i with + | nil => simp at hx + | cons hxy _ ih => + cases i with + | zero => + simp at hx + subst x + exact ⟨_, rfl, hxy⟩ + | succ i => simpa using ih (i := i) (by simpa using hx) + /-- info: 'Lean4Lean.TrExprS.toConstructor_ready' depends on axioms: [propext, Classical.choice, Quot.sound] -/ From 867675adb1989800f66907c3b46121bb8cc55e19 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Tue, 11 Aug 2026 10:28:57 -0400 Subject: [PATCH 25/27] theory: expose consumer-neutral verification lemmas Move generic spine, primitive-environment, literal-typing, containment, and elimination-mode APIs from Verify into Theory. Preserve deprecated compatibility shims, add a Theory-only import/axiom audit, and record the L4L-15B structure-eta decision gate. --- Lean4Lean/Tests/TheoryConsumerSurface.lean | 94 ++++++++ Lean4Lean/Theory/Inductive.lean | 17 ++ Lean4Lean/Theory/Literals.lean | 215 ++++++++++++++++++ Lean4Lean/Theory/Typing/InductiveLemmas.lean | 44 ++++ Lean4Lean/Theory/Typing/UniqueTyping.lean | 87 +++++++ .../Environment/ConstructorValidation.lean | 142 ------------ .../ConstructorValidityReplay.lean | 2 +- Lean4Lean/Verify/Environment/Elimination.lean | 34 +-- .../Verify/Environment/InductiveFixtures.lean | 12 +- .../Verify/Environment/Normalization.lean | 213 ++--------------- Lean4Lean/Verify/Typing/Lemmas.lean | 10 - plans/roadmap.md | 163 +++++++------ 12 files changed, 583 insertions(+), 450 deletions(-) create mode 100644 Lean4Lean/Tests/TheoryConsumerSurface.lean diff --git a/Lean4Lean/Tests/TheoryConsumerSurface.lean b/Lean4Lean/Tests/TheoryConsumerSurface.lean new file mode 100644 index 0000000..b9f2ccf --- /dev/null +++ b/Lean4Lean/Tests/TheoryConsumerSurface.lean @@ -0,0 +1,94 @@ +import Lean4Lean.Theory.Literals +import Lean4Lean.Theory.Typing.InductiveLemmas +import Lean4Lean.Theory.Typing.UniqueTyping + +/-! +# Theory-only consumer surface + +This module deliberately imports no `Lean4Lean.Verify` module. Name +resolution here is the regression gate for the consumer-neutral declarations +migrated by L4L-15C; the deprecated Verify aliases can therefore be removed +without taking these APIs away from Theory consumers. +-/ + +namespace Lean4Lean.Tests.TheoryConsumerSurface + +#check VEnv.reflectedPrimitiveNames +#check VEnv.HasPrimitives.of_avoids +#check VEnv.addConst_other +#check VEnv.HasPrimitives.addConst +#check VExpr.WF.boolLit_has_type +#check VExpr.hasConst_lift' +#check VEnv.HasType.hasConst_false_of_absent +#check VEnv.SpineWF.weak' +#check VEnv.SpineWF.weakN_inv +#check VEnv.SpineWF.weak'_inv +#check VInductDecl.ElimMode.ofBool + +/-- +info: 'Lean4Lean.VEnv.reflectedPrimitiveNames' does not depend on any axioms +-/ +#guard_msgs in +#print axioms VEnv.reflectedPrimitiveNames + +/-- +info: 'Lean4Lean.VEnv.HasPrimitives.of_avoids' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.HasPrimitives.of_avoids + +/-- +info: 'Lean4Lean.VEnv.addConst_other' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.addConst_other + +/-- +info: 'Lean4Lean.VEnv.HasPrimitives.addConst' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.HasPrimitives.addConst + +/-- +info: 'Lean4Lean.VExpr.WF.boolLit_has_type' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VExpr.WF.boolLit_has_type + +/-- +info: 'Lean4Lean.VExpr.hasConst_lift'' depends on axioms: [propext] +-/ +#guard_msgs in +#print axioms VExpr.hasConst_lift' + +/-- +info: 'Lean4Lean.VEnv.HasType.hasConst_false_of_absent' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.HasType.hasConst_false_of_absent + +/-- +info: 'Lean4Lean.VEnv.SpineWF.weak'' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.SpineWF.weak' + +/-- +info: 'Lean4Lean.VEnv.SpineWF.weakN_inv' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.SpineWF.weakN_inv + +/-- +info: 'Lean4Lean.VEnv.SpineWF.weak'_inv' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.SpineWF.weak'_inv + +/-- +info: 'Lean4Lean.VInductDecl.ElimMode.ofBool' does not depend on any axioms +-/ +#guard_msgs in +#print axioms VInductDecl.ElimMode.ofBool + +end Lean4Lean.Tests.TheoryConsumerSurface diff --git a/Lean4Lean/Theory/Inductive.lean b/Lean4Lean/Theory/Inductive.lean index 66a7bb1..9733740 100644 --- a/Lean4Lean/Theory/Inductive.lean +++ b/Lean4Lean/Theory/Inductive.lean @@ -33,6 +33,14 @@ def VExpr.hasConst (n : Name) : VExpr → Bool | .const c _ => c == n | .app e1 e2 | .lam e1 e2 | .forallE e1 e2 => e1.hasConst n || e2.hasConst n +/-- Context lifting changes only bound-variable indices and therefore +preserves the constants occurring in a Theory expression. -/ +@[simp] theorem VExpr.hasConst_lift' (expression : VExpr) (lift : Lift) + (name : Name) : + (expression.lift' lift).hasConst name = expression.hasConst name := by + induction expression generalizing lift <;> + simp [VExpr.hasConst, *] + def VExpr.appN (f : VExpr) : List VExpr → VExpr | [] => f | a :: as => (f.app a).appN as @@ -650,6 +658,15 @@ inductive ElimMode where | small deriving DecidableEq, Repr +/-- Interpret the ordinary checker's Boolean large-elimination result in the +consumer-neutral Theory representation. -/ +def ElimMode.ofBool : Bool → ElimMode + | false => .small + | true => .large + +@[simp] theorem ElimMode.ofBool_false : ElimMode.ofBool false = .small := rfl +@[simp] theorem ElimMode.ofBool_true : ElimMode.ofBool true = .large := rfl + /-- Universe-slot offset used by recursor metadata. Large elimination inserts the fresh motive universe before the declaration universes; small elimination adds no universe parameter. -/ diff --git a/Lean4Lean/Theory/Literals.lean b/Lean4Lean/Theory/Literals.lean index ae8afee..e97daaa 100644 --- a/Lean4Lean/Theory/Literals.lean +++ b/Lean4Lean/Theory/Literals.lean @@ -240,6 +240,221 @@ structure VEnv.HasPrimitives (env : VEnv) : Prop where env.HasType 0 [] .listCharNil .listChar ∧ env.HasType 0 [] .listCharCons (.forallE .char <| .forallE .listChar .listChar) +/-- A well-formed Boolean literal can only occur when the corresponding +Boolean declaration is present. -/ +theorem VExpr.WF.boolLit_has_type (wf : env.Ordered) + (henv : env.HasPrimitives) (hΓ : OnCtx Γ (env.IsType U)) + (H : VExpr.WF env U Γ (.boolLit b)) : env.contains ``Bool := by + suffices env.HasType U Γ (.boolLit b) .bool by + have ⟨_, H⟩ := this.isType wf hΓ + have ⟨_, H, _⟩ := VEnv.HasType.const_inv wf hΓ H + exact ⟨_, H⟩ + cases b with + have ⟨_, h1, h2, h3⟩ := + let ⟨_, H⟩ := H + VEnv.HasType.const_inv wf hΓ H + | false => cases henv.boolFalse h1; exact .const h1 h2 h3 + | true => cases henv.boolTrue h1; exact .const h1 h2 h3 + +/-- The primitive constants whose Theory reflections are tracked by +`VEnv.HasPrimitives`. `Nat.pred` and `Nat.bitwise` are kernel primitive names +too, but they have no dedicated fields in that contract. -/ +def VEnv.reflectedPrimitiveNames : List Name := [ + ``Bool, ``Bool.false, ``Bool.true, + ``Nat, ``Nat.zero, ``Nat.succ, + ``Nat.add, ``Nat.sub, ``Nat.mul, ``Nat.pow, + ``Nat.gcd, ``Nat.mod, ``Nat.div, ``Nat.beq, ``Nat.ble, + ``Nat.land, ``Nat.lor, ``Nat.xor, + ``Nat.shiftLeft, ``Nat.shiftRight, + ``Char.ofNat, ``String.ofList] + +/-- An environment containing none of the hard-coded reflected primitive +names satisfies the primitive-reflection contract vacuously. -/ +theorem VEnv.HasPrimitives.of_avoids + {env : VEnv} + (h : ∀ n ∈ VEnv.reflectedPrimitiveNames, env.constants n = none) : + env.HasPrimitives := by + have noContains (n) (hn : n ∈ VEnv.reflectedPrimitiveNames) : + ¬env.contains n := by + rintro ⟨ci, hci⟩ + rw [h n hn] at hci + contradiction + have noLookup (n) (hn : n ∈ VEnv.reflectedPrimitiveNames) + {ci} (hci : env.constants n = some ci) : False := by + rw [h n hn] at hci + contradiction + exact { + bool := fun hc => + (noContains ``Bool (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + boolFalse := fun hci => + (noLookup ``Bool.false + (by simp [VEnv.reflectedPrimitiveNames]) hci).elim + boolTrue := fun hci => + (noLookup ``Bool.true + (by simp [VEnv.reflectedPrimitiveNames]) hci).elim + nat := fun hc => + (noContains ``Nat (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natZero := fun hci => + (noLookup ``Nat.zero + (by simp [VEnv.reflectedPrimitiveNames]) hci).elim + natSucc := fun hci => + (noLookup ``Nat.succ + (by simp [VEnv.reflectedPrimitiveNames]) hci).elim + natAdd := fun hc => + (noContains ``Nat.add + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natSub := fun hc => + (noContains ``Nat.sub + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natMul := fun hc => + (noContains ``Nat.mul + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natPow := fun hc => + (noContains ``Nat.pow + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natGcd := fun hc => + (noContains ``Nat.gcd + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natMod := fun hc => + (noContains ``Nat.mod + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natDiv := fun hc => + (noContains ``Nat.div + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natBEq := fun hc => + (noContains ``Nat.beq + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natBLE := fun hc => + (noContains ``Nat.ble + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natLAnd := fun hc => + (noContains ``Nat.land + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natLOr := fun hc => + (noContains ``Nat.lor + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natXor := fun hc => + (noContains ``Nat.xor + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natShiftLeft := fun hc => + (noContains ``Nat.shiftLeft + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + natShiftRight := fun hc => + (noContains ``Nat.shiftRight + (by simp [VEnv.reflectedPrimitiveNames]) hc).elim + charOfNat := fun hci => + (noLookup ``Char.ofNat + (by simp [VEnv.reflectedPrimitiveNames]) hci).elim + stringOfList := fun hci => + (noLookup ``String.ofList + (by simp [VEnv.reflectedPrimitiveNames]) hci).elim } + +/-- A fresh Theory constant leaves every other lookup unchanged. -/ +theorem VEnv.addConst_other + {env env' : VEnv} {name other : Name} {ci : VConstant} + (hadd : env.addConst name ci = some env') + (hne : name ≠ other) : + env'.constants other = env.constants other := by + unfold VEnv.addConst at hadd + split at hadd <;> cases hadd + simp [hne] + +/-- Inserting a non-reflected constant preserves the primitive-reflection +contract. -/ +theorem VEnv.HasPrimitives.addConst + {env env' : VEnv} {name : Name} {ci : VConstant} + (H : env.HasPrimitives) + (hname : name ∉ VEnv.reflectedPrimitiveNames) + (hadd : env.addConst name ci = some env') : + env'.HasPrimitives := by + have lookup (other : Name) (hother : other ∈ VEnv.reflectedPrimitiveNames) : + env'.constants other = env.constants other := + VEnv.addConst_other hadd (by + intro equality + apply hname + simpa only [equality] using hother) + have oldContains (other : Name) + (hother : other ∈ VEnv.reflectedPrimitiveNames) : + env'.contains other → env.contains other := by + rintro ⟨value, hvalue⟩ + exact ⟨value, by simpa only [lookup other hother] using hvalue⟩ + have newContains (other : Name) : + env.contains other → env'.contains other := by + rintro ⟨value, hvalue⟩ + exact ⟨value, (VEnv.addConst_le hadd).constants hvalue⟩ + have hle := VEnv.addConst_le hadd + exact { + bool := fun h => by + obtain ⟨hfalse, htrue⟩ := H.bool (oldContains ``Bool + (by simp [VEnv.reflectedPrimitiveNames]) h) + exact ⟨newContains _ hfalse, newContains _ htrue⟩ + boolFalse := fun h => H.boolFalse (by + simpa only [lookup ``Bool.false + (by simp [VEnv.reflectedPrimitiveNames])] using h) + boolTrue := fun h => H.boolTrue (by + simpa only [lookup ``Bool.true + (by simp [VEnv.reflectedPrimitiveNames])] using h) + nat := fun h => by + obtain ⟨hzero, hsucc⟩ := H.nat (oldContains ``Nat + (by simp [VEnv.reflectedPrimitiveNames]) h) + exact ⟨newContains _ hzero, newContains _ hsucc⟩ + natZero := fun h => H.natZero (by + simpa only [lookup ``Nat.zero + (by simp [VEnv.reflectedPrimitiveNames])] using h) + natSucc := fun h => H.natSucc (by + simpa only [lookup ``Nat.succ + (by simp [VEnv.reflectedPrimitiveNames])] using h) + natAdd := fun h a b => + (H.natAdd (oldContains ``Nat.add + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natSub := fun h a b => + (H.natSub (oldContains ``Nat.sub + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natMul := fun h a b => + (H.natMul (oldContains ``Nat.mul + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natPow := fun h a b => + (H.natPow (oldContains ``Nat.pow + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natGcd := fun h a b => + (H.natGcd (oldContains ``Nat.gcd + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natMod := fun h a b => + (H.natMod (oldContains ``Nat.mod + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natDiv := fun h a b => + (H.natDiv (oldContains ``Nat.div + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natBEq := fun h a b => + (H.natBEq (oldContains ``Nat.beq + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natBLE := fun h a b => + (H.natBLE (oldContains ``Nat.ble + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natLAnd := fun h a b => + (H.natLAnd (oldContains ``Nat.land + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natLOr := fun h a b => + (H.natLOr (oldContains ``Nat.lor + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natXor := fun h a b => + (H.natXor (oldContains ``Nat.xor + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natShiftLeft := fun h a b => + (H.natShiftLeft (oldContains ``Nat.shiftLeft + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + natShiftRight := fun h a b => + (H.natShiftRight (oldContains ``Nat.shiftRight + (by simp [VEnv.reflectedPrimitiveNames]) h) a b).mono hle + charOfNat := fun h => H.charOfNat (by + simpa only [lookup ``Char.ofNat + (by simp [VEnv.reflectedPrimitiveNames])] using h) + stringOfList := fun h => by + obtain ⟨hconstant, hnil, hcons⟩ := H.stringOfList (by + simpa only [lookup ``String.ofList + (by simp [VEnv.reflectedPrimitiveNames])] using h) + exact ⟨hconstant, hnil.mono hle, hcons.mono hle⟩ } + variable! {env env' : VEnv} (henv : env ≤ env') in theorem VEnv.ContainsLits.mono : ∀ {l}, env.ContainsLits l → env'.ContainsLits l | .natVal _, ⟨_, H⟩ => ⟨_, henv.constants H⟩ diff --git a/Lean4Lean/Theory/Typing/InductiveLemmas.lean b/Lean4Lean/Theory/Typing/InductiveLemmas.lean index 3984fce..0efa7a9 100644 --- a/Lean4Lean/Theory/Typing/InductiveLemmas.lean +++ b/Lean4Lean/Theory/Typing/InductiveLemmas.lean @@ -1,6 +1,7 @@ import Lean4Lean.Theory.Typing.Lemmas import Lean4Lean.Theory.Typing.Env import Lean4Lean.Theory.Typing.Meta +import Lean4Lean.Theory.Typing.Strong namespace Lean4Lean @@ -1529,6 +1530,49 @@ theorem getElem?_stack_mid {α} (Δ mid Γ : List α) {i : Nat} namespace VEnv +/-- A typed Theory expression cannot mention a constant absent from its +environment. -/ +theorem HasType.hasConst_false_of_absent + {env : VEnv} {U : Nat} {Γ : List VExpr} + {name : Name} {e A : VExpr} + (henv : env.Ordered) (hΓ : OnCtx Γ (env.IsType U)) + (absent : env.constants name = none) + (typed : env.HasType U Γ e A) : + e.hasConst name = false := by + induction e generalizing Γ A with + | bvar | sort => rfl + | const constant levels => + by_cases equality : constant = name + · subst constant + obtain ⟨ci, present, levelWF, arity⟩ := + typed.const_inv henv hΓ + rw [absent] at present + contradiction + · simpa [VExpr.hasConst, equality] + | app function argument functionIH argumentIH => + obtain ⟨domain, body, functionType, argumentType⟩ := + typed.app_inv henv hΓ + simp only [VExpr.hasConst, functionIH hΓ functionType, + argumentIH hΓ argumentType, Bool.false_or] + | lam domain body domainIH bodyIH => + obtain ⟨domainType, bodyWF⟩ := typed.lam_inv henv hΓ + obtain ⟨domainLevel, domainHasType⟩ := domainType + obtain ⟨bodyType, bodyHasType⟩ := bodyWF + have nextContextWF : OnCtx (domain :: Γ) (env.IsType U) := by + change OnCtx Γ (env.IsType U) ∧ env.IsType U Γ domain + exact ⟨hΓ, ⟨domainLevel, domainHasType⟩⟩ + simp only [VExpr.hasConst, domainIH hΓ domainHasType, + bodyIH nextContextWF bodyHasType, Bool.false_or] + | forallE domain body domainIH bodyIH => + obtain ⟨domainType, bodyType⟩ := typed.forallE_inv henv + obtain ⟨domainLevel, domainHasType⟩ := domainType + obtain ⟨bodyLevel, bodyHasType⟩ := bodyType + have nextContextWF : OnCtx (domain :: Γ) (env.IsType U) := by + change OnCtx Γ (env.IsType U) ∧ env.IsType U Γ domain + exact ⟨hΓ, ⟨domainLevel, domainHasType⟩⟩ + simp only [VExpr.hasConst, domainIH hΓ domainHasType, + bodyIH nextContextWF bodyHasType, Bool.false_or] + /-- The spine `bvarRevRange Δ.length As.length` selects exactly the binders `As` (reversed into the context past `Δ`), when all of `As` are closed. -/ theorem hasType_bvarRevRange {env : VEnv} {U : Nat} : diff --git a/Lean4Lean/Theory/Typing/UniqueTyping.lean b/Lean4Lean/Theory/Typing/UniqueTyping.lean index 9016277..81872ff 100644 --- a/Lean4Lean/Theory/Typing/UniqueTyping.lean +++ b/Lean4Lean/Theory/Typing/UniqueTyping.lean @@ -267,6 +267,93 @@ variable! (henv : VEnv.WF env) (hΓ : OnCtx Γ' (env.IsType U)) in theorem _root_.Lean4Lean.VExpr.WF.weak'_iff (W : Ctx.Lift' l Γ Γ') : VExpr.WF env U Γ' (e.lift' l) ↔ VExpr.WF env U Γ e := IsDefEqU.weak'_iff henv hΓ W +/-! ### Application-spine weakening and inversion -/ + +/-- General context weakening for an application spine. -/ +theorem SpineWF.weak' {env : VEnv} (henv : env.Ordered) + {U : Nat} {lift : Lift} {Γ Γ' : List VExpr} + (W : Ctx.Lift' lift Γ Γ') : + ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ A es B → + env.SpineWF U Γ' (A.lift' lift) + (es.map fun e => e.lift' lift) (B.lift' lift) := by + intro es + induction es with + | nil => + intro A B h + exact congrArg (fun e => e.lift' lift) h + | cons e es ih => + intro A B h + obtain ⟨A₁, A₂, rfl, he, hrest⟩ := h + refine ⟨A₁.lift' lift, A₂.lift' lift.cons, rfl, + he.weak' henv W, ?_⟩ + have weakened := ih hrest + rwa [VExpr.lift'_inst_hi] at weakened + +/-- Invert weakening of every component of an application-spine judgment +when the enlarged context is well formed. -/ +theorem SpineWF.weakN_inv {env : VEnv} {U n k : Nat} {Γ Γ' : List VExpr} + (henv : env.WF) (hΓ' : OnCtx Γ' (env.IsType U)) + (W : Ctx.LiftN n k Γ Γ') : + ∀ {es : List VExpr} {A B : VExpr}, + env.SpineWF U Γ' (A.liftN n k) + (es.map fun e => e.liftN n k) (B.liftN n k) → + env.SpineWF U Γ A es B := by + intro es + induction es with + | nil => + intro A B h + exact VExpr.liftN_inj.1 h + | cons e es ih => + intro A B h + obtain ⟨A₁', A₂', sourceEq, he, hrest⟩ := h + cases A with + | bvar index => cases sourceEq + | sort level => cases sourceEq + | const name levels => cases sourceEq + | app fn argument => cases sourceEq + | lam domain body => cases sourceEq + | forallE A₁ A₂ => + injection sourceEq with domainEq bodyEq + subst A₁' + subst A₂' + refine ⟨A₁, A₂, rfl, + (HasType.weakN_iff henv hΓ' W).1 he, ?_⟩ + rw [← VExpr.liftN_inst_hi] at hrest + exact ih hrest + +/-- Invert a general context lift componentwise across an application-spine +judgment. -/ +theorem SpineWF.weak'_inv {env : VEnv} {U : Nat} {lift : Lift} + {Γ Γ' : List VExpr} + (henv : env.WF) (hΓ' : OnCtx Γ' (env.IsType U)) + (W : Ctx.Lift' lift Γ Γ') : + ∀ {es : List VExpr} {A B : VExpr}, + env.SpineWF U Γ' (A.lift' lift) + (es.map fun e => e.lift' lift) (B.lift' lift) → + env.SpineWF U Γ A es B := by + intro es + induction es with + | nil => + intro A B h + exact VExpr.lift'_inj.1 h + | cons e es ih => + intro A B h + obtain ⟨A₁', A₂', sourceEq, he, hrest⟩ := h + cases A with + | bvar index => cases sourceEq + | sort level => cases sourceEq + | const name levels => cases sourceEq + | app fn argument => cases sourceEq + | lam domain body => cases sourceEq + | forallE A₁ A₂ => + injection sourceEq with domainEq bodyEq + subst A₁' + subst A₂' + refine ⟨A₁, A₂, rfl, + (HasType.weak'_iff henv hΓ' W).1 he, ?_⟩ + rw [← VExpr.lift'_inst_hi] at hrest + exact ih hrest + variable! (henv : VEnv.WF env) in theorem _root_.Lean4Lean.OnCtx.weak'_inv (W : Ctx.Lift' ρ Γ Γ') (H : OnCtx Γ' (env.IsType U)) : OnCtx Γ (env.IsType U) := by diff --git a/Lean4Lean/Verify/Environment/ConstructorValidation.lean b/Lean4Lean/Verify/Environment/ConstructorValidation.lean index 3a46672..6a93e3d 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidation.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidation.lean @@ -5313,29 +5313,6 @@ theorem forall₂_tr_mono | nil => exact .nil | cons head tail ih => exact .cons (head.mono add) ih -/-- General verified context weakening for an application spine. -/ -theorem VEnv.SpineWF.weak' - {env : VEnv} (henv : env.Ordered) - {U : Nat} {lift : Lift} {context enlarged : List VExpr} - (extension : Ctx.Lift' lift context enlarged) : - ∀ {arguments : List VExpr} {source target : VExpr}, - env.SpineWF U context source arguments target → - env.SpineWF U enlarged (source.lift' lift) - (arguments.map fun argument => argument.lift' lift) - (target.lift' lift) := by - intro arguments - induction arguments with - | nil => - intro source target run - exact congrArg (fun expression => expression.lift' lift) run - | cons argument arguments ih => - intro source target run - obtain ⟨domain, body, rfl, argumentType, tail⟩ := run - refine ⟨domain.lift' lift, body.lift' lift.cons, rfl, - argumentType.weak' henv extension, ?_⟩ - have weakened := ih tail - rwa [VExpr.lift'_inst_hi] at weakened - theorem isValidIndAppIdx_shape {stats : AddInductive.InductiveStats} {source : Expr} {familyIdx : Nat} @@ -5506,74 +5483,6 @@ theorem TrExprS.forall₂_weakFV_inv_defeq exact ⟨headBase :: tailBase, .cons headBaseRun tailBaseRuns, by simp only [List.map_cons, tailEq]⟩ -/-- Invert weakening of every component of an application-spine judgment when -the enlarged context is well formed. -/ -theorem VEnv.SpineWF.weakN_inv - {env : VEnv} {U n k : Nat} {context enlarged : List VExpr} - (henv : VEnv.WF env) (enlargedWF : OnCtx enlarged (env.IsType U)) - (extension : Ctx.LiftN n k context enlarged) : - ∀ {arguments : List VExpr} {source target : VExpr}, - env.SpineWF U enlarged (source.liftN n k) - (arguments.map fun argument => argument.liftN n k) - (target.liftN n k) → - env.SpineWF U context source arguments target := by - intro arguments - induction arguments with - | nil => - intro source target run - exact VExpr.liftN_inj.1 run - | cons argument arguments ih => - intro source target run - obtain ⟨domain', body', sourceEq, argumentType, tail⟩ := run - cases source with - | bvar index => cases sourceEq - | sort level => cases sourceEq - | const name levels => cases sourceEq - | app fn argument => cases sourceEq - | lam domain body => cases sourceEq - | forallE domain body => - injection sourceEq with domainEq bodyEq - subst domain' - subst body' - refine ⟨domain, body, rfl, - (HasType.weakN_iff henv enlargedWF extension).1 argumentType, ?_⟩ - rw [← VExpr.liftN_inst_hi] at tail - exact ih tail - -/-- Invert a general verified context lift componentwise across an -application-spine judgment. -/ -theorem VEnv.SpineWF.weak'_inv - {env : VEnv} {U : Nat} {lift : Lift} {context enlarged : List VExpr} - (henv : VEnv.WF env) (enlargedWF : OnCtx enlarged (env.IsType U)) - (extension : Ctx.Lift' lift context enlarged) : - ∀ {arguments : List VExpr} {source target : VExpr}, - env.SpineWF U enlarged (source.lift' lift) - (arguments.map fun argument => argument.lift' lift) - (target.lift' lift) → - env.SpineWF U context source arguments target := by - intro arguments - induction arguments with - | nil => - intro source target run - exact VExpr.lift'_inj.1 run - | cons argument arguments ih => - intro source target run - obtain ⟨domain', body', sourceEq, argumentType, tail⟩ := run - cases source with - | bvar index => cases sourceEq - | sort level => cases sourceEq - | const name levels => cases sourceEq - | app fn argument => cases sourceEq - | lam domain body => cases sourceEq - | forallE domain body => - injection sourceEq with domainEq bodyEq - subst domain' - subst body' - refine ⟨domain, body, rfl, - (HasType.weak'_iff henv enlargedWF extension).1 argumentType, ?_⟩ - rw [← VExpr.lift'_inst_hi] at tail - exact ih tail - theorem ConstructorPreFamilyIndexSpineSemanticRun.expected_eq_of_family_lift {env : VEnv} {Us : List Name} {context : AddInductive.Context} {contextRun : AddInductive.ConstructorContextRun env Us context} @@ -6545,57 +6454,6 @@ private theorem forallN_hasConst_of_terminal simp only [VExpr.forallN, VExpr.hasConst, Bool.or_eq_true] exact .inr ih -/-- Context lifting changes only bound-variable indices and therefore -preserves the set of constants occurring in a Theory expression. -/ -private theorem VExpr.hasConst_lift' (expression : VExpr) (lift : Lift) - (name : Name) : - (expression.lift' lift).hasConst name = expression.hasConst name := by - induction expression generalizing lift <;> - simp [VExpr.hasConst, *] - -/-- A typed Theory expression cannot mention a constant absent from its -environment. -/ -theorem VEnv.HasType.hasConst_false_of_absent - {env : VEnv} {U : Nat} {context : List VExpr} - {familyName : Name} {expression type : VExpr} - (henv : env.Ordered) (contextWF : OnCtx context (env.IsType U)) - (absent : env.constants familyName = none) - (typed : env.HasType U context expression type) : - expression.hasConst familyName = false := by - induction expression generalizing context type with - | bvar | sort => rfl - | const name levels => - by_cases equality : name = familyName - · subst name - obtain ⟨constant, present, levelWF, arity⟩ := - typed.const_inv henv contextWF - rw [absent] at present - contradiction - · simpa [VExpr.hasConst, equality] - | app function argument functionIH argumentIH => - obtain ⟨domain, body, functionType, argumentType⟩ := - typed.app_inv henv contextWF - simp only [VExpr.hasConst, functionIH contextWF functionType, - argumentIH contextWF argumentType, Bool.false_or] - | lam domain body domainIH bodyIH => - obtain ⟨domainType, bodyWF⟩ := typed.lam_inv henv contextWF - obtain ⟨domainLevel, domainHasType⟩ := domainType - obtain ⟨bodyType, bodyHasType⟩ := bodyWF - have nextContextWF : OnCtx (domain :: context) (env.IsType U) := by - change OnCtx context (env.IsType U) ∧ env.IsType U context domain - exact ⟨contextWF, ⟨domainLevel, domainHasType⟩⟩ - simp only [VExpr.hasConst, domainIH contextWF domainHasType, - bodyIH nextContextWF bodyHasType, Bool.false_or] - | forallE domain body domainIH bodyIH => - obtain ⟨domainType, bodyType⟩ := typed.forallE_inv henv - obtain ⟨domainLevel, domainHasType⟩ := domainType - obtain ⟨bodyLevel, bodyHasType⟩ := bodyType - have nextContextWF : OnCtx (domain :: context) (env.IsType U) := by - change OnCtx context (env.IsType U) ∧ env.IsType U context domain - exact ⟨contextWF, ⟨domainLevel, domainHasType⟩⟩ - simp only [VExpr.hasConst, domainIH contextWF domainHasType, - bodyIH nextContextWF bodyHasType, Bool.false_or] - theorem recArg?_eq_none_of_hasConst_false (free : field.hasConst familyName = false) : VInductDecl.recArg? U familyName np ni fieldIndex field = none := by diff --git a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean index 5c2afeb..d068e30 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean @@ -57,7 +57,7 @@ def l4l05EmptyVEnvs : VEnvs where venv _ := VEnv.empty theorem l4l05EmptyHasPrimitives : VEnv.HasPrimitives VEnv.empty := by - apply TypeChecker.VEnv.HasPrimitives.of_avoids + apply VEnv.HasPrimitives.of_avoids intro name membership rfl diff --git a/Lean4Lean/Verify/Environment/Elimination.lean b/Lean4Lean/Verify/Environment/Elimination.lean index 6f027e7..9f0c87e 100644 --- a/Lean4Lean/Verify/Environment/Elimination.lean +++ b/Lean4Lean/Verify/Environment/Elimination.lean @@ -6,11 +6,11 @@ open Lean hiding Environment Exception namespace AddInductive -/-- Theory's presentation of the Boolean returned by the ordinary -large-eliminator checker. -/ -def checkerElimMode : Bool → VInductDecl.ElimMode - | false => .small - | true => .large +/-- Compatibility name for Theory's presentation of the Boolean returned by +the ordinary large-eliminator checker. -/ +@[deprecated VInductDecl.ElimMode.ofBool (since := "2026-08-11")] +abbrev checkerElimMode : Bool → VInductDecl.ElimMode := + VInductDecl.ElimMode.ofBool /-- Lightweight alignment for an exact `getElimLevel` execution when the normalization statistics are already pinned independently. This is useful for @@ -22,7 +22,7 @@ structure CheckerElimLevelRun (execution : ElimLevelExecution stats indTypes context) : Type where sourceUvars_eq : source.uvars = context.lparams.length mode_eq : generation.elimination = - checkerElimMode execution.large.result + VInductDecl.ElimMode.ofBool execution.large.result recUvars_eq : generation.recUvars = (getRecLevelParams execution.level context.lparams).length recLevels_eq : @@ -42,7 +42,7 @@ def build? Option (CheckerElimLevelRun generation execution) := do if huvars : source.uvars = context.lparams.length then if hmode : generation.elimination = - checkerElimMode execution.large.result then + VInductDecl.ElimMode.ofBool execution.large.result then if hrecUvars : generation.recUvars = (getRecLevelParams execution.level context.lparams).length then if hlevels : @@ -67,11 +67,11 @@ theorem large_result_iff cases hresult : execution.large.result with | false => have hmode : generation.elimination = VInductDecl.ElimMode.small := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] | true => have hmode : generation.elimination = VInductDecl.ElimMode.large := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] theorem small_result_iff @@ -81,11 +81,11 @@ theorem small_result_iff cases hresult : execution.large.result with | false => have hmode : generation.elimination = VInductDecl.ElimMode.small := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] | true => have hmode : generation.elimination = VInductDecl.ElimMode.large := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] end CheckerElimLevelRun @@ -143,7 +143,7 @@ structure CheckerEliminationRun sourceUvars_eq : source.uvars = execution.normalization.validationContext.lparams.length mode_eq : generation.elimination = - checkerElimMode execution.elimination.large.result + VInductDecl.ElimMode.ofBool execution.elimination.large.result kTarget_eq : generation.kTarget = execution.kTarget.result recUvars_eq : generation.recUvars = execution.recLevelParams.length recLevels_eq : execution.recLevels.mapM @@ -164,7 +164,7 @@ def build? if huvars : source.uvars = execution.normalization.validationContext.lparams.length then if hmode : generation.elimination = - checkerElimMode execution.elimination.large.result then + VInductDecl.ElimMode.ofBool execution.elimination.large.result then if hkTarget : generation.kTarget = execution.kTarget.result then if hrecUvars : generation.recUvars = execution.recLevelParams.length then @@ -192,11 +192,11 @@ theorem large_result_iff cases hresult : execution.elimination.large.result with | false => have hmode : generation.elimination = VInductDecl.ElimMode.small := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] | true => have hmode : generation.elimination = VInductDecl.ElimMode.large := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] theorem small_result_iff @@ -206,11 +206,11 @@ theorem small_result_iff cases hresult : execution.elimination.large.result with | false => have hmode : generation.elimination = VInductDecl.ElimMode.small := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] | true => have hmode : generation.elimination = VInductDecl.ElimMode.large := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] theorem kTarget_result_true_iff diff --git a/Lean4Lean/Verify/Environment/InductiveFixtures.lean b/Lean4Lean/Verify/Environment/InductiveFixtures.lean index 04bfe71..bfec8aa 100644 --- a/Lean4Lean/Verify/Environment/InductiveFixtures.lean +++ b/Lean4Lean/Verify/Environment/InductiveFixtures.lean @@ -2537,9 +2537,9 @@ private theorem outParam_trEnv : private theorem outParam_hasPrimitives : VEnv.HasPrimitives outParamEnv := by - apply TypeChecker.VEnv.HasPrimitives.of_avoids + apply VEnv.HasPrimitives.of_avoids intro n hn - simp only [TypeChecker.reflectedPrimitiveNames, List.mem_cons, + simp only [VEnv.reflectedPrimitiveNames, List.mem_cons, List.not_mem_nil, or_false] at hn rcases hn with rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | @@ -3399,9 +3399,9 @@ private theorem aliasFormerNormalization_trEnv : private theorem aliasFormerNormalization_hasPrimitives : VEnv.HasPrimitives typeFamilyAliasEnv := by - apply TypeChecker.VEnv.HasPrimitives.of_avoids + apply VEnv.HasPrimitives.of_avoids intro n hn - simp only [TypeChecker.reflectedPrimitiveNames, List.mem_cons, + simp only [VEnv.reflectedPrimitiveNames, List.mem_cons, List.not_mem_nil, or_false] at hn rcases hn with rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | @@ -3514,9 +3514,9 @@ private theorem aliasRecNormalization_trEnv : private theorem aliasRecNormalization_hasPrimitives : VEnv.HasPrimitives aliasRecTypeEnv := by - apply TypeChecker.VEnv.HasPrimitives.of_avoids + apply VEnv.HasPrimitives.of_avoids intro n hn - simp only [TypeChecker.reflectedPrimitiveNames, List.mem_cons, + simp only [VEnv.reflectedPrimitiveNames, List.mem_cons, List.not_mem_nil, or_false] at hn rcases hn with rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | diff --git a/Lean4Lean/Verify/Environment/Normalization.lean b/Lean4Lean/Verify/Environment/Normalization.lean index b3a5f5b..bf679c2 100644 --- a/Lean4Lean/Verify/Environment/Normalization.lean +++ b/Lean4Lean/Verify/Environment/Normalization.lean @@ -7,190 +7,37 @@ open Kernel namespace TypeChecker -/-- The primitive constants whose Theory reflections are required by the -verified checker. `Nat.pred` and `Nat.bitwise` are kernel primitive names too, -but they have no dedicated fields in `VEnv.HasPrimitives`. -/ -def reflectedPrimitiveNames : List Name := [ - ``Bool, ``Bool.false, ``Bool.true, - ``Nat, ``Nat.zero, ``Nat.succ, - ``Nat.add, ``Nat.sub, ``Nat.mul, ``Nat.pow, - ``Nat.gcd, ``Nat.mod, ``Nat.div, ``Nat.beq, ``Nat.ble, - ``Nat.land, ``Nat.lor, ``Nat.xor, - ``Nat.shiftLeft, ``Nat.shiftRight, - ``Char.ofNat, ``String.ofList] - -/-- A small Theory environment that contains none of Lean's hard-coded -primitive names satisfies the primitive-reflection contract vacuously. This is -useful for isolated staged checker contexts. -/ +/-- Compatibility name for the consumer-neutral reflected-primitive list. -/ +@[deprecated Lean4Lean.VEnv.reflectedPrimitiveNames (since := "2026-08-11")] +abbrev reflectedPrimitiveNames : List Name := + Lean4Lean.VEnv.reflectedPrimitiveNames + +/-- Compatibility shim for the consumer-neutral Theory theorem. -/ +@[deprecated Lean4Lean.VEnv.HasPrimitives.of_avoids (since := "2026-08-11")] theorem VEnv.HasPrimitives.of_avoids {env : VEnv} (h : ∀ n ∈ reflectedPrimitiveNames, env.constants n = none) : - env.HasPrimitives := by - have noContains (n) (hn : n ∈ reflectedPrimitiveNames) : - ¬env.contains n := by - rintro ⟨ci, hci⟩ - rw [h n hn] at hci - contradiction - have noLookup (n) (hn : n ∈ reflectedPrimitiveNames) - {ci} (hci : env.constants n = some ci) : False := by - rw [h n hn] at hci - contradiction - exact { - bool := fun hc => - (noContains ``Bool (by simp [reflectedPrimitiveNames]) hc).elim - boolFalse := fun hci => - (noLookup ``Bool.false (by simp [reflectedPrimitiveNames]) hci).elim - boolTrue := fun hci => - (noLookup ``Bool.true (by simp [reflectedPrimitiveNames]) hci).elim - nat := fun hc => - (noContains ``Nat (by simp [reflectedPrimitiveNames]) hc).elim - natZero := fun hci => - (noLookup ``Nat.zero (by simp [reflectedPrimitiveNames]) hci).elim - natSucc := fun hci => - (noLookup ``Nat.succ (by simp [reflectedPrimitiveNames]) hci).elim - natAdd := fun hc => - (noContains ``Nat.add (by simp [reflectedPrimitiveNames]) hc).elim - natSub := fun hc => - (noContains ``Nat.sub (by simp [reflectedPrimitiveNames]) hc).elim - natMul := fun hc => - (noContains ``Nat.mul (by simp [reflectedPrimitiveNames]) hc).elim - natPow := fun hc => - (noContains ``Nat.pow (by simp [reflectedPrimitiveNames]) hc).elim - natGcd := fun hc => - (noContains ``Nat.gcd (by simp [reflectedPrimitiveNames]) hc).elim - natMod := fun hc => - (noContains ``Nat.mod (by simp [reflectedPrimitiveNames]) hc).elim - natDiv := fun hc => - (noContains ``Nat.div (by simp [reflectedPrimitiveNames]) hc).elim - natBEq := fun hc => - (noContains ``Nat.beq (by simp [reflectedPrimitiveNames]) hc).elim - natBLE := fun hc => - (noContains ``Nat.ble (by simp [reflectedPrimitiveNames]) hc).elim - natLAnd := fun hc => - (noContains ``Nat.land (by simp [reflectedPrimitiveNames]) hc).elim - natLOr := fun hc => - (noContains ``Nat.lor (by simp [reflectedPrimitiveNames]) hc).elim - natXor := fun hc => - (noContains ``Nat.xor (by simp [reflectedPrimitiveNames]) hc).elim - natShiftLeft := fun hc => - (noContains ``Nat.shiftLeft - (by simp [reflectedPrimitiveNames]) hc).elim - natShiftRight := fun hc => - (noContains ``Nat.shiftRight - (by simp [reflectedPrimitiveNames]) hc).elim - charOfNat := fun hci => - (noLookup ``Char.ofNat (by simp [reflectedPrimitiveNames]) hci).elim - stringOfList := fun hci => - (noLookup ``String.ofList - (by simp [reflectedPrimitiveNames]) hci).elim } - -/-- A fresh Theory constant leaves every other lookup unchanged. -/ + env.HasPrimitives := + Lean4Lean.VEnv.HasPrimitives.of_avoids h + +/-- Compatibility shim for the consumer-neutral Theory theorem. -/ +@[deprecated Lean4Lean.VEnv.addConst_other (since := "2026-08-11")] theorem VEnv.addConst_other {env env' : VEnv} {name other : Name} {ci : VConstant} (hadd : env.addConst name ci = some env') (hne : name ≠ other) : - env'.constants other = env.constants other := by - unfold Lean4Lean.VEnv.addConst at hadd - split at hadd <;> cases hadd - simp [hne] - -/-- Inserting a non-primitive constant preserves the verified checker's -primitive-reflection contract. The computational reflection equations are -transported monotonically; the primitive constant lookups themselves are -unchanged. -/ + env'.constants other = env.constants other := + Lean4Lean.VEnv.addConst_other hadd hne + +/-- Compatibility shim for the consumer-neutral Theory theorem. -/ +@[deprecated Lean4Lean.VEnv.HasPrimitives.addConst (since := "2026-08-11")] theorem VEnv.HasPrimitives.addConst {env env' : VEnv} {name : Name} {ci : VConstant} (H : env.HasPrimitives) (hname : name ∉ reflectedPrimitiveNames) (hadd : env.addConst name ci = some env') : - env'.HasPrimitives := by - have lookup (other : Name) (hother : other ∈ reflectedPrimitiveNames) : - env'.constants other = env.constants other := - VEnv.addConst_other hadd (by - intro h - apply hname - simpa only [h] using hother) - have oldContains (other : Name) - (hother : other ∈ reflectedPrimitiveNames) : - env'.contains other → env.contains other := by - rintro ⟨value, hvalue⟩ - exact ⟨value, by simpa only [lookup other hother] using hvalue⟩ - have newContains (other : Name) : - env.contains other → env'.contains other := by - rintro ⟨value, hvalue⟩ - exact ⟨value, (VEnv.addConst_le hadd).constants hvalue⟩ - have hle := VEnv.addConst_le hadd - exact { - bool := fun h => by - obtain ⟨hfalse, htrue⟩ := H.bool (oldContains ``Bool - (by simp [reflectedPrimitiveNames]) h) - exact ⟨newContains _ hfalse, newContains _ htrue⟩ - boolFalse := fun h => H.boolFalse (by - simpa only [lookup ``Bool.false - (by simp [reflectedPrimitiveNames])] using h) - boolTrue := fun h => H.boolTrue (by - simpa only [lookup ``Bool.true - (by simp [reflectedPrimitiveNames])] using h) - nat := fun h => by - obtain ⟨hzero, hsucc⟩ := H.nat (oldContains ``Nat - (by simp [reflectedPrimitiveNames]) h) - exact ⟨newContains _ hzero, newContains _ hsucc⟩ - natZero := fun h => H.natZero (by - simpa only [lookup ``Nat.zero - (by simp [reflectedPrimitiveNames])] using h) - natSucc := fun h => H.natSucc (by - simpa only [lookup ``Nat.succ - (by simp [reflectedPrimitiveNames])] using h) - natAdd := fun h a b => - (H.natAdd (oldContains ``Nat.add - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natSub := fun h a b => - (H.natSub (oldContains ``Nat.sub - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natMul := fun h a b => - (H.natMul (oldContains ``Nat.mul - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natPow := fun h a b => - (H.natPow (oldContains ``Nat.pow - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natGcd := fun h a b => - (H.natGcd (oldContains ``Nat.gcd - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natMod := fun h a b => - (H.natMod (oldContains ``Nat.mod - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natDiv := fun h a b => - (H.natDiv (oldContains ``Nat.div - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natBEq := fun h a b => - (H.natBEq (oldContains ``Nat.beq - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natBLE := fun h a b => - (H.natBLE (oldContains ``Nat.ble - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natLAnd := fun h a b => - (H.natLAnd (oldContains ``Nat.land - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natLOr := fun h a b => - (H.natLOr (oldContains ``Nat.lor - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natXor := fun h a b => - (H.natXor (oldContains ``Nat.xor - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natShiftLeft := fun h a b => - (H.natShiftLeft (oldContains ``Nat.shiftLeft - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - natShiftRight := fun h a b => - (H.natShiftRight (oldContains ``Nat.shiftRight - (by simp [reflectedPrimitiveNames]) h) a b).mono hle - charOfNat := fun h => H.charOfNat (by - simpa only [lookup ``Char.ofNat - (by simp [reflectedPrimitiveNames])] using h) - stringOfList := fun h => by - obtain ⟨hconstant, hnil, hcons⟩ := H.stringOfList (by - simpa only [lookup ``String.ofList - (by simp [reflectedPrimitiveNames])] using h) - exact ⟨hconstant, hnil.mono hle, hcons.mono hle⟩ } + env'.HasPrimitives := + Lean4Lean.VEnv.HasPrimitives.addConst H hname hadd /-- A verified implementation local context remains verified when the Theory environment grows. Kernel local declarations and their free-variable names @@ -3634,7 +3481,7 @@ structure CandidateFamilyStagedInput { familyContext with env := constructorContext.env } quotInit_eq : constructorContext.env.quotInit = familyContext.env.quotInit - name_not_reflected : raw.name ∉ TypeChecker.reflectedPrimitiveNames + name_not_reflected : raw.name ∉ VEnv.reflectedPrimitiveNames name_not_primitive : Environment.primitives.contains raw.name = false @@ -3666,7 +3513,7 @@ def CandidateFamilyStagedInput.postContext have H : env.HasPrimitives := by simpa only [preFamily.venv_eq] using preFamily.contextRun.context.hasPrimitives - exact TypeChecker.VEnv.HasPrimitives.addConst H + exact VEnv.HasPrimitives.addConst H input.name_not_reflected input.addInduct.env_add safePrimitives := by intro n ci @@ -5449,22 +5296,12 @@ def GenerationCandidateSemanticRun.producedPackage run.run.producedPackage context nparams numNested isUnsafe produced /- -The evidence types mention exact verifier executions, so these semantic -interpretation roots intentionally inherit the same transitional Verify +The evidence types mention exact verifier executions, so the semantic +interpretation roots below intentionally inherit the same transitional Verify closure as `WhnfRun.isDefEq`. Exact guards ensure that the generic assembler -does not silently widen it. +does not silently widen it. Theory-only helper closures are guarded by +`Tests.TheoryConsumerSurface` without importing Verify. -/ -/-- -info: 'Lean4Lean.TypeChecker.VEnv.HasPrimitives.addConst' depends on axioms: [propext, Classical.choice, Quot.sound] --/ -#guard_msgs in -#print axioms TypeChecker.VEnv.HasPrimitives.addConst - -/-- -info: 'Lean4Lean.TypeChecker.VEnv.addConst_other' depends on axioms: [propext, Quot.sound] --/ -#guard_msgs in -#print axioms TypeChecker.VEnv.addConst_other /-- info: 'Lean4Lean.TypeChecker.AddInductConstant.safePrimitives' depends on axioms: [propext, diff --git a/Lean4Lean/Verify/Typing/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean index 178a808..6757630 100644 --- a/Lean4Lean/Verify/Typing/Lemmas.lean +++ b/Lean4Lean/Verify/Typing/Lemmas.lean @@ -2161,16 +2161,6 @@ theorem TrExprS.boolLit (henv : env.HasPrimitives) (H : env.contains ``Bool) (b theorem FVarsIn.boolLit {b : Bool} : FVarsIn P (toExpr b) := by cases b <;> exact nofun -theorem VExpr.WF.boolLit_has_type (wf : env.Ordered) (henv : env.HasPrimitives) - (hΓ : OnCtx Γ (env.IsType U)) (H : VExpr.WF env U Γ (.boolLit b)) : env.contains ``Bool := by - suffices env.HasType U Γ (.boolLit b) .bool by - have ⟨_, H⟩ := this.isType wf hΓ - have ⟨_, H, _⟩ := HasType.const_inv wf hΓ H - exact ⟨_, H⟩ - cases b with have ⟨_, h1, h2, h3⟩ := let ⟨_, H⟩ := H; HasType.const_inv wf hΓ H - | false => cases henv.boolFalse h1; exact .const h1 h2 h3 - | true => cases henv.boolTrue h1; exact .const h1 h2 h3 - theorem TrExprS.lit_has_type (H : TrExprS env Us Δ (.lit l) e') : env.ContainsLits l := let .lit H _ := H; H diff --git a/plans/roadmap.md b/plans/roadmap.md index 6827637..4b871ab 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -1,7 +1,7 @@ # Lean4Lean completion roadmap -**Status:** authoritative local roadmap, audited 2026-08-10 against the -committed fork and the current `jcb/formalization` development bookmark; +**Status:** authoritative local roadmap, audited 2026-08-11 against the +committed fork and the current `jcb/formalization2` development bookmark; publication to `jcb/induct` remains a separate boundary. **Versioning.** `plans/roadmap.md` is intentionally tracked so the @@ -67,12 +67,12 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| 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 | +| Ladder position | **L4L-15B active at its required upstream decision gate**; L4L-14 and L4L-15A are complete and pruned from §5; the independent L4L-15C Theory-only surface migration is complete in this checkpoint | +| Current formalization source | the L4L-15A projection-checker checkpoint `e8ccc70f` at `jcb/formalization2`, plus this checkpoint's L4L-15C ownership migration; publication to `argumentcomputer/lean4lean` `jcb/induct` remains 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 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 | +| Trust frontier | exactly 11 live source `sorry` tokens across 10 proof declarations, plus six kernel-rejection recovery declarations (16 compiled allowlist entries total), and 29 custom-axiom declarations; all are pinned by exact audits | +| Gates | the full §6 gate is green on this checkpoint: the 198-job default Lake build, all nine Nix flake checks, the 16-entry exact sorry frontier, the Theory-only import/axiom audit, downstream-consumer and CLI checks, and whitespace hygiene | ### 2.1 What is green @@ -281,9 +281,26 @@ longer inherit `sorryAx` through the projection branch. The 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 L4L-14 structural package is proved: weakening, inverse weakening, +context-defeq transport, WF, uniqueness, term substitution, and universe +instantiation retain their compatibility names and are bundled by +`TrProj.structuralLaws`. L4L-15A proves `inferProj.WF`, both constructor and +string branches of `reduceProj.WF`, and the enclosing WHNF/translation +projection paths. Their exact guards distinguish the remaining inherited +Tier-R inversion dependency from projection-specific proof debt. + +**Theory-only consumer surface.** The L4L-15C audit moved the generic +`SpineWF` weakening/inversion laws to `Theory/Typing/UniqueTyping.lean`, +primitive-environment extension and Bool-literal typing to +`Theory/Literals.lean`, constant-absence and containment facts to their +Theory owners, and the Bool-to-elimination-mode conversion to +`Theory/Inductive.lean`. Verify keeps only deprecated compatibility shims +where a public name existed. `Tests/TheoryConsumerSurface.lean` imports no +Verify module and pins the availability and exact axiom closure of every +migrated API. + +**Not claimed.** Structure eta and unit-like checker verification (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 @@ -299,15 +316,15 @@ never generation-shape authority or Theory semantics. The sorry audit (`Lean4Lean/Audit/SorryFrontier.lean`, a declaration-level `sorryAx` allowlist over the compiled Theory/Verify surface) currently -accepts exactly 19 live sorries across 18 declarations (`NormalEq.parRed` -carries two), plus six deliberately kernel-rejected fixture recoveries that -are not proof debt: +accepts exactly 11 live source tokens across 10 proof declarations +(`NormalEq.parRed` carries two), plus six deliberately kernel-rejected +fixture recoveries that are not proof debt. The compiled allowlist therefore +contains 16 declarations: | Area | Live debt | |---|---| -| 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 | +| Core metatheory | `Injectivity.lean` x3; `UniqueTyping.lean` x1; `Projection.lean` x1; `ChurchRosser.lean` x2 | +| Checker verification | `Verify/Environment.lean` x1; `WHNF.lean` x1; `IsDefEq.lean` x2 | The remaining v4.31-added sorry is classified: `Lean4Lean.addDecl.WF` → L4L-19B. Non-sorry debt: @@ -318,14 +335,15 @@ The remaining v4.31-added sorry is classified: 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 + projection semantics landed at L4L-13A/B and projection structural/checker + verification closed at L4L-14/L4L-15A; structure eta and unit-like + comparison remain at the L4L-15B decision gate. `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. +- The L4L-15C consumer-neutral audit is complete. Generic spine laws, + primitive-environment extension, literal typing, containment/absence, and + elimination-mode conversion now have Theory-only homes, with a dedicated + import-boundary/axiom audit and deprecated Verify shims only where needed. - 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 @@ -506,85 +524,58 @@ from this ladder, with their record kept in git history. Earlier partial implementation counts as a prerequisite, never as partial credit. A suffixed identifier such as L4L-01D2 is a full checkpoint with its own commit and gates. Read-only design reconnaissance for a later milestone is allowed when -it changes the active design, but implementation and publication stay serial: -this keeps one auditable claim per checkpoint and prevents several -half-migrated public artifact paths from being live simultaneously. +it changes the active design. Implementation and publication normally stay +serial; an explicitly independent later milestone may close as its own +audited checkpoint while the active milestone waits at a mandatory external +approval gate, provided this exception is recorded here and does not change +the blocked semantics. L4L-15C is such an exception while L4L-15B awaits the +structure-eta decision. This keeps one auditable claim per checkpoint and +prevents several half-migrated public artifact paths from being live +simultaneously. If upstream advances at a milestone boundary, insert an explicit integration-only reconciliation checkpoint (as was done for v4.31) rather than hiding merge work inside a semantic milestone. -### 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. 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. 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. - -**L4L-15B — structure eta and unit-like comparison.** Derive +### Structures (L4L-15B) + +Projection semantics, structural laws, and checker verification are complete; +their current claim surface is recorded in §2.1 and their checkpoint evidence +lives in history. The remaining structure work is the kernel's eta behavior. + +**L4L-15B — structure eta and unit-like comparison (active, decision +gate).** Derive `tryEtaStructCore.WF` and `isDefEqUnitLike.WF`. First attempt derivation from the recursor/iota package, proof irrelevance, and projection uniqueness. If Lean's structure eta requires a new primitive Theory defeq rule, write a design note covering subject reduction, injectivity, confluence, and downstream impact, and obtain upstream agreement before changing `IsDefEq` — this is a metatheory change, not a local checker lemma. + +The 2026-08-11 derivability audit reached that gate. The pinned Lean sources +implement eta for nonrecursive, single-constructor, zero-index structures as +special kernel support: comparison checks the common structure type and its +fields, while the unit-like path is the zero-field specialization. Existing +Theory rules can derive equality of every projected field and can reduce a +projection whose major is already constructor-headed, but cannot derive the +missing reconstruction equation +`C params (proj₀ t) ... (projₙ t) ≡ t` for a neutral `t`. Function eta does +not apply, proof irrelevance covers only `Prop`, and projection uniqueness is +not structure extensionality. No `IsDefEq` rule has been changed. + +The proposed upstream decision is an explicit registered structure-eta rule, +restricted to checked nonrecursive, single-constructor, zero-index structure +views. Acceptance requires: subject reduction from the registered constructor +and projector typing package; updated injectivity/discrimination arguments; +confluence/standardization critical-pair coverage against beta, iota, proof +irrelevance, and registered extra rules; and an audit of every exhaustive +`IsDefEq` consumer plus environment monotonicity. If upstream declines that +Theory change, the faithful alternative is to disable the two executable +heuristics rather than certify them from an absent rule. Upstream agreement is +required before implementation proceeds. *Exit:* both roots are sorry-free and audited; any Theory-rule change has subject-reduction/injectivity/confluence and downstream-impact evidence. -**L4L-15C — Theory-only consumer import surface.** Audit the consumer-neutral -lemmas still living under Verify after 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. - ### Metatheory closure (L4L-16–L4L-18B) Scheduled completion work; coordinate with Mario because upstream has active From 700c7baa2cc1f6f83371f31b77a4153c9150262d Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Tue, 11 Aug 2026 10:46:42 -0400 Subject: [PATCH 26/27] theory: stage structure eta typing infrastructure --- Lean4Lean/Tests/ProjectionExpressibility.lean | 9 + Lean4Lean/Tests/TheoryConsumerSurface.lean | 28 +++ Lean4Lean/Theory/Projection.lean | 167 ++++++++++++++++++ plans/roadmap.md | 11 ++ 4 files changed, 215 insertions(+) diff --git a/Lean4Lean/Tests/ProjectionExpressibility.lean b/Lean4Lean/Tests/ProjectionExpressibility.lean index 349b682..c720409 100644 --- a/Lean4Lean/Tests/ProjectionExpressibility.lean +++ b/Lean4Lean/Tests/ProjectionExpressibility.lean @@ -211,6 +211,15 @@ example : dependentRecordView.projectionLevels valueCode.fieldSort symbolicLevel example : dependentRecordView.project? symbolicLevels symbolicParams 2 (.bvar 0) = none := rfl +/-- Eta reconstruction uses every generated projector in constructor-field +order, including the projector whose motive depends on the earlier field. -/ +example : dependentRecordView.etaRebuild symbolicLevels symbolicParams + (.bvar 0) = + VExpr.appN (.const ``DependentRecord.mk symbolicLevels) + (symbolicParams ++ + [.app keyCode.projector (.bvar 0), + .app valueCode.projector (.bvar 0)]) := rfl + /-! A fully constrained `VEnv.TrProj` witness in a universe-polymorphic local context. -/ diff --git a/Lean4Lean/Tests/TheoryConsumerSurface.lean b/Lean4Lean/Tests/TheoryConsumerSurface.lean index b9f2ccf..486050e 100644 --- a/Lean4Lean/Tests/TheoryConsumerSurface.lean +++ b/Lean4Lean/Tests/TheoryConsumerSurface.lean @@ -1,4 +1,5 @@ import Lean4Lean.Theory.Literals +import Lean4Lean.Theory.Projection import Lean4Lean.Theory.Typing.InductiveLemmas import Lean4Lean.Theory.Typing.UniqueTyping @@ -24,6 +25,9 @@ namespace Lean4Lean.Tests.TheoryConsumerSurface #check VEnv.SpineWF.weakN_inv #check VEnv.SpineWF.weak'_inv #check VInductDecl.ElimMode.ofBool +#check VStructureView.etaRebuild +#check VStructureView.ProgramsWF.projectionArgsSpine +#check VStructureView.ProgramsWF.etaRebuild_hasType_of_constructorPrefix /-- info: 'Lean4Lean.VEnv.reflectedPrimitiveNames' does not depend on any axioms @@ -91,4 +95,28 @@ info: 'Lean4Lean.VInductDecl.ElimMode.ofBool' does not depend on any axioms #guard_msgs in #print axioms VInductDecl.ElimMode.ofBool +/-- +info: 'Lean4Lean.VStructureView.etaRebuild' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VStructureView.etaRebuild + +/-- +info: 'Lean4Lean.VStructureView.ProgramsWF.projectionArgsSpine' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms VStructureView.ProgramsWF.projectionArgsSpine + +/-- +info: 'Lean4Lean.VStructureView.ProgramsWF.etaRebuild_hasType_of_constructorPrefix' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms VStructureView.ProgramsWF.etaRebuild_hasType_of_constructorPrefix + end Lean4Lean.Tests.TheoryConsumerSurface diff --git a/Lean4Lean/Theory/Projection.lean b/Lean4Lean/Theory/Projection.lean index 8c27a57..b4aac62 100644 --- a/Lean4Lean/Theory/Projection.lean +++ b/Lean4Lean/Theory/Projection.lean @@ -1274,6 +1274,16 @@ def projectionArgs (view : VStructureView) (levels : List VLevel) (view.projectionCodes levels params).take count |>.map fun code => .app code.projector major +/-- Rebuild a structure value from all of its canonical generated +projections. This is syntax only: `ProgramsWF.projectionArgsSpine` below +supplies the rule-independent typing evidence, while any equality between +this term and `major` remains an explicit definitional-equality capability. -/ +def etaRebuild (view : VStructureView) (levels : List VLevel) + (params : List VExpr) (major : VExpr) : VExpr := + VExpr.appN (.const view.constructorName levels) + (params ++ view.projectionArgs levels params + (view.specializedFields levels params).length major) + @[simp] theorem projectionArgs_length (view : VStructureView) (levels : List VLevel) (params : List VExpr) (count : Nat) (major : VExpr) (hcount : count ≤ @@ -1563,6 +1573,163 @@ theorem ProgramsWF.projector_hasType_field refine ⟨field, typeBody, hfield, htypeFn, ?_⟩ simpa [projectionArgs] using hout +private theorem ProgramsWF.projectionArgsSpineAux + {view : VStructureView} {env : VEnv} + (self : view.ProgramsWF env) (henv : env.WF) + {U : Nat} {Γ : List VExpr} {levels : List VLevel} + {params : List VExpr} + (hΓ : OnCtx Γ (env.IsType U)) + (hlevels : ∀ level ∈ levels, level.WF U) + (hlevelsLength : levels.length = view.uvars) + (hparamsLength : params.length = view.nparams) + (hparamsSpine : ∃ resultLevel, + env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel)) + {major : VExpr} + (hmajor : env.HasType U Γ major (view.structureType levels params)) + (tailResult : VExpr) : + ∀ {count : Nat}, + count ≤ (view.specializedFields levels params).length → + ∃ cursor, + VExpr.consumeForalls? + (VExpr.forallN (view.specializedFields levels params) tailResult) + (view.projectionArgs levels params count major) = some cursor ∧ + env.SpineWF U Γ + (VExpr.forallN (view.specializedFields levels params) tailResult) + (view.projectionArgs levels params count major) cursor := by + intro count hcount + induction count with + | zero => + exact ⟨_, rfl, rfl⟩ + | succ count ih => + have hcountLt : count < + (view.specializedFields levels params).length := by omega + have hcodeIdx : count < + (view.projectionCodes levels params).length := by + simpa using hcountLt + let code := (view.projectionCodes levels params)[count] + have hcode : + (view.projectionCodes levels params)[count]? = some code := + List.getElem?_eq_getElem hcodeIdx + have hargsLength : + (view.projectionArgs levels params count major).length = count := + view.projectionArgs_length levels params count major + (Nat.le_of_lt hcodeIdx) + obtain ⟨cursor, hconsume, hspine⟩ := + ih (Nat.le_of_lt hcountLt) + obtain ⟨field, semanticBody, hfield, hconsumeDomain⟩ := + VExpr.consumeForalls?_forallN_domain + (view.specializedFields levels params) tailResult + (view.projectionArgs levels params count major) + (by simpa [hargsLength] using hcountLt) + have hcursorShape : cursor = + .forallE + (field.instRevAt + (view.projectionArgs levels params count major) 0) + semanticBody := + Option.some.inj (hconsume.symm.trans hconsumeDomain) + subst cursor + obtain ⟨field', _, hfield', _, hprojectorField⟩ := + self.projector_hasType_field henv hΓ hlevels hlevelsLength + hparamsLength hparamsSpine hcode hmajor + have hfieldEq : field' = field := + Option.some.inj + (hfield'.symm.trans (by simpa [hargsLength] using hfield)) + subst field' + refine ⟨semanticBody.inst (.app code.projector major), ?_, ?_⟩ + · rw [view.projectionArgs_succ levels params count major hcode] + rw [VExpr.consumeForalls?_append, hconsumeDomain] + rfl + · rw [view.projectionArgs_succ levels params count major hcode] + exact hspine.snoc hprojectorField + +/-- All canonical generated projections of a well-typed major form a single +well-typed dependent constructor-field spine. This theorem deliberately +stops at typing: it does not assert structure eta. -/ +theorem ProgramsWF.projectionArgsSpine + {view : VStructureView} {env : VEnv} + (self : view.ProgramsWF env) (henv : env.WF) + {U : Nat} {Γ : List VExpr} {levels : List VLevel} + {params : List VExpr} + (hΓ : OnCtx Γ (env.IsType U)) + (hlevels : ∀ level ∈ levels, level.WF U) + (hlevelsLength : levels.length = view.uvars) + (hparamsLength : params.length = view.nparams) + (hparamsSpine : ∃ resultLevel, + env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel)) + {major : VExpr} + (hmajor : env.HasType U Γ major (view.structureType levels params)) + (tailResult : VExpr) : + env.SpineWF U Γ + (VExpr.forallN (view.specializedFields levels params) tailResult) + (view.projectionArgs levels params + (view.specializedFields levels params).length major) + (VExpr.instRev tailResult + (view.projectionArgs levels params + (view.specializedFields levels params).length major)) := by + obtain ⟨_, _, hspine⟩ := self.projectionArgsSpineAux henv hΓ hlevels + hlevelsLength hparamsLength hparamsSpine hmajor tailResult + (Nat.le_refl _) + apply hspine.retarget + · exact view.projectionArgs_length levels params + (view.specializedFields levels params).length major (by simp) + +/-- Applying the complete canonical projection spine to a constructor prefix +is well typed. The constructor-prefix premise is kept explicit so this +lemma remains independent of any proposed structure-eta equality rule. -/ +theorem ProgramsWF.etaRebuild_hasType_of_constructorPrefix + {view : VStructureView} {env : VEnv} + (self : view.ProgramsWF env) (henv : env.WF) + {U : Nat} {Γ : List VExpr} {levels : List VLevel} + {params : List VExpr} + (hΓ : OnCtx Γ (env.IsType U)) + (hlevels : ∀ level ∈ levels, level.WF U) + (hlevelsLength : levels.length = view.uvars) + (hparamsLength : params.length = view.nparams) + (hparamsSpine : ∃ resultLevel, + env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel)) + {major : VExpr} + (hmajor : env.HasType U Γ major (view.structureType levels params)) + (hconstructorPrefix : env.HasType U Γ + (VExpr.appN (.const view.constructorName levels) params) + (VExpr.forallN (view.specializedFields levels params) + ((view.structureType levels params).liftN + (view.specializedFields levels params).length))) : + env.HasType U Γ (view.etaRebuild levels params major) + (view.structureType levels params) := by + have hfields := self.projectionArgsSpine henv hΓ hlevels hlevelsLength + hparamsLength hparamsSpine hmajor + ((view.structureType levels params).liftN + (view.specializedFields levels params).length) + have hrebuild := hfields.hasType_appN hconstructorPrefix + let args := view.projectionArgs levels params + (view.specializedFields levels params).length major + have hargsLength : + args.length = (view.specializedFields levels params).length := + view.projectionArgs_length levels params + (view.specializedFields levels params).length major (by simp) + have hlift : + (view.structureType levels params).liftN + (view.specializedFields levels params).length = + (view.structureType levels params).liftN args.length := + congrArg (view.structureType levels params).liftN hargsLength.symm + have hresult : + VExpr.instRev + ((view.structureType levels params).liftN + (view.specializedFields levels params).length) + args = + view.structureType levels params := by + calc + _ = VExpr.instRev + ((view.structureType levels params).liftN args.length) args := + congrArg (VExpr.instRev · args) hlift + _ = view.structureType levels params := + VExpr.instRev_liftN_len args _ + rw [hresult] at hrebuild + simpa [etaRebuild, VExpr.appN_append] using hrebuild + /-- Exact registration of the checked structure artifact in a Theory environment. These are concrete lookups and generated iota rules, not an oracle supplied by a projection consumer. -/ diff --git a/plans/roadmap.md b/plans/roadmap.md index 4b871ab..60f10be 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -563,6 +563,17 @@ missing reconstruction equation not apply, proof irrelevance covers only `Prop`, and projection uniqueness is not structure extensionality. No `IsDefEq` rule has been changed. +The rule-independent subject-reduction prerequisite is now explicit in +`Theory/Projection.lean`. `VStructureView.etaRebuild` is the canonical +constructor applied to every generated projector; +`ProgramsWF.projectionArgsSpine` assembles the pointwise projector +certificates into the exact dependent field `SpineWF`; and +`etaRebuild_hasType_of_constructorPrefix` proves the rebuild well typed from +the registered constructor-prefix typing judgment. The Theory-only consumer +test pins all three public names and their exact transitive axiom closures. +This adds no `sorry` and, deliberately, proves no reconstruction equality: +that last step is precisely the pending semantic decision. + The proposed upstream decision is an explicit registered structure-eta rule, restricted to checked nonrecursive, single-constructor, zero-index structure views. Acceptance requires: subject reduction from the registered constructor From ae6ee9d61b495e1083ec3fb969879fe89849d8b1 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Tue, 11 Aug 2026 11:33:14 -0400 Subject: [PATCH 27/27] verify: prove structure eta roots behind capability --- Lean4Lean/Tests/StructureEtaCapability.lean | 55 ++ Lean4Lean/Theory/Projection.lean | 122 +++- Lean4Lean/Theory/Typing/InductiveLemmas.lean | 11 + .../Theory/Typing/InductivePatternWF.lean | 34 + Lean4Lean/TypeChecker.lean | 21 +- Lean4Lean/Verify/TypeChecker/Basic.lean | 51 ++ Lean4Lean/Verify/TypeChecker/IsDefEq.lean | 688 ++++++++++++++++++ plans/roadmap.md | 12 + 8 files changed, 990 insertions(+), 4 deletions(-) create mode 100644 Lean4Lean/Tests/StructureEtaCapability.lean diff --git a/Lean4Lean/Tests/StructureEtaCapability.lean b/Lean4Lean/Tests/StructureEtaCapability.lean new file mode 100644 index 0000000..3a46d99 --- /dev/null +++ b/Lean4Lean/Tests/StructureEtaCapability.lean @@ -0,0 +1,55 @@ +import Lean4Lean.Verify.TypeChecker.IsDefEq + +/-! +# Conditional structure-eta checker surface + +The executable checker roots remain at the L4L-15B upstream semantic gate. +These guards pin the proof-complete conditional bridge: host metadata must +resolve to a registered structure artifact and the Theory environment must +supply the missing reconstruction equality explicitly. +-/ + +namespace Lean4Lean.Tests.StructureEtaCapability + +open Lean4Lean.TypeChecker.Inner + +#check VEnv.HasStructureEta +#check StructureEtaArtifact +#check StructureEtaReady +#check tryEtaStructCore.WF_of_structureEta +#check isDefEqUnitLike.WF_of_structureEta + +/-- +info: 'Lean4Lean.VEnv.HasStructureEta' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.HasStructureEta + +/-- +info: 'Lean4Lean.TypeChecker.Inner.tryEtaStructCore.WF_of_structureEta' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + Lean.Expr.eqv_eq, + Lean.Level.instLawfulBEqLevel, + Lean.PersistentArray.toList'_push, + Lean.Syntax.structEq_eq, + Lean.PersistentHashMap.WF.find?_eq, + Lean.PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms tryEtaStructCore.WF_of_structureEta + +/-- +info: 'Lean4Lean.TypeChecker.Inner.isDefEqUnitLike.WF_of_structureEta' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + Lean.PersistentArray.toList'_push, + Lean.PersistentHashMap.WF.find?_eq, + Lean.PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms isDefEqUnitLike.WF_of_structureEta + +end Lean4Lean.Tests.StructureEtaCapability diff --git a/Lean4Lean/Theory/Projection.lean b/Lean4Lean/Theory/Projection.lean index b4aac62..d29a4c1 100644 --- a/Lean4Lean/Theory/Projection.lean +++ b/Lean4Lean/Theory/Projection.lean @@ -653,7 +653,8 @@ private theorem VEnv.OnSortTel.instRevParams {env : VEnv} rw [← hparams, VExpr.instRevAt_instTelN_cons] at hout exact hout -private theorem VEnv.OnTel.toOnCtx {env : VEnv} {U : Nat} : +/-- Extend a well-formed ambient context by a well-formed telescope. -/ +theorem VEnv.OnTel.toOnCtx {env : VEnv} {U : Nat} : ∀ {As Γ}, env.OnTel U Γ As → OnCtx Γ (env.IsType U) → OnCtx (As.reverse ++ Γ) (env.IsType U) | [], _, _, hΓ => by simpa using hΓ @@ -1784,6 +1785,28 @@ theorem WF.rule_mem (self : VStructureView.WF view env) {df : VDefEq} VEnv.defeqs env df := self.rules df h +/-- The semantic capability required by structure-eta consumers. + +`VStructureView.WF` and `ProgramsWF` account for the registered structure +artifact and the typing of its generated projectors. This property records +only the additional equality that those rule-independent certificates do not +derive: rebuilding every canonical projection is definitionally equal to the +original major premise. Keeping it as an explicit environment capability +prevents checker verification from silently extending `VEnv.IsDefEq`. -/ +def _root_.Lean4Lean.VEnv.HasStructureEta (env : VEnv) : Prop := + ∀ (view : VStructureView), view.WF env → view.ProgramsWF env → + ∀ {U : Nat} {Γ : List VExpr} {levels : List VLevel} + {params : List VExpr} {major : VExpr}, + OnCtx Γ (env.IsType U) → + (∀ level ∈ levels, level.WF U) → + levels.length = view.uvars → + params.length = view.nparams → + (∃ resultLevel, env.SpineWF U Γ (view.familyType.instL levels) + params (.sort resultLevel)) → + env.HasType U Γ major (view.structureType levels params) → + env.IsDefEq U Γ (view.etaRebuild levels params major) major + (view.structureType levels params) + theorem Registered.mono {env env' : VEnv} (henv : env ≤ env') (self : VStructureView.Registered view env) : VStructureView.Registered view env' where @@ -2140,6 +2163,103 @@ theorem _root_.Lean4Lean.VStructureView.WF.constructorParamsSpine (by simpa [VStructureView.constructorParams] using hparamsLength.trans hconstructorShape.2.2.1.symm) target +/-- Recover the structure-family parameter spine from the corresponding +constructor-parameter prefix. This is the converse consumer bridge needed +when a checker recognizes a fully applied constructor before it knows the +family application carried by its result type. -/ +theorem _root_.Lean4Lean.VStructureView.WF.familyParamsSpine_of_constructor + (self : VStructureView.WF view env) (henv : env.Ordered) + {U : Nat} {Γ : List VExpr} (levels : List VLevel) + (hlevels : ∀ level ∈ levels, level.WF U) + (hlevelsLength : levels.length = view.uvars) + (params : List VExpr) (hparamsLength : params.length = view.nparams) + {target cursor : VExpr} + (constructorSpine : env.SpineWF U Γ + (VExpr.forallN + (view.constructorParams.map (VExpr.instL levels)) target) + params cursor) + (resultLevel : VLevel) + (hresult : view.generation.block.rawResult = .sort resultLevel) : + env.SpineWF U Γ (view.familyType.instL levels) params + (.sort (resultLevel.inst levels)) := by + let S := self.toGenerationEnv henv + have hrawLength : + view.generation.block.rawParams.length = view.nparams := + view.generation.shape.1 + have hconstructorMem : + view.constructor ∈ view.generation.block.ctorPairs := by + simp [view.constructor_eq] + have hconstructorShape := + view.generation.shape.2.2.2.2.2 view.constructor hconstructorMem + have hconstructorLength : params.length = + (view.constructorParams.map (VExpr.instL levels)).length := by + simpa [VStructureView.constructorParams] using + hparamsLength.trans hconstructorShape.2.2.1.symm + have hparamsConstructor : env.SpineWF U Γ + (VExpr.forallN + (view.constructorParams.map (VExpr.instL levels)) (.sort .zero)) + params (.sort .zero) := by + have hout := constructorSpine.retarget hconstructorLength (.sort .zero) + rw [VExpr.instRev_closedN params (by trivial)] at hout + exact hout + have hfamilyDefEq := S.rawParams_defeq.instL hlevels + have hrawLift : VExpr.liftTelN Γ.length + (view.generation.block.rawParams.map (VExpr.instL levels)) 0 = + view.generation.block.rawParams.map (VExpr.instL levels) := by + simpa using VEnv.OnTel.liftTelN_eq henv + hfamilyDefEq.raw_onTel (by trivial) Γ.length + have hcheckedLift : VExpr.liftTelN Γ.length + (view.generation.block.checked.params.map (VExpr.instL levels)) 0 = + view.generation.block.checked.params.map (VExpr.instL levels) := by + simpa using VEnv.OnTel.liftTelN_eq henv + (hfamilyDefEq.view_onTel henv) (by trivial) Γ.length + have hfamilyDefEqΓ := hfamilyDefEq.weakN henv + (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ) + rw [hrawLift, hcheckedLift] at hfamilyDefEqΓ + simp only [List.append_nil] at hfamilyDefEqΓ + have hconstructorDefEq₀ := + ((S.ctorWF view.constructor hconstructorMem).declaredTel.take + view.nparams).instL hlevels + have hconstructorDefEq : env.TelDefEq U [] + (view.constructorParams.map (VExpr.instL levels)) + (view.generation.block.checked.params.map (VExpr.instL levels)) := by + simpa [VStructureView.constructorParams, + VInductDecl.NormalizedCtor.declaredBinders, + VInductDecl.NormalizedCtor.viewBinders, + hconstructorShape.2.2.1, self.parameters_length] using + hconstructorDefEq₀ + have hconstructorRawLift : VExpr.liftTelN Γ.length + (view.constructorParams.map (VExpr.instL levels)) 0 = + view.constructorParams.map (VExpr.instL levels) := by + simpa using VEnv.OnTel.liftTelN_eq henv + hconstructorDefEq.raw_onTel (by trivial) Γ.length + have hconstructorDefEqΓ := hconstructorDefEq.weakN henv + (Ctx.LiftN.zero (n := Γ.length) (Γ := []) Γ) + rw [hconstructorRawLift, hcheckedLift] at hconstructorDefEqΓ + simp only [List.append_nil] at hconstructorDefEqΓ + have hparamsChecked : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.checked.params.map (VExpr.instL levels)) + (.sort .zero)) params (.sort .zero) := + VEnv.TelDefEq.spine_sort_view henv hconstructorDefEqΓ + hparamsConstructor hconstructorLength + have hrawParamsLength : params.length = + (view.generation.block.rawParams.map (VExpr.instL levels)).length := by + simpa [hrawLength] using hparamsLength + have hparamsRaw : env.SpineWF U Γ + (VExpr.forallN + (view.generation.block.rawParams.map (VExpr.instL levels)) + (.sort .zero)) params (.sort .zero) := + VEnv.TelDefEq.spine_sort henv hfamilyDefEqΓ hparamsChecked + hrawParamsLength + have hout := hparamsRaw.retarget hrawParamsLength + (.sort (resultLevel.inst levels)) + rw [VExpr.instRev_closedN params (by trivial)] at hout + simpa [VStructureView.familyType, + VInductDecl.NormalizedChecked.rawType_eq, + view.raw_indices_eq, hresult, VExpr.instL_forallN, + VExpr.forallN, VExpr.instL] using hout + theorem _root_.Lean4Lean.VStructureView.WF.specializedFields_onSortTel (self : VStructureView.WF view env) (henv : env.Ordered) {U : Nat} {Γ : List VExpr} (levels : List VLevel) diff --git a/Lean4Lean/Theory/Typing/InductiveLemmas.lean b/Lean4Lean/Theory/Typing/InductiveLemmas.lean index 0efa7a9..d6771ec 100644 --- a/Lean4Lean/Theory/Typing/InductiveLemmas.lean +++ b/Lean4Lean/Theory/Typing/InductiveLemmas.lean @@ -1760,6 +1760,17 @@ theorem SpineWF.append {env : VEnv} {U : Nat} {Γ : List VExpr} : | _ :: _, _, _, ⟨A₁, A₂, rfl, he, hrest⟩, _, _, h' => ⟨A₁, A₂, rfl, he, SpineWF.append hrest h'⟩ +/-- Split a well-typed application spine at an explicit list prefix. -/ +theorem SpineWF.split {env : VEnv} {U : Nat} {Γ : List VExpr} : + ∀ {front suffix : List VExpr} {A B : VExpr}, + env.SpineWF U Γ A (front ++ suffix) B → + ∃ cursor, env.SpineWF U Γ A front cursor ∧ + env.SpineWF U Γ cursor suffix B + | [], suffix, A, B, h => ⟨A, rfl, by simpa using h⟩ + | _ :: front, suffix, _, _, ⟨A₁, A₂, rfl, he, hrest⟩ => by + obtain ⟨cursor, hfront, hsuffix⟩ := SpineWF.split hrest + exact ⟨cursor, ⟨A₁, A₂, rfl, he, hfront⟩, hsuffix⟩ + /-- Extend a well-typed application spine by one final argument. -/ theorem SpineWF.snoc {env : VEnv} {U : Nat} {Γ : List VExpr} {e D C : VExpr} : ∀ {es : List VExpr} {A : VExpr}, env.SpineWF U Γ A es (.forallE D C) → diff --git a/Lean4Lean/Theory/Typing/InductivePatternWF.lean b/Lean4Lean/Theory/Typing/InductivePatternWF.lean index 519253d..2c0806c 100644 --- a/Lean4Lean/Theory/Typing/InductivePatternWF.lean +++ b/Lean4Lean/Theory/Typing/InductivePatternWF.lean @@ -234,6 +234,40 @@ theorem VEnv.IsDefEq.appN_lamN {env : VEnv} (henv : env.Ordered) {U : Nat} : rw [hlen2] exact hstep.trans IH +/-- Instantiate a terminal definitional equality through a saturated telescope spine. -/ +theorem VEnv.SpineWF.instRev_defeq + {env : VEnv} (henv : env.Ordered) {U : Nat} {Γ : List VExpr} : + ∀ {As : List VExpr} {C C' T : VExpr} {es : List VExpr} {B : VExpr}, + env.SpineWF U Γ (VExpr.forallN As C) es B → + es.length = As.length → + env.IsDefEq U (As.reverse ++ Γ) C C' T → + env.IsDefEq U Γ (VExpr.instRev C es) (VExpr.instRev C' es) + (VExpr.instRev T es) + | [], C, C', T, [], B, hspine, _, hterminal => by + simpa [VExpr.instRev] using hterminal + | [], _, _, _, _ :: _, _, _, hlen, _ => by simp at hlen + | _ :: _, _, _, _, [], _, _, hlen, _ => by simp at hlen + | A :: As, C, C', T, e :: es, B, + ⟨A₁, A₂, hshape, he, hrest⟩, hlen, hterminal => by + change VExpr.forallE A (VExpr.forallN As C) = + VExpr.forallE A₁ A₂ at hshape + injection hshape with hA htail + subst A₁ + subst A₂ + have hlen' : es.length = As.length := by simpa using hlen + have W := Ctx.InstN.consTel (Γ₀ := Γ) (e₀ := e) (A₀ := A) As .zero + have hterminal₀ : env.IsDefEq U (As.reverse ++ A :: Γ) C C' T := by + simpa [List.reverse_cons, List.append_assoc] using hterminal + have hterminal' := hterminal₀.instN henv he W + have hrest' : env.SpineWF U Γ + (VExpr.forallN (VExpr.instTelN e As 0) + (C.inst e As.length)) es B := by + rw [VExpr.instN_forallN] at hrest + simpa using hrest + have hout := VEnv.SpineWF.instRev_defeq henv hrest' + (by simpa [VExpr.instTelN_length] using hlen') hterminal' + simpa [VExpr.instRev, hlen'] using hout + /-- Iterated inversion of a lambda tower's typing: the telescope is well-formed and the body is typed under it. -/ theorem VEnv.HasType.lamN_wf {env : VEnv} {U : Nat} (henv : env.Ordered) : diff --git a/Lean4Lean/TypeChecker.lean b/Lean4Lean/TypeChecker.lean index cf9a2b0..bce4d6d 100644 --- a/Lean4Lean/TypeChecker.lean +++ b/Lean4Lean/TypeChecker.lean @@ -537,6 +537,19 @@ def tryEtaExpansionCore (t s : Expr) : RecM Bool := do def tryEtaExpansion (t s : Expr) : RecM Bool := tryEtaExpansionCore t s <||> tryEtaExpansionCore s t +/-- One field comparison in the structure-eta fast path. Naming the +callback keeps the executable range loop and its verification aligned without +depending on proof terms synthesized by `for` notation. -/ +def tryEtaStructFieldStep (t : Expr) (induct : Name) (numParams : Nat) + (args : Array Expr) (i : Nat) (_ : i ∈ [numParams:args.size]) + (_ : Option Bool × PUnit) : + RecM (ForInStep (Option Bool × PUnit)) := do + let b ← isDefEq (.proj induct (i - numParams) t) args[i] + if b = true then + pure (.yield ⟨none, PUnit.unit⟩) + else + pure (.done ⟨some false, PUnit.unit⟩) + def tryEtaStructCore (t s : Expr) : RecM Bool := do let .const f _ := s.getAppFn | return false let env ← getEnv @@ -545,9 +558,11 @@ def tryEtaStructCore (t s : Expr) : RecM Bool := do unless env.isNonRecStructure fInfo.induct do return false unless ← isDefEq (← inferType t) (← inferType s) do return false let args := s.getAppArgs - for h : i in [fInfo.numParams:args.size] do - unless ← isDefEq (.proj fInfo.induct (i - fInfo.numParams) t) args[i] do return false - return true + let r ← forIn' [fInfo.numParams:args.size] ⟨none, PUnit.unit⟩ + (tryEtaStructFieldStep t fInfo.induct fInfo.numParams args) + match r.1 with + | none => return true + | some b => return b def tryEtaStruct (t s : Expr) : RecM Bool := tryEtaStructCore t s <||> tryEtaStructCore s t diff --git a/Lean4Lean/Verify/TypeChecker/Basic.lean b/Lean4Lean/Verify/TypeChecker/Basic.lean index a05c736..ff1c258 100644 --- a/Lean4Lean/Verify/TypeChecker/Basic.lean +++ b/Lean4Lean/Verify/TypeChecker/Basic.lean @@ -139,6 +139,57 @@ structure ProjectionReady (env : Environment) (venv : VEnv) : Prop where env.find? view.constructorName = some (.ctorInfo info) → info.numParams = view.nparams +/-- Exact host/Theory alignment for one constructor/family pair accepted by +the runtime structure-eta heuristics. The underlying projection artifact +supplies the registered Theory view and its typed projector programs; the two +equalities identify that artifact with the precise host constructor lookup +which triggered the heuristic. -/ +structure StructureEtaArtifact (env : Environment) (familyName : Name) + (familyInfo : InductiveVal) (constructorName : Name) + (constructorInfo : ConstructorVal) (venv : VEnv) where + projection : ProjectionArtifact env familyName familyInfo venv + constructor_name_eq : projection.view.constructorName = constructorName + constructor_info_eq : projection.constructorInfo = constructorInfo + +/-- Host-metadata coherence required whenever the executable checker accepts +a family/constructor pair as a nonrecursive structure. This deliberately +contains no Theory equality: `VEnv.HasStructureEta` is the separate semantic +capability consumed by the verification theorem. -/ +structure StructureEtaReady (env : Environment) (venv : VEnv) : Prop where + resolve : ∀ familyName familyInfo constructorName constructorInfo, + env.find? familyName = some (.inductInfo familyInfo) → + env.find? constructorName = some (.ctorInfo constructorInfo) → + env.isNonRecStructure familyName = true → + Nonempty (StructureEtaArtifact env familyName familyInfo + constructorName constructorInfo venv) + +/-- Resolve the family artifact named by a constructor lookup after the +runtime nonrecursive-structure test has succeeded. -/ +theorem StructureEtaReady.resolveConstructor + (self : StructureEtaReady env venv) + (hctor : env.find? constructorName = some (.ctorInfo constructorInfo)) + (hnonrec : env.isNonRecStructure constructorInfo.induct = true) : + ∃ familyInfo, + env.find? constructorInfo.induct = some (.inductInfo familyInfo) ∧ + Nonempty (StructureEtaArtifact env constructorInfo.induct familyInfo + constructorName constructorInfo venv) := by + have hshape := hnonrec + unfold Kernel.Environment.isNonRecStructure at hshape + generalize hfamily : env.find? constructorInfo.induct = found at hshape + cases found with + | none => simp at hshape + | some info => cases info with + | inductInfo familyInfo => + exact ⟨familyInfo, rfl, + self.resolve _ _ _ _ hfamily hctor hnonrec⟩ + | axiomInfo _ => simp at hshape + | defnInfo _ => simp at hshape + | thmInfo _ => simp at hshape + | opaqueInfo _ => simp at hshape + | quotInfo _ => simp at hshape + | ctorInfo _ => simp at hshape + | recInfo _ => simp at hshape + /-- Environments which contain no constructor metadata satisfy projection readiness vacuously. This is the common staging case for validation fixtures: families may already be present, but their constructors have not been diff --git a/Lean4Lean/Verify/TypeChecker/IsDefEq.lean b/Lean4Lean/Verify/TypeChecker/IsDefEq.lean index 992ae6a..9e21a8c 100644 --- a/Lean4Lean/Verify/TypeChecker/IsDefEq.lean +++ b/Lean4Lean/Verify/TypeChecker/IsDefEq.lean @@ -1,4 +1,5 @@ import Lean4Lean.Verify.TypeChecker.Reduce +import Lean4Lean.Verify.TypeChecker.InferType import Lean4Lean.Verify.EquivManager open Lean4Lean @@ -223,6 +224,546 @@ theorem tryEtaExpansion.WF {c : VContext} {s : VState} split <;> [exact .pure fun _ => h rfl; skip] exact (tryEtaExpansionCore.WF he₂ he₁).mono fun _ _ _ h hb => (h hb).symm +private theorem AppStack.toSpineWF_of_isType {c : VContext} + (H : AppStack c.venv c.lparams c.vlctx f f' args) + (hf : c.HasType f' (VExpr.forallN As (.sort resultLevel))) + (hfull : c.TrExprS (f.mkAppList args) full') + (hfullType : c.venv.IsType c.lparams.length c.vlctx.toCtx full') : + ∃ args', args.Forall₂ (c.TrExprS · ·) args' ∧ + c.venv.SpineWF c.lparams.length c.vlctx.toCtx + (VExpr.forallN As (.sort resultLevel)) args' (.sort resultLevel) ∧ + c.TrExprS (f.mkAppList args) (VExpr.appN f' args') := by + induction args generalizing f f' As full' with + | nil => + let .head hhead := H + cases As with + | nil => + refine ⟨[], .nil, rfl, ?_⟩ + change c.TrExprS f f' + exact hhead + | cons A As => + obtain ⟨sortLevel, hfullSort⟩ := hfullType + have hheadEq := hhead.uniq c.Ewf (.refl c.Ewf c.Δwf) hfull + have hheadSort := hfullSort.defeqU_l c.Ewf c.Δwf hheadEq.symm + have htypes := hf.uniqU c.Ewf c.Δwf hheadSort + exact False.elim <| + VEnv.IsDefEqU.sort_forallE_inv c.Ewf c.Δwf htypes.symm + | cons arg args ih => + let .app hfun harg hhead hargTr Hrest := H + cases As with + | nil => + have htypes := hf.uniqU c.Ewf c.Δwf hfun + exact False.elim <| + VEnv.IsDefEqU.sort_forallE_inv c.Ewf c.Δwf htypes + | cons A As => + have htypes := hf.uniqU c.Ewf c.Δwf hfun + obtain ⟨⟨_, hdomain⟩, _, _hcodomain⟩ := + htypes.forallE_inv c.Ewf c.Δwf + have hargA := harg.defeqU_r c.Ewf c.Δwf ⟨_, hdomain.symm⟩ + have htailType := hf.app hargA + rw [VExpr.instN_forallN] at htailType + obtain ⟨args', hargs, hspine, htailFull⟩ := + ih Hrest htailType (by simpa [Expr.mkAppList] using hfull) + hfullType + refine ⟨_ :: args', .cons hargTr hargs, + ⟨A, VExpr.forallN As (.sort resultLevel), rfl, hargA, ?_⟩, ?_⟩ + · rw [VExpr.instN_forallN] + rw [Nat.zero_add] + rw [(show (VExpr.sort resultLevel).ClosedN 0 by trivial).instN_eq + (e2 := _) (Nat.zero_le As.length)] + exact hspine + · simpa [Expr.mkAppList, VExpr.appN] using htailFull + +private theorem forall₂_of_getElem? {R : α → β → Prop} : + ∀ {xs : List α} {ys : List β}, + xs.length = ys.length → + (∀ (i : Nat) (x : α) (y : β), + xs[i]? = some x → ys[i]? = some y → R x y) → + List.Forall₂ R xs ys + | [], [], _, _ => .nil + | [], _ :: _, hlen, _ => by simp at hlen + | _ :: _, [], hlen, _ => by simp at hlen + | x :: xs, y :: ys, hlen, h => by + refine .cons (h 0 x y (by simp) (by simp)) ?_ + apply forall₂_of_getElem? (Nat.succ.inj hlen) + intro i x' y' hx hy + exact h (i + 1) x' y' (by simpa using hx) (by simpa using hy) + + +theorem tryEtaStructCore.WF_of_structureEta {c : VContext} {s : VState} + (ready : StructureEtaReady c.env c.venv) + (eta : c.venv.HasStructureEta) + (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : + RecM.WF c s (tryEtaStructCore e₁ e₂) fun b _ => b → c.IsDefEqU e₁' e₂' := by + unfold tryEtaStructCore + split <;> [skip; exact .pure nofun] + refine .getEnv ?_ + refine (M.WF.liftExcept envGet.WF).lift.bind fun _ci _ _ hfind => ?_ + split <;> [skip; exact .pure nofun] + extract_lets F1 F2 + split <;> [skip; exact .pure nofun] + rename_i hostHead ctorName ctorLevels hhead state hstate hostInfo ctorInfo + inferLoop nonrecLoop hargs + simp only [pure_bind] + unfold nonrecLoop + split <;> [skip; exact .pure nofun] + rename_i hnonrec + simp only [pure_bind] + unfold inferLoop + refine (inferType.WF he₁).bind fun _ _ _ + ⟨ty₁', _aBelow, _aTerm, aType, aTyped⟩ => ?_ + refine (inferType.WF he₂).bind fun _ _ _ + ⟨ty₂', _bBelow, _bTerm, bType, bTyped⟩ => ?_ + refine (isDefEq.WF aType bType).bind fun _ _ _ htypes => ?_ + split <;> [skip; exact .pure nofun] + rename_i htypesTrue + simp only [pure_bind] + unfold F2 + obtain ⟨familyInfo, hfamily, ⟨artifact⟩⟩ := + ready.resolveConstructor hfind hnonrec + have ⟨head', hstack⟩ := AppStack.build <| + e₂.mkAppList_getAppArgsList ▸ he₂ + have hheadTr := hstack.tr + rw [hhead] at hheadTr + let .const (us' := levels) hconst hlevelsMap hlevelsHostLength := hheadTr + have hviewConstructor := artifact.projection.viewWF.constructor + rw [artifact.constructor_name_eq] at hviewConstructor + rw [hviewConstructor] at hconst + cases hconst + have hlevelsWF : ∀ level ∈ levels, + level.WF c.lparams.length := + VLevel.WF.of_mapM_ofLevel hlevelsMap + have hrawCtorUvars : artifact.projection.view.constructor.raw.uvars = + artifact.projection.view.uvars := + artifact.projection.view.generation.ctor_uvars_eq + (by simp [artifact.projection.view.constructor_eq]) + have hlevelsLength : levels.length = artifact.projection.view.uvars := + (List.mapM_eq_some.1 hlevelsMap).length_eq.symm.trans <| + hlevelsHostLength.trans hrawCtorUvars + have hctorHead : c.HasType (.const ctorName levels) + (artifact.projection.view.constructor.raw.type.instL levels) := + VEnv.HasType.const hviewConstructor hlevelsWF + (hlevelsLength.trans hrawCtorUvars.symm) + let ctorBinders := + (artifact.projection.view.constructor.declaredBinders + artifact.projection.view.nparams).map (VExpr.instL levels) + let ctorResult := + (artifact.projection.view.constructor.rawResult + artifact.projection.view.nparams).instL levels + have hctorHeadShape : c.HasType (.const ctorName levels) + (VExpr.forallN ctorBinders ctorResult) := by + rw [artifact.projection.view.constructor.rawType_eq] at hctorHead + simpa [ctorBinders, ctorResult, VExpr.instL_forallN] using hctorHead + have hhostArgsLength : e₂.getAppArgsList.length = + ctorInfo.numParams + ctorInfo.numFields := by + simpa [Expr.getAppNumArgs_eq, ← Expr.getAppArgsList_reverse] using hargs + have hnumParams : ctorInfo.numParams = artifact.projection.view.nparams := by + exact (congrArg ConstructorVal.numParams + artifact.constructor_info_eq).symm.trans + artifact.projection.constructor_numParams_eq + have hnumFields : ctorInfo.numFields = artifact.projection.view.fields.length := by + exact (congrArg ConstructorVal.numFields + artifact.constructor_info_eq).symm.trans + artifact.projection.constructor_numFields_eq + have hconstructorMem : artifact.projection.view.constructor ∈ + artifact.projection.view.generation.block.ctorPairs := by + simp [artifact.projection.view.constructor_eq] + have hconstructorShape := + artifact.projection.view.generation.shape.2.2.2.2.2 + artifact.projection.view.constructor hconstructorMem + have hhostBinderLength : e₂.getAppArgsList.length = ctorBinders.length := by + simpa [ctorBinders, VInductDecl.NormalizedCtor.declaredBinders, + VStructureView.fields, hnumParams, hnumFields, + hconstructorShape.2.2.1] using hhostArgsLength + obtain ⟨args', hargsTr, hargsSpine, hfullTr⟩ := + AppStack.toSpineWF hstack hctorHeadShape hhostBinderLength + rw [e₂.mkAppList_getAppArgsList] at hfullTr + have hargsLength : args'.length = artifact.projection.view.nparams + + artifact.projection.view.fields.length := + hargsTr.length_eq.symm.trans <| by + simpa [hnumParams, hnumFields] using hhostArgsLength + let params := args'.take artifact.projection.view.nparams + let fields := args'.drop artifact.projection.view.nparams + have hargsSplit : args' = params ++ fields := by + simpa [params, fields] using + (List.take_append_drop artifact.projection.view.nparams args').symm + have hparamsLength : params.length = artifact.projection.view.nparams := by + simp [params, hargsLength] + have hfieldsLength : fields.length = artifact.projection.view.fields.length := by + simp [fields, hargsLength] + have hargsSpineSplit := hargsSpine + rw [hargsSplit] at hargsSpineSplit + obtain ⟨paramCursor, hparamRaw, hfieldsRaw⟩ := + hargsSpineSplit.split + let ctorTail := VExpr.forallN + (artifact.projection.view.fields.map (VExpr.instL levels)) ctorResult + have hparamCtor : c.venv.SpineWF c.lparams.length c.vlctx.toCtx + (VExpr.forallN + (artifact.projection.view.constructorParams.map + (VExpr.instL levels)) ctorTail) + params paramCursor := by + simpa [ctorBinders, ctorTail, + VInductDecl.NormalizedCtor.declaredBinders, + VStructureView.constructorParams, VStructureView.fields, + List.map_append, VExpr.forallN_append] using hparamRaw + obtain ⟨resultLevel, hrawResult⟩ := artifact.projection.rawResult_sort + have hparamsSpine := + artifact.projection.viewWF.familyParamsSpine_of_constructor + c.Ewf.ordered levels hlevelsWF hlevelsLength params hparamsLength + hparamCtor resultLevel hrawResult + have hdeclResult₀ := + artifact.projection.viewWF.generationSemantics.constructor.declaredResult + have hdeclResult₁ := hdeclResult₀.instL hlevelsWF + have hdeclResult : c.venv.IsDefEq c.lparams.length + ctorBinders.reverse ctorResult + ((VInductDecl.NormalizedCtor.resultTarget + artifact.projection.view.generation.block + artifact.projection.view.constructor).instL levels) + ((VExpr.sort + artifact.projection.view.generation.block.checked.resultLevel).instL + levels) := by + simpa [ctorBinders, ctorResult, List.map_reverse] using hdeclResult₁ + have hdeclTel₀ := + artifact.projection.viewWF.generationSemantics.constructor.declaredTel + have hdeclTel := hdeclTel₀.instL hlevelsWF + have hctorOnTel : c.venv.OnTel c.lparams.length [] ctorBinders := by + simpa [ctorBinders] using hdeclTel.raw_onTel + have hctorCtxClosed : CtxClosed ctorBinders.reverse := + VEnv.CtxWF.closed c.Ewf.ordered <| by + simpa using hctorOnTel.toOnCtx (by trivial) + have hdeclResultΓ := hdeclResult.weakR c.Ewf.ordered hctorCtxClosed + c.vlctx.toCtx + have hargsTelLength : args'.length = ctorBinders.length := + hargsTr.length_eq.symm.trans hhostBinderLength + have hresultEq := hargsSpine.instRev_defeq c.Ewf.ordered + hargsTelLength hdeclResultΓ + let S := artifact.projection.viewWF.toGenerationEnv c.Ewf.ordered + have hresultIndices : + artifact.projection.view.constructor.view.resultIndices = [] := by + apply List.length_eq_zero_iff.1 + rw [S.viewResultIndices_length hconstructorMem] + simp [artifact.projection.view.checked_indices_eq] + have hrange := VExpr.map_instRev_bvarRevRange_seg args' + artifact.projection.view.nparams artifact.projection.view.fields.length + (by omega) + have hrange' : + (VExpr.bvarRevRange + (artifact.projection.view.constructor.rawFields + artifact.projection.view.source.nparams).length + artifact.projection.view.source.nparams).map (VExpr.instRev · args') = + params := by + simpa [VStructureView.fields, hargsLength, params] using hrange + have htarget : + ((VInductDecl.NormalizedCtor.resultTarget + artifact.projection.view.generation.block + artifact.projection.view.constructor).instL levels).instRev args' = + artifact.projection.view.structureType levels params := by + simp only [VInductDecl.NormalizedCtor.resultTarget, + VExpr.instL_appN, VExpr.instL, VExpr.instRev_appN, VExpr.instRev, + VExpr.bvarRevRange_map_instL, hresultIndices, List.append_nil] + rw [VLevel.inst_map_id hlevelsLength] + rw [VExpr.instRev_closedN args' (by trivial)] + rw [hrange'] + rfl + rw [htarget] at hresultEq + have hcanonicalRaw := hargsSpine.hasType_appN hctorHeadShape + have hcanonical : c.HasType + ((VExpr.const ctorName levels).appN args') + (artifact.projection.view.structureType levels params) := + hcanonicalRaw.defeqU_r c.Ewf c.Δwf ⟨_, hresultEq⟩ + have hfullEq := hfullTr.uniq c.Ewf (.refl c.Ewf c.Δwf) he₂ + have hbStruct := hcanonical.defeqU_l c.Ewf c.Δwf hfullEq + have hty₂Struct := bTyped.uniqU c.Ewf c.Δwf hbStruct + have hty₁Struct := VEnv.IsDefEqU.trans c.Ewf c.Δwf + (htypes htypesTrue) hty₂Struct + have haStruct := aTyped.defeqU_r c.Ewf c.Δwf hty₁Struct + have heta := eta artifact.projection.view artifact.projection.viewWF + artifact.projection.programsWF c.Δwf hlevelsWF hlevelsLength + hparamsLength ⟨_, hparamsSpine⟩ haStruct + have hF1Size : F1.size = args'.length := by + calc + F1.size = F1.toList.length := by simp + _ = e₂.getAppArgsList.length := by simp [F1, Expr.getAppArgs_toList] + _ = args'.length := hargsTr.length_eq + have hfieldData : ∀ (j : Nat), j < fields.length → + ∃ code : VStructureView.ProjectionCode, + (artifact.projection.view.projectionCodes levels params)[j]? = + some code ∧ + c.TrExprS (.proj ctorInfo.induct j e₁) + (.app code.projector e₁') ∧ + ∀ (hi : ctorInfo.numParams + j < F1.size), + c.TrExprS F1[ctorInfo.numParams + j] fields[j] := by + intro j hj + have hcodeIdx : j < + (artifact.projection.view.projectionCodes levels params).length := by + simpa [VStructureView.specializedFields, hfieldsLength] using hj + let code := (artifact.projection.view.projectionCodes levels params)[j] + have hcode : + (artifact.projection.view.projectionCodes levels params)[j]? = + some code := List.getElem?_eq_getElem hcodeIdx + have hprojector := artifact.projection.programsWF c.Δwf hlevelsWF + hlevelsLength hparamsLength ⟨_, hparamsSpine⟩ hcode + have hprojSem : c.venv.TrProj c.lparams.length c.vlctx.toCtx + artifact.projection.view levels params j e₁' + (.app code.projector e₁') := { + viewWF := artifact.projection.viewWF + levelsWF := hlevelsWF + levels_length := hlevelsLength + params_length := hparamsLength + paramsSpine := ⟨_, hparamsSpine⟩ + majorType := haStruct + program := ⟨code, hcode, rfl, hprojector⟩ } + have hprojTr : c.TrExprS (.proj ctorInfo.induct j e₁) + (.app code.projector e₁') := + .proj he₁ ⟨artifact.projection.view, levels, params, + artifact.projection.name_eq, hprojSem⟩ + refine ⟨code, hcode, hprojTr, ?_⟩ + intro hi + have hselectedList : + e₂.getAppArgsList[ctorInfo.numParams + j]? = + some F1[ctorInfo.numParams + j] := by + rw [← Expr.getAppArgs_toList] + simpa [F1] using List.getElem?_eq_getElem hi + obtain ⟨translated, htranslated, htr⟩ := + Lean4Lean.List.Forall₂.getElem?_left hargsTr hselectedList + have hfieldGet : args'[ctorInfo.numParams + j]? = some fields[j] := by + rw [hargsSplit, List.getElem?_append_right] + · simpa [hnumParams, hparamsLength] using + (List.getElem?_eq_getElem hj) + · simpa [hnumParams, hparamsLength] + have : translated = fields[j] := + Option.some.inj (htranslated.symm.trans hfieldGet) + subst translated + exact htr + rw [Std.Legacy.Range.forIn'_eq_forIn'_range'] + simp only [Std.Legacy.Range.size, Nat.add_sub_cancel, Nat.div_one] + let FieldEq := fun (j : Nat) => ∃ (field : VExpr) + (code : VStructureView.ProjectionCode), + fields[j]? = some field ∧ + (artifact.projection.view.projectionCodes levels params)[j]? = some code ∧ + c.IsDefEqU (.app code.projector e₁') field + let etaStep (indices : List Nat) + (hlow : ∀ i, i ∈ indices → ctorInfo.numParams ≤ i) + (hhigh : ∀ i, i ∈ indices → i < F1.size) : + (i : Nat) → i ∈ indices → Option Bool × PUnit → + RecM (ForInStep (Option Bool × PUnit)) := + fun i hi r => tryEtaStructFieldStep e₁ ctorInfo.induct + ctorInfo.numParams F1 i + ⟨hlow i hi, hhigh i hi, by + change (i - ctorInfo.numParams) % 1 = 0 + exact Nat.mod_one _⟩ r + have etaLoopWF : ∀ (all indices : List Nat) + (hsuffix : ∃ pre, pre ++ indices = all) + (hlow : ∀ i, i ∈ all → ctorInfo.numParams ≤ i) + (hhigh : ∀ i, i ∈ all → i < F1.size) {st : VState}, + RecM.WF c st + (List.forIn'.loop all (etaStep all hlow hhigh) indices + ⟨none, PUnit.unit⟩ hsuffix) + fun r _ => + (r.1 = none → + ∀ i, i ∈ indices → FieldEq (i - ctorInfo.numParams)) ∧ + r.1 ≠ some true := by + intro all indices hsuffix hlow hhigh st + induction indices generalizing st with + | nil => + simp only [List.forIn'.loop] + exact .pure (by simp) + | cons i indices ih => + simp only [List.forIn'.loop] + simp only [etaStep, tryEtaStructFieldStep] + obtain ⟨pre, hprefix⟩ := hsuffix + have hiAll : i ∈ all := by + rw [← hprefix] + simp + have hlo := hlow i hiAll + have hhi := hhigh i hiAll + have hj : i - ctorInfo.numParams < fields.length := by + rw [hF1Size, hargsLength, ← hnumParams, + ← hfieldsLength] at hhi + omega + obtain ⟨code, hcode, hprojTr, hargTr⟩ := + hfieldData (i - ctorInfo.numParams) hj + have hiEq : ctorInfo.numParams + (i - ctorInfo.numParams) = i := + Nat.add_sub_of_le hlo + have hargBound : + ctorInfo.numParams + (i - ctorInfo.numParams) < F1.size := by + omega + have hargTr' : c.TrExprS F1[i] fields[i - ctorInfo.numParams] := by + simpa [hiEq] using hargTr hargBound + simp only [bind_assoc] + refine (isDefEq.WF hprojTr hargTr').bind fun b next _ hb => ?_ + by_cases hbtrue : b = true + · simp only [hbtrue, if_pos, pure_bind] + have hcur : FieldEq (i - ctorInfo.numParams) := + ⟨fields[i - ctorInfo.numParams], code, + List.getElem?_eq_getElem hj, hcode, hb hbtrue⟩ + have hsuffixTail : ∃ pre, pre ++ indices = all := by + refine ⟨pre ++ [i], ?_⟩ + simpa [List.append_assoc] using hprefix + have htail : RecM.WF c next + (List.forIn'.loop all (etaStep all hlow hhigh) indices + ⟨none, PUnit.unit⟩ hsuffixTail) + (fun r _ => + (r.1 = none → + ∀ k, k ∈ i :: indices → + FieldEq (k - ctorInfo.numParams)) ∧ + r.1 ≠ some true) := + (ih hsuffixTail (st := next)).mono + (fun r _ _ hrest => ⟨fun hnone k hk => by + rw [List.mem_cons] at hk + rcases hk with rfl | hk + · exact hcur + · exact hrest.1 hnone k hk, + hrest.2⟩) + simpa only [etaStep, tryEtaStructFieldStep, pure_bind] using htail + · simp only [hbtrue, if_neg, pure_bind] + exact .pure (by simp) + have hparamsLe : ctorInfo.numParams ≤ F1.size := by + rw [hF1Size, hargsLength, ← hnumParams] + omega + have hlowRange : ∀ i, + i ∈ List.range' ctorInfo.numParams + (F1.size - ctorInfo.numParams) → + ctorInfo.numParams ≤ i := by + intro i hi + rcases List.mem_range'.mp hi with ⟨j, hj, rfl⟩ + omega + have hhighRange : ∀ i, + i ∈ List.range' ctorInfo.numParams + (F1.size - ctorInfo.numParams) → + i < F1.size := by + intro i hi + rcases List.mem_range'.mp hi with ⟨j, hj, rfl⟩ + omega + have etaForInWF : ∀ {st : VState}, RecM.WF c st + (List.forIn' + (List.range' ctorInfo.numParams (F1.size - ctorInfo.numParams)) + ⟨none, PUnit.unit⟩ + (etaStep + (List.range' ctorInfo.numParams + (F1.size - ctorInfo.numParams)) hlowRange hhighRange)) + (fun r _ => (r.1 = none → ∀ i, + i ∈ List.range' ctorInfo.numParams + (F1.size - ctorInfo.numParams) → + FieldEq (i - ctorInfo.numParams)) ∧ + r.1 ≠ some true) := by + intro st + exact etaLoopWF + (List.range' ctorInfo.numParams (F1.size - ctorInfo.numParams)) + (List.range' ctorInfo.numParams (F1.size - ctorInfo.numParams)) + ⟨[], by simp⟩ hlowRange hhighRange + change RecM.WF c _ + (do + let r ← List.forIn' + (List.range' ctorInfo.numParams (F1.size - ctorInfo.numParams)) + ⟨none, PUnit.unit⟩ + (etaStep + (List.range' ctorInfo.numParams + (F1.size - ctorInfo.numParams)) hlowRange hhighRange) + match r.1 with + | none => pure true + | some a => pure a) + (fun b _ => b = true → c.IsDefEqU e₁' e₂') + refine etaForInWF.bind fun r next _ hr => ?_ + cases hr₁ : r.1 with + | some b => + simp only + refine .pure fun hbtrue => False.elim <| + hr.2 (hr₁.trans (congrArg some hbtrue)) + | none => + simp only + refine .pure fun _ => ?_ + have hrangeCount : + F1.size - ctorInfo.numParams = fields.length := by + rw [hF1Size, hargsLength, hnumParams, hfieldsLength] + omega + have hfieldEq : ∀ j, j < fields.length → FieldEq j := by + intro j hj + have hjmem : ctorInfo.numParams + j ∈ + List.range' ctorInfo.numParams + (F1.size - ctorInfo.numParams) := by + apply List.mem_range'.2 + exact ⟨j, by simpa [hrangeCount] using hj, by simp⟩ + simpa using hr.1 hr₁ (ctorInfo.numParams + j) hjmem + let projections := artifact.projection.view.projectionArgs levels params + (artifact.projection.view.specializedFields levels params).length e₁' + have hprojectionCount : + (artifact.projection.view.specializedFields levels params).length = + fields.length := by + simpa [VStructureView.specializedFields] using hfieldsLength.symm + have hprojectionsLength : projections.length = fields.length := by + dsimp [projections] + rw [artifact.projection.view.projectionArgs_length levels params + (artifact.projection.view.specializedFields levels params).length + e₁' (by simp)] + exact hprojectionCount + have hpointwise : List.Forall₂ + (fun a a' => a = a' ∨ c.IsDefEqU a a') projections fields := by + apply forall₂_of_getElem? hprojectionsLength + intro j projection field hprojection hfield + have hj := (List.getElem?_eq_some_iff.mp hfield).1 + obtain ⟨field', code, hfield', hcode, hdefeq⟩ := hfieldEq j hj + have hprojection' : projections[j]? = + some (.app code.projector e₁') := by + dsimp [projections, VStructureView.projectionArgs] + have hjspec : j < + (artifact.projection.view.specializedFields levels params).length := + hprojectionCount.symm ▸ hj + rw [List.getElem?_map, List.getElem?_take_of_lt hjspec, hcode] + rfl + have hpEq : projection = .app code.projector e₁' := + Option.some.inj (hprojection.symm.trans hprojection') + have hfEq : field = field' := + Option.some.inj (hfield.symm.trans hfield') + subst projection + subst field + exact .inr hdefeq + let tailResult := VExpr.instRevAt ctorResult params + artifact.projection.view.fields.length + have hctorTailShape : VExpr.instRev ctorTail params = + VExpr.forallN + (artifact.projection.view.specializedFields levels params) + tailResult := by + simp only [ctorTail, tailResult, VExpr.instRev_forallN_projection, + VStructureView.specializedFields, List.length_map] + rw [VExpr.instRevAt_map_instL_zipIdx] + have hconstructorParamsLength : params.length = + artifact.projection.view.constructorParams.length := by + exact hparamsLength.trans <| by + simpa [VStructureView.constructorParams] using + hconstructorShape.2.2.1.symm + have hctorHeadPrefix : c.HasType (.const ctorName levels) + (VExpr.forallN + (artifact.projection.view.constructorParams.map + (VExpr.instL levels)) ctorTail) := by + simpa [ctorBinders, ctorTail, + VInductDecl.NormalizedCtor.declaredBinders, + VStructureView.constructorParams, VStructureView.fields, + List.map_append, VExpr.forallN_append] using hctorHeadShape + have hprefixSpine := hparamCtor.retarget + (by simpa using hconstructorParamsLength) ctorTail + rw [hctorTailShape] at hprefixSpine + have hprefixType := hprefixSpine.hasType_appN hctorHeadPrefix + have hprojectionSpine := + VStructureView.ProgramsWF.projectionArgsSpine + artifact.projection.programsWF + c.Ewf c.Δwf hlevelsWF hlevelsLength hparamsLength + ⟨_, hparamsSpine⟩ haStruct tailResult + have hprojectionDefEq := hprojectionSpine.defEq_of_pointwise + c.Ewf c.Δwf (by simpa [projections] using hpointwise) + have happEq := VEnv.IsDefEq.appN_defEq hprefixType + hprojectionDefEq + have happEqU : c.IsDefEqU + (artifact.projection.view.etaRebuild levels params e₁') + ((VExpr.const ctorName levels).appN args') := by + refine ⟨VExpr.instRev tailResult projections, ?_⟩ + simpa [VStructureView.etaRebuild, VExpr.appN_append, + artifact.constructor_name_eq, hargsSplit] using happEq + exact VEnv.IsDefEqU.trans c.Ewf c.Δwf + ⟨artifact.projection.view.structureType levels params, heta.symm⟩ + (VEnv.IsDefEqU.trans c.Ewf c.Δwf happEqU hfullEq) + + theorem tryEtaStructCore.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : RecM.WF c s (tryEtaStructCore e₁ e₂) fun b _ => b → c.IsDefEqU e₁' e₂' := sorry @@ -462,6 +1003,153 @@ theorem tryStringLitExpansion.WF {c : VContext} {s : VState} split <;> [skip; exact .pure h] exact (tryStringLitExpansionCore.WF he₂ he₁).mono fun _ _ _ h hb => (h hb).symm +theorem isDefEqUnitLike.WF_of_structureEta {c : VContext} {s : VState} + (ready : StructureEtaReady c.env c.venv) + (eta : c.venv.HasStructureEta) + (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : + RecM.WF c s (isDefEqUnitLike e₁ e₂) + fun b _ => b = .true → c.IsDefEqU e₁' e₂' := by + unfold isDefEqUnitLike + refine (inferType.WF he₁).bind fun _ _ _ + ⟨ty₁', _aBelow, _aTerm, aType, aTyped⟩ => ?_ + refine (whnf.WF aType).bind fun normalizedType _ _ + ⟨_aWhnfBelow, tType', tTypeTr, tTypeEq⟩ => ?_ + split <;> [skip; exact .pure nofun] + rename_i _ familyName hostLevels hhead + refine .getEnv ?_ + refine (M.WF.liftExcept envGet.WF).lift.bind fun _ _ _ hfamily => ?_ + split <;> [skip; exact .pure nofun] + rename_i _ familyDeclName familyLevelParams familyRawType hostNumParams + familyAll ctorName familyNumNested familyUnsafe familyReflexive + refine (M.WF.liftExcept envGet.WF).lift.bind fun _ _ _ hctor => ?_ + split <;> [skip; exact .pure nofun] + rename_i _ ctorDeclName ctorLevelParams ctorRawType ctorInduct ctorIndex + ctorNumParams ctorUnsafe + refine (inferType.WF he₂).bind fun _ _ _ + ⟨ty₂', _bBelow, _bTerm, bType, bTyped⟩ => ?_ + refine (isDefEqCore.WF tTypeTr bType).mono fun _ _ _ h hb => ?_ + let familyInfo : InductiveVal := { + name := familyDeclName + levelParams := familyLevelParams + type := familyRawType + numParams := hostNumParams + numIndices := 0 + all := familyAll + ctors := [ctorName] + numNested := familyNumNested + isRec := false + isUnsafe := familyUnsafe + isReflexive := familyReflexive } + let constructorInfo : ConstructorVal := { + name := ctorDeclName + levelParams := ctorLevelParams + type := ctorRawType + induct := ctorInduct + cidx := ctorIndex + numParams := ctorNumParams + numFields := 0 + isUnsafe := ctorUnsafe } + have hnonrec : c.env.isNonRecStructure familyName = true := by + unfold Kernel.Environment.isNonRecStructure + rw [hfamily] + rfl + obtain ⟨artifact⟩ := ready.resolve familyName familyInfo ctorName + constructorInfo hfamily hctor hnonrec + have ⟨head', hstack⟩ := AppStack.build <| + normalizedType.mkAppList_getAppArgsList ▸ tTypeTr + have hheadTr := hstack.tr + rw [hhead] at hheadTr + let .const (us' := levels) hconst hlevelsMap hlevelsHostLength := hheadTr + have hviewFamily := artifact.projection.viewWF.family + rw [artifact.projection.name_eq] at hviewFamily + rw [hviewFamily] at hconst + cases hconst + have hlevelsWF : ∀ level ∈ levels, + level.WF c.lparams.length := + VLevel.WF.of_mapM_ofLevel hlevelsMap + have hsourceUvars : + artifact.projection.view.generation.block.sourceType.uvars = + artifact.projection.view.uvars := + artifact.projection.view.generation.block.sourceType_uvars_eq + have hlevelsLength : levels.length = artifact.projection.view.uvars := + (List.mapM_eq_some.1 hlevelsMap).length_eq.symm.trans + (hlevelsHostLength.trans hsourceUvars) + have hfamilyHead : c.HasType (.const familyName levels) + (artifact.projection.view.familyType.instL levels) := + VEnv.HasType.const hviewFamily hlevelsWF + (hlevelsLength.trans hsourceUvars.symm) + obtain ⟨resultLevel, hrawResult⟩ := artifact.projection.rawResult_sort + let rawParams := artifact.projection.view.generation.block.rawParams.map + (VExpr.instL levels) + have hfamilyHeadShape : c.HasType (.const familyName levels) + (VExpr.forallN rawParams (.sort (resultLevel.inst levels))) := by + simpa [rawParams, VStructureView.familyType, + VInductDecl.NormalizedChecked.rawType_eq, + artifact.projection.view.raw_indices_eq, hrawResult, + VExpr.instL_forallN, VExpr.forallN, VExpr.instL] using hfamilyHead + have htTypeIsType : c.venv.IsType c.lparams.length c.vlctx.toCtx tType' := + (aTyped.isType c.Ewf.ordered c.Δwf).defeqU_l c.Ewf c.Δwf + tTypeEq.symm + have normalizedTypeTr : c.TrExprS + (normalizedType.getAppFn.mkAppList normalizedType.getAppArgsList) + tType' := by + rw [normalizedType.mkAppList_getAppArgsList] + exact tTypeTr + obtain ⟨params, _hparamsTr, hparamsSpine, hfullTr⟩ := + AppStack.toSpineWF_of_isType + (f := normalizedType.getAppFn) + (args := normalizedType.getAppArgsList) + (full' := tType') hstack hfamilyHeadShape + normalizedTypeTr htTypeIsType + have hparamsLength : params.length = artifact.projection.view.nparams := + hparamsSpine.forallN_sort_length.trans <| by + simpa [rawParams] using + artifact.projection.view.generation.shape.1 + have hfamilyShape : artifact.projection.view.familyType.instL levels = + VExpr.forallN rawParams (.sort (resultLevel.inst levels)) := by + simp [rawParams, VStructureView.familyType, + VInductDecl.NormalizedChecked.rawType_eq, + artifact.projection.view.raw_indices_eq, hrawResult, + VExpr.instL_forallN, VExpr.forallN, VExpr.instL] + have hparamsFamily : c.venv.SpineWF c.lparams.length c.vlctx.toCtx + (artifact.projection.view.familyType.instL levels) params + (.sort (resultLevel.inst levels)) := by + rw [hfamilyShape] + exact hparamsSpine + have hfullStruct : c.TrExprS normalizedType + (artifact.projection.view.structureType levels params) := by + rw [← normalizedType.mkAppList_getAppArgsList] + simpa [VStructureView.structureType, + artifact.projection.name_eq] using hfullTr + have hfullEq := hfullStruct.uniq c.Ewf (.refl c.Ewf c.Δwf) tTypeTr + have hstructTy₁ := VEnv.IsDefEqU.trans c.Ewf c.Δwf hfullEq tTypeEq + have hstructTy₂ := VEnv.IsDefEqU.trans c.Ewf c.Δwf hfullEq (h hb) + have haStruct := aTyped.defeqU_r c.Ewf c.Δwf hstructTy₁.symm + have hbStruct := bTyped.defeqU_r c.Ewf c.Δwf hstructTy₂.symm + have heta₁ := eta artifact.projection.view artifact.projection.viewWF + artifact.projection.programsWF c.Δwf hlevelsWF hlevelsLength + hparamsLength ⟨_, hparamsFamily⟩ haStruct + have heta₂ := eta artifact.projection.view artifact.projection.viewWF + artifact.projection.programsWF c.Δwf hlevelsWF hlevelsLength + hparamsLength ⟨_, hparamsFamily⟩ hbStruct + have hfieldsLength : artifact.projection.view.fields.length = 0 := by + calc + artifact.projection.view.fields.length = + artifact.projection.constructorInfo.numFields := + artifact.projection.constructor_numFields_eq.symm + _ = constructorInfo.numFields := + congrArg ConstructorVal.numFields artifact.constructor_info_eq + _ = 0 := rfl + have hfields : artifact.projection.view.fields = [] := + List.length_eq_zero_iff.mp hfieldsLength + have hrebuild : + artifact.projection.view.etaRebuild levels params e₁' = + artifact.projection.view.etaRebuild levels params e₂' := by + simp [VStructureView.etaRebuild, VStructureView.projectionArgs, + VStructureView.specializedFields, hfields] + rw [hrebuild] at heta₁ + exact VEnv.IsDefEqU.trans c.Ewf c.Δwf ⟨_, heta₁.symm⟩ ⟨_, heta₂⟩ + theorem isDefEqUnitLike.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : RecM.WF c s (isDefEqUnitLike e₁ e₂) fun b _ => b = .true → c.IsDefEqU e₁' e₂' := sorry diff --git a/plans/roadmap.md b/plans/roadmap.md index 60f10be..c647ede 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -574,6 +574,18 @@ test pins all three public names and their exact transitive axiom closures. This adds no `sorry` and, deliberately, proves no reconstruction equality: that last step is precisely the pending semantic decision. +The checker-side derivations are also staged completely behind that decision. +`VEnv.HasStructureEta` names only the missing reconstruction equality; +`StructureEtaReady` aligns the exact host family/constructor metadata with a +registered Theory view; and the sorry-free proof bodies +`tryEtaStructCore.WF_of_structureEta` and +`isDefEqUnitLike.WF_of_structureEta` discharge every remaining executable, +typing, parameter-spine, and zero-field obligation under those explicit +premises. Their exact transitive axiom closures are guarded in +`Tests/StructureEtaCapability.lean` (including already-tracked L4L-17 and +projection-frontier `sorryAx` dependencies). The unconditional roots remain +unchanged at the approval gate, and `VEnv.IsDefEq` remains untouched. + The proposed upstream decision is an explicit registered structure-eta rule, restricted to checked nonrecursive, single-constructor, zero-index structure views. Acceptance requires: subject reduction from the registered constructor