From 779c51fdea49c57c60f8039703605faae126b17f Mon Sep 17 00:00:00 2001 From: Kim Morrison <477956+kim-em@users.noreply.github.com> Date: Tue, 4 Aug 2026 10:51:37 +1000 Subject: [PATCH 01/51] chore: bump Lean toolchain to v4.32.2 (#30) * chore: bump Lean toolchain to v4.32.2 Exactly two commits touch `src/kernel` in v4.31.0..v4.32.2, and both are fixes: * leanprover/lean4#14498, "fix: kernel to check opaque values for fvars", adds a `check_no_metavar_no_fvar` call to `environment::add_opaque`. `addOpaque` now makes the same call in the same position, between `checkConstantVal` and the `checkType` of the value. * leanprover/lean4#14577, "fix: missing check at kernel inductive declaration", is already mirrored: `Lean4Lean/Inductive/Add.lean` type checks the nested applications against the post-declaration environment, covered by `Lean4Lean.Tests.NestedInductive`. lean4lean had the #14498 bug verbatim, not merely by transcription. `addOpaque` runs `checkConstantVal` and the value's `checkType` inside one `M.run`, so they share one `TypeChecker.State` exactly as C++ shares one `type_checker`. A type that beta-reduces to `False` but whose inference pushes a free variable through the local context leaves that variable in `inferTypeI`; the value can then name it, inference answers from the cache rather than the popped local context, and the declaration is accepted. The leaked variable is `_kernel_fresh.2`, the same name as in the lean4 test for this issue, since `TypeChecker.State.ngen` uses the same prefix and starts at the same index. `Lean4Lean.Tests.OpaqueFVar` pins both directions and is a real regression test: with the `checkNoMVarNoFVar` line removed it fails with "opaque value containing a free variable was accepted". The rest of the diff is not a kernel change. leanprover/lean4#13305 made the new `do` elaborator the default in v4.32.0, which reshapes the terms that `do` notation produces. The `Verify` proofs are written against the legacy shape, and `Lean4Lean/Experimental/ShapeLogRel.lean` proves things about `Option`-monad `do`/`return` definitions the same way, so those four files pin `backward.do.legacy true` with a comment saying why. That keeps the elaborated implementation identical to v4.31.0, which is the conservative choice for a kernel. Migrating the proofs to the new elaborator is follow-up work. Also refresh the toolchain-pinned `Lean.Level` divergence link, and make `stringProof` a `theorem` for the new `linter.defProp`. Validated with `lake build`, `lake build Lean4Lean.Experimental`, and both CI replay commands: `lean4lean Init.Core` checked 1036 declarations and `lean4lean --fresh Init.System.IO` checked 43721. No statement changes and no new `sorry`s. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01RFCAQgoGN4ndJA1rxNx9RE * fix: check declaration values for free variables in all three places `check_no_metavar_no_fvar` is called on the value in three places in the C++ kernel: `add_definition` (safe branch, environment.cpp:184), `add_theorem` (:203), and, since leanprover/lean4#14498, `add_opaque` (:217). This branch added the third; the first two were removed deliberately, and `divergences.md` recorded them as redundant. That argument is wrong, and all three are soundness bugs. A free variable in the value is harmless only while inference always consults the local context, and inference also answers from its cache: the type and then the value are checked by the same `TypeChecker.State`, exactly as C++ shares one `type_checker`, so a declaration whose *type* is inferred by pushing a free variable through the local context leaves that variable's type in `inferTypeI`. The value can then name the variable, inference answers from the cache instead of the already popped local context, and the declaration is accepted. With a type that beta-reduces to `False`, the result is a proof of `False` -- confirmed against the v4.31.0 tree, where `theorem Bad : (fun _ => False) id := _kernel_fresh.2` was accepted and `theorem FalseFromBad : False := Bad` then went through on top of it. `addTheorem` is the more serious of the two, being both the common path and, unlike the opaque case, not an upstream bug: lean4 has always had this call. `Lean4Lean.Tests.DeclFVar` replaces `Tests.OpaqueFVar` and pins all three sites, in both directions, and asserts that the rejection comes from the free variable check rather than from some other path, so that it cannot quietly stop testing the cache route. Co-authored-by: Claude Opus 5 (1M context) Co-authored-by: Mario Carneiro --- Lean4Lean/Environment.lean | 3 + Lean4Lean/EquivManager.lean | 9 +++ Lean4Lean/Experimental/ShapeLogRel.lean | 9 +++ Lean4Lean/Tests/DeclFVar.lean | 99 ++++++++++++++++++++++++ Lean4Lean/Tests/Toolchain.lean | 2 +- Lean4Lean/TypeChecker.lean | 9 +++ Lean4Lean/Verify/TypeChecker/Reduce.lean | 8 ++ divergences.md | 3 +- lake-manifest.json | 4 +- lakefile.toml | 2 +- lean-toolchain | 2 +- 11 files changed, 143 insertions(+), 7 deletions(-) create mode 100644 Lean4Lean/Tests/DeclFVar.lean diff --git a/Lean4Lean/Environment.lean b/Lean4Lean/Environment.lean index 226ebd49..a9ce1376 100644 --- a/Lean4Lean/Environment.lean +++ b/Lean4Lean/Environment.lean @@ -43,6 +43,7 @@ def addDefinition (env : Environment) (v : DefinitionVal) if check then M.run env (safety := .safe) (lctx := {}) (lparams := v.levelParams) (fuel := fuel) do checkConstantVal env v.toConstantVal (← checkPrimitiveDef v) + checkNoMVarNoFVar env v.name v.value let valType ← TypeChecker.checkType v.value if !(← isDefEq valType v.type) then throw <| .declTypeMismatch env (.defnDecl v) valType @@ -56,6 +57,7 @@ def addTheorem (env : Environment) (v : TheoremVal) (check := true) (fuel : Fuel checkConstantVal env v.toConstantVal if !(← isProp v.type) then throw <| .thmTypeIsNotProp env v.name v.type + checkNoMVarNoFVar env v.name v.value let valType ← TypeChecker.checkType v.value if !(← isDefEq valType v.type) then throw <| .declTypeMismatch env (.thmDecl v) valType @@ -66,6 +68,7 @@ def addOpaque (env : Environment) (v : OpaqueVal) (check := true) (fuel : FuelCo if check then M.run env (safety := .safe) (lctx := {}) (lparams := v.levelParams) (fuel := fuel) do checkConstantVal env v.toConstantVal + checkNoMVarNoFVar env v.name v.value let valType ← TypeChecker.checkType v.value if !(← isDefEq valType v.type) then throw <| .declTypeMismatch env (.opaqueDecl v) valType diff --git a/Lean4Lean/EquivManager.lean b/Lean4Lean/EquivManager.lean index 51cb3f00..fa7ab9c1 100644 --- a/Lean4Lean/EquivManager.lean +++ b/Lean4Lean/EquivManager.lean @@ -1,6 +1,15 @@ import Batteries.Data.UnionFind.Basic import Lean4Lean.PtrEq +/- +The `Lean4Lean.Verify` proofs about the definitions below are written against the term shape +the legacy `do` elaborator produces, destructuring with `extract_lets` the join points it +emits as `let`s. leanprover/lean4#13305 made the new `do` elaborator the default in v4.32.0, +and it emits `have __do_jp` join points and inlines the `if` chains instead. Pin the legacy +elaborator here until those proofs are migrated (digama0/lean4lean#31). +-/ +set_option backward.do.legacy true + namespace Lean4Lean open Lean diff --git a/Lean4Lean/Experimental/ShapeLogRel.lean b/Lean4Lean/Experimental/ShapeLogRel.lean index ac55969e..97185ead 100644 --- a/Lean4Lean/Experimental/ShapeLogRel.lean +++ b/Lean4Lean/Experimental/ShapeLogRel.lean @@ -1,5 +1,14 @@ import Lean4Lean.Experimental.SExpr +/- +`Shape.plift` and friends below are written in `Option`-monad `do`/`return` notation, and +the proofs about them `simp` through the exact term that notation elaborates to. +leanprover/lean4#13305 made the new `do` elaborator the default in v4.32.0, which reshapes +those terms. Pin the legacy elaborator here until the proofs are migrated +(digama0/lean4lean#31). +-/ +set_option backward.do.legacy true + namespace Lean4Lean open Lean4Lean diff --git a/Lean4Lean/Tests/DeclFVar.lean b/Lean4Lean/Tests/DeclFVar.lean new file mode 100644 index 00000000..c3e4c4c9 --- /dev/null +++ b/Lean4Lean/Tests/DeclFVar.lean @@ -0,0 +1,99 @@ +import Lean4Lean.Environment + +/-! +Regression test for the free variable check on declaration *values*. + +`check_no_metavar_no_fvar` is called on the value in three places in the C++ kernel: +`add_definition` (safe branch), `add_theorem`, and -- since leanprover/lean4#14498 -- +`add_opaque`. lean4lean had none of them. + +The first two were removed deliberately, on the grounds that a free variable in the value +cannot survive type checking anyway. That argument is wrong. It holds only while inference +always consults the local context, and inference also answers from its cache: since the +type and then the value are checked by the *same* `TypeChecker.State` -- exactly as C++ +shares one `type_checker` -- a declaration whose type is inferred by pushing a free +variable into the local context leaves that variable's type in `inferTypeI`. The value can +then name the variable, inference answers from the cache instead of the (already popped) +local context, and the declaration is accepted. With a type that beta-reduces to `False` +this proves `False` (leanprover/lean4#14484). + +Half of that argument is true, and that is what made it plausible: without these checks an +fvar that was never primed into the cache is still rejected, by inference, as `unknown free +variable`. Only the primed one slips through. Once the checks are restored they run before +inference, so both are rejected as `declaration has free variables` and the two cases are +no longer distinguishable from inside the test -- the assertion below pins the rejection +message so that a rejection coming from some *other* path is not silently accepted as +success. + +The leaked variable is `_kernel_fresh.2` because `TypeChecker.State.ngen` uses that prefix +and starts at that index; if either changes, these declarations stop exercising the cache +path and only pin that some free variable is rejected, which was never in doubt. + +The declarations are built by hand rather than elaborated, so that the environment does +not already contain them and only the kernel path is exercised. +-/ + +namespace Lean4Lean.Tests.DeclFVar + +open Lean + +/-- `(fun _ : False → False => False) (fun h : False => h)`. + +This beta-reduces to `False`, so it is a legitimate type, but inferring it pushes +`_kernel_fresh.1 : False → False` and `_kernel_fresh.2 : False` through the local context, +leaving them in the inference cache. -/ +def cachePrimingType : Expr := + let falseE := mkConst ``False + let falseToFalse := Expr.forallE `h falseE falseE .default + let identity := Expr.lam `h falseE (.bvar 0) .default + .app (.lam `_ falseToFalse falseE .default) identity + +/-- The value that only the inference cache still knows about. -/ +def leakedFVar : Expr := .fvar { name := .num `_kernel_fresh 2 } + +def thmDecl (name : Name) (value : Expr) : Declaration := + .thmDecl { name, levelParams := [], type := cachePrimingType, value } + +def defnDecl (name : Name) (value : Expr) : Declaration := + .defnDecl { name, levelParams := [], type := cachePrimingType, value + hints := .abbrev, safety := .safe } + +def opaqueDecl (name : Name) (value : Expr) : Declaration := + .opaqueDecl { name, levelParams := [], type := cachePrimingType, value, isUnsafe := false } + +/-- Closed counterparts, so that a blanket rejection cannot pass this test. -/ +def goodThm : Declaration := + .thmDecl { name := `GoodThm, levelParams := [], type := mkConst ``True, + value := mkConst ``True.intro } +def goodDefn : Declaration := + .defnDecl { name := `GoodDefn, levelParams := [], type := mkConst ``Nat, + value := mkRawNatLit 0, hints := .abbrev, safety := .safe } +def goodOpaque : Declaration := + .opaqueDecl { name := `GoodOpaque, levelParams := [], type := mkConst ``Nat, + value := mkRawNatLit 0, isUnsafe := false } + +run_meta do + let kenv := (← getEnv).toKernelEnv + + let errorOf (decl : Declaration) : MetaM (Option String) := do + match Lean4Lean.addDecl kenv decl with + | .ok _ => return none + | .error e => return some (← (e.toMessageData {}).toString) + let mentions (pat : String) (s : String) : Bool := (s.splitOn pat).length > 1 + + for (kind, mk) in [("theorem", thmDecl), ("safe definition", defnDecl), ("opaque", opaqueDecl)] do + -- The value that the inference cache leaks must be rejected *by the fvar check*. + match ← errorOf (mk `Bad leakedFVar) with + | none => throwError "{kind} value containing a leaked free variable was accepted" + | some msg => + unless mentions "declaration has free variables" msg do + throwError "{kind} leaked free variable was rejected, but not by the free variable \ + check, so this test no longer pins the cache path: {msg}" + + -- ... and closed values must still go through. + for (kind, decl) in [("theorem", goodThm), ("safe definition", goodDefn), + ("opaque", goodOpaque)] do + if let some msg ← errorOf decl then + throwError "closed {kind} was rejected: {msg}" + +end Lean4Lean.Tests.DeclFVar diff --git a/Lean4Lean/Tests/Toolchain.lean b/Lean4Lean/Tests/Toolchain.lean index 47d10f38..9254cbe4 100644 --- a/Lean4Lean/Tests/Toolchain.lean +++ b/Lean4Lean/Tests/Toolchain.lean @@ -9,7 +9,7 @@ theorem theoremDelta : True := trivial theorem proofOnlyDependency : True := trivial theorem dependencyOnlyInProof : True := proofOnlyDependency -def stringProof (_ : String) : True := trivial +theorem stringProof (_ : String) : True := trivial theorem stringOnlyInProof : True := stringProof "audit" run_meta diff --git a/Lean4Lean/TypeChecker.lean b/Lean4Lean/TypeChecker.lean index 4d0bae88..46f74876 100644 --- a/Lean4Lean/TypeChecker.lean +++ b/Lean4Lean/TypeChecker.lean @@ -7,6 +7,15 @@ import Lean4Lean.ForEachExprV import Lean4Lean.EquivManager import Lean4Lean.FuelConfig +/- +The `Lean4Lean.Verify` proofs about the definitions below are written against the term shape +the legacy `do` elaborator produces, destructuring with `extract_lets` the join points it +emits as `let`s. leanprover/lean4#13305 made the new `do` elaborator the default in v4.32.0, +and it emits `have __do_jp` join points and inlines the `if` chains instead. Pin the legacy +elaborator here until those proofs are migrated (digama0/lean4lean#31). +-/ +set_option backward.do.legacy true + namespace Lean4Lean open Lean hiding Environment Exception open Kernel diff --git a/Lean4Lean/Verify/TypeChecker/Reduce.lean b/Lean4Lean/Verify/TypeChecker/Reduce.lean index 549d2a61..3ba43ef3 100644 --- a/Lean4Lean/Verify/TypeChecker/Reduce.lean +++ b/Lean4Lean/Verify/TypeChecker/Reduce.lean @@ -1,5 +1,13 @@ import Lean4Lean.Verify.TypeChecker.Basic +/- +This file states `RecM.WF` goals with `do` blocks that have to match the shape the +definitions in `Lean4Lean.TypeChecker` elaborate to, which is pinned to the legacy `do` +elaborator (leanprover/lean4#13305). Pin it here too so the two agree +(digama0/lean4lean#31). +-/ +set_option backward.do.legacy true + namespace Lean4Lean.TypeChecker.Inner open Lean hiding Environment Exception open Kernel diff --git a/divergences.md b/divergences.md index dbcfd9c6..d7189272 100644 --- a/divergences.md +++ b/divergences.md @@ -6,8 +6,7 @@ This is a list of places where lean4lean deliberately has different behavior fro * [`Lean4Lean.Environment.checkPrimitiveDef`](Lean4Lean/Primitive.lean), `checkPrimitiveInductive`: Lean does not check that primitives are declared with the correct types and definitional behavior, except in the case of `Eq` which is used in the declaration of `Quot`. This is required for soundness, but Lean is able to get away with it because Lean ships its prelude and using an alternative prelude is not supported. * [`Lean4Lean.TypeChecker.Inner.inferType'`](Lean4Lean/TypeChecker.lean), literal case: The original code was not checking that the literal type actually exists. Again, this is okay provided that the prelude is trusted. * [`Lean4Lean.TypeChecker.Inner.tryStringLitExpansionCore`](Lean4Lean/TypeChecker.lean): there is a counterproductive `whnf` call in this function which is removed in Lean4lean. -* [`Lean.Level.normalize`](https://github.com/leanprover/lean4/blob/v4.31.0/src/Lean/Level.lean), `isEquiv`, `geq`: Lean4lean uses the level operations from Lean's standard library. These currently differ from the C++ kernel implementation; [leanprover/lean4#14356](https://github.com/leanprover/lean4/pull/14356) tracks aligning them. The primed operations in [`Lean4Lean/Level.lean`](Lean4Lean/Level.lean) are an unused experimental decision procedure for level algebra. -* [`Lean4Lean.addDefinition`](Lean4Lean/Environment.lean), `Lean4Lean.addTheorem`: two calls ([1](https://github.com/leanprover/lean4/blob/v4.26.0/src/kernel/environment.cpp#L183) [2](https://github.com/leanprover/lean4/blob/v4.26.0/src/kernel/environment.cpp#L203)) are redundant and have been removed. +* [`Lean.Level.normalize`](https://github.com/leanprover/lean4/blob/v4.32.2/src/Lean/Level.lean), `isEquiv`, `geq`: Lean4lean uses the level operations from Lean's standard library. These currently differ from the C++ kernel implementation; [leanprover/lean4#14356](https://github.com/leanprover/lean4/pull/14356) tracks aligning them. The primed operations in [`Lean4Lean/Level.lean`](Lean4Lean/Level.lean) are an unused experimental decision procedure for level algebra. * [`Lean4Lean.TypeChecker.Inner.inferLambda`](Lean4Lean/TypeChecker.lean), `inferLet`: lean4lean does the `ensureSort` call before extending the context, while [`infer_lambda`](https://github.com/leanprover/lean4/blob/v4.26.0/src/kernel/type_checker.cpp#L124-L126) does it afterward. It's not clear whether this is actually unsound but it would require some very weird invariants to justify having unchecked things in the local context and hoping that they won't be used in the typing proof of that same expression. * [`Lean4Lean.checkConstantVal`](Lean4Lean/Environment.lean): The original implementation would call `check` which sets the level params and then unsets them afterward, and then `ensure_sort` would run in a context without any level params. In lean4lean the monad is parameterized over level params, so they remain the same across the two calls. * [`Lean4Lean.TypeChecker.Inner.isProp`](Lean4Lean/TypeChecker.lean), [`Lean4Lean.toCtorWhenStruct`](Lean4Lean/Inductive/Reduce.lean): Lean decides whether a sort is `Prop` by comparing it syntactically against `Sort 0`. That misses `Sort (imax 1 0)`, which denotes `Prop` without being syntactically `zero`, and the mismatch between this test and the one used for proof irrelevance resulted in a soundness bug ([leanprover/lean4#14613](https://github.com/leanprover/lean4/pull/14613)). Lean4lean tests the level instead, but using `isAlwaysZero` instead of `isZero` in `isProp`, and `isNeverZero` instead of `!isAlwaysZero` in `toCtorWhenStruct` and `inferProj`. The lean check using `!isAlwaysZero` in `toCtorWhenStruct` would be unsound if not for the fact that the level algorithm rejects the true equation `imax 1 u ≤ u`: `inductive T.{u} : Sort u where mk : Bool → T` would allow proving false using a similar construction to the one in [#14613](https://github.com/leanprover/lean4/pull/14613). diff --git a/lake-manifest.json b/lake-manifest.json index 3542863a..70c6efab 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,10 +5,10 @@ "type": "git", "subDir": null, "scope": "", - "rev": "fa08db58b30eb033edcdab331bba000827f9f785", + "rev": "cb3961288e99f02ee3d23aab55391aebb258fd0c", "name": "batteries", "manifestFile": "lake-manifest.json", - "inputRev": "v4.31.0", + "inputRev": "v4.32.2", "inherited": false, "configFile": "lakefile.toml"}], "name": "lean4lean", diff --git a/lakefile.toml b/lakefile.toml index f862fab7..4c16c997 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -4,7 +4,7 @@ defaultTargets = ["Lean4Lean", "lean4lean", "Lean4Lean.Theory", "Lean4Lean.Verif [[require]] name = "batteries" git = "https://github.com/leanprover-community/batteries" -rev = "v4.31.0" +rev = "v4.32.2" [[lean_lib]] name = "Lean4Lean" diff --git a/lean-toolchain b/lean-toolchain index 18640c8b..0ec5999c 100644 --- a/lean-toolchain +++ b/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.31.0 +leanprover/lean4:v4.32.2 From 408edad8930c1d9d974f93fcbe4a304a174b2b6f Mon Sep 17 00:00:00 2001 From: Kim Morrison <477956+kim-em@users.noreply.github.com> Date: Tue, 4 Aug 2026 13:41:59 +1000 Subject: [PATCH 02/51] refactor: migrate to the new do elaborator (#33) * refactor: migrate to the new do elaborator * refactor: address independent review feedback * refactor: leave ShapeLogRel on legacy do elaborator * tweak formatting --------- Co-authored-by: Mario Carneiro --- Lean4Lean/EquivManager.lean | 9 --- Lean4Lean/TypeChecker.lean | 9 --- Lean4Lean/Verify/EquivManager.lean | 14 ++-- Lean4Lean/Verify/TypeChecker/Basic.lean | 2 +- Lean4Lean/Verify/TypeChecker/InferType.lean | 6 +- Lean4Lean/Verify/TypeChecker/IsDefEq.lean | 72 ++++++++++----------- Lean4Lean/Verify/TypeChecker/Reduce.lean | 43 ++++++------ Lean4Lean/Verify/TypeChecker/WHNF.lean | 36 +++++------ 8 files changed, 78 insertions(+), 113 deletions(-) diff --git a/Lean4Lean/EquivManager.lean b/Lean4Lean/EquivManager.lean index fa7ab9c1..51cb3f00 100644 --- a/Lean4Lean/EquivManager.lean +++ b/Lean4Lean/EquivManager.lean @@ -1,15 +1,6 @@ import Batteries.Data.UnionFind.Basic import Lean4Lean.PtrEq -/- -The `Lean4Lean.Verify` proofs about the definitions below are written against the term shape -the legacy `do` elaborator produces, destructuring with `extract_lets` the join points it -emits as `let`s. leanprover/lean4#13305 made the new `do` elaborator the default in v4.32.0, -and it emits `have __do_jp` join points and inlines the `if` chains instead. Pin the legacy -elaborator here until those proofs are migrated (digama0/lean4lean#31). --/ -set_option backward.do.legacy true - namespace Lean4Lean open Lean diff --git a/Lean4Lean/TypeChecker.lean b/Lean4Lean/TypeChecker.lean index 46f74876..4d0bae88 100644 --- a/Lean4Lean/TypeChecker.lean +++ b/Lean4Lean/TypeChecker.lean @@ -7,15 +7,6 @@ import Lean4Lean.ForEachExprV import Lean4Lean.EquivManager import Lean4Lean.FuelConfig -/- -The `Lean4Lean.Verify` proofs about the definitions below are written against the term shape -the legacy `do` elaborator produces, destructuring with `extract_lets` the join points it -emits as `let`s. leanprover/lean4#13305 made the new `do` elaborator the default in v4.32.0, -and it emits `have __do_jp` join points and inlines the `if` chains instead. Pin the legacy -elaborator here until those proofs are migrated (digama0/lean4lean#31). --/ -set_option backward.do.legacy true - namespace Lean4Lean open Lean hiding Environment Exception open Kernel diff --git a/Lean4Lean/Verify/EquivManager.lean b/Lean4Lean/Verify/EquivManager.lean index 31a07b2e..8197b26d 100644 --- a/Lean4Lean/Verify/EquivManager.lean +++ b/Lean4Lean/Verify/EquivManager.lean @@ -261,21 +261,19 @@ theorem toNode.WF : theorem isEquiv.WF : M.WF env Us Δ m (isEquiv useHash e₁ e₂) fun b _ => b → IsDefEqE env Us Δ e₁ e₂ := by - unfold isEquiv; extract_lets F1 F2 F3 - split <;> [exact .pure fun _ => ptrEqExpr_eq ‹_› ▸ .rfl; skip] - simp [F3]; split <;> [exact .pure nofun; skip] - simp [F2]; split + unfold isEquiv; split <;> [exact .pure fun _ => ptrEqExpr_eq ‹_› ▸ .rfl; skip] + split <;> [exact .pure nofun; split] · rename_i h; refine .pure ?_ - unfold Expr.isBVar at h; split at h <;> cases h.1; split at h <;> cases h.2 + simp only [Bool.and_eq_true, Expr.isBVar] at h + split at h <;> cases h.1; split at h <;> cases h.2 simp [Expr.bvarIdx!]; rintro ⟨⟩; exact .rfl - unfold F1 refine toNode.WF.bind fun i₁ _ _ a1 => find.WF.bind fun j₁ _ le₁ a2 => ?_ refine toNode.WF.bind fun i₂ _ le₂ b1 => find.WF.bind fun j₂ m₀ le₃ b2 => ?_ refine .stateWF fun wf => ?_ replace a1 := le₁.trans le₂ |>.trans le₃ |>.toNodeMap a1 replace a2 := le₂.trans le₃ |>.uf a2 replace b1 := le₃.toNodeMap b1 - extract_lets F4 F5 + extract_lets F4 split · rename_i h; simp at h; cases h; refine .pure fun _ => wf.defeq a1 b1 (a2.trans b2.symm) have {m b} (le₄ : m₀ ≤ m) (H : b = true → IsDefEqE env Us Δ e₁ e₂) : @@ -288,7 +286,7 @@ theorem isEquiv.WF : have ⟨r₂, hr₂⟩ := wf.wf.1 <| b2.lt_size.1 <| wf.wf.2 ⟨_, b1⟩ suffices IsDefEqE env Us Δ r₁ r₂ from have ⟨wf, h⟩ := merge.WF wf this hr₁ hr₂; ⟨wf, h, H⟩ exact (wf.defeq a1 hr₁ a2).symm.trans <| .trans (H ‹_›) (wf.defeq b1 hr₂ b2) - simp; unfold F5; split + simp; split · apply this .rfl; simp; rintro rfl rfl; exact .rfl · apply this .rfl; simp; rintro rfl; exact .rfl · apply this .rfl; simp; rintro rfl; exact .rfl diff --git a/Lean4Lean/Verify/TypeChecker/Basic.lean b/Lean4Lean/Verify/TypeChecker/Basic.lean index 6252d896..751258f5 100644 --- a/Lean4Lean/Verify/TypeChecker/Basic.lean +++ b/Lean4Lean/Verify/TypeChecker/Basic.lean @@ -917,7 +917,7 @@ theorem unfoldDefinitionCore.WF {c : VContext} {s : VState} (he : c.TrExprS e e' · exact (List.mapM_eq_some.1 a2).length_eq.symm.trans <| a3.trans b2.symm split <;> [rename_i h5; exact .pure this] refine .pureBind <| .get ?_ - split <;> [rename_i eq; refine .pureBind ?_] + split <;> [rename_i eq; skip] · refine .stateWF fun wf => .pure ?_ obtain ⟨_, _, _, ⟨⟩, a1, rfl⟩ := wf.unfold_wf eq cases h3.symm.trans a1; exact this diff --git a/Lean4Lean/Verify/TypeChecker/InferType.lean b/Lean4Lean/Verify/TypeChecker/InferType.lean index da5b6f01..04a4b33d 100644 --- a/Lean4Lean/Verify/TypeChecker/InferType.lean +++ b/Lean4Lean/Verify/TypeChecker/InferType.lean @@ -414,7 +414,7 @@ theorem inferType'.WF (h1 : e.FVarsIn (· ∈ c.vlctx.fvars)) (hinf : inferOnly = true → ∃ e', c.TrExprS e e') : (inferType' e inferOnly).WF c s fun ty _ => ∃ e' ty', c.TrTyping e ty e' ty' := by - unfold inferType'; lift_lets; intro F F1 F2 --; simp + unfold inferType'; lift_lets; intro F F1 split <;> [exact .throw; refine .get <| .get ?_] split · rename_i h; refine .stateWF fun wf => .pure ?_ @@ -422,7 +422,7 @@ theorem inferType'.WF have : ic.WF c s := by subst ic; cases inferOnly <;> [exact wf.inferTypeC_wf; exact wf.inferTypeI_wf] exact (this h).2.2.2.2 h1 - generalize hP : (fun ty:Expr => _) = P + generalize hP : (fun _ (_ : VState) => _) = P have hF {ty e' ty' s} (H : c.TrTyping e ty e' ty') : (F ty).WF c s P := by rintro _ mwf wf a s' ⟨⟩ refine let s' := _; ⟨s', rfl, ?_⟩ @@ -436,7 +436,7 @@ theorem inferType'.WF subst P; revert s'; cases inferOnly <;> (dsimp -zeta; intro s'; refine ⟨.rfl, ?_, _, _, H⟩) · exact { wf with inferTypeC_wf := hic wf.inferTypeC_wf } · exact { wf with inferTypeI_wf := hic wf.inferTypeI_wf } - unfold F1; refine .get ?_; split + split · extract_lets G1; split <;> [split; skip] · refine .getEnv <| (M.WF.liftExcept envGet.WF).lift.bind fun _ _ _ h => ?_ have ⟨_, h, _⟩ := c.trenv.find? h <| diff --git a/Lean4Lean/Verify/TypeChecker/IsDefEq.lean b/Lean4Lean/Verify/TypeChecker/IsDefEq.lean index 7eddbada..9dfdf541 100644 --- a/Lean4Lean/Verify/TypeChecker/IsDefEq.lean +++ b/Lean4Lean/Verify/TypeChecker/IsDefEq.lean @@ -15,7 +15,7 @@ theorem isDefEqLambda.WF {c : VContext} {s : VState} b → (c.withMLC m).IsDefEqU ei₁' ei₂' := by unfold isDefEqLambda; let c' := c.withMLC m split <;> [rename_i n₁ d₁ b₁ bi₁ n₂ d₂ b₂ bi₂; (simp [hsubst]; exact isDefEq.WF he₁ he₂)] - extract_lets F di₁ di₂ G; unfold G di₁ di₂ + extract_lets F di₁ di₂; unfold di₁ di₂ simp at he₁ he₂ let .lam (ty' := t₁') (body' := b₁') ⟨_, a1⟩ a2 a3 := he₁ let .lam (ty' := t₂') (body' := b₂') b1 b2 b3 := he₂ @@ -85,7 +85,7 @@ theorem isDefEqForall.WF {c : VContext} {s : VState} b → (c.withMLC m).IsDefEqU ei₁' ei₂' := by unfold isDefEqForall; let c' := c.withMLC m split <;> [rename_i n₁ d₁ b₁ bi₁ n₂ d₂ b₂ bi₂; (simp [hsubst]; exact isDefEq.WF he₁ he₂)] - extract_lets F di₁ di₂ G; unfold G di₁ di₂ + extract_lets F di₁ di₂; unfold di₁ di₂ simp at he₁ he₂ let .forallE (ty' := t₁') (body' := b₁') ⟨_, a1⟩ _ a2 a3 := he₁ let .forallE (ty' := t₂') (body' := b₂') b1 ⟨_, bT⟩ b2 b3 := he₂ @@ -164,8 +164,7 @@ theorem quickIsDefEq.WF {c : VContext} {s : VState} · intro h; apply (VEnv.IsDefEqU.weak'_iff c.Ewf a1 a2.toCtx).1 exact (h1 h).uniq c.Ewf (a2.bvars_eq.trans c.mlctx.noBV) a1 (he₁.weakFV' c.Ewf a2 a1) (he₂.weakFV' c.Ewf a2 a1) - extract_lets F; split <;> [exact .pure fun _ => h ‹_›; skip] - refine .pureBind ?_; unfold F; split + split <;> [exact .pure fun _ => h ‹_›; split] · exact .toLBoolM <| c.withMLC_self ▸ isDefEqLambda.WF (subst := #[]) (fvs := []) rfl (c.withMLC_self ▸ he₁) (c.withMLC_self ▸ he₂) · exact .toLBoolM <| c.withMLC_self ▸ @@ -238,14 +237,13 @@ theorem tryEtaStruct.WF {c : VContext} {s : VState} theorem isDefEqApp.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : RecM.WF c s (isDefEqApp e₁ e₂) fun b _ => b → c.IsDefEqU e₁' e₂' := by - unfold isDefEqApp; extract_lets F1 - split <;> [(refine .pureBind ?_; unfold F1); exact .pure nofun] + unfold isDefEqApp; split <;> [skip; exact .pure nofun] rw [Expr.withApp_eq, Expr.withApp_eq] split <;> [rename_i eq; exact .pure nofun] have ⟨_, he₁'⟩ := AppStack.build <| e₁.mkAppList_getAppArgsList ▸ he₁ have ⟨_, he₂'⟩ := AppStack.build <| e₂.mkAppList_getAppArgsList ▸ he₂ - refine (isDefEq.WF he₁'.tr he₂'.tr).bind fun _ _ _ h => ?_; extract_lets F2 - split <;> [(refine .pureBind ?_; unfold F2); exact .pure nofun] + refine (isDefEq.WF he₁'.tr he₂'.tr).bind fun _ _ _ h => ?_ + split <;> [skip; exact .pure nofun] let rec loop.WF {s args₁ args₂ f₁ f₂ f₁' f₂' eq i} (l₁ r₁ l₂ r₂) (h₁ : args₁.toList = l₁ ++ r₁) (hi₁ : l₁.length = i) (h₂ : args₂.toList = l₂ ++ r₂) (hi₂ : l₂.length = i) @@ -300,9 +298,9 @@ theorem isDefEqProofIrrel.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : RecM.WF c s (isDefEqProofIrrel e₁ e₂) fun b _ => b = .true → c.IsDefEqU e₁' e₂' := by unfold isDefEqProofIrrel - refine (inferType.WF he₁).bind fun _ _ _ ⟨_, a1, a2, a3, a4⟩ => ?_; extract_lets F1 + refine (inferType.WF he₁).bind fun _ _ _ ⟨_, a1, a2, a3, a4⟩ => ?_ refine (isProp.WF a3).bind fun _ _ _ h1 => ?_ - split <;> [exact .pure nofun; (refine .pureBind ?_; unfold F1)] + split <;> [exact .pure nofun; skip] rename_i h; simp at h refine (inferType.WF he₂).bind fun _ _ _ ⟨_, b1, b2, b3, b4⟩ => .toLBoolM ?_ refine (isDefEq.WF a3 b3).mono fun _ _ _ h2 hb => ?_ @@ -316,9 +314,8 @@ theorem cacheFailure.WF {c : VContext} {s : VState} : theorem tryUnfoldProjApp.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : (tryUnfoldProjApp e).WF c s fun oe _ => ∀ e₁, oe = some e₁ → c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := by - unfold tryUnfoldProjApp; extract_lets f F + unfold tryUnfoldProjApp; extract_lets f split <;> [exact .pure nofun; skip] - refine .pureBind ?_; unfold F refine (whnfCore.WF he).bind fun _ _ _ h => ?_ refine .pure fun _ => ?_ split <;> rintro ⟨⟩; exact h @@ -420,11 +417,11 @@ theorem isNatSuccOf?_wf {c : VContext} (H : isNatSuccOf? e = some e₁) theorem isDefEqOffset.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : (isDefEqOffset e₁ e₂).WF c s fun b _ => b = .true → c.IsDefEqU e₁' e₂' := by - unfold isDefEqOffset; extract_lets F; split + unfold isDefEqOffset; split · rename_i h; simp at h cases isNatZero_wf h.1 he₁; cases isNatZero_wf h.2 he₂ exact .pure fun _ => .refl <| he₁.wf c.Ewf c.Δwf - · refine .pureBind ?_; unfold F; split <;> [skip; exact .pure nofun] + · split <;> [skip; exact .pure nofun] obtain ⟨_, a1, rfl⟩ := isNatSuccOf?_wf ‹_› he₁ obtain ⟨_, b1, rfl⟩ := isNatSuccOf?_wf ‹_› he₂ refine .toLBoolM <| (isDefEqCore.WF a1 b1).mono fun _ _ _ h hb => ?_ @@ -436,11 +433,11 @@ theorem lazyDeltaReduction.loop.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : (lazyDeltaReduction.loop e₁ e₂ n).WF c s fun r _ => r.WF c e₁' e₂' := by induction n generalizing s e₁ e₂ e₁' e₂' with | zero => exact .throw | succ n ih - unfold loop; extract_lets F1 F2 F3 + unfold loop; extract_lets F1 refine (isDefEqOffset.WF he₁ he₂).bind fun _ _ _ h => ?_; split · exact .pure fun hb => h (by simpa using hb) - suffices hF2 : ∀ {s}, (F2 ⟨⟩).WF c s fun r _ => r.WF c e₁' e₂' by - refine .pureBind <|.readThe ?_; split <;> [skip; exact hF2] + suffices hF1 : ∀ {s}, (F1 ⟨⟩).WF c s fun r _ => r.WF c e₁' e₂' by + refine .readThe ?_; split <;> [skip; exact hF1] refine (reduceNat.WF he₁).bind fun _ _ _ h => ?_; split · have ⟨_, a1, a2⟩ := (h _ rfl).2 refine (isDefEqCore.WF a1 he₂).bind fun _ _ _ h => .pure fun hb => ?_ @@ -449,13 +446,12 @@ theorem lazyDeltaReduction.loop.WF {c : VContext} {s : VState} · have ⟨_, a1, a2⟩ := (h _ rfl).2 refine (isDefEqCore.WF he₁ a1).bind fun _ _ _ h => .pure fun hb => ?_ exact (h hb).trans c.Ewf c.Δwf a2 - exact hF2 - intro s; unfold F2; refine .getEnv ?_ + exact hF1 + intro s; unfold F1; refine .getEnv ?_ refine (M.WF.liftExcept reduceNative.WF).lift.bind fun _ _ _ h => ?_ split <;> [cases h _ rfl; skip] refine (M.WF.liftExcept reduceNative.WF).lift.bind fun _ _ _ h => ?_ split <;> [cases h _ rfl; skip] - refine .pureBind ?_; unfold F1 refine (lazyDeltaReductionStep.WF he₁ he₂).bind fun r _ _ h => ?_ obtain r|r|r := r · let ⟨_, ⟨_, a1, a2⟩, ⟨_, b1, b2⟩⟩ := h @@ -484,11 +480,11 @@ theorem isDefEqUnitLike.WF {c : VContext} {s : VState} theorem isDefEqCore'.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : RecM.WF c s (isDefEqCore' e₁ e₂) fun b _ => b = true → c.IsDefEqU e₁' e₂' := by - unfold isDefEqCore'; extract_lets F1 F2 F3 + unfold isDefEqCore'; extract_lets F1 refine (quickIsDefEq.WF he₁ he₂).bind fun _ _ _ h => ?_ split <;> [exact .pure fun hb => h (by simpa using hb); skip] - refine .pureBind <| .readThe ?_ - suffices ∀ {s}, RecM.WF c s (F2 ⟨⟩) fun b _ => b = true → c.IsDefEqU e₁' e₂' by + refine .readThe ?_ + suffices ∀ {s}, RecM.WF c s (F1 ⟨⟩) fun b _ => b = true → c.IsDefEqU e₁' e₂' by split <;> [rename_i h1; exact this] refine (whnf.WF he₁).bind fun _ _ _ ⟨_, _, a1, a2⟩ => ?_ split <;> [rename_i h2; exact this] @@ -501,29 +497,29 @@ theorem isDefEqCore'.WF {c : VContext} {s : VState} cases c.hasPrimitives.boolTrue c1 simp at b3 c3; subst b3 c3; simp at b2 c2; subst b2 c2 exact a2.symm - intro; unfold F2 + intro; unfold F1 refine (whnfCore.WF he₁).bind fun _ _ _ ⟨_, e₁', a1, a2⟩ => ?_ refine (whnfCore.WF he₂).bind fun _ _ _ ⟨_, e₂', b1, b2⟩ => ?_ - extract_lets F2 F3 + extract_lets F2 refine .mono (Q := fun b _ => b = true → c.IsDefEqU e₁' e₂') ?_ fun _ _ _ h hb => a2.symm.trans c.Ewf c.Δwf (h (by simpa using hb)) |>.trans c.Ewf c.Δwf b2 - suffices ∀ {s}, RecM.WF c s (F3 ⟨⟩) fun b _ => b = true → c.IsDefEqU e₁' e₂' by + suffices ∀ {s}, RecM.WF c s (F2 ⟨⟩) fun b _ => b = true → c.IsDefEqU e₁' e₂' by split <;> [skip; exact this] refine (quickIsDefEq.WF a1 b1).bind fun _ _ _ h => ?_ split <;> [skip; exact this] exact .pure fun hb => h (by simpa using hb) - intro; unfold F3 + intro; unfold F2 refine (isDefEqProofIrrel.WF a1 b1).bind fun _ _ _ h => ?_ split · exact .pure fun hb => h (by simpa using hb) - refine .pureBind <| (lazyDeltaReduction.loop.WF a1 b1).readThe.bind fun _ _ _ h => ?_; split + refine (lazyDeltaReduction.loop.WF a1 b1).readThe.bind fun _ _ _ h => ?_; split · cases h.1 · exact .pure h have ⟨⟨e₁', c1, c4⟩, ⟨e₂', d1, d4⟩⟩ := h refine .mono (Q := fun b _ => b = true → c.IsDefEqU e₁' e₂') ?_ fun _ _ _ h hb => c4.symm.trans c.Ewf c.Δwf (h (by simpa using hb)) |>.trans c.Ewf c.Δwf d4 - extract_lets F2 F3 F4 F5 F6 F7 - suffices ∀ {s}, RecM.WF c s (F7 ⟨⟩) fun b _ => b = true → c.IsDefEqU e₁' e₂' by + extract_lets F3 + suffices ∀ {s}, RecM.WF c s (F3 ⟨⟩) fun b _ => b = true → c.IsDefEqU e₁' e₂' by split · split <;> [rename_i h2; exact this] refine .pure fun _ => ?_ @@ -545,20 +541,20 @@ theorem isDefEqCore'.WF {c : VContext} {s : VState} simp at h2; subst h2; clear h exact .pure fun _ => c2.uniq c.Ewf (.refl c.Δwf) d2 (h ‹_›) · exact this - intro; unfold F7 + intro; unfold F3 refine (whnfCore.WF c1).bind fun _ _ _ ⟨_, e₁'', c5, c6⟩ => ?_ refine (whnfCore.WF d1).bind fun _ _ _ ⟨_, e₂'', d5, d6⟩ => ?_ split - · exact (isDefEqCore.WF c5 d5).bind fun _ _ _ h => .pure fun hb => + · exact (isDefEqCore.WF c5 d5).mono fun _ _ _ h hb => c6.symm.trans c.Ewf c.Δwf (h (by simpa using hb)) |>.trans c.Ewf c.Δwf d6 - refine .pureBind <| (isDefEqApp.WF c1 d1).bind fun _ _ _ h => ?_ + refine (isDefEqApp.WF c1 d1).bind fun _ _ _ h => ?_ split <;> [exact .pure fun _ => h ‹_›; skip] - refine .pureBind <| (tryEtaExpansion.WF c1 d1).bind fun _ _ _ h => ?_ + refine (tryEtaExpansion.WF c1 d1).bind fun _ _ _ h => ?_ split <;> [exact .pure fun _ => h ‹_›; skip] - refine .pureBind <| (tryEtaStruct.WF c1 d1).bind fun _ _ _ h => ?_ + refine (tryEtaStruct.WF c1 d1).bind fun _ _ _ h => ?_ split <;> [exact .pure fun _ => h ‹_›; skip] - refine .pureBind <| (tryStringLitExpansion.WF c1 d1).bind fun _ _ _ h => ?_ + refine (tryStringLitExpansion.WF c1 d1).bind fun _ _ _ h => ?_ split <;> [exact .pure fun hb => h (by simpa using hb); skip] - refine .pureBind <| (isDefEqUnitLike.WF c1 d1).bind fun _ _ _ h => ?_ + refine (isDefEqUnitLike.WF c1 d1).bind fun _ _ _ h => ?_ split <;> [exact .pure fun _ => h ‹_›; skip] - exact .pureBind <| .pure nofun + exact .pure nofun diff --git a/Lean4Lean/Verify/TypeChecker/Reduce.lean b/Lean4Lean/Verify/TypeChecker/Reduce.lean index 3ba43ef3..0151edaa 100644 --- a/Lean4Lean/Verify/TypeChecker/Reduce.lean +++ b/Lean4Lean/Verify/TypeChecker/Reduce.lean @@ -1,13 +1,5 @@ import Lean4Lean.Verify.TypeChecker.Basic -/- -This file states `RecM.WF` goals with `do` blocks that have to match the shape the -definitions in `Lean4Lean.TypeChecker` elaborate to, which is pinned to the legacy `do` -elaborator (leanprover/lean4#13305). Pin it here too so the two agree -(digama0/lean4lean#31). --/ -set_option backward.do.legacy true - namespace Lean4Lean.TypeChecker.Inner open Lean hiding Environment Exception open Kernel @@ -102,23 +94,9 @@ theorem reduceNat.WF {c : VContext} (he : c.TrExprS e e') : replace hprims {a} : Environment.primitives.contains a ↔ a ∈ prims := by simp [hprims, NameSet.contains, NameSet.ofList] unfold reduceNat; extract_lets nargs F1 fn - split <;> (split <;> [skip; exact hP ▸ .pure nofun]) - · rename_i h1 h2 - simp [nargs, Expr.getAppNumArgs_eq] at h1; subst fn - let .app f a := e; simp [Expr.appFn!, Expr.eqv_const] at h2 ⊢; subst h2 - let .app ha1 ha2 hf ha := he - let .const h1 h2 h3 := hf - refine (whnf.WF ha).bind fun a₁ _ _ ⟨a1, _, a2, a3⟩ => ?_ - split <;> [rename_i n h; exact hP ▸ .pure nofun] - obtain ⟨hn, rfl⟩ := rawNatLitExt?.WF h a2 - refine hP ▸ .pure ?_; rintro _ ⟨⟩; refine ⟨fun _ _ _ => trivial, ?_⟩ - have ⟨ci, c1, _⟩ := c.trenv.find?_iff.2 ⟨_, h1⟩ - have ⟨c2, c3⟩ := c.safePrimitives c1 <| hprims.2 (by simp [prims]) - have ⟨d1, d2, d3⟩ := c.trenv.find?_uniq c1 h1; cases h2 - refine have ⟨p1, p2⟩ := TrExprS.natLit c.hasPrimitives hn _; ⟨_, p1, ?_⟩ - refine p2.toU.symm.trans c.Ewf c.Δwf ?_ - exact ⟨_, ha1.appDF <| a3.of_r c.Ewf c.Δwf ha2⟩ - · split <;> [rename_i f ls a b _ h2; exact hP ▸ .pure nofun] + cases h1 : nargs == 1 <;> simp only [Bool.false_eq_true, ↓reduceIte] + · cases nargs == 2 <;> [exact hP ▸ .pure nofun; simp only [↓reduceIte]] + split <;> [rename_i f ls a b; exact hP ▸ .pure nofun] have hfun guard {g fc G} [DecidableRel guard] (hprim : fc ∈ prims) (heval : c.venv.ReflectsNatNatNat fc g) (hG : RecM.WF c s G P) : RecM.WF c s (do if f == fc then {return ← reduceBinNatOpG guard g a b}; G) P := by @@ -146,3 +124,18 @@ theorem reduceNat.WF {c : VContext} (he : c.TrExprS e e') : apply hfun (fun _ _ => False) (by simp [prims]) c.hasPrimitives.natShiftLeft apply hfun (fun _ _ => False) (by simp [prims]) c.hasPrimitives.natShiftRight exact hP ▸ .pure nofun + · split <;> [rename_i h2; exact hP ▸ .pure nofun] + simp [nargs, Expr.getAppNumArgs_eq] at h1; subst fn + let .app f a := e; simp [Expr.appFn!, Expr.eqv_const] at h2 ⊢; subst h2 + let .app ha1 ha2 hf ha := he + let .const h1 h2 h3 := hf + refine (whnf.WF ha).bind fun a₁ _ _ ⟨a1, _, a2, a3⟩ => ?_ + split <;> [rename_i n h; exact hP ▸ .pure nofun] + obtain ⟨hn, rfl⟩ := rawNatLitExt?.WF h a2 + refine hP ▸ .pure ?_; rintro _ ⟨⟩; refine ⟨fun _ _ _ => trivial, ?_⟩ + have ⟨ci, c1, _⟩ := c.trenv.find?_iff.2 ⟨_, h1⟩ + have ⟨c2, c3⟩ := c.safePrimitives c1 <| hprims.2 (by simp [prims]) + have ⟨d1, d2, d3⟩ := c.trenv.find?_uniq c1 h1; cases h2 + refine have ⟨p1, p2⟩ := TrExprS.natLit c.hasPrimitives hn _; ⟨_, p1, ?_⟩ + refine p2.toU.symm.trans c.Ewf c.Δwf ?_ + exact ⟨_, ha1.appDF <| a3.of_r c.Ewf c.Δwf ha2⟩ diff --git a/Lean4Lean/Verify/TypeChecker/WHNF.lean b/Lean4Lean/Verify/TypeChecker/WHNF.lean index 9815dcdf..828b3288 100644 --- a/Lean4Lean/Verify/TypeChecker/WHNF.lean +++ b/Lean4Lean/Verify/TypeChecker/WHNF.lean @@ -29,18 +29,18 @@ theorem reduceProj.WF {c : VContext} {s : VState} (he : c.TrExprS (.proj n i e) theorem whnfCore'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : RecM.WF c s (whnfCore' e cheapRec cheapProj) fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := by - unfold whnfCore'; extract_lets F G + unfold whnfCore'; extract_lets F let full := (· matches Expr.fvar _ | .app .. | .letE .. | .proj ..) generalize hP : (fun e₁ (_ : VState) => _) = P have hid {s} : RecM.WF c s (pure e) P := hP ▸ .pure ⟨.rfl, he.trExpr c.Ewf c.Δwf⟩ - suffices hG : full e → RecM.WF c s (G ⟨⟩) P by + suffices hF : full e → RecM.WF c s (F ⟨⟩) P by split any_goals exact hid - any_goals exact hG rfl + any_goals exact hF rfl · let .mdata he := he - exact (whnfCore'.WF he).bind fun _ _ _ h => hP ▸ .pure h - · refine .getLCtx ?_; split <;> [exact hid; exact hG rfl] - simp [G]; refine fun hfull => .get ?_; split + exact hP ▸ whnfCore'.WF he + · refine .getLCtx ?_; split <;> [exact hid; exact hF rfl] + simp [F]; refine fun hfull => .get ?_; split · rename_i r eq; refine .stateWF fun wf => hP ▸ .pure ?_ have ⟨_, h1, h2, h3⟩ := (wf.whnfCore_wf eq).2.2.2.2 he.fvarsIn refine ⟨h1, h3.defeq c.Ewf c.Δwf ?_⟩ @@ -59,10 +59,9 @@ theorem whnfCore'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : · exact he.fvarsIn.mono wf.ngen_wf · exact h2.fvarsIn.mono wf.ngen_wf exact hP ▸ ⟨.rfl, { wf with whnfCore_wf := hic wf.whnfCore_wf }, h1, h2⟩ - unfold F; split <;> cases hfull - · simp; exact hP ▸ whnfFVar.WF he + split <;> cases hfull + · exact hP ▸ whnfFVar.WF he · rename_i fn arg _; generalize eq : fn.app arg = e at * - rw [Expr.withRevApp_eq] have ⟨_, stk⟩ := AppStack.build <| e.mkAppList_getAppArgsList ▸ he refine (whnfCore.WF stk.tr).bind fun _ s _ ⟨h1, h2⟩ => ?_ split <;> [rename_i name dom body bi _; split] @@ -120,7 +119,7 @@ theorem whnfCore'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : let ⟨h3, _, h4, eq⟩ := eq ▸ this h1 (eq ▸ he) stk.tr h2 refine (whnfCore.WF h4).bind fun _ _ _ ⟨h5, h6⟩ => ?_ refine hsave (h3.trans h5) (h6.defeq c.Ewf c.Δwf eq) - · let .letE h1 h2 h3 h4 := he; simp + · let .letE h1 h2 h3 h4 := he refine (whnfCore.WF (h4.inst_let c.Ewf.ordered h3)).bind fun _ _ _ ⟨h1, h2⟩ => ?_ exact hsave (.trans (fun _ _ he => he.2.2.instantiate1 he.2.1) h1) h2 · refine (reduceProj.WF he).bind fun _ _ _ H => ?_ @@ -132,32 +131,29 @@ theorem whnfCore'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : theorem whnf'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : RecM.WF c s (whnf' e) fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := by - unfold whnf'; extract_lets F G + unfold whnf'; extract_lets F generalize hP : (fun e₁ (_ : VState) => _) = P have hid {s} : RecM.WF c s (pure e) P := hP ▸ .pure ⟨.rfl, he.trExpr c.Ewf c.Δwf⟩ - suffices hG : RecM.WF c s (G ()) P by + suffices hF : RecM.WF c s (F ()) P by split any_goals exact hid - any_goals exact hG + any_goals exact hF · let .mdata he := he - exact (whnf'.WF he).bind fun _ _ _ h => hP ▸ .pure h - · refine .getLCtx ?_; split <;> [exact hid; exact hG] - simp [G]; refine .get ?_; split + exact hP ▸ whnf'.WF he + · refine .getLCtx ?_; split <;> [exact hid; exact hF] + simp [F]; refine .get ?_; split · rename_i r eq; refine .stateWF fun wf => hP ▸ .pure ?_ have ⟨_, h1, h2, h3⟩ := (wf.whnf_wf eq).2.2.2.2 he.fvarsIn refine ⟨h1, h3.defeq c.Ewf c.Δwf ?_⟩ exact h2.uniq c.Ewf (.refl c.Ewf c.Δwf) he - unfold F have {e e' s n} (he : c.TrExprS e e') : (loop e n).WF c s fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := by induction n generalizing s e e' with | zero => exact .throw | succ n ih => ?_ refine .getEnv <| (whnfCore'.WF he).bind fun e₁ s _ ⟨h1, _, he₁, eq⟩ => ?_ refine (M.WF.liftExcept reduceNative.WF).lift.bind fun _ _ _ h3 => ?_ - extract_lets F1 F2; split <;> [cases h3 _ rfl; skip] - refine .pureBind ?_; unfold F2 + split <;> [cases h3 _ rfl; skip] refine (reduceNat.WF he₁).bind fun _ _ _ h3 => ?_; split · exact .pure ⟨.trans h1 (h3 _ rfl).1, (h3 _ rfl).2.defeq c.Ewf c.Δwf eq⟩ - refine .pureBind ?_; unfold F1 refine (unfoldDefinition.WF he₁).bind fun _ _ _ H => ?_ split <;> [skip; exact .pure ⟨h1, _, he₁, eq⟩] have ⟨a1, _, a2, eq'⟩ := H From 5518bf83860bab48e8d53f1f447cdd6c50c30c3f Mon Sep 17 00:00:00 2001 From: Kim Morrison <477956+kim-em@users.noreply.github.com> Date: Tue, 4 Aug 2026 16:21:54 +1000 Subject: [PATCH 03/51] chore: bump Lean toolchain to v4.33.0-rc2 (#34) * chore: bump Lean toolchain to v4.33.0-rc2 * chore: clarify projection comparison names * review: drop speculative kernel checks and document the divergences The kernel hardening in the v4.32.2..v4.33.0-rc2 range splits into fixes for reachable bugs and checks that defend against mistakes elsewhere in the kernel. Lean4lean keeps the former and declines the latter: a check that establishes no precondition of a later step adds proof obligations without contributing an invariant, and the correctness proof is what discharges "we might have a bug". Removed, each with a `divergences.md` entry: * The projection structure-name comparison in `isEquiv`, `isDefEqCore'` and `reduceProj` (lean4#14631). `inferProj` already rejects `.proj S i e` unless the type of `e` whnfs to an application of `S`, so comparison and reduction only ever see projections that have been through inference. Upstream's own test has to plant the declaration under `debug.skipKernelTC` to reach the difference. * The kernel exceptions in `restoreNested` and `restoreCtorName` (lean4#14632), back to `unreachable!` and `assert!`. Upstream states that nothing in that PR is reachable from ordinary Lean code, and the motivation given there -- out of bounds reads once the assertions vanish in a release build -- does not apply to total `Array`/`Option` accesses. * The `_nested` scan on inductive types (lean4#14616). The rewrite touches constructor types only, and an auxiliary is neither in scope while the block's own types are checked nor present afterwards. The constructor scan is kept: it guards a hole that is reachable. * The recheck of the restored constructor and recursor declarations (lean4#14621), which upstream describes as redundant sanity checking. `Lean4Lean.Tests.KernelHardening` now runs the counterexamples upstream shipped with the fixes -- #14577, #14607, #14608, #14613 and the duplicate mutual name -- and replaces the ported `_nested` case with one naming an auxiliary the kernel really generates, so it fails when the check is removed instead of passing either way. Also simplifies the v4.33.0-rc2 compatibility workarounds in `ShapeLogRel`, `Verify/Axioms`, `Verify/Expr`, `Verify/Level` and `Level`. Co-authored-by: Mario Carneiro Co-authored-by: Claude Opus 5 --- Lean4Lean/Environment.lean | 7 + Lean4Lean/Experimental/DomainTheory.lean | 4 +- Lean4Lean/Experimental/MoreStepIndexed.lean | 2 +- Lean4Lean/Experimental/SExpr.lean | 4 +- Lean4Lean/Experimental/ShapeLogRel.lean | 15 +- Lean4Lean/Experimental/StepIndexed.lean | 2 +- Lean4Lean/Experimental/Thierry2.lean | 2 +- Lean4Lean/FuelConfig.lean | 10 +- Lean4Lean/Inductive/Add.lean | 18 +- Lean4Lean/Level.lean | 2 +- Lean4Lean/Quot.lean | 4 + Lean4Lean/Tests/KernelHardening.lean | 204 ++++++++++++++++++++ Lean4Lean/Theory/Typing/Lemmas.lean | 2 +- Lean4Lean/Theory/Typing/Pattern.lean | 6 +- Lean4Lean/Theory/VLevel.lean | 12 +- Lean4Lean/Verify/Expr.lean | 14 +- Lean4Lean/Verify/Level.lean | 22 ++- Lean4Lean/Verify/Typing/Expr.lean | 2 +- Lean4Lean/Verify/Typing/Lemmas.lean | 6 +- Lean4Lean/Verify/VLCtx.lean | 2 +- divergences.md | 10 +- lake-manifest.json | 4 +- lakefile.toml | 2 +- lean-toolchain | 2 +- 24 files changed, 301 insertions(+), 57 deletions(-) create mode 100644 Lean4Lean/Tests/KernelHardening.lean diff --git a/Lean4Lean/Environment.lean b/Lean4Lean/Environment.lean index a9ce1376..f783e736 100644 --- a/Lean4Lean/Environment.lean +++ b/Lean4Lean/Environment.lean @@ -81,10 +81,17 @@ def addMutual (env : Environment) (vs : List DefinitionVal) throw <| .other "invalid mutual definition, declaration is not tagged as unsafe/partial" if check then M.run env (safety := v₀.safety) (lctx := {}) (lparams := v₀.levelParams) (fuel := fuel) do + let mut found : NameSet := {} for v in vs do if v.safety != v₀.safety then throw <| .other "invalid mutual definition, declarations must have the same safety annotation" + if v.levelParams != v₀.levelParams then + throw <| .other + "invalid mutual definition, declarations must have the same universe level parameters" + if found.contains v.name then + throw <| .other s!"invalid mutual definition, duplicate declaration name '{v.name}'" + found := found.insert v.name checkConstantVal env v.toConstantVal let mut env' := env for v in vs do diff --git a/Lean4Lean/Experimental/DomainTheory.lean b/Lean4Lean/Experimental/DomainTheory.lean index a20b2b95..6c036e41 100644 --- a/Lean4Lean/Experimental/DomainTheory.lean +++ b/Lean4Lean/Experimental/DomainTheory.lean @@ -41,7 +41,7 @@ inductive FinElem where | bot | val : SExprF FinElem (FinFun FinElem FinElem) → FinElem -def DomN : Nat → Type +@[implicit_reducible] def DomN : Nat → Type | 0 => Unit | n+1 => Option (SExprF (DomN n) (DomN n → DomN n)) @@ -176,7 +176,7 @@ theorem DomN.cast_eq (x : DomN (a + 1)) : simp [SExprF.map_comp]; congr 1 <;> ext t <;> simp [this] congr 2; exact DomN.cast_upN (k := 1) _ (Nat.le_add_right ..) -def Dom : Type := { f : ∀ n, DomN n // ∀ n, f n = (f (n + 1)).down } +@[implicit_reducible] def Dom : Type := { f : ∀ n, DomN n // ∀ n, f n = (f (n + 1)).down } def Dom.bot : Dom := ⟨fun | 0 => () | _+1 => none, fun | 0 | _+1 => rfl⟩ diff --git a/Lean4Lean/Experimental/MoreStepIndexed.lean b/Lean4Lean/Experimental/MoreStepIndexed.lean index b533aa77..14430d01 100644 --- a/Lean4Lean/Experimental/MoreStepIndexed.lean +++ b/Lean4Lean/Experimental/MoreStepIndexed.lean @@ -66,7 +66,7 @@ inductive ShapeS (Shape : Type) (n : Nat) : Type where | forallE : Shape → List (Shape × Shape) → ShapeS Shape n | lam : List (Shape × Shape) → ShapeS Shape n -def Shape : Nat → Type +@[implicit_reducible] def Shape : Nat → Type | 0 => Unit -- bottom | n + 1 => ShapeS (Shape n) n diff --git a/Lean4Lean/Experimental/SExpr.lean b/Lean4Lean/Experimental/SExpr.lean index 4204fccc..82150b09 100644 --- a/Lean4Lean/Experimental/SExpr.lean +++ b/Lean4Lean/Experimental/SExpr.lean @@ -62,7 +62,7 @@ def max (l₁ l₂ : SLevel) : SLevel := let ⟨u, h1, h2⟩ := l₁.2; let ⟨v, h3, h4⟩ := l₂.2; ⟨u.max v, ⟨h1, h3⟩, h2 ▸ h4 ▸ rfl⟩⟩ def imax (l₁ l₂ : SLevel) : SLevel := - ⟨fun v => (l₁.1 v).imax (l₂.1 v), + ⟨fun v => Lean.Nat.imax (l₁.1 v) (l₂.1 v), let ⟨u, h1, h2⟩ := l₁.2; let ⟨v, h3, h4⟩ := l₂.2; ⟨u.imax v, ⟨h1, h3⟩, h2 ▸ h4 ▸ rfl⟩⟩ def inst (ls : List SLevel) (l : SLevel) : SLevel := by @@ -161,7 +161,7 @@ theorem _root_.Lean4Lean.VExpr.ClosedN.mkS : ∀ {e : VExpr}, e.ClosedN k → Cl | .bvar .., h | .sort .., h | .const .., h => h | .app .., h | .lam .., h | .forallE .., h => ⟨h.1.mkS, h.2.mkS⟩ -def Subst := Nat → SExpr +@[reducible] def Subst := Nat → SExpr def Subst.Depth (σ : Subst) (n n' : Nat) := ∀ i, σ (i + n') = .bvar (i + n) diff --git a/Lean4Lean/Experimental/ShapeLogRel.lean b/Lean4Lean/Experimental/ShapeLogRel.lean index 97185ead..45f46fa4 100644 --- a/Lean4Lean/Experimental/ShapeLogRel.lean +++ b/Lean4Lean/Experimental/ShapeLogRel.lean @@ -31,12 +31,12 @@ private noncomputable instance : DecidableEq SLevel := fun a b => Classical.prop simp [SLevel.imax, SLevel.zero] at hv apply Subtype.ext; funext v have := congrFun hv v - simp [Nat.imax, VLevel.eval] at this + simp [Lean.Nat.imax, VLevel.eval] at this exact Decidable.byContradiction fun h => absurd (this h).2 h · intro h subst h apply Subtype.ext; funext v - simp [SLevel.imax, SLevel.zero, Nat.imax, VLevel.eval] + simp [SLevel.imax, SLevel.zero, Lean.Nat.imax, VLevel.eval] inductive Shape0 : Type where | bot : Shape0 @@ -50,7 +50,7 @@ inductive ShapeS (Shape : Type) : Type where | ctor : Name → List Shape → ShapeS Shape | indTy : ShapeS Shape -def Shape : Nat → Type +@[implicit_reducible] def Shape : Nat → Type | 0 => Shape0 | n + 1 => ShapeS (Shape n) @@ -925,8 +925,8 @@ protected theorem Shape.WF.sort : (Shape.sort (n := n) r).WF := by cases n <;> t protected theorem ShapeFun.WF.bot : (ShapeFun.bot (n := n)).WF Shape.WF := by simp [WF, bot, Shape.Compat.bot_l, Shape.bot_join, Shape.WF.bot] -def WShape (n : Nat) := {s : Shape n // s.WF} -def WShapeFun (n : Nat) := {s : ShapeFun n // s.WF Shape.WF} +@[implicit_reducible] def WShape (n : Nat) := {s : Shape n // s.WF} +@[implicit_reducible] def WShapeFun (n : Nat) := {s : ShapeFun n // s.WF Shape.WF} instance : Membership (WShape n × WShape n) (WShapeFun n) := ⟨fun f a => (a.1.1, a.2.1) ∈ f.1⟩ @@ -1518,7 +1518,8 @@ theorem ih_fun {f f' : WShapeFun n} : have ⟨_, g1, g2, dg⟩ := app_core ih f' d; have ⟨g3, g4, g2⟩ := f'.mem_val' g2 have ⟨e, e1, e2⟩ := of_compat ih (x := ⟨_, f4⟩) (x' := ⟨_, g4⟩) (compat_app_l ih hc d) refine d1 ▸ e1 ▸ ⟨d.2, e.2⟩ - · intro f₃; conv => enter [1,x,y,1]; simp only [WShapeFun.mem_def, ShapeFun.mem_join] + · intro f₃; conv => + enter [1,x,y,1]; (conv => apply propext WShapeFun.mem_def); simp only [ShapeFun.mem_join] refine ⟨fun H => ?_, fun ⟨H1, H2⟩ => ?_⟩ · refine ⟨fun x y hf => ?_, fun x y hf' => ?_⟩ · have ⟨_, hf'⟩ := f'.bot_mem @@ -1815,7 +1816,7 @@ theorem WShapeFun.mem_ofElems {f : List (WShape n × WShape n)} {h1 h2} : exact ⟨fun ⟨⟨a, b⟩, h, ha, hb⟩ => by cases WShape.ext ha; cases WShape.ext hb; exact h, fun h => ⟨_, h, rfl, rfl⟩⟩ -def TShape := Σ n, WShape n +@[implicit_reducible] def TShape := Σ n, WShape n abbrev WShape.T : WShape n → TShape := Sigma.mk _ def TShape.LE (a b : TShape) : Prop := a.2.lift (max a.1 b.1) ≤ b.2.lift _ diff --git a/Lean4Lean/Experimental/StepIndexed.lean b/Lean4Lean/Experimental/StepIndexed.lean index 7b32fcac..e83c4f02 100644 --- a/Lean4Lean/Experimental/StepIndexed.lean +++ b/Lean4Lean/Experimental/StepIndexed.lean @@ -8,7 +8,7 @@ variable [Params] structure Classifier' where level : SLevel HasTy' (e : SExpr) : Prop -def Classifier (_Γ : List SExpr) (_A : SExpr) := Classifier' +@[implicit_reducible] def Classifier (_Γ : List SExpr) (_A : SExpr) := Classifier' def Classifier.HasTy (C : Classifier Γ A) (e : SExpr) : Prop := Γ ⊢ e : A ∧ C.HasTy' e diff --git a/Lean4Lean/Experimental/Thierry2.lean b/Lean4Lean/Experimental/Thierry2.lean index 86eb589b..68de65ec 100644 --- a/Lean4Lean/Experimental/Thierry2.lean +++ b/Lean4Lean/Experimental/Thierry2.lean @@ -18,7 +18,7 @@ inductive ShapeS (Shape : Type) : Type where | pi : Shape → List (Shape × Shape) → ShapeS Shape | lam : List (Shape × Shape) → ShapeS Shape -def Shape : Nat → Type +@[implicit_reducible] def Shape : Nat → Type | 0 => Shape0 | n + 1 => ShapeS (Shape n) diff --git a/Lean4Lean/FuelConfig.lean b/Lean4Lean/FuelConfig.lean index a1e633fe..32eb3966 100644 --- a/Lean4Lean/FuelConfig.lean +++ b/Lean4Lean/FuelConfig.lean @@ -9,11 +9,11 @@ Every field is a positive `Nat`; on exhaustion the corresponding loop throws `.deterministicTimeout` (whnf-family) or `.deepRecursion` (structural / mutual-recursion loops). -Defaults are set so mathlib passes. The C++ Lean kernel has no analog for any -of these bounds (its whnf/lazy-delta loops are `while (true)` and its -mutual-recursion depth is bounded only by the native stack); the counters exist -in lean4lean purely as termination witnesses for the Lean-level proofs and as a -defensive check against runaway reductions. +Defaults are set so mathlib passes. Since lean4#13956 the native kernel bounds +its mutually recursive type-checker entry points using `maxRecDepth`. +Lean4lean instead keeps separate, explicit fuel for those calls and for loops +that need structural termination witnesses; these counters also provide a +deterministic defensive check against runaway reductions. -/ structure FuelConfig where /-- `whnf'` unfold-loop, non-eager path (`TypeChecker.lean` whnf'). -/ diff --git a/Lean4Lean/Inductive/Add.lean b/Lean4Lean/Inductive/Add.lean index a396f1d2..b027ecd6 100644 --- a/Lean4Lean/Inductive/Add.lean +++ b/Lean4Lean/Inductive/Add.lean @@ -223,7 +223,7 @@ def checkConstructors (indTypes : Array InductiveType) loop (body.instantiate1 param) (i + 1) fuel else let s ← ensureType dom - unless stats.resultLevel.isZero || stats.resultLevel.geq s.sortLevel! do + unless stats.resultLevel.isAlwaysZero || stats.resultLevel.geq s.sortLevel! do throw <| .other s!"universe level of type_of(arg #{i + 1}) of '{n}' \ is too big for the corresponding inductive datatype" if !isUnsafe then @@ -268,7 +268,7 @@ def isLargeEliminator (stats : InductiveStats) (indTypes : Array InductiveType) withLocalDecl name bi dom.consumeTypeAnnotations fun arg => do let mut toCheck := toCheck if i ≥ stats.params.size then - if !(← ensureType dom).sortLevel!.isZero then + if !(← ensureType dom).sortLevel!.isAlwaysZero then toCheck := toCheck.push arg loop (body.instantiate1 arg) (i + 1) toCheck fuel else @@ -288,7 +288,7 @@ def getElimLevel (stats : InductiveStats) (indTypes : Array InductiveType) : def isKTarget (stats : InductiveStats) (indTypes : Array InductiveType) : M Bool := do let #[indType] := indTypes | return false - unless stats.resultLevel.isZero do return false + unless stats.resultLevel.isAlwaysZero do return false let [ctor] := indType.ctors | return false let rec loop i | .forallE _ _ body _ => i < stats.params.size && loop (i + 1) body @@ -723,9 +723,21 @@ def mkAuxRecNameMap (env' : Environment) (types : List InductiveType) : oldRecNames := oldRecNames.push oldRecName return (oldRecNames.toList, recMap) +def checkNoNestedAux (n : Name) (e : Expr) : Except Exception Unit := do + if (e.find? fun + | .const c _ => (`_nested).isPrefixOf c + | .proj s _ _ => (`_nested).isPrefixOf s + | _ => false).isSome then + throw <| .other s!"invalid declaration '{n}', it uses the reserved prefix '_nested'" + def Environment.addInductive (env : Environment) (lparams : List Name) (nparams : Nat) (types : List InductiveType) (isUnsafe allowPrimitive : Bool) (fuel : FuelConfig := {}) : Except Exception Environment := do + for indType in types do + env.checkNoMVarNoFVar indType.name indType.type + for ctor in indType.ctors do + env.checkNoMVarNoFVar ctor.name ctor.type + checkNoNestedAux ctor.name ctor.type let res ← ElimNestedInductive.run fuel.inductiveFuel nparams types env |>.run' { lvls := lparams.map .param, newTypes := types.toArray } let numNested := res.aux2nested.size diff --git a/Lean4Lean/Level.lean b/Lean4Lean/Level.lean index e8b64987..85043fb7 100644 --- a/Lean4Lean/Level.lean +++ b/Lean4Lean/Level.lean @@ -70,7 +70,7 @@ def orderedInsert (cmp : α → α → Ordering) (a : α) : List α → Option ( | .eq => none | .gt => (orderedInsert cmp a l).map (b :: ·) -def NormLevel := Std.TreeMap (List Name) Node compare +@[reducible] def NormLevel := Std.TreeMap (List Name) Node compare deriving Repr instance : BEq NormLevel where diff --git a/Lean4Lean/Quot.lean b/Lean4Lean/Quot.lean index 194b3a47..e7874f98 100644 --- a/Lean4Lean/Quot.lean +++ b/Lean4Lean/Quot.lean @@ -38,6 +38,10 @@ def checkEqType (env : Environment) : Except Exception Unit := do def Environment.addQuot (env : Environment) : Except Exception Environment := do if env.quotInit then return env checkEqType env + env.checkName ``Quot + env.checkName ``Quot.mk + env.checkName ``Quot.lift + env.checkName ``Quot.ind ExprBuildT.run do let u := .param `u withLocalDecl `α .implicit (.sort u) fun α => do diff --git a/Lean4Lean/Tests/KernelHardening.lean b/Lean4Lean/Tests/KernelHardening.lean new file mode 100644 index 00000000..d698389a --- /dev/null +++ b/Lean4Lean/Tests/KernelHardening.lean @@ -0,0 +1,204 @@ +import Lean4Lean.Environment + +/-! +Executable regressions for the kernel hardening merged between Lean v4.32.2 and +v4.33.0-rc2. The declarations are assembled manually so they exercise +`Lean4Lean.addDecl` and `Lean4Lean.TypeChecker` directly. +-/ + +namespace Lean4Lean.Tests.KernelHardening + +open Lean Lean4Lean TypeChecker + +private def errorOf (r : Except Kernel.Exception α) : MetaM (Option String) := do + match r with + | .ok _ => return none + | .error e => return some (← (e.toMessageData {}).toString) + +private def mentions (pat s : String) : Bool := (s.splitOn pat).length > 1 + +private def expectError (label pat : String) (r : Except Kernel.Exception α) : MetaM Unit := do + match ← errorOf r with + | none => throwError "{label} was accepted" + | some msg => unless mentions pat msg do throwError "{label} failed for the wrong reason: {msg}" + +private def runM (r : Except Kernel.Exception α) : MetaM α := do + match r with + | .ok a => pure a + | .error e => throwError "kernel operation failed: {← (e.toMessageData {}).toString}" + +private def mkPartial (n : Name) (lparams : List Name) (type value : Expr) : DefinitionVal := + { name := n, levelParams := lparams, type, value, hints := .opaque, safety := .partial } + +private def universeTy : Expr := + .forallE `x (.sort (.param `u)) (.sort (.param `u)) .default + +private def universeVal : Expr := + .lam `x (.sort (.param `u)) (.bvar 0) .default + +private def imaxProp : Expr := .sort (.imax (.succ .zero) .zero) + +private def imaxDataDecl : Declaration := + .inductDecl [] 0 [{ + name := `L4LKIPData + type := imaxProp + ctors := [{ + name := `L4LKIPData.mk + type := .forallE `b (.const ``Bool []) (.const `L4LKIPData []) .default }] + }] false + +/-- The auxiliary name the kernel generates for a nested `List` occurrence. -/ +private def auxListName : Name := (`_nested ++ `List).appendIndexAfter 1 + +/-- lean4#14616. `mk` nests `List L4LKNReal`, so eliminating it makes the kernel generate +`_nested.List_1`; `bad` then names that auxiliary. This is the form that *discriminates*: +without the check the declaration is accepted, and `restoreNested` rewrites the stored type of +`bad` to `List L4LKNReal → L4LKNReal`, which the kernel never checked. A declaration naming an +auxiliary that never exists is instead rejected as an unknown constant either way. -/ +private def nestedAuxRealDecl : Declaration := + .inductDecl [] 0 [{ + name := `L4LKNReal + type := .sort 1 + ctors := [ + { name := `L4LKNReal.mk + type := .forallE `xs (.app (.const ``List [.zero]) (.const `L4LKNReal [])) + (.const `L4LKNReal []) .default }, + { name := `L4LKNReal.bad + type := .forallE `y (.const auxListName []) (.const `L4LKNReal []) .default }] + }] false + +private def nestedAuxProjDecl : Declaration := + .inductDecl [] 0 [{ + name := `L4LKNProj + type := .sort .zero + ctors := [{ + name := `L4LKNProj.mk + type := .forallE `x (.const ``Nat []) + (.forallE `y (.proj `_nested.L4LHost_1 0 (.bvar 0)) + (.const `L4LKNProj []) .default) .default }] + }] false + +private def nestedBadDecl (bad : Expr) (name : Name) : Declaration := + let ind := fun a => .app (.const name []) a + .inductDecl [] 1 [{ + name + type := .forallE `α (.sort 1) (.sort 1) .default + ctors := [{ + name := name ++ `mk + type := .forallE `α (.sort 1) + (.forallE `xs (.app (.const ``Array [.zero]) (ind bad)) + (ind (.bvar 1)) .default) .default }] + }] false + +/-- lean4#14613: projecting the field back out of a `Sort (imax 1 0)` proof would break proof +irrelevance, so `inferProj` must reject it. -/ +private def imaxLeakDecl : Declaration := + .defnDecl { + name := `L4LKIPLeak + levelParams := [] + type := .forallE `proof (.const `L4LKIPData []) (.const ``Bool []) .default + value := .lam `proof (.const `L4LKIPData []) (.proj `L4LKIPData 0 (.bvar 0)) .default + hints := .abbrev, safety := .safe } + +structure L4LKC where b : Bool +inductive L4LKW : Type where | mk (p : Bool) +inductive L4LKL (α : Type) (b : Bool) : Type where | mk + +/-- lean4#14576/#14577: the parametric arguments of a nested occurrence are dropped from the +auxiliary declaration, so they escape checking unless they are checked against the environment +that results from the declaration. Here `w.1.1` is ill typed. -/ +private def nestedIllTypedParams : Declaration := + let w : Expr := .bvar 0 + let Ew : Expr := .app (.const `L4LKE []) w + let b : Expr := .proj ``L4LKC 0 (.proj ``L4LKC 0 w) + let l : Expr := mkApp2 (.const ``L4LKL []) Ew b + .inductDecl [] 1 [{ + name := `L4LKE + type := .forallE `w (.const ``L4LKW []) (.sort 1) .default + ctors := [{ + name := `L4LKE.mk + type := .forallE `w (.const ``L4LKW []) + (.forallE `l l (.app (.const `L4LKE []) (.bvar 1)) .default) .default }] + }] false + +private partial def deepNat : Nat → Expr + | 0 => .const ``Nat.zero [] + | n + 1 => .app (.const ``Nat.succ []) (deepNat n) + +structure ProjB where b : Nat + +run_meta do + let env := (← getEnv).toKernelEnv + + -- lean4#14608 and lean4#14632: mutual blocks share level parameters and names. + expectError "mutual block with mismatched universe parameters" + "same universe level parameters" <| + Lean4Lean.addDecl env <| .mutualDefnDecl [ + mkPartial `L4LMutA [`u] universeTy universeVal, + mkPartial `L4LMutB [] universeTy universeVal] + expectError "mutual block with a duplicate name" "duplicate declaration name" <| + Lean4Lean.addDecl env <| .mutualDefnDecl [ + mkPartial `L4LMutDup [] (.const ``Nat []) (mkRawNatLit 0), + mkPartial `L4LMutDup [] (.const ``Bool []) (.const ``Bool.true [])] + match Lean4Lean.addDecl env <| .mutualDefnDecl [ + mkPartial `L4LMutGoodA [] (.const ``Nat []) (mkRawNatLit 0), + mkPartial `L4LMutGoodB [] (.const ``Bool []) (.const ``Bool.true [])] with + | .error e => throwError "valid mutual block was rejected: {← (e.toMessageData {}).toString}" + | .ok _ => pure () + + -- lean4#14613/#14615: normalized `Prop` controls inductive classification and recursor levels. + let env' ← match Lean4Lean.addDecl env imaxDataDecl with + | .ok env' => pure env' + | .error e => throwError "imax-Prop inductive was rejected: {← (e.toMessageData {}).toString}" + let some (.recInfo recInfo) := env'.find? `L4LKIPData.rec + | throwError "imax-Prop recursor was not generated" + unless recInfo.levelParams.isEmpty do + throwError "imax-Prop inductive received a large-elimination universe" + -- ... but its field must not be projectable back out, or proof irrelevance equates + -- `mk false` and `mk true`. + expectError "projection out of an `imax`-`Prop` proof" "invalid projection" <| + Lean4Lean.addDecl env' imaxLeakDecl + + -- lean4#14616: a constructor naming a `_nested` auxiliary the kernel really generated. + expectError "constructor naming a generated nested auxiliary" "reserved prefix '_nested'" <| + Lean4Lean.addDecl env nestedAuxRealDecl + -- The `Expr.proj` form of the same scan. Note this one names an auxiliary that never exists, + -- so it pins the branch rather than the hole: without the check it is still rejected, as an + -- unknown constant. + expectError "constructor naming a nested auxiliary in a projection" "reserved prefix '_nested'" <| + Lean4Lean.addDecl env nestedAuxProjDecl + + -- lean4#14576/#14577: parametric arguments dropped from the auxiliary declaration. + expectError "nested inductive with ill-typed dropped parameters" "invalid projection" <| + Lean4Lean.addDecl env nestedIllTypedParams + + -- lean4#14607: validate original nested constructor types before elimination can hide them. + expectError "nested inductive containing a free variable" "free variables" <| + Lean4Lean.addDecl env <| nestedBadDecl (.fvar { name := `l4lBadFVar }) `L4LNestedFVar + expectError "nested inductive containing a metavariable" "metavariables" <| + Lean4Lean.addDecl env <| nestedBadDecl (.mvar { name := `l4lBadMVar }) `L4LNestedMVar + + -- lean4#14632: projection indices are `Nat` throughout lean4lean, so an index past `2^32` + -- is stuck rather than truncated. The structure *name* is deliberately not compared here; + -- see the projection entry in `divergences.md`. + let b : Expr := .app (.const ``ProjB.mk []) (mkRawNatLit 7) + let good : Expr := .proj ``ProjB 0 b + let huge : Expr := .proj ``ProjB 4294967296 b + let goodWhnf ← runM <| TypeChecker.M.run env (x := TypeChecker.whnf good) + unless goodWhnf == mkRawNatLit 7 do throwError "valid projection did not reduce" + let hugeWhnf ← runM <| TypeChecker.M.run env (x := TypeChecker.whnf huge) + unless hugeWhnf == huge do throwError "large projection index was truncated during reduction" + let same ← runM <| TypeChecker.M.run env (x := TypeChecker.isDefEq good good) + unless same do throwError "identical projections were not definitionally equal" + expectError "out-of-range large projection" "invalid projection" <| + TypeChecker.M.run env (x := TypeChecker.checkType huge) + + -- lean4#13956: lean4lean's explicit fuel remains deterministic and configurable. + expectError "deep term with low recursion fuel" "deep recursion" <| + TypeChecker.M.run env (fuel := { recDepth := 1 }) (x := TypeChecker.checkType (deepNat 100)) + match TypeChecker.M.run env (fuel := { recDepth := 1000 }) + (x := TypeChecker.checkType (deepNat 100)) with + | .error e => throwError "deep term with sufficient recursion fuel failed: {← (e.toMessageData {}).toString}" + | .ok ty => unless ty.isConstOf ``Nat do throwError "deep term inferred an unexpected type" + +end Lean4Lean.Tests.KernelHardening diff --git a/Lean4Lean/Theory/Typing/Lemmas.lean b/Lean4Lean/Theory/Typing/Lemmas.lean index 88523692..293073c0 100644 --- a/Lean4Lean/Theory/Typing/Lemmas.lean +++ b/Lean4Lean/Theory/Typing/Lemmas.lean @@ -9,7 +9,7 @@ inductive Ctx.LiftN (n : Nat) : Nat → List VExpr → List VExpr → Prop where | zero (As) (h : As.length = n := by rfl) : Ctx.LiftN n 0 Γ (As ++ Γ) | succ : Ctx.LiftN n k Γ Γ' → Ctx.LiftN n (k+1) (A::Γ) (A.liftN n k :: Γ') -def Ctx.LiftN.one : Ctx.LiftN 1 0 Γ (A::Γ) := .zero [_] +theorem Ctx.LiftN.one : Ctx.LiftN 1 0 Γ (A::Γ) := .zero [_] theorem Ctx.LiftN.isSuffix (H : Ctx.LiftN n k Γ Γ') : ∃ Γ₀ As Δ Δ', diff --git a/Lean4Lean/Theory/Typing/Pattern.lean b/Lean4Lean/Theory/Typing/Pattern.lean index 87e77492..52a0c53b 100644 --- a/Lean4Lean/Theory/Typing/Pattern.lean +++ b/Lean4Lean/Theory/Typing/Pattern.lean @@ -19,7 +19,7 @@ inductive Subpattern (p : Pattern) : Pattern → Prop where | appR : Subpattern p a → Subpattern p (.app f a) | varL : Subpattern p f → Subpattern p (.var f) -def Subpattern.varN (h : Subpattern p f) : ∀ {n}, Subpattern p (.varN f n) +theorem Subpattern.varN (h : Subpattern p f) : ∀ {n}, Subpattern p (.varN f n) | 0 => h | _+1 => .varL (.varN h) @@ -86,7 +86,7 @@ theorem Pattern.Matches.uniq {p : Pattern} {e : VExpr} {m1 m2 m1' m2'} induction H1 generalizing m1' with cases H2 | const => simp | var _ ih => rename_i h; simp [ih h] - | app _ _ ih1 ih2 => rename_i h2 h1; simp [ih1 h1, ih2 h2] + | app _ _ ih1 ih2 => rename_i h2 h1; simp [ih1 h1, ih2 h2]; rfl def Pattern.OnArgs (P : VExpr → Prop) : Pattern → Prop | .const .. => True @@ -208,7 +208,7 @@ theorem Pattern.matches_determ (h1 : Matches p e m1 m2) (h2 : Matches p e m1' m2') : m1 = m1' ∧ m2 = m2' := by induction h1 generalizing m1' with | const => let .const := h2; simp - | app l1 l2 ih1 ih2 => let .app r1 r2 := h2; simp [ih1 r1, ih2 r2] + | app l1 l2 ih1 ih2 => let .app r1 r2 := h2; simp [ih1 r1, ih2 r2]; rfl | var l1 ih1 => let .var r1 := h2; simp [ih1 r1] def Pattern.Check.OK (defeq : VExpr → VExpr → Prop) {p : Pattern} diff --git a/Lean4Lean/Theory/VLevel.lean b/Lean4Lean/Theory/VLevel.lean index 7816d0f4..e0b36f24 100644 --- a/Lean4Lean/Theory/VLevel.lean +++ b/Lean4Lean/Theory/VLevel.lean @@ -35,7 +35,7 @@ def eval : VLevel → Nat | .zero => 0 | .succ l => l.eval + 1 | .max l₁ l₂ => l₁.eval.max l₂.eval - | .imax l₁ l₂ => l₁.eval.imax l₂.eval + | .imax l₁ l₂ => Lean.Nat.imax l₁.eval l₂.eval | .param i => ls.getD i 0 protected def LE (a b : VLevel) : Prop := ∀ ls, a.eval ls ≤ b.eval ls @@ -94,22 +94,22 @@ theorem LE.max_eq_right (h : a.LE b) : max a b ≈ b := by theorem max_self : max a a ≈ a := by simp [equiv_def, eval] theorem zero_imax : imax zero a ≈ a := by - simp [equiv_def, eval, Nat.imax, eq_comm (b := 0)] + simp [equiv_def, eval, Lean.Nat.imax, eq_comm (b := 0)] -theorem imax_zero : imax a zero ≈ zero := by simp [equiv_def, eval, Nat.imax] +theorem imax_zero : imax a zero ≈ zero := by simp [equiv_def, eval, Lean.Nat.imax] theorem imax_self : imax a a ≈ a := by - simp [equiv_def, eval, Nat.imax, eq_comm (b := 0)] + simp [equiv_def, eval, Lean.Nat.imax, eq_comm (b := 0)] theorem imax_eq_zero : imax a b ≈ zero ↔ b ≈ zero := by - simp [equiv_def, eval, Nat.imax] + simp [equiv_def, eval, Lean.Nat.imax] refine ⟨fun H ls => ?_, fun H ls hn => nomatch hn (H ls)⟩ exact Decidable.byContradiction fun h => h (H ls h).2 def IsNeverZero (a : VLevel) : Prop := ∀ ls, a.eval ls ≠ 0 theorem IsNeverZero.imax_eq_max (h : IsNeverZero b) : imax a b ≈ max a b := by - simp_all [equiv_def, eval, Nat.imax, IsNeverZero] + simp_all [equiv_def, eval, Lean.Nat.imax, IsNeverZero] variable (ls : List VLevel) in def inst : VLevel → VLevel diff --git a/Lean4Lean/Verify/Expr.lean b/Lean4Lean/Verify/Expr.lean index a3eeeb89..7fd59045 100644 --- a/Lean4Lean/Verify/Expr.lean +++ b/Lean4Lean/Verify/Expr.lean @@ -73,7 +73,7 @@ theorem beq_refl (s : Substring.Raw) : s == s := by termination_by n.byteIdx - i.byteIdx refine ⟨?_, loop⟩ obtain h | h := Nat.le_or_le s.repair.startPos.byteIdx s.repair.stopPos.byteIdx - · rw [Nat.add_sub_cancel' h] + · simp only [Nat.add_sub_cancel' h, decide_eq_true_eq] apply String.Pos.Raw.IsValid.le_rawEndPos simp [Substring.Raw.repair]; split <;> simp [*] · simp [Nat.sub_eq_zero_of_le h] @@ -82,7 +82,8 @@ theorem beq_refl (s : Substring.Raw) : s == s := by open private substrEq.loop from Init.Data.String.Basic in theorem beq_symm {s t : Substring.Raw} : s == t → t == s := by - simp +contextual [(· == ·), Substring.Raw.beq, Substring.Raw.bsize, String.Pos.Raw.substrEq] + simp +contextual [(· == ·), Substring.Raw.beq, String.Pos.Raw.substrEq] + simp [Substring.Raw.bsize] let rec loop {s s' b b' i n} : substrEq.loop s s' ⟨b + i⟩ ⟨b' + i⟩ ⟨b + n⟩ ↔ substrEq.loop s' s ⟨b' + i⟩ ⟨b + i⟩ ⟨b' + n⟩ := by @@ -98,7 +99,8 @@ theorem beq_symm {s t : Substring.Raw} : s == t → t == s := by open private substrEq.loop from Init.Data.String.Basic in theorem beq_trans {s t : Substring.Raw} : s == t → t == u → s == u := by - simp +contextual [(· == ·), Substring.Raw.beq, Substring.Raw.bsize, String.Pos.Raw.substrEq] + simp +contextual [(· == ·), Substring.Raw.beq, String.Pos.Raw.substrEq] + simp [Substring.Raw.bsize] let ⟨s, ⟨b⟩, e⟩ := s.repair let ⟨s2, ⟨b2⟩, e2⟩ := t.repair let ⟨s3, ⟨b3⟩, e3⟩ := u.repair @@ -248,6 +250,9 @@ private def flagAt (fv ev lv lp : Bool) : Nat → Bool | 3 => lp | _ => false +set_option allowUnsafeReducibility true +attribute [local reducible] Data + private theorem mkData_flags (H : br ≤ 2 ^ 20 - 1) : (mkData h br d fv ev lv lp).hasFVar = fv ∧ (mkData h br d fv ev lv lp).hasExprMVar = ev ∧ @@ -554,6 +559,9 @@ attribute [simp] mkConst mkBVar mkSort mkFVar mkMVar mkMData mkProj mkApp mkLamb updateApp! updateFVar! updateConst! updateSort! updateMData! updateProj! updateForall! updateForallE! updateLambda! updateLambdaE! updateLetE! updateLet! +set_option allowUnsafeReducibility true +attribute [local reducible] Data + theorem mkData_looseBVarRange (H : br ≤ 2^20 - 1) : (mkData h br d fv ev lv lp).looseBVarRange.toNat = br := by rw [mkData_eq, mkData', if_pos H]; dsimp only [Data.looseBVarRange, -Nat.reducePow] diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index 6d63a0a3..1562b064 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -7,7 +7,7 @@ import Std.Data.TreeMap.Lemmas namespace Lean namespace Name -open Std +open _root_.Std instance : TransCmp cmp := by have eq_swap {a b : Name} : a.cmp b = (b.cmp a).swap := by @@ -112,6 +112,9 @@ attribute [simp] mkLevelSucc mkLevelMax mkLevelIMax updateSucc! updateMax! updat unfold getOffsetAux getOffset'; split <;> simp rw [go]; simp [Nat.add_right_comm, Nat.add_assoc] +set_option allowUnsafeReducibility true +attribute [local reducible] Data + theorem mkData_depth (H : d < 2 ^ 24) : (mkData h d hmv hp).depth.toNat = d := by rw [mkData_eq, mkData', if_neg (Nat.not_lt.2 (Nat.le_sub_one_of_lt H)), Data.depth] have : d.toUInt64.toUInt32.toNat = d := by simp; omega @@ -363,12 +366,13 @@ theorem normalizeAux_contains (H : acc.contains x) : (normalizeAux u path k acc) · exact H · exact NormLevel.addVar_contains H -theorem imax_max : Nat.imax a (max' b c) = max' (Nat.imax a b) (Nat.imax a c) := by - simp [Nat.imax]; symm; split <;> simp [*]; split <;> simp [*, Nat.max_eq_max] +theorem imax_max : Lean.Nat.imax a (max' b c) = max' (Lean.Nat.imax a b) (Lean.Nat.imax a c) := by + simp [Lean.Nat.imax]; symm; split <;> simp [*]; split <;> simp [*, Nat.max_eq_max] rw [Nat.max_left_comm b, ← Nat.max_assoc, Nat.max_self] -theorem imax_imax : Nat.imax a (Nat.imax b c) = max' (Nat.imax a c) (Nat.imax b c) := by - simp [Nat.imax]; by_cases h : c = 0 <;> simp [*, Nat.max_eq_max] +theorem imax_imax : Lean.Nat.imax a (Lean.Nat.imax b c) = + max' (Lean.Nat.imax a c) (Lean.Nat.imax b c) := by + simp [Lean.Nat.imax]; by_cases h : c = 0 <;> simp [*, Nat.max_eq_max] rw [Nat.max_left_comm c, Nat.max_self] theorem mem_orderedInsert [BEq α] [LawfulBEq α] [Std.LawfulBEqCmp (α := α) cmp] : @@ -467,7 +471,7 @@ theorem normalizeAux_eval (hu : VLevel.ofLevel ls u = some u') unfold normalizeAux; split · cases hu; simp [NormLevel.addConst_eval H le, VLevel.eval] · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, rfl⟩ := hu - simp [VLevel.eval, Nat.imax, NormLevel.addConst_eval H le] + simp [VLevel.eval, Lean.Nat.imax, NormLevel.addConst_eval H le] · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, rfl⟩ := hu rw [normalizeAux_eval hu H le, Nat.add_succ, ← Nat.succ_add]; rfl · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, hv, rfl⟩ := hu @@ -500,7 +504,7 @@ theorem normalizeAux_eval (hu : VLevel.ofLevel ls u = some u') rw [NormLevel.addNode_eval, NormLevel.addConst_eval H le, Nat.max_assoc] · rw [Nat.max_assoc, ← evalPath_max, this, evalPath_cons, ← evalPath_max, Nat.add_max_add_right]; congr 2 - simp [VLevel.eval, ← evalParam_eq hv, Nat.imax] + simp [VLevel.eval, ← evalParam_eq hv, Lean.Nat.imax] cases evalParam .. <;> simp [Nat.max_eq_max, Nat.max_comm] · refine .insert h (Nat.le_trans ?_ (Nat.le_max_right ..)) le.max rw [this, evalPath_cons, ← evalPath_max]; apply evalPath_mono; grind @@ -511,13 +515,13 @@ theorem normalizeAux_eval (hu : VLevel.ofLevel ls u = some u') have ⟨p1, p2, a1, a2, a3, a4⟩ := le.of_mem hm have := evalPath_le.1 a3 (allNZ_mono a1 nz) simp [allNZ] at nz; specialize nz _ hm - simp [VLevel.eval, Nat.imax]; simp [← evalParam_eq hv] + simp [VLevel.eval, Lean.Nat.imax]; simp [← evalParam_eq hv] revert this nz; cases evalParam .. <;> simp rw [Nat.max_eq_max, Nat.max_comm (a := VLevel.eval ..), ← Nat.add_max_add_right, ← Nat.max_assoc] intro h; rw [Nat.max_eq_left (b := _+1+k)]; omega · rw [normalizeAux_eval hu (NormLevel.addVar_contains H)] <;> rw [NormLevel.addVar_eval H] · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right, this, - evalPath_cons, evalPath_cons]; congr 2; split <;> simp [VLevel.eval, Nat.imax] + evalPath_cons, evalPath_cons]; congr 2; split <;> simp [VLevel.eval, Lean.Nat.imax] rename_i h; revert h; simp [← evalParam_eq hv] cases evalParam .. <;> simp [Nat.max_eq_max, Nat.max_comm] · exact le.max diff --git a/Lean4Lean/Verify/Typing/Expr.lean b/Lean4Lean/Verify/Typing/Expr.lean index a572fabd..a3c85e30 100644 --- a/Lean4Lean/Verify/Typing/Expr.lean +++ b/Lean4Lean/Verify/Typing/Expr.lean @@ -60,7 +60,7 @@ def VLCtx.WF : VLCtx → Prop VLCtx.WF Δ ∧ (∀ fv deps, ofv = some (fv, deps) → fv ∉ Δ.fvars ∧ deps ⊆ Δ.fvars) ∧ VLocalDecl.WF env U Δ.toCtx d -def VLCtx.WF.fvwf : ∀ {Δ}, VLCtx.WF env U Δ → Δ.FVWF +theorem VLCtx.WF.fvwf : ∀ {Δ}, VLCtx.WF env U Δ → Δ.FVWF | [], h => h | _ :: _, ⟨h1, h2, _⟩ => ⟨h1.fvwf, h2⟩ diff --git a/Lean4Lean/Verify/Typing/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean index 31b7d78a..a8073909 100644 --- a/Lean4Lean/Verify/Typing/Lemmas.lean +++ b/Lean4Lean/Verify/Typing/Lemmas.lean @@ -268,7 +268,7 @@ theorem FVLift'.fvars_sublist (W : FVLift' Δ Δ' dk n k) : Δ.fvars <+ Δ'.fvar induction W with | refl => exact .refl _ | skip_fvar _ _ _ ih => exact .cons _ ih - | cons_fvar _ _ _ _ ih => exact .cons₂ _ ih + | cons_fvar _ _ _ _ ih => exact .cons_cons _ ih | cons_bvar _ _ ih => exact ih theorem FVLift'.bvars_eq (W : FVLift' Δ Δ' dk n k) : Δ'.bvars = Δ.bvars := by @@ -1383,7 +1383,7 @@ theorem ofLevel_isNeverZero (h : VLevel.ofLevel Us u = some u') (H : u.isNeverZe exact H.elim (ih1 h1 · _ h.1) (ih2 h2 · _ h.2) | imax _ _ ih1 ih2 => obtain ⟨_, h1, _, h2, rfl⟩ := h - simp [VLevel.eval, Nat.imax, ih2 h2 H ls] + simp [VLevel.eval, Lean.Nat.imax, ih2 h2 H ls] theorem ofLevel_isAlwaysZero (h : VLevel.ofLevel Us u = some u') (H : u.isAlwaysZero) : u' ≈ .zero := by @@ -1396,7 +1396,7 @@ theorem ofLevel_isAlwaysZero (h : VLevel.ofLevel Us u = some u') (H : u.isAlways simp [VLevel.eval, VLevel.equiv_def.1 (ih1 h1 H.1) ls, VLevel.equiv_def.1 (ih2 h2 H.2) ls] | imax _ _ _ ih2 => obtain ⟨_, _, _, h2, rfl⟩ := h - simp [VLevel.eval, Nat.imax, VLevel.equiv_def.1 (ih2 h2 H) ls] + simp [VLevel.eval, Lean.Nat.imax, VLevel.equiv_def.1 (ih2 h2 H) ls] theorem ofLevel_mkLevelIMax' (h1 : VLevel.ofLevel Us u = some u') (h2 : VLevel.ofLevel Us v = some v') : diff --git a/Lean4Lean/Verify/VLCtx.lean b/Lean4Lean/Verify/VLCtx.lean index f6c6d08c..ef0c619b 100644 --- a/Lean4Lean/Verify/VLCtx.lean +++ b/Lean4Lean/Verify/VLCtx.lean @@ -41,7 +41,7 @@ def VLocalDecl.instL : VLocalDecl → List VLevel → VLocalDecl | .vlam A, ls => .vlam (A.instL ls) | .vlet A e, ls => .vlet (A.instL ls) (e.instL ls) -def VLCtx := List (Option (FVarId × List FVarId) × VLocalDecl) +@[reducible] def VLCtx := List (Option (FVarId × List FVarId) × VLocalDecl) namespace VLCtx diff --git a/divergences.md b/divergences.md index d7189272..b6d9eec0 100644 --- a/divergences.md +++ b/divergences.md @@ -6,7 +6,11 @@ This is a list of places where lean4lean deliberately has different behavior fro * [`Lean4Lean.Environment.checkPrimitiveDef`](Lean4Lean/Primitive.lean), `checkPrimitiveInductive`: Lean does not check that primitives are declared with the correct types and definitional behavior, except in the case of `Eq` which is used in the declaration of `Quot`. This is required for soundness, but Lean is able to get away with it because Lean ships its prelude and using an alternative prelude is not supported. * [`Lean4Lean.TypeChecker.Inner.inferType'`](Lean4Lean/TypeChecker.lean), literal case: The original code was not checking that the literal type actually exists. Again, this is okay provided that the prelude is trusted. * [`Lean4Lean.TypeChecker.Inner.tryStringLitExpansionCore`](Lean4Lean/TypeChecker.lean): there is a counterproductive `whnf` call in this function which is removed in Lean4lean. -* [`Lean.Level.normalize`](https://github.com/leanprover/lean4/blob/v4.32.2/src/Lean/Level.lean), `isEquiv`, `geq`: Lean4lean uses the level operations from Lean's standard library. These currently differ from the C++ kernel implementation; [leanprover/lean4#14356](https://github.com/leanprover/lean4/pull/14356) tracks aligning them. The primed operations in [`Lean4Lean/Level.lean`](Lean4Lean/Level.lean) are an unused experimental decision procedure for level algebra. -* [`Lean4Lean.TypeChecker.Inner.inferLambda`](Lean4Lean/TypeChecker.lean), `inferLet`: lean4lean does the `ensureSort` call before extending the context, while [`infer_lambda`](https://github.com/leanprover/lean4/blob/v4.26.0/src/kernel/type_checker.cpp#L124-L126) does it afterward. It's not clear whether this is actually unsound but it would require some very weird invariants to justify having unchecked things in the local context and hoping that they won't be used in the typing proof of that same expression. +* [`Lean.Level.normalize`](https://github.com/leanprover/lean4/blob/v4.33.0-rc2/src/Lean/Level.lean), `isEquiv`, `geq`: Lean4lean uses the level operations from Lean's standard library. These currently differ from the C++ kernel implementation; [leanprover/lean4#14356](https://github.com/leanprover/lean4/pull/14356) tracks aligning them. The primed operations in [`Lean4Lean/Level.lean`](Lean4Lean/Level.lean) are an unused experimental decision procedure for level algebra. * [`Lean4Lean.checkConstantVal`](Lean4Lean/Environment.lean): The original implementation would call `check` which sets the level params and then unsets them afterward, and then `ensure_sort` would run in a context without any level params. In lean4lean the monad is parameterized over level params, so they remain the same across the two calls. -* [`Lean4Lean.TypeChecker.Inner.isProp`](Lean4Lean/TypeChecker.lean), [`Lean4Lean.toCtorWhenStruct`](Lean4Lean/Inductive/Reduce.lean): Lean decides whether a sort is `Prop` by comparing it syntactically against `Sort 0`. That misses `Sort (imax 1 0)`, which denotes `Prop` without being syntactically `zero`, and the mismatch between this test and the one used for proof irrelevance resulted in a soundness bug ([leanprover/lean4#14613](https://github.com/leanprover/lean4/pull/14613)). Lean4lean tests the level instead, but using `isAlwaysZero` instead of `isZero` in `isProp`, and `isNeverZero` instead of `!isAlwaysZero` in `toCtorWhenStruct` and `inferProj`. The lean check using `!isAlwaysZero` in `toCtorWhenStruct` would be unsound if not for the fact that the level algorithm rejects the true equation `imax 1 u ≤ u`: `inductive T.{u} : Sort u where mk : Bool → T` would allow proving false using a similar construction to the one in [#14613](https://github.com/leanprover/lean4/pull/14613). +* [`Lean4Lean.toCtorWhenStruct`](Lean4Lean/Inductive/Reduce.lean), `inferProj`: both kernels now recognize `Prop` using normalized universe levels ([leanprover/lean4#14613](https://github.com/leanprover/lean4/pull/14613)). Lean4lean remains more conservative for uncertain levels, using `isNeverZero` where Lean uses `!isAlwaysZero`. Lean's choice would be unsound if its level algorithm did not reject the true equation `imax 1 u ≤ u`: `inductive T.{u} : Sort u where mk : Bool → T` would otherwise permit an analogue of the construction in #14613. +* [`Lean4Lean.EquivManager.isEquiv`](Lean4Lean/EquivManager.lean), [`Lean4Lean.TypeChecker.Inner.isDefEqCore'`](Lean4Lean/TypeChecker.lean), `reduceProj`: when comparing two projections, and when reducing one, lean4lean uses only the projection index, while the C++ kernel also compares the structure name ([leanprover/lean4#14631](https://github.com/leanprover/lean4/pull/14631), [#14632](https://github.com/leanprover/lean4/pull/14632)). The name has already been checked by the time either happens: [`inferProj`](Lean4Lean/TypeChecker.lean) rejects `.proj S i e` unless the type of `e` whnfs to an application of `S` itself. Comparison and reduction only ever see projections that have been through type inference, so re-comparing the name there is redundant. +* [`Lean4Lean.Environment.addInductive`](Lean4Lean/Inductive/Add.lean): [leanprover/lean4#14621](https://github.com/leanprover/lean4/pull/14621) rechecks the declarations produced by nested-inductive elimination — the restored constructor types, the restored recursor types and the recursor rules' right-hand sides. Lean4lean does not. Upstream describes these as redundant sanity checks that "may prevent soundness bugs if the nested-inductive code is still missing any required validations"; they establish no precondition that a later step consumes. Lean4lean aims to prove the elimination correct rather than to recheck its output, and a speculative check would only add proof obligations without contributing an invariant. The check of the nested applications `I Ds` from [#14577](https://github.com/leanprover/lean4/pull/14577) is kept, because those arguments are dropped from the auxiliary declarations and so are not covered by checking the block. +* [`Lean4Lean.checkNoNestedAux`](Lean4Lean/Inductive/Add.lean): [leanprover/lean4#14616](https://github.com/leanprover/lean4/pull/14616) rejects the reserved `_nested` prefix in both the inductive types and the constructor types of a declaration; lean4lean checks only the constructor types. The bug that check fixes is specific to constructors: nested occurrences are rewritten to the auxiliary types in constructor types only (`replaceAllNested`), and rewritten back the same way (`restoreNested`), so an inductive's own type is carried through both directions verbatim and cannot acquire a type it was not checked at. A `_nested` name written in an inductive type also cannot resolve in the first place: the auxiliary types are declared in the same block, so they are not in the environment while that block's types are checked (unlike constructor types, which are checked once the block's types, auxiliaries included, are present), and they never survive into the final environment. Lean's check additionally reserves the whole `_nested` namespace against unrelated user declarations, which lean4lean does not. +* [`Lean4Lean.ElimNestedInductive.Result.restoreNested`](Lean4Lean/Inductive/Add.lean), `restoreCtorName`: [leanprover/lean4#14632](https://github.com/leanprover/lean4/pull/14632) turned the `lean_assert`s in the nested-inductive restoration into kernel exceptions; lean4lean keeps `unreachable!` and `assert!`. The branches are unreachable: `restoreCtorName` runs only for the recursors of the auxiliary types the elimination generates, whose constructors are exactly the keys of `aux2nested`, and the nested occurrences stored there are applications of a constant by construction. Upstream's stated motivation is that the assertions vanish in a release build and the C++ consumers then read out of bounds; the corresponding accesses here are total, so there is nothing to read out of bounds. Note that if one of these invariants were broken anyway, `unreachable!` would continue with a default value rather than reject; the restored constructor and recursor types are re-checked in the final environment ([#14621](https://github.com/leanprover/lean4/pull/14621)), which lean4lean retains, but a restored rule constructor *name* is not covered by that pass. +* [`Lean4Lean.FuelConfig`](Lean4Lean/FuelConfig.lean): since [leanprover/lean4#13956](https://github.com/leanprover/lean4/pull/13956), the native kernel bounds mutually recursive checking through the `maxRecDepth` option. Lean4lean exposes several independent fuel counters instead, because its Lean definitions also need explicit termination witnesses. Replay comparison therefore uses each implementation's default bound unless an explicit lean4lean fuel configuration is supplied. diff --git a/lake-manifest.json b/lake-manifest.json index 70c6efab..3679dc7f 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,10 +5,10 @@ "type": "git", "subDir": null, "scope": "", - "rev": "cb3961288e99f02ee3d23aab55391aebb258fd0c", + "rev": "76e1c118b0700b4ceafe99532e887d6431625e1a", "name": "batteries", "manifestFile": "lake-manifest.json", - "inputRev": "v4.32.2", + "inputRev": "v4.33.0-rc2", "inherited": false, "configFile": "lakefile.toml"}], "name": "lean4lean", diff --git a/lakefile.toml b/lakefile.toml index 4c16c997..ede19ae5 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -4,7 +4,7 @@ defaultTargets = ["Lean4Lean", "lean4lean", "Lean4Lean.Theory", "Lean4Lean.Verif [[require]] name = "batteries" git = "https://github.com/leanprover-community/batteries" -rev = "v4.32.2" +rev = "v4.33.0-rc2" [[lean_lib]] name = "Lean4Lean" diff --git a/lean-toolchain b/lean-toolchain index 0ec5999c..c084c7fb 100644 --- a/lean-toolchain +++ b/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.32.2 +leanprover/lean4:v4.33.0-rc2 From dc00b8eeeb6b30fcc667dc138bb2d629c48e3710 Mon Sep 17 00:00:00 2001 From: Bryan Gin-ge Chen Date: Tue, 4 Aug 2026 17:17:58 -0400 Subject: [PATCH 04/51] ci: add Zulip emoji reconcile workflow (#35) Adds the mathlib-ci Zulip emoji reconciler so PR state (open/closed/ merged) and CI status are mirrored as emoji reactions on Zulip messages that mention lean4lean PRs. Triggers: hourly sweep, manual dispatch, PR close/reopen events, and CI workflow runs. Co-authored-by: Claude Fable 5 --- .github/workflows/zulip_emoji_reconcile.yml | 90 +++++++++++++++++++++ .github/zulip-emoji-config.json | 23 ++++++ 2 files changed, 113 insertions(+) create mode 100644 .github/workflows/zulip_emoji_reconcile.yml create mode 100644 .github/zulip-emoji-config.json diff --git a/.github/workflows/zulip_emoji_reconcile.yml b/.github/workflows/zulip_emoji_reconcile.yml new file mode 100644 index 00000000..d2f30d1d --- /dev/null +++ b/.github/workflows/zulip_emoji_reconcile.yml @@ -0,0 +1,90 @@ +name: Zulip emoji reconcile + +on: + schedule: + - cron: "37 * * * *" # hourly sweep: the self-healing safety net + workflow_dispatch: + inputs: + pr: + description: "PR number(s), space-separated; leave empty to sweep recent messages" + required: false + default: "" + dry-run: + description: "Log planned reaction changes without writing to Zulip" + type: boolean + default: false + pull_request_target: # close/merge/reopen changes, within seconds + types: [closed, reopened] + workflow_run: # CI start/finish, so the CI emoji updates promptly + workflows: ["CI"] + types: [requested, completed] + +concurrency: + # Serialize runs: the reconciler reads live PR state and then writes + # reactions, so two interleaved runs could re-assert stale state. GitHub + # keeps only the newest queued run per group (earlier pending runs are + # canceled), which suits a level-triggered tool — the last run recomputes + # everything from live state and converges to the final answer. + group: ${{ github.workflow }} + cancel-in-progress: false + +permissions: + contents: read + pull-requests: read + +jobs: + reconcile: + runs-on: ubuntu-latest + if: github.repository == 'digama0/lean4lean' # skip runs on forks + steps: + # On pull_request_target / workflow_run this checks out the *default* + # branch, so the config (and everything else that runs in this job) is + # never PR-controlled. + - name: Check out this repo's config + uses: actions/checkout@3d3c42e5aac5ba805825da76410c181273ba90b1 # v7.0.1 + with: + sparse-checkout: .github/zulip-emoji-config.json + sparse-checkout-cone-mode: false + + - name: Determine PR number(s) + id: target + env: + GH_TOKEN: ${{ github.token }} + EVENT: ${{ github.event_name }} + INPUT_PR: ${{ inputs.pr }} + EVENT_PR: ${{ github.event.pull_request.number }} + HEAD_SHA: ${{ github.event.workflow_run.head_sha }} + run: | + set -euo pipefail + case "$EVENT" in + workflow_dispatch) pr="$INPUT_PR" ;; + pull_request_target) pr="$EVENT_PR" ;; + workflow_run) + # PR(s) at the CI run's head commit (works for fork PRs too). + pr=$(gh api "repos/${GITHUB_REPOSITORY}/commits/${HEAD_SHA}/pulls" \ + --jq 'map(.number) | join(" ")') + ;; + *) pr="" ;; # schedule -> sweep + esac + echo "pr=${pr}" >> "$GITHUB_OUTPUT" + + - name: Reconcile + # Skip only a workflow_run whose head commit no longer maps to a PR; + # schedule and PR-less dispatches sweep instead. + if: steps.target.outputs.pr != '' || github.event_name == 'schedule' || github.event_name == 'workflow_dispatch' + uses: leanprover-community/mathlib-ci/.github/actions/zulip-emoji-reconcile@5668fbbccf0fecefdfcddf539b8406db197dfc59 + with: + config: .github/zulip-emoji-config.json + pr: ${{ steps.target.outputs.pr }} + sweep: ${{ !steps.target.outputs.pr }} + dry-run: ${{ inputs.dry-run == true }} + zulip-api-key: ${{ secrets.ZULIP_API_KEY }} + github-token: ${{ github.token }} + + workflow-keepalive: + if: github.repository == 'digama0/lean4lean' && github.event_name == 'schedule' + runs-on: ubuntu-latest + permissions: + actions: write + steps: + - uses: liskin/gh-workflow-keepalive@f72ff1a1336129f29bf0166c0fd0ca6cf1bcb38c # v1.2.1 diff --git a/.github/zulip-emoji-config.json b/.github/zulip-emoji-config.json new file mode 100644 index 00000000..92cd0f26 --- /dev/null +++ b/.github/zulip-emoji-config.json @@ -0,0 +1,23 @@ +{ + "_comment": "Reconcile config for digama0/lean4lean: open/closed/merged plus CI status, using standard unicode emoji. See docs/zulip-emoji-quickstart.md in leanprover-community/mathlib-ci for setup, and docs/zulip-emoji-reconcile.md there for the full schema.", + + "github_repo": "digama0/lean4lean", + + "zulip": { + "site": "https://leanprover.zulipchat.com", + "email": "leanprover-community-repo-update-bot@leanprover.zulipchat.com" + }, + + "channels": { + "pr_reviews": "lean4lean" + }, + + "states": [ + {"name": "merged", "group": "pr", "priority": 30, "source": {"state": "merged"}, "emoji": "merge"}, + {"name": "closed", "group": "pr", "priority": 20, "source": {"state": "closed"}, "emoji": "closed-pr", "emoji_code": "61293", "reaction_type": "realm_emoji"}, + + {"name": "ci-running", "group": "ci", "source": {"ci": "running"}, "emoji": "yellow"}, + {"name": "ci-success", "group": "ci", "source": {"ci": "success"}, "emoji": "check"}, + {"name": "ci-failure", "group": "ci", "source": {"ci": "failure"}, "emoji": "cross_mark"} + ] +} From 924e7d8e49c5da2e0ff6f385cc256c8963354371 Mon Sep 17 00:00:00 2001 From: Serhii Khoma Date: Wed, 5 Aug 2026 04:23:05 +0700 Subject: [PATCH 05/51] docs: document defeq and type inference related functions (#12) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * docs: document defeq and type inference related functions Squash merge of PR #2 by rish987. Reference: https://github.com/digama0/lean4lean/pull/2 Adds documentation for defeq and type-inference related functions to improve codebase understandability. * docs: restyle to match the codebase Reflow the docstrings added in the previous commit to the style used in the rest of the codebase: text starts on the `/--` line, `-/` closes the last line, and lines are wrapped at 100 columns (also applied to the new `--` comments, four of which ran to 100-187 columns). Incidental fixes while rewrapping: backtick and modernize the `cheapBetaReduce` example (Lean 3 `λ x, x` -> `fun x => x`, and the body is `xᵢ`, not `x₁`); `inferConstant` documents `.const name ls`, not `.const e ls`; `->` -> `→` and `cheapProj = true` -> `cheapProj := true`. Co-Authored-By: Claude Opus 5 * docs: correct the claims that don't match the code The docstrings added two commits ago were written against an older lean4lean and describe several things the code does not do. Rewritten against the current implementation: * `unfoldDefinitionCore` takes a `.const`, not an application with a constant head (that is `unfoldDefinition`); its doc had been copied from `isDelta`. * `isDelta` also requires the right number of universe levels, and the question of which constants delta-reduce is already settled by `ConstantInfo.deltaValue?`, so point at it rather than restating it. * `quickIsDefEq` defers constants and free variables too, not just applications and projections, and it refutes as well as confirms. Same correction in the `lazyDeltaReductionStep` and `lazyDeltaReduction` docs, which reused the wording. * `lazyDeltaReductionStep` hands `.unknown` back to `isDefEqCore'`, not `isDefEq`. * `reduceNat` was missing `Nat.succ`, `land`, `lor`, `xor`, `shiftLeft` and `shiftRight`, and `Nat.beq`/`Nat.ble` yield `Bool`, not `Nat`, literals. * `isDefEqOffset` decides `0 ≡ 0` before looking at successors. * `cheapBetaReduce` also reduces a body with no loose bvars, and leaves `e` alone in every other case, which is the point of the name. * `toCtorWhenStruct`'s `String` example predates `String` becoming a two-field structure over `ByteArray`; use `Prod`. Likewise `tryStringLitExpansionCore` matches `String.ofList`, which is no longer the constructor. * `inductiveReduceRec` applies the rule to the motives and minor premises as well as the parameters, accepts literal major premises, and re-applies the arguments past the major premise. * `inferType` also throws on resource exhaustion, so not "if and only if". * `isDefEqCore` referred to a `check` function; it is `checkType`. * `whnfFVar` uses `whnfCore`, and `whnfCore`'s `cheapRec` is never set. * `RecM.run` and `lazyDeltaReduction` take their limits from `FuelConfig`. All three `FIXME(kernel)` comments are rewritten as statements: each asked a question the code answers -- `cheapProj := true` leaves head projections unreduced, the recursive `whnfCore` call does reach `reduceRecursor`, and the eta-struct case is redundant work that the kernel performs identically -- so none of them is a divergence, and none stays a FIXME. Co-authored-by: Mario Carneiro Co-authored-by: Claude Opus 5 Co-authored-by: Rishikesh Vaishnav --- Lean4Lean/Inductive/Reduce.lean | 24 +++++ Lean4Lean/Instantiate.lean | 4 + Lean4Lean/Level.lean | 1 + Lean4Lean/Quot.lean | 18 +++- Lean4Lean/TypeChecker.lean | 166 ++++++++++++++++++++++++++++++++ 5 files changed, 212 insertions(+), 1 deletion(-) diff --git a/Lean4Lean/Inductive/Reduce.lean b/Lean4Lean/Inductive/Reduce.lean index deb29292..cdac9f9e 100644 --- a/Lean4Lean/Inductive/Reduce.lean +++ b/Lean4Lean/Inductive/Reduce.lean @@ -20,6 +20,12 @@ def mkNullaryCtor (type : Expr) (nparams : Nat) : Option Expr := let name ← getFirstCtor env dName return mkAppRange (.const name ls) 0 nparams args +/-- When `e` has the type of a K-like inductive, converts it into a constructor application. + +For instance if we have `e : Eq a a`, it is converted into `Eq.refl a` (which it is definitionally +equal to by proof irrelevance). Note that the indices of `e`'s type must match those of the +constructor application (for instance, `e : Eq a b` cannot be converted if `a` and `b` are not +defeq). -/ def toCtorWhenK (rval : RecursorVal) (e : Expr) : m Expr := do assert! rval.k let appType ← whnf (← inferType e) @@ -30,6 +36,7 @@ def toCtorWhenK (rval : RecursorVal) (e : Expr) : m Expr := do for h : i in [rval.numParams:appTypeArgs.size] do if appTypeArgs[i].hasExprMVar then return e let some newCtorApp := mkNullaryCtor env appType rval.numParams | return e + -- check that the indices of types of `e` and `newCtorApp` match unless ← isDefEq appType (← inferType newCtorApp) do return e return newCtorApp @@ -43,6 +50,11 @@ def expandEtaStruct (eType e : Expr) : Expr := result := .app result (.proj I i e) pure result +/-- When `e` is of non-recursive structure type, and that type is not a proposition, converts `e` +into a constructor application using projections. + +For instance if we have `e : α × β`, it is converted into `Prod.mk α β e.1 e.2` (which is +definitionally equal to `e` by struct eta). -/ def toCtorWhenStruct (inductName : Name) (e : Expr) : m Expr := do if !env.isNonRecStructure inductName || (e.isConstructorApp?' env).isSome then return e @@ -56,6 +68,15 @@ def getRecRuleFor (rval : RecursorVal) (major : Expr) : Option RecursorRule := d let .const fn _ := major.getAppFn | none rval.rules.find? (·.ctor == fn) +/-- Performs recursor reduction on `e` (returning `none` if not applicable). + +For recursor reduction to occur, `e` must be a recursor application where the major premise is +either a complete constructor application, a `Nat` or `String` literal, or of a K- or +structure-like inductive type (in each case it is converted into an equivalent constructor +application). The reduction is done by applying the `RecursorRule.rhs` associated with the +constructor to everything before the indices in the recursor application (its parameters, motives +and minor premises) and then to the fields of the constructor application; any arguments after the +major premise are re-applied to the result. -/ def inductiveReduceRec [Monad m] (env : Environment) (e : Expr) (whnf : Expr → m Expr) (inferType : Expr → m Expr) (isDefEq : Expr → Expr → m Bool) : m (Option Expr) := do @@ -76,7 +97,10 @@ def inductiveReduceRec [Monad m] (env : Environment) (e : Expr) if rule.nfields > majorArgs.size then return none if ls.length != info.levelParams.length then return none let mut rhs := rule.rhs.instantiateLevelParams info.levelParams ls + -- get the parameters, motives and minor premises from the recursor application (recursor rules + -- don't need the indices, as these are determined by the constructor and its parameters/fields) rhs := mkAppRange rhs 0 info.getFirstIndexIdx recArgs + -- get fields from constructor application rhs := mkAppRange rhs (majorArgs.size - rule.nfields) majorArgs.size majorArgs if majorIdx + 1 < recArgs.size then rhs := mkAppRange rhs (majorIdx + 1) recArgs.size recArgs diff --git a/Lean4Lean/Instantiate.lean b/Lean4Lean/Instantiate.lean index b8cd6b9b..e5379536 100644 --- a/Lean4Lean/Instantiate.lean +++ b/Lean4Lean/Instantiate.lean @@ -5,6 +5,10 @@ import Lean.Util.InstantiateLevelParams namespace Lean namespace Expr +/-- Beta-reduces an application `(fun x₁ ... xₙ => b) a₁ ... aₙ aₙ₊₁ ... aₘ` in the two cases where +no substitution is needed: to `b aₙ₊₁ ... aₘ` when `b` has no loose bound variables, and to +`aᵢ aₙ₊₁ ... aₘ` when `b` is the bound variable `xᵢ`. In any other case `e` is returned unchanged — +this is what makes it cheap. -/ def cheapBetaReduce (e : Expr) : Expr := Id.run do if !e.isApp then return e let fn := e.getAppFn diff --git a/Lean4Lean/Level.lean b/Lean4Lean/Level.lean index 85043fb7..4550fe26 100644 --- a/Lean4Lean/Level.lean +++ b/Lean4Lean/Level.lean @@ -10,6 +10,7 @@ def forEach [Monad m] (l : Level) (f : Level → m Bool) : m Unit := do | .max l₁ l₂ | .imax l₁ l₂ => l₁.forEach f; l₂.forEach f | .zero | .param .. | .mvar .. => pure () +/-- Returns `some n` if level parameter `n` appears in `l` and `n ∉ ps`. -/ def getUndefParam (l : Level) (ps : List Name) : Option Name := Id.run do (·.2) <$> StateT.run (s := none) do l.forEach fun l => do diff --git a/Lean4Lean/Quot.lean b/Lean4Lean/Quot.lean index e7874f98..d6b55199 100644 --- a/Lean4Lean/Quot.lean +++ b/Lean4Lean/Quot.lean @@ -78,7 +78,7 @@ def Environment.addQuot (env : Environment) : Except Exception Environment := do let all_quot := (← read).mkForall #[a] <| .app β quotMk_a withLocalDecl `q .implicit quot_r fun q => do -- constant Quot.ind.{u} {α : Sort u} {r : α → α → Prop} {β : @Quot.{u} α r → Prop} : - -- (∀ a : α, β (@Quot.mk.{u} α r a)) → ∀ q : @Quot.{u} α r, β q */ + -- (∀ a : α, β (@Quot.mk.{u} α r a)) → ∀ q : @Quot.{u} α r, β q let env := env.add <| .quotInfo { name := ``Quot.ind, kind := .ind, levelParams := [`u] type := (← read).mkForall #[α, r, β] <| @@ -86,6 +86,22 @@ def Environment.addQuot (env : Environment) : Except Exception Environment := do } return markQuotInit env +/-- Reduces the head application of a quotient eliminator as follows: + +``` +Quot.lift.{u, v} {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β) : + (∀ a b : α, r a b → f a = f b) → @Quot.{u} α r → β + +Quot.lift f h (Quot.mk r a) ... ⟶ f a ... +``` + +``` +Quot.ind.{u} {α : Sort u} {r : α → α → Prop} {β : @Quot.{u} α r → Prop} : + (∀ a : α, β (@Quot.mk.{u} α r a)) → ∀ q : @Quot.{u} α r, β q + +Quot.ind p (Quot.mk r a) ... ⟶ p a ... +``` +-/ def quotReduceRec [Monad m] (e : Expr) (whnf : Expr → m Expr) : m (Option Expr) := do let .const fn _ := e.getAppFn | return none let cont mkPos argPos := do diff --git a/Lean4Lean/TypeChecker.lean b/Lean4Lean/TypeChecker.lean index 4d0bae88..2b1f30db 100644 --- a/Lean4Lean/TypeChecker.lean +++ b/Lean4Lean/TypeChecker.lean @@ -76,23 +76,29 @@ inductive ReductionStatus where namespace Inner +/-- Reduces `e` to its weak-head normal form. -/ def whnf (e : Expr) : RecM Expr := fun m => m.whnf e @[inline] def withLCtx [MonadWithReaderOf LocalContext m] (lctx : LocalContext) (x : m α) : m α := withReader (fun _ => lctx) x +/-- Ensures that `e` is defeq to some `e' := .sort ..`, returning `e'`. If not, throws an error with +`s` (the expression required to be a sort). -/ def ensureSortCore (e s : Expr) : RecM Expr := do if e.isSort then return e let e ← whnf e if e.isSort then return e throw <| .typeExpected (← getEnv) (← getLCtx) s +/-- Ensures that `e` is defeq to some `e' := .forallE ..`, returning `e'`. If not, throws an error +with `s := f a` (the application requiring `f` to be of function type). -/ def ensureForallCore (e s : Expr) : RecM Expr := do if e.isForall then return e let e ← whnf e if e.isForall then return e throw <| .funExpected (← getEnv) (← getLCtx) s +/-- Checks that `l` does not contain any level parameters not found in the context `tc`. -/ def checkLevel (tc : Context) (l : Level) : Except Exception Unit := do if let some n2 := l.getUndefParam tc.lparams then throw <| .other s!"invalid reference to undefined universe level parameter '{n2}'" @@ -102,6 +108,7 @@ def inferFVar (tc : Context) (name : FVarId) : Except Exception Expr := do return decl.type throw <| .other "unknown free variable" +/-- Infers the type of `.const name ls`. -/ def inferConstant (tc : Context) (name : Name) (ls : List Level) (inferOnly : Bool) : Except Exception Expr := do let e := Expr.const name ls @@ -121,8 +128,14 @@ def inferConstant (tc : Context) (name : Name) (ls : List Level) (inferOnly : Bo checkLevel tc l return info.instantiateTypeLevelParams ls +/-- Infers the type of expression `e`. If `inferOnly := false`, this function throws an error +whenever `e` is not typeable according to Lean's algorithmic typing judgment (barring resource +exhaustion: it may also throw `.deterministicTimeout` or `.deepRecursion` on a typeable term). +Setting `inferOnly := true` optimizes to avoid unnecessary checks in the case that `e` is already +known to be well-typed. -/ def inferType (e : Expr) (inferOnly := true) : RecM Expr := fun m => m.inferType e inferOnly +/-- Infers the type of lambda expression `e`. -/ def inferLambda (e : Expr) (inferOnly : Bool) : RecM Expr := loop #[] e where loop fvars : Expr → RecM Expr | .lam name dom body bi => do @@ -137,6 +150,7 @@ def inferLambda (e : Expr) (inferOnly : Bool) : RecM Expr := loop #[] e where let r := r.cheapBetaReduce return (← getLCtx).mkForall fvars r +/-- Infers the type of for-all expression `e`. -/ def inferForall (e : Expr) (inferOnly : Bool) : RecM Expr := loop #[] #[] e where loop fvars us : Expr → RecM Expr | .forallE name dom body bi => do @@ -150,14 +164,24 @@ def inferForall (e : Expr) (inferOnly : Bool) : RecM Expr := loop #[] #[] e wher let s ← ensureSortCore r e return .sort <| us.foldr mkLevelIMax' s.sortLevel! +/-- Returns whether `t` and `s` are definitionally equal according to Lean's algorithmic +definitional equality judgment. + +NOTE: This function does not do any typechecking of its own on `t` and `s`. So, when this is used as +part of a typechecking routine, it is expected that they are already well-typed (that is, that +`checkType t` and `checkType s` did not/would not throw an error). This is what justifies the +internal uses of `inferType` at its default `inferOnly := true`: on a well-typed subterm the fast +path returns the same type the checking path would have. -/ def isDefEqCore (t s : Expr) : RecM Bool := fun m => m.isDefEqCore t s +@[inherit_doc isDefEqCore] def isDefEq (t s : Expr) : RecM Bool := do let r ← isDefEqCore t s if r then modify fun st => { st with eqvManager := st.eqvManager.addEquiv t s } pure r +/-- Infers the type of application `e`, assuming that `e` is already well-typed. -/ def inferApp (e : Expr) : RecM Expr := do e.withApp fun f args => let rec loop fType j i : RecM Expr := @@ -172,6 +196,7 @@ def inferApp (e : Expr) : RecM Expr := do return fType.instantiateRevRange j args.size args do loop (← inferType f) 0 0 +/-- Infers the type of let-expression `e`. -/ def inferLet (e : Expr) (inferOnly : Bool) : RecM Expr := loop #[] e where loop fvars : Expr → RecM Expr | .letE name type val body _ => do @@ -189,12 +214,17 @@ def inferLet (e : Expr) (inferOnly : Bool) : RecM Expr := loop #[] e where let r := r.cheapBetaReduce return (← getLCtx).mkForall fvars r +/-- Gets the universe level of the sort that `e`'s type is defeq to, failing if `e` is not +a type. -/ def getSortLevel (e : Expr) : RecM Level := do let .sort u ← ensureSortCore (← inferType e) e | unreachable! return u +/-- Checks if `e` is a proposition, that is, if its type is a sort whose level normalizes to +zero. -/ def isProp (e : Expr) : RecM Bool := return (← getSortLevel e).isAlwaysZero +/-- Infers the type of structure projection `e`. -/ def inferProj (typeName : Name) (idx : Nat) (struct structType : Expr) : RecM Expr := do let e := Expr.proj typeName idx struct let type ← whnf structType @@ -215,6 +245,7 @@ def inferProj (typeName : Name) (idx : Nat) (struct structType : Expr) : RecM Ex for i in [:idx] do let .forallE _ dom b _ ← whnf r | fail if b.hasLooseBVars then + -- prop structs cannot have non-prop dependent fields if maybePropType then if !(← isProp dom) then fail r := b.instantiate1 (.proj I_name i struct) else @@ -223,6 +254,7 @@ def inferProj (typeName : Name) (idx : Nat) (struct structType : Expr) : RecM Ex if maybePropType then if !(← isProp dom) then fail return dom +@[inherit_doc inferType] def inferType' (e : Expr) (inferOnly : Bool) : RecM Expr := do if e.hasLooseBVars then throw <| .other @@ -257,6 +289,8 @@ def inferType' (e : Expr) (inferOnly : Bool) : RecM Expr := do let fType ← ensureForallCore (← inferType' f inferOnly) e let aType ← inferType' a inferOnly let dType := fType.bindingDomain! + -- it can be shown that if `e` is typeable as `T`, then `T` is typeable as `Sort l` + -- for some universe level `l`, so this use of `isDefEq` is valid let ok ← if a.isAppOfArity ``eagerReduce 2 then withTheReader Context (fun s => {s with eagerReduce := true}) <| isDefEq dType aType @@ -270,6 +304,19 @@ def inferType' (e : Expr) (inferOnly : Bool) : RecM Expr := do { s with inferTypeC := s.inferTypeC.insert e r } return r +/-- Reduces `e` to its weak-head normal form, without unfolding definitions. This is a conservative +version of `whnf` (which does unfold definitions), to be used for efficiency purposes. + +Setting `cheapRec` or `cheapProj` to `true` will cause the major premise/struct argument to be +reduced "lazily" (using `whnfCore` rather than `whnf`) when reducing recursor applications/struct +projections, and suppresses caching of the result. This can be a useful optimization if we're +checking the definitional equality of two recursor applications/struct projections of the same +recursor/projection, where we might save some work by directly checking if the major premises/struct +arguments are defeq (rather than eagerly applying a recursor rule/projection). + +In practice only `cheapProj` is ever set. `cheapRec` is threaded through to mirror the kernel, where +it has been dead since lean4#9275 removed the old compiler: its one caller was `csimp`, through the +`whnf_core_cheap` wrapper that still exists but is now unused. -/ def whnfCore (e : Expr) (cheapRec := false) (cheapProj := false) : RecM Expr := fun m => m.whnfCore e cheapRec cheapProj @@ -283,11 +330,15 @@ def reduceRecursor (e : Expr) (cheapRec := false) (cheapProj := false) : RecM (O return r return none +/-- Reduces the free variable `e`: to the `whnfCore` of its definition if `e` is a let variable, +and to itself if it is a lambda variable. -/ def whnfFVar (e : Expr) (cheapRec cheapProj : Bool) : RecM Expr := do if let some (.ldecl (value := v) ..) := (← getLCtx).find? e.fvarId! then return ← whnfCore v cheapRec cheapProj return e +/-- Reduces a projection of `struct` at index `idx` (when `struct` is reducible to a constructor +application). -/ def reduceProj (idx : Nat) (struct : Expr) (cheapRec cheapProj : Bool) : RecM (Option Expr) := do let mut c ← (if cheapProj then whnfCore struct cheapRec cheapProj else whnf struct) if let .lit (.strVal s) := c then @@ -301,6 +352,7 @@ def reduceProj (idx : Nat) (struct : Expr) (cheapRec cheapProj : Bool) : RecM (O def isLetFVar (lctx : LocalContext) (fvar : FVarId) : Bool := lctx.find? fvar matches some (.ldecl ..) +@[inherit_doc whnfCore] def whnfCore' (e : Expr) (cheapRec := false) (cheapProj := false) : RecM Expr := do match e with | .bvar .. | .sort .. | .mvar .. | .forallE .. | .const .. | .lam .. | .lit .. => return e @@ -318,7 +370,10 @@ def whnfCore' (e : Expr) (cheapRec := false) (cheapProj := false) : RecM Expr := | .mdata .. => unreachable! | .fvar _ => return ← whnfFVar e cheapRec cheapProj | .app .. => + -- beta-reduce at the head as much as possible, apply any remaining `rargs` + -- to the resulting expression, and re-run `whnfCore` e.withAppRev fun f0 rargs => do + -- the head may still be a let variable/binding, projection, or mdata-wrapped expression let f ← whnfCore f0 cheapRec cheapProj if let .lam _ _ body _ := f then let rec loop m (f : Expr) : RecM Expr := @@ -338,6 +393,9 @@ def whnfCore' (e : Expr) (cheapRec := false) (cheapProj := false) : RecM Expr := pure e else let r := f.mkAppRevRange 0 rargs.size rargs + -- the recursive call re-decomposes `r` and reaches the `f == f0` branch above, so + -- `reduceRecursor` is still applied; adding arguments can only enable further normalization + -- if the head reduced to a partial recursor application save <|← whnfCore r cheapRec cheapProj | .letE _ _ val body _ => save <|← whnfCore (body.instantiate1 val) cheapRec cheapProj @@ -347,6 +405,9 @@ def whnfCore' (e : Expr) (cheapRec := false) (cheapProj := false) : RecM Expr := else save e +/-- Checks if the head of `e` is a constant that can be delta-reduced, applied to the right number +of universe levels, returning its `ConstantInfo` if so. See `ConstantInfo.deltaValue?` for which +constants qualify. -/ def isDelta (env : Environment) (e : Expr) : Option ConstantInfo := do if let .const c ls := e.getAppFn then if let some ci := env.find? c then @@ -357,6 +418,9 @@ def isDelta (env : Environment) (e : Expr) : Option ConstantInfo := do def instantiateDeltaValue (ci : ConstantInfo) (ls : List Level) : Expr := ci.deltaValue?.get!.instantiateLevelParams ci.levelParams ls +/-- If `e` is itself a constant that can be delta-reduced, returns its value with the constant's +level parameters instantiated. Unlike `unfoldDefinition`, this does not look through applications: +`e` must be a `.const`. -/ def unfoldDefinitionCore (e : Expr) : RecM (Option Expr) := do let .const _ ls := e | return none let env ← getEnv @@ -367,6 +431,8 @@ def unfoldDefinitionCore (e : Expr) : RecM (Option Expr) := do modify fun s => { s with unfold := s.unfold.insert e r } return some r +/-- Unfolds the definition at the head of the application `e` (or `e` itself if it is not an +application). -/ def unfoldDefinition (e : Expr) : RecM (Option Expr) := do if e.isApp then let f0 := e.getAppFn @@ -386,6 +452,9 @@ def reduceNative (_env : Environment) (e : Expr) : Except Exception (Option Expr def rawNatLitExt? (e : Expr) : Option Nat := if e == .natZero then some 0 else e.rawNatLit? +/-- Reduces the application `f a b` to a Nat literal if `a` and `b` can be reduced to Nat literals. + +Note: `f` should have an (efficient) external implementation. -/ def reduceBinNatOp (f : Nat → Nat → Nat) (a b : Expr) : RecM (Option Expr) := do let some v1 := rawNatLitExt? (← whnf a) | return none let some v2 := rawNatLitExt? (← whnf b) | return none @@ -399,11 +468,20 @@ def reducePow (a b : Expr) : RecM (Option Expr) := do if v2 > reducePowMaxExp then return none return some <| .lit <| .natVal <| Nat.pow v1 v2 +/-- Reduces the application `f a b` to a boolean expression if `a` and `b` can be reduced to Nat +literals. + +Note: `f` should have an (efficient) external implementation. -/ def reduceBinNatPred (f : Nat → Nat → Bool) (a b : Expr) : RecM (Option Expr) := do let some v1 := rawNatLitExt? (← whnf a) | return none let some v2 := rawNatLitExt? (← whnf b) | return none return toExpr <| f v1 v2 +/-- Reduces `e` to a literal if possible, where the unary operation `Nat.succ` and the binary +operations and predicates with an external implementation may be applied: `Nat.add`, `Nat.sub`, +`Nat.mul`, `Nat.pow`, `Nat.gcd`, `Nat.mod`, `Nat.div`, `Nat.land`, `Nat.lor`, `Nat.xor`, +`Nat.shiftLeft`, `Nat.shiftRight` produce a `Nat` literal, while the predicates `Nat.beq` and +`Nat.ble` produce a `Bool` literal. -/ def reduceNat (e : Expr) : RecM (Option Expr) := do let nargs := e.getAppNumArgs if nargs == 1 then @@ -429,6 +507,7 @@ def reduceNat (e : Expr) : RecM (Option Expr) := do if f == ``Nat.shiftRight then return ← reduceBinNatOp Nat.shiftRight a b return none +@[inherit_doc whnf] def whnf' (e : Expr) : RecM Expr := do -- Do not cache easy cases match e with @@ -455,6 +534,9 @@ def whnf' (e : Expr) : RecM Expr := do modify fun s => { s with whnfCache := s.whnfCache.insert e r } return r +/-- If `t` and `s` are lambda expressions, checks that their domains are defeq and recurses on the +bodies, substituting in a new free variable for that binder (this substitution is delayed for +efficiency purposes using the `subst` parameter). Otherwise, does a normal defeq check. -/ def isDefEqLambda (t s : Expr) (subst : Array Expr := #[]) : RecM Bool := match t, s with | .lam _ tDom tBody _, .lam name sDom sBody bi => do @@ -471,6 +553,9 @@ def isDefEqLambda (t s : Expr) (subst : Array Expr := #[]) : RecM Bool := isDefEqLambda tBody sBody (subst.push default) | t, s => isDefEq (t.instantiateRev subst) (s.instantiateRev subst) +/-- If `t` and `s` are for-all expressions, checks that their domains are defeq and recurses on the +bodies, substituting in a new free variable for that binder (this substitution is delayed for +efficiency purposes using the `subst` parameter). Otherwise, does a normal defeq check. -/ def isDefEqForall (t s : Expr) (subst : Array Expr := #[]) : RecM Bool := match t, s with | .forallE _ tDom tBody _, .forallE name sDom sBody bi => do @@ -487,7 +572,16 @@ def isDefEqForall (t s : Expr) (subst : Array Expr := #[]) : RecM Bool := isDefEqForall tBody sBody (subst.push default) | t, s => isDefEq (t.instantiateRev subst) (s.instantiateRev subst) +/-- Decides definitional equality of `t` and `s` in the cases that can be settled without +reduction, returning `.undef` to defer to the calling function otherwise. + +It returns `.true` if they are α-equivalent or have previously been checked for definitional +equality, and otherwise decides two sorts by level equivalence and two literals by equality, +returning `.false` where these disagree. Two lambdas or two for-alls are handed to +`isDefEqLambda`/`isDefEqForall`, which may return either. All remaining cases — including two +constants, two free variables, two applications and two projections — are deferred. -/ def quickIsDefEq (t s : Expr) (useHash := false) : RecM LBool := do + -- optimization for terms that are already α-equivalent or were previously checked if ← modifyGet fun (.mk a1 a2 a3 a4 a5 a6 a7 (eqvManager := m)) => let (b, m) := m.isEquiv useHash t s (b, .mk a1 a2 a3 a4 a5 a6 a7 (eqvManager := m)) @@ -501,6 +595,9 @@ def quickIsDefEq (t s : Expr) (useHash := false) : RecM LBool := do | .lit a1, .lit a2 => pure (a1 == a2).toLBool | _, _ => return .undef +/-- Assuming that `t` and `s` have the same function heads, returns true if they are applications +with definitionally equal arguments (in which case they are defeq), and false otherwise (deferring +further defeq checking to caller). -/ def isDefEqArgs (t s : Expr) : RecM Bool := do match t, s with | .app tf ta, .app sf sa => @@ -509,15 +606,27 @@ def isDefEqArgs (t s : Expr) : RecM Bool := do | .app .., _ | _, .app .. => return false | _, _ => return true +/-- Assuming `t` and `s` are WHNF, checks if they are defeq on account of `t` being an η-expansion +of `s`. + +Assuming that `s` has a function type `(x : A) → B x`, it η-expands to `fun (x : A) => s x` +(which it is definitionally equal to by the η rule). -/ def tryEtaExpansionCore (t s : Expr) : RecM Bool := do if t.isLambda && !s.isLambda then let .forallE name ty _ bi ← whnf (← inferType s) | return false isDefEq t (.lam name ty (.app s (.bvar 0)) bi) else return false +@[inherit_doc tryEtaExpansionCore] def tryEtaExpansion (t s : Expr) : RecM Bool := tryEtaExpansionCore t s <||> tryEtaExpansionCore s t +/-- Assuming `t` and `s` in WHNF, checks if they are defeq on account of `s` being defeq to the +struct-η-expansion of `t`. + +Assuming that `t` has a non-recursive structure type `S` with constructor `S.mk` and projections +`pᵢ`, it struct-η-expands to `S.mk (p₁ t) ... (pₙ t)` (which it is definitionally equal to by the +struct-η rule). -/ def tryEtaStructCore (t s : Expr) : RecM Bool := do let .const f _ := s.getAppFn | return false let env ← getEnv @@ -527,12 +636,20 @@ def tryEtaStructCore (t s : Expr) : RecM Bool := do unless ← isDefEq (← inferType t) (← inferType s) do return false let args := s.getAppArgs for h : i in [fInfo.numParams:args.size] do + -- since `t` is in WHNF, and assuming it is not a constructor application, this projection + -- cannot reduce (so we are directly checking if `s` is defeq to the struct-η-expansion of `t`) unless ← isDefEq (.proj fInfo.induct (i - fInfo.numParams) t) args[i] do return false return true +@[inherit_doc tryEtaStructCore] def tryEtaStruct (t s : Expr) : RecM Bool := + -- when `t` and `s` are both constructor applications, `isDefEqApp` has already compared their + -- arguments and returned false, and the projections in `tryEtaStructCore` reduce back to those + -- same arguments, so both calls below merely redo that work. The kernel has the same redundancy. tryEtaStructCore t s <||> tryEtaStructCore s t +/-- Checks if applications `t` and `s` (should be WHNF) are defeq on account of their function heads +and arguments being defeq. -/ def isDefEqApp (t s : Expr) : RecM Bool := do unless t.isApp && s.isApp do return false t.withApp fun tf tArgs => @@ -547,6 +664,8 @@ def isDefEqApp (t s : Expr) : RecM Bool := do loop 0 else return false +/-- Checks if `t` and `s` are definitionally equivalent according to proof irrelevance (that is, +they are proofs of the same proposition). -/ def isDefEqProofIrrel (t s : Expr) : RecM LBool := do let tType ← inferType t if !(← isProp tType) then return .undef @@ -570,6 +689,15 @@ def tryUnfoldProjApp (e : Expr) : RecM (Option Expr) := do let e' ← whnfCore e return if e' != e then e' else none +/-- Performs a single step of δ-reduction on `tn`, `sn`, or both (according to optimizations) +followed by weak-head normalization (without further δ-reduction). Returns `.bool` if the resulting +terms are settled by `quickIsDefEq`, or if they are applications of the same defined constant with +defeq args. Otherwise returns `.continue`, indicating to the calling `lazyDeltaReduction` that +δ-reduction is to be continued. + +If neither side has a δ-reducible head, returns `.unknown` with the terms unchanged, leaving further +defeq-checking to `isDefEqCore'`. Note that these are weak-head normal forms with respect to +`cheapProj := true`, so a projection at the head may still be reducible. -/ def lazyDeltaReductionStep (tn sn : Expr) : RecM ReductionStatus := do let env ← getEnv let delta e := do whnfCore (← unfoldDefinition e).get! (cheapProj := true) @@ -581,6 +709,8 @@ def lazyDeltaReductionStep (tn sn : Expr) : RecM ReductionStatus := do match isDelta env tn, isDelta env sn with | none, none => return .unknown tn sn | some _, none => + -- `sn` was normalized with `cheapProj := true`, so a projection at its head may not have been + -- reduced; `tryUnfoldProjApp` retries it with the struct argument fully normalized if let some sn' ← tryUnfoldProjApp sn then cont tn sn' else @@ -615,6 +745,9 @@ def isNatSuccOf? : Expr → Option Expr | .app (.const ``Nat.succ _) e => return e | _ => none +/-- Returns `.true` if `t` and `s` are both zero, either as a literal or as `Nat.zero`. If they are +both successors of natural numbers `t'` and `s'`, either as literals or `Nat.succ` applications, +checks that `t'` and `s'` are definitionally equal. Otherwise, defers to the calling function. -/ def isDefEqOffset (t s : Expr) : RecM LBool := do if isNatZero t && isNatZero s then return .true @@ -622,6 +755,14 @@ def isDefEqOffset (t s : Expr) : RecM LBool := do | some t', some s' => toLBoolM <| isDefEqCore t' s' | _, _ => return .undef +/-- Repeatedly δ-reduces the `cheapProj := true` weak-head normal forms `tn` and `sn` until the +question is settled. Returns `.bool` if: +- they are both zero or both natural number successors (as literals or `Nat.succ` applications) +- one of them can be converted to a natural number/boolean literal +- a `lazyDeltaReductionStep` settles them + +Otherwise returns `.unknown` with the reduced terms, deferring to the calling function. Throws +`.deterministicTimeout` after `FuelConfig.lazyDelta` steps. -/ def lazyDeltaReduction (tn sn : Expr) : RecM ReductionStatus := do loop tn sn (← readThe Context).fuel.lazyDelta where @@ -644,17 +785,23 @@ where | .continue tn sn => loop tn sn fuel | r => return r +/-- If `t` is a string literal and `s` is a `String.ofList` application, checks that they are defeq +after expanding `t` into a `String.ofList` application of an explicit character list. Otherwise, +defers to the calling function. -/ def tryStringLitExpansionCore (t s : Expr) : RecM LBool := do let .lit (.strVal st) := t | return .undef let .app sf _ := s | return .undef unless sf == .const ``String.ofList [] do return .undef toLBoolM <| isDefEqCore (.strLitToConstructor st) s +@[inherit_doc tryStringLitExpansionCore] def tryStringLitExpansion (t s : Expr) : RecM LBool := do match ← tryStringLitExpansionCore t s with | .undef => tryStringLitExpansionCore s t | r => return r +/-- Checks if `t` and `s` are defeq on account of both being of a unit type (a type with one +constructor without any fields or indices). -/ def isDefEqUnitLike (t s : Expr) : RecM Bool := do let tType ← whnf (← inferType t) let .const I _ := tType.getAppFn | return false @@ -664,6 +811,7 @@ def isDefEqUnitLike (t s : Expr) : RecM Bool := do let .ctorInfo { numFields := 0, .. } ← env.get c | return false isDefEqCore tType (← inferType s) +@[inherit_doc isDefEqCore] def isDefEqCore' (t s : Expr) : RecM Bool := do let r ← quickIsDefEq t s (useHash := true) if r != .undef then return r == .true @@ -691,14 +839,18 @@ def isDefEqCore' (t s : Expr) : RecM Bool := do if tf == sf && Level.isEquivList tl sl then return true | .fvar tv, .fvar sv => if tv == sv then return true | .proj _ ti te, .proj _ si se => + -- optimized by the previous reduction functions using `cheapProj := true` if ti == si then if ← isDefEq te se then return true | _, _ => pure () + -- the previous reduction functions used `cheapProj := true`, so we may not have a complete WHNF let tnn ← whnfCore tn let snn ← whnfCore sn if !(ptrEqExpr tnn tn && ptrEqExpr snn sn) then + -- if projection reduced, need to re-run (as we may not have a WHNF) return ← isDefEqCore tnn snn + -- tn and sn are both in WHNF if ← isDefEqApp tn sn then return true if ← tryEtaExpansion tn sn then return true if ← tryEtaStruct tn sn then return true @@ -723,6 +875,7 @@ def Methods.withFuel : Nat → Methods whnf := fun e => whnf' e (withFuel n) inferType := fun e i => inferType' e i (withFuel n) } +/-- Runs `x` with a limit on the recursion depth, taken from `FuelConfig.recDepth`. -/ def RecM.run (x : RecM α) : M α := do x (Methods.withFuel (← readThe Context).fuel.recDepth) def RecM.runTermElab (x : RecM α) (safety := DefinitionSafety.safe) : Elab.Term.TermElabM α := @@ -730,24 +883,37 @@ def RecM.runTermElab (x : RecM α) (safety := DefinitionSafety.safe) : Elab.Term instance : MonadLift RecM Elab.Term.TermElabM := ⟨RecM.runTermElab⟩ +@[inherit_doc whnf'] def whnf (e : Expr) : M Expr := (Inner.whnf e).run def whnfCore (e : Expr) : M Expr := (Inner.whnfCore e).run def unfoldDefinition (e : Expr) : M Expr := return (← (Inner.unfoldDefinition e).run).getD e +/-- Infers the type of expression `e`. Note that this uses the optimization `inferOnly := true`, and +so should only be used for the purpose of type inference on terms that are known to be well-typed. +To typecheck terms for the first time, use `checkType`. -/ def inferType (e : Expr) : M Expr := (Inner.inferType e).run +/-- Infers the type of expression `e` and checks that `e` is well-typed according to Lean's typing +judgment. + +Use `inferType` to infer type alone. -/ def checkType (e : Expr) : M Expr := (Inner.inferType e (inferOnly := false)).run +@[inherit_doc isDefEqCore] def isDefEq (t s : Expr) : M Bool := (Inner.isDefEq t s).run +@[inherit_doc Inner.isProp] def isProp (t : Expr) : M Bool := (Inner.isProp t).run +@[inherit_doc ensureSortCore] def ensureSort (t : Expr) (s := t) : M Expr := (ensureSortCore t s).run +@[inherit_doc ensureForallCore] def ensureForall (t : Expr) (s := t) : M Expr := (ensureForallCore t s).run +/-- Ensures that `e` is a type/proposition. If it is not, throws an error. -/ def ensureType (e : Expr) : M Expr := do ensureSort (← inferType e) e def etaExpand (e : Expr) : M Expr := From 88cade6bdd6b47aed0f2e6d6176acbb552e1c398 Mon Sep 17 00:00:00 2001 From: Mario Carneiro Date: Tue, 4 Aug 2026 23:31:11 +0200 Subject: [PATCH 06/51] refactor: remove the dead `cheapRec` parameter `whnfCore`'s `cheapRec` flag has never been set to `true` anywhere in this repo, so every `if cheapRec then ... else whnf e` took the `whnf` branch and the flag only cost us an argument to thread through eight functions. It is dead upstream too, so this does not diverge from kernel behavior. The flag was added in 2019 for one caller outside the kernel, `csimp`'s `is_stuck_at_cases`, which wanted to look through recursor applications without paying for delta-reduction. When lean4 commit 14260f454b split `cheap` into `cheap_rec`/`cheap_proj` so `is_def_eq` could use lazy projections alone, that caller moved to a new `whnf_core_cheap` wrapper; lean4#9275 then deleted the old compiler, and with it the only thing that ever passed `cheap_rec = true`. The wrapper survives in `type_checker.h` with no callers. Dropping it makes `reduceRecursor`'s `cheapProj` unused as well, since its sole use was inside the `cheapRec` branch, so that goes too. The `whnfCore` docstring added in #12 loses its `cheapRec` half, keeping a note that the kernel still carries the flag. The `Verify` proofs about these functions go through unchanged apart from the dropped argument, which is the check that behavior is unaffected. Co-Authored-By: Claude Opus 5 --- Lean4Lean/TypeChecker.lean | 63 ++++++++++++------------- Lean4Lean/Verify/TypeChecker/Basic.lean | 4 +- Lean4Lean/Verify/TypeChecker/WHNF.lean | 12 ++--- 3 files changed, 38 insertions(+), 41 deletions(-) diff --git a/Lean4Lean/TypeChecker.lean b/Lean4Lean/TypeChecker.lean index 2b1f30db..f60d0ca3 100644 --- a/Lean4Lean/TypeChecker.lean +++ b/Lean4Lean/TypeChecker.lean @@ -63,7 +63,7 @@ instance (priority := low) : MonadWithReaderOf LocalContext M where structure Methods where protected isDefEqCore : Expr → Expr → M Bool - protected whnfCore (e : Expr) (cheapRec := false) (cheapProj := false) : M Expr + protected whnfCore (e : Expr) (cheapProj := false) : M Expr protected whnf (e : Expr) : M Expr protected inferType (e : Expr) (inferOnly : Bool) : M Expr @@ -307,40 +307,37 @@ def inferType' (e : Expr) (inferOnly : Bool) : RecM Expr := do /-- Reduces `e` to its weak-head normal form, without unfolding definitions. This is a conservative version of `whnf` (which does unfold definitions), to be used for efficiency purposes. -Setting `cheapRec` or `cheapProj` to `true` will cause the major premise/struct argument to be -reduced "lazily" (using `whnfCore` rather than `whnf`) when reducing recursor applications/struct -projections, and suppresses caching of the result. This can be a useful optimization if we're -checking the definitional equality of two recursor applications/struct projections of the same -recursor/projection, where we might save some work by directly checking if the major premises/struct -arguments are defeq (rather than eagerly applying a recursor rule/projection). +Setting `cheapProj` to `true` will cause the struct argument to be reduced "lazily" (using +`whnfCore` rather than `whnf`) when reducing struct projections, and suppresses caching of the +result. This can be a useful optimization if we're checking the definitional equality of two struct +projections of the same projection, where we might save some work by directly checking if the struct +arguments are defeq (rather than eagerly applying a projection). -In practice only `cheapProj` is ever set. `cheapRec` is threaded through to mirror the kernel, where -it has been dead since lean4#9275 removed the old compiler: its one caller was `csimp`, through the -`whnf_core_cheap` wrapper that still exists but is now unused. -/ -def whnfCore (e : Expr) (cheapRec := false) (cheapProj := false) : RecM Expr := - fun m => m.whnfCore e cheapRec cheapProj +The kernel has a companion `cheap_rec` flag doing the same for the major premise of a recursor, but +nothing has set it since lean4#9275 removed the old compiler, so it is omitted here. -/ +def whnfCore (e : Expr) (cheapProj := false) : RecM Expr := + fun m => m.whnfCore e cheapProj -def reduceRecursor (e : Expr) (cheapRec := false) (cheapProj := false) : RecM (Option Expr) := do +def reduceRecursor (e : Expr) : RecM (Option Expr) := do let env ← getEnv if env.quotInit then if let some r ← quotReduceRec e whnf then return r - let whnf' e := if cheapRec then whnfCore e cheapRec cheapProj else whnf e - if let some r ← inductiveReduceRec env e whnf' inferType isDefEq then + if let some r ← inductiveReduceRec env e whnf inferType isDefEq then return r return none /-- Reduces the free variable `e`: to the `whnfCore` of its definition if `e` is a let variable, and to itself if it is a lambda variable. -/ -def whnfFVar (e : Expr) (cheapRec cheapProj : Bool) : RecM Expr := do +def whnfFVar (e : Expr) (cheapProj : Bool) : RecM Expr := do if let some (.ldecl (value := v) ..) := (← getLCtx).find? e.fvarId! then - return ← whnfCore v cheapRec cheapProj + return ← whnfCore v cheapProj return e /-- Reduces a projection of `struct` at index `idx` (when `struct` is reducible to a constructor application). -/ -def reduceProj (idx : Nat) (struct : Expr) (cheapRec cheapProj : Bool) : RecM (Option Expr) := do - let mut c ← (if cheapProj then whnfCore struct cheapRec cheapProj else whnf struct) +def reduceProj (idx : Nat) (struct : Expr) (cheapProj : Bool) : RecM (Option Expr) := do + let mut c ← (if cheapProj then whnfCore struct cheapProj else whnf struct) if let .lit (.strVal s) := c then c ← whnf (.strLitToConstructor s) c.withApp fun mk args => do @@ -353,42 +350,42 @@ def isLetFVar (lctx : LocalContext) (fvar : FVarId) : Bool := lctx.find? fvar matches some (.ldecl ..) @[inherit_doc whnfCore] -def whnfCore' (e : Expr) (cheapRec := false) (cheapProj := false) : RecM Expr := do +def whnfCore' (e : Expr) (cheapProj := false) : RecM Expr := do match e with | .bvar .. | .sort .. | .mvar .. | .forallE .. | .const .. | .lam .. | .lit .. => return e - | .mdata _ e => return ← whnfCore' e cheapRec cheapProj + | .mdata _ e => return ← whnfCore' e cheapProj | .fvar id => if !isLetFVar (← getLCtx) id then return e | .app .. | .letE .. | .proj .. => pure () if let some r := (← get).whnfCoreCache[e]? then return r let rec save r := do - if !cheapRec && !cheapProj then + if !cheapProj then modify fun s => { s with whnfCoreCache := s.whnfCoreCache.insert e r } return r match e with | .bvar .. | .sort .. | .mvar .. | .forallE .. | .const .. | .lam .. | .lit .. | .mdata .. => unreachable! - | .fvar _ => return ← whnfFVar e cheapRec cheapProj + | .fvar _ => return ← whnfFVar e cheapProj | .app .. => -- beta-reduce at the head as much as possible, apply any remaining `rargs` -- to the resulting expression, and re-run `whnfCore` e.withAppRev fun f0 rargs => do -- the head may still be a let variable/binding, projection, or mdata-wrapped expression - let f ← whnfCore f0 cheapRec cheapProj + let f ← whnfCore f0 cheapProj if let .lam _ _ body _ := f then let rec loop m (f : Expr) : RecM Expr := let rec cont := do let r := f.instantiateRange (rargs.size - m) rargs.size rargs let r := r.mkAppRevRange 0 (rargs.size - m) rargs - save <|← whnfCore r cheapRec cheapProj + save <|← whnfCore r cheapProj if let .lam _ _ body _ := f then if m < rargs.size then loop (m + 1) body else cont else cont loop 1 body else if f == f0 then - if let some r ← reduceRecursor e cheapRec cheapProj then - whnfCore r cheapRec cheapProj + if let some r ← reduceRecursor e then + whnfCore r cheapProj else pure e else @@ -396,12 +393,12 @@ def whnfCore' (e : Expr) (cheapRec := false) (cheapProj := false) : RecM Expr := -- the recursive call re-decomposes `r` and reaches the `f == f0` branch above, so -- `reduceRecursor` is still applied; adding arguments can only enable further normalization -- if the head reduced to a partial recursor application - save <|← whnfCore r cheapRec cheapProj + save <|← whnfCore r cheapProj | .letE _ _ val body _ => - save <|← whnfCore (body.instantiate1 val) cheapRec cheapProj + save <|← whnfCore (body.instantiate1 val) cheapProj | .proj _ idx s => - if let some m ← reduceProj idx s cheapRec cheapProj then - save <|← whnfCore m cheapRec cheapProj + if let some m ← reduceProj idx s cheapProj then + save <|← whnfCore m cheapProj else save e @@ -866,12 +863,12 @@ open Inner def Methods.withFuel : Nat → Methods | 0 => { isDefEqCore := fun _ _ => throw .deepRecursion - whnfCore := fun _ _ _ => throw .deepRecursion + whnfCore := fun _ _ => throw .deepRecursion whnf := fun _ => throw .deepRecursion inferType := fun _ _ => throw .deepRecursion } | n + 1 => { isDefEqCore := fun t s => isDefEqCore' t s (withFuel n) - whnfCore := fun e r p => whnfCore' e r p (withFuel n) + whnfCore := fun e p => whnfCore' e p (withFuel n) whnf := fun e => whnf' e (withFuel n) inferType := fun e i => inferType' e i (withFuel n) } diff --git a/Lean4Lean/Verify/TypeChecker/Basic.lean b/Lean4Lean/Verify/TypeChecker/Basic.lean index 751258f5..f5bdeec0 100644 --- a/Lean4Lean/Verify/TypeChecker/Basic.lean +++ b/Lean4Lean/Verify/TypeChecker/Basic.lean @@ -315,7 +315,7 @@ structure Methods.WF (m : Methods) where isDefEqCore : c.TrExprS e₁ e₁' → c.TrExprS e₂ e₂' → (m.isDefEqCore e₁ e₂).WF c s fun b _ => b → c.IsDefEqU e₁' e₂' whnfCore : c.TrExprS e e' → - (m.whnfCore e cheapRec cheapProj).WF c s fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' + (m.whnfCore e cheapProj).WF c s fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' whnf : c.TrExprS e e' → (m.whnf e).WF c s fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' inferType : e.FVarsIn (· ∈ c.vlctx.fvars) → @@ -880,7 +880,7 @@ theorem checkType.WF {c : VContext} {s : VState} (h1 : e.FVarsIn (· ∈ c.vlctx inferType.WF' h1 nofun theorem whnfCore.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : - RecM.WF c s (whnfCore e cheapRec cheapProj) fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := + RecM.WF c s (whnfCore e cheapProj) fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := fun _ wf => wf.whnfCore he theorem isDelta_is_some : isDelta env e = some ci ↔ diff --git a/Lean4Lean/Verify/TypeChecker/WHNF.lean b/Lean4Lean/Verify/TypeChecker/WHNF.lean index 828b3288..d89f70b2 100644 --- a/Lean4Lean/Verify/TypeChecker/WHNF.lean +++ b/Lean4Lean/Verify/TypeChecker/WHNF.lean @@ -4,11 +4,11 @@ namespace Lean4Lean.TypeChecker.Inner open Lean hiding Environment Exception theorem reduceRecursor.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : - RecM.WF c s (reduceRecursor e cheapRec cheapProj) fun oe _ => + RecM.WF c s (reduceRecursor e) fun oe _ => ∀ e₁, oe = some e₁ → c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := sorry theorem whnfFVar.WF {c : VContext} {s : VState} (he : c.TrExprS (.fvar fv) e') : - RecM.WF c s (whnfFVar (.fvar fv) cheapRec cheapProj) fun e₁ _ => + RecM.WF c s (whnfFVar (.fvar fv) cheapProj) fun e₁ _ => c.FVarsBelow (.fvar fv) e₁ ∧ c.TrExpr e₁ e' := by refine .getLCtx ?_ simp [Expr.fvarId!]; split <;> [skip; exact .pure ⟨.rfl, he.trExpr c.Ewf c.Δwf⟩] @@ -23,11 +23,11 @@ theorem whnfFVar.WF {c : VContext} {s : VState} (he : c.TrExprS (.fvar fv) e') : exact .refl c.Ewf c.Δwf theorem reduceProj.WF {c : VContext} {s : VState} (he : c.TrExprS (.proj n i e) e') : - RecM.WF c s (reduceProj i e cheapRec cheapProj) fun oe _ => + RecM.WF c s (reduceProj i e cheapProj) fun oe _ => ∀ e₁, oe = some e₁ → c.FVarsBelow (.proj n i e) e₁ ∧ c.TrExpr e₁ e' := sorry theorem whnfCore'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : - RecM.WF c s (whnfCore' e cheapRec cheapProj) fun e₁ _ => + RecM.WF c s (whnfCore' e cheapProj) fun e₁ _ => c.FVarsBelow e e₁ ∧ c.TrExpr e₁ e' := by unfold whnfCore'; extract_lets F let full := (· matches Expr.fvar _ | .app .. | .letE .. | .proj ..) @@ -46,7 +46,7 @@ theorem whnfCore'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : refine ⟨h1, h3.defeq c.Ewf c.Δwf ?_⟩ exact h2.uniq c.Ewf (.refl c.Ewf c.Δwf) he have hsave {e₁ s} (h1 : c.FVarsBelow e e₁) (h2 : c.TrExpr e₁ e') : - (save e cheapRec cheapProj e₁).WF c s P := by + (save e cheapProj e₁).WF c s P := by simp [save] split <;> [skip; exact hP ▸ .pure ⟨h1, h2⟩] rintro _ mwf wf a s' ⟨⟩ @@ -67,7 +67,7 @@ theorem whnfCore'.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : split <;> [rename_i name dom body bi _; split] · let rec loop.WF {e e' i rargs f} (H : LambdaBodyN i e' f) (hi : i ≤ rargs.size) : ∃ n f', LambdaBodyN n e' f' ∧ n ≤ rargs.size ∧ - loop e cheapRec cheapProj rargs i f = loop.cont e cheapRec cheapProj rargs n f' := by + loop e cheapProj rargs i f = loop.cont e cheapProj rargs n f' := by unfold loop; split · split · refine loop.WF (by simpa [Nat.add_comm] using H.add (.succ .zero)) ‹_› From cbb70bc3500060f22098c838f92e56bd363834e6 Mon Sep 17 00:00:00 2001 From: Kim Morrison <477956+kim-em@users.noreply.github.com> Date: Wed, 5 Aug 2026 11:38:41 +1000 Subject: [PATCH 07/51] Verify front-end declaration checking (#28) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * fix: match kernel declaration checks * refactor: model verified environment entries faithfully * verify declaration checker correctness * verify front-end environment extension and dispatch * verify: strengthen the front-end statements and restore the model Reworks the environment front-end verification so that the abstract model matches the kernel rather than the other way round, and so that the `add*` lemmas say which constant a step added. Model: * `TrEnv'.opaque` carries the body again (`VDefVal`/`TrDefVal`). `checkOpaque.WF` already established the body translation and typing -- it returned them beside a header-only `VConstVal` -- so it now packages them and `addOpaque.WF` is proved against the restored constructor. * `TrThmVal` is dropped: `TrDefVal` covers theorems once `TrDefVal` uses `ci.value! (allowOpaque := true)`. Without that flag `value!` `panic!`s on `.thmInfo` and `.opaqueInfo`, and since Lean panics return `Inhabited.default` rather than aborting, it silently related `ci'.value` to a junk `Expr`. * `Declaration.IsModelled` is dropped. Nothing consumed it; it only narrowed `addDecl.WF` below the statement `master` already had. The declaration forms that are genuinely outstanding are now `sorry`s in the proof. Statements: * `VEnv.AddConst` and `VEnv.AddDef` record the step an abstract environment takes, including the invisible case, and `addConstCore.WF`/`addDef.WF` conclude them. `AddConst.le`/`AddDef.le` recover the old extension-only conclusion. * `addDefinition.WF` takes no `≠ .unsafe` precondition; the `AddDef` step is claimed under that hypothesis while extension holds unconditionally. An unsafe definition is added before its body is checked, so `AddDef` -- which relates the body to the pre-addition environment -- is false of it, not merely unproven. Construction: * `VEnvs.axiom_of_choice` assembles a `VEnvs` from a pointwise existential by splitting on the three `DefinitionSafety` values. Both extension lemmas build their successor with it instead of `Classical.choose`, and `Verify/Environment` no longer mentions `classical` at all. Implementation: * `addMutual` checks the block under one `M.run` with fixed level parameters, and now requires the members' level parameters to agree (as lean4#14608 does), rather than rebinding `lparams` per member inside a single run. * `checkPrimitiveDef` rejects non-safe definitions. Co-authored-by: Mario Carneiro Co-authored-by: Claude Opus 5 --- Lean4Lean/Environment.lean | 2 + Lean4Lean/Primitive.lean | 1 + Lean4Lean/Tests.lean | 1 + Lean4Lean/Tests/Environment.lean | 25 ++ Lean4Lean/Theory/VDecl.lean | 3 - Lean4Lean/Verify.lean | 2 +- Lean4Lean/Verify/Environment.lean | 160 +++++++++- Lean4Lean/Verify/Environment/Basic.lean | 55 +++- Lean4Lean/Verify/Environment/Boundaries.lean | 35 +++ Lean4Lean/Verify/Environment/Checker.lean | 226 ++++++++++++++ Lean4Lean/Verify/Environment/Extension.lean | 295 +++++++++++++++++++ Lean4Lean/Verify/Environment/Lemmas.lean | 25 +- Lean4Lean/Verify/TypeChecker.lean | 6 + 13 files changed, 818 insertions(+), 18 deletions(-) create mode 100644 Lean4Lean/Tests/Environment.lean create mode 100644 Lean4Lean/Verify/Environment/Boundaries.lean create mode 100644 Lean4Lean/Verify/Environment/Checker.lean create mode 100644 Lean4Lean/Verify/Environment/Extension.lean diff --git a/Lean4Lean/Environment.lean b/Lean4Lean/Environment.lean index f783e736..f2e3babb 100644 --- a/Lean4Lean/Environment.lean +++ b/Lean4Lean/Environment.lean @@ -86,6 +86,8 @@ def addMutual (env : Environment) (vs : List DefinitionVal) if v.safety != v₀.safety then throw <| .other "invalid mutual definition, declarations must have the same safety annotation" + -- The whole block is checked under one set of level parameters, so they must agree; + -- lean4#14608 adds the same check to the C++ kernel. if v.levelParams != v₀.levelParams then throw <| .other "invalid mutual definition, declarations must have the same universe level parameters" diff --git a/Lean4Lean/Primitive.lean b/Lean4Lean/Primitive.lean index fae0c93a..3853cf35 100644 --- a/Lean4Lean/Primitive.lean +++ b/Lean4Lean/Primitive.lean @@ -244,6 +244,7 @@ def unfoldNatWellFounded (e : Expr) (fvs : Array Expr) (eq_def : Expr) (fail : return (← getLCtx).mkLambda fvs rhs def checkPrimitiveDef (v : DefinitionVal) : M Bool := do + unless v.safety == .safe do return false let fail {α} : M α := throw <| .other s!"invalid form for primitive def {v.name}" let tru := q(true) let fal := q(false) diff --git a/Lean4Lean/Tests.lean b/Lean4Lean/Tests.lean index dc420f92..cf76d06b 100644 --- a/Lean4Lean/Tests.lean +++ b/Lean4Lean/Tests.lean @@ -1 +1,2 @@ import Lean4Lean.Tests.Toolchain +import Lean4Lean.Tests.Environment diff --git a/Lean4Lean/Tests/Environment.lean b/Lean4Lean/Tests/Environment.lean new file mode 100644 index 00000000..dc80794e --- /dev/null +++ b/Lean4Lean/Tests/Environment.lean @@ -0,0 +1,25 @@ +import Lean4Lean.Environment + +/-! +Front-end declaration checks that are not covered by `Lean4Lean.Tests.KernelHardening`. + +The mutual-block level parameter and duplicate name checks live there, since v4.33.0-rc2 +made the kernel reject both (lean4#14608). +-/ + +namespace Lean4Lean.Tests.Environment + +open Lean + +run_meta + let env ← Lean.getEnv + let some (.defnInfo natAdd) := env.toKernelEnv.find? ``Nat.add + | throwError "Nat.add is not a definition" + let partialNatAdd := { natAdd with safety := DefinitionSafety.partial } + match (Lean4Lean.Environment.checkPrimitiveDef partialNatAdd).run env.toKernelEnv + (lparams := partialNatAdd.levelParams) with + | .ok false => pure () + | .ok true => throwError "a partial definition was accepted as a primitive" + | .error _ => throwError "the partial primitive check failed unexpectedly" + +end Lean4Lean.Tests.Environment diff --git a/Lean4Lean/Theory/VDecl.lean b/Lean4Lean/Theory/VDecl.lean index 1dfdea0e..0e0803bc 100644 --- a/Lean4Lean/Theory/VDecl.lean +++ b/Lean4Lean/Theory/VDecl.lean @@ -20,9 +20,6 @@ structure VInductDecl where types : List VInductiveType inductive VDecl where - /-- Reserve a constant name, which cannot be used in expressions. - Used to represent unsafe declarations in safe mode -/ - | block (n : Name) | axiom (_ : VConstVal) | def (_ : VDefVal) | opaque (_ : VDefVal) diff --git a/Lean4Lean/Verify.lean b/Lean4Lean/Verify.lean index d9faa29f..86c7e841 100644 --- a/Lean4Lean/Verify.lean +++ b/Lean4Lean/Verify.lean @@ -1 +1 @@ -import Lean4Lean.Verify.Typing.Lemmas +import Lean4Lean.Verify.Environment diff --git a/Lean4Lean/Verify/Environment.lean b/Lean4Lean/Verify/Environment.lean index 1e85a11c..f798e77b 100644 --- a/Lean4Lean/Verify/Environment.lean +++ b/Lean4Lean/Verify/Environment.lean @@ -1,20 +1,156 @@ -import Lean4Lean.Verify.TypeChecker -import Lean4Lean.Environment +import Lean4Lean.Verify.Environment.Extension namespace Lean4Lean open Lean hiding Environment Exception open Kernel -/-- The intended main theorem of the `Verify` development, currently unproved: -if `env` is well-formed and `addDecl env decl` (in checking mode) succeeds, -then the resulting environment is also well-formed, and it extends `env`. +open private Lean.Kernel.Environment.add from Lean.Environment -None of the pieces of this theorem exist yet: nothing relates -`Lean.Kernel.Environment.add` to the `TrEnv` relation, and nothing repackages -the `checkType.WF`/`isDefEq.WF` postconditions at the empty local context into -the abstract `VDecl.WF` premises needed to extend `TrEnv`. -/ +theorem addAxiom.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (v : AxiomVal) : + (addAxiom env v).WF fun env' => + ∃ ves' : VEnvs, ves'.WF env' ∧ ∃ ci' : VConstVal, ∀ safety, + (ves.venv safety).AddConst safety (.axiomInfo v) ci'.toVConstant (ves'.venv safety) := by + let checkSafety : DefinitionSafety := if v.isUnsafe then .unsafe else .safe + have hsafety : checkSafety ≤ (ConstantInfo.axiomInfo v).safety := by + cases v.isUnsafe <;> exact DefinitionSafety.le_rfl + unfold addAxiom + refine (checkConstantVal.WF wf (.axiomInfo v) false hsafety).run wf |>.bind fun _ h => ?_ + obtain ⟨ci', htr, hci, hn, hnonprim⟩ := h + have ⟨ves', hwf, hstep⟩ := addConst.WF wf (.axiomInfo v) ci' checkSafety ?_ htr hci hn + (hnonprim rfl) fun _ _ htr hci hadd old => ?_ + · exact .pure ⟨ves', hwf, ci', hstep⟩ + · intro safety _ + cases v.isUnsafe <;> cases safety <;> trivial + · exact .axiom htr + (by rwa [← old.map_wf.find?'_eq_find?]) hci hadd old + +theorem addDefinition.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (v : DefinitionVal) : + (addDefinition env v).WF fun env' => + ∃ ves' : VEnvs, ves'.WF env' ∧ (∀ safety, ves.venv safety ≤ ves'.venv safety) ∧ + (v.safety ≠ .unsafe → ∃ ci' : VDefVal, ∀ safety, + (ves.venv safety).AddDef safety (.defnInfo v) ci' (ves'.venv safety)) := by + unfold addDefinition + split + · extract_lets _ F1 F2 + refine (checkConstantVal.WF wf (.defnInfo v) false + DefinitionSafety.unsafe_le).run wf |>.bind fun _ h1 => ?_ + unfold F2 + refine (checkNoMVarNoFVar.WF _ _ _).bind fun _ h2 => ?_ + sorry + refine (checkDefinition.WF wf v).run wf |>.bind fun _ h => ?_ + obtain ⟨allow, ci', hp, hu, ht, hname, hvalue, hci, hfresh, hnonprim⟩ := h + have hle : v.safety ≤ .safe := DefinitionSafety.le_safe + have hmono := wf.mono hle + have htr : TrDefVal v.safety (ves.venv v.safety) (.defnInfo v) ci' := by + refine ⟨⟨⟨?_, hu, ht.mono hmono⟩, hname⟩, hvalue.mono hmono⟩ + rw [ConstantInfo.defnInfo_safety] + exact DefinitionSafety.le_rfl + have ⟨ves', hwf, hstep⟩ := addDef.WF wf v ci' v.safety ?_ htr (hci.mono hmono) hfresh ?_ ?_ + · exact .pure ⟨ves', hwf, (hstep · |>.le), fun _ => ⟨ci', hstep⟩⟩ + · simp [ConstantInfo.defnInfo_safety] + · intro hnamePrim + have hallow : allow = true := by + cases allow + · simp_all + · rfl + exact ⟨by rw [ConstantInfo.defnInfo_safety, hp.safe hallow], hp.no_level_params hallow⟩ + · intro safety base hvisible hadd + have hs : safety ≤ v.safety := by + simpa [ConstantInfo.defnInfo_safety] using hvisible + have htr' : TrDefVal safety (ves.venv safety) (.defnInfo v) ci' := by + have hsf : TrDefVal safety (ves.venv v.safety) (.defnInfo v) ci' := + ⟨⟨htr.1.1.sf_mono hs, htr.1.2⟩, htr.2⟩ + exact hsf.mono (wf.mono hs) + have hci' := hci.mono (hmono.trans (wf.mono hs)) + cases allow with + | false => exact (wf.hasPrimitives.addConst (hnonprim rfl) hadd).addDefEq + | true => + exact hp.preserves (safety := safety) (venv := ves.venv safety) + (env' := base) (ci' := ci') rfl (wf.mono DefinitionSafety.le_safe) + (wf.tr (safety := safety)).wf wf.hasPrimitives htr' hci' hadd + +theorem addTheorem.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (v : TheoremVal) : + (addTheorem env v).WF fun env' => + ∃ ves' : VEnvs, ves'.WF env' ∧ ∃ ci' : VConstVal, ∀ safety, + (ves.venv safety).AddConst safety (.thmInfo v) ci'.toVConstant (ves'.venv safety) := by + refine (checkTheorem.WF wf v).run wf |>.bind fun _ h => ?_ + obtain ⟨ci', htr, hbody, hprop, hn, hnonprim⟩ := h + have ⟨ves', hwf, hstep⟩ := addConst.WF wf (.thmInfo v) ci'.toVConstVal .safe + (fun _ _ => DefinitionSafety.le_safe) htr.1 ⟨_, hprop⟩ hn hnonprim + fun safety _ hheader _ hadd old => ?_ + · exact .pure ⟨ves', hwf, ci'.toVConstVal, hstep⟩ + have hle := wf.mono hheader.1 + have htr' : TrDefVal safety (ves.venv safety) (.thmInfo v) ci' := + ⟨⟨hheader, htr.1.2⟩, htr.2.mono hle⟩ + exact .thm htr' (by rwa [← old.map_wf.find?'_eq_find?]) (hbody.mono hle) + (hprop.mono hle) hadd old + +theorem addOpaque.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (v : OpaqueVal) : + (addOpaque env v).WF fun env' => + ∃ ves' : VEnvs, ves'.WF env' ∧ ∃ ci' : VConstVal, ∀ safety, + (ves.venv safety).AddConst safety (.opaqueInfo v) ci'.toVConstant (ves'.venv safety) := by + let checkSafety : DefinitionSafety := if v.isUnsafe then .unsafe else .safe + have hsafety : (ConstantInfo.opaqueInfo v).safety = checkSafety := by + cases v.isUnsafe <;> rfl + refine (checkOpaque.WF wf v).run wf |>.bind fun _ h => ?_ + obtain ⟨ci', hu, ht, hname, hvalue, hciC, hci, hfresh, hnonprim⟩ := h + have hle : checkSafety ≤ .safe := DefinitionSafety.le_safe + have hmono := wf.mono hle + have htr : TrConstVal checkSafety (ves.venv checkSafety) (.opaqueInfo v) ci'.toVConstVal := + ⟨⟨hsafety.symm ▸ DefinitionSafety.le_rfl, hu, ht.mono hmono⟩, hname⟩ + have ⟨ves', hwf, hstep⟩ := addConst.WF wf (.opaqueInfo v) ci'.toVConstVal checkSafety ?_ htr + (hciC.mono hmono) hfresh hnonprim fun safety _ htr hciW hadd old => ?_ + · exact .pure ⟨ves', hwf, ci'.toVConstVal, hstep⟩ + · intro safety hvisible + rwa [hsafety] at hvisible + · have hvis : safety ≤ checkSafety := hsafety ▸ htr.1 + have hto := hmono.trans (wf.mono hvis) + exact .opaque (ci' := ci') ⟨⟨htr, hname⟩, hvalue.mono hto⟩ + (by rwa [← old.map_wf.find?'_eq_find?]) (hci.mono hto) hadd old + +theorem checkEqType.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) : + (checkEqType env).WF fun _ => False := by + -- `AddInduct` currently has no constructors, so the unsafe translation cannot contain + -- the inductive `Eq` declaration required by quotient initialization. This case becomes + -- constructive when the inductive-declaration verification boundary is implemented. + intro _ h + unfold checkEqType at h + simp only [Environment.get] at h + split at h <;> try contradiction + rename_i ci hfind + cases ci with + | inductInfo info => + have hfind' : env.constants.find? ``Eq = some (.inductInfo info) := by + rw [← (wf.tr (safety := .unsafe)).map_wf.find?'_eq_find?] + exact hfind + exact False.elim <| (wf.tr (safety := .unsafe)).no_inductInfo hfind' + | _ => simp_all [( · >>= · ), Except.bind, pure, Pure.pure, Except.pure] + +/-- This is currently vacuous in the non-initialized case: `TrEnv` cannot contain the +inductive `Eq` declaration until `AddInduct` is implemented. -/ +theorem addQuot.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) : + (Environment.addQuot env).WF fun env' => + ∃ ves' : VEnvs, ves'.WF env' ∧ ∀ safety, ves.venv safety ≤ ves'.venv safety := by + unfold Environment.addQuot + split + · exact .pure ⟨ves, wf, fun _ => VEnv.LE.rfl⟩ + · exact (checkEqType.WF wf).bind fun _ h => False.elim h + +/-- Successful checked addition preserves well-formedness and extends every safety-indexed +abstract environment. The declaration forms still outstanding are recursive unsafe and mutual +definitions, which need a recursive-body relation, and inductives, which need a constructive +`AddInduct` model. -/ theorem addDecl.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (decl : Declaration) : - (addDecl env decl).WF fun env' => - ∃ ves' : VEnvs, ves'.WF env' ∧ ∀ safety, ves.venv safety ≤ ves'.venv safety := - sorry + (addDecl env decl (check := true) (fuel := {})).WF fun env' => + ∃ ves' : VEnvs, ves'.WF env' ∧ ∀ safety, ves.venv safety ≤ ves'.venv safety := by + cases decl with + | axiomDecl v => exact (addAxiom.WF wf v).mono fun _ ⟨ves', hwf, _, h⟩ => ⟨ves', hwf, (h · |>.le)⟩ + | thmDecl v => exact (addTheorem.WF wf v).mono fun _ ⟨ves', hwf, _, h⟩ => ⟨ves', hwf, (h · |>.le)⟩ + | defnDecl v => exact (addDefinition.WF wf v).mono fun _ ⟨ves', hwf, h, _⟩ => ⟨ves', hwf, h⟩ + | opaqueDecl v => + exact (addOpaque.WF wf v).mono fun _ ⟨ves', hwf, _, h⟩ => ⟨ves', hwf, (h · |>.le)⟩ + | quotDecl => exact addQuot.WF wf + | mutualDefnDecl _ => sorry + | inductDecl _ _ _ _ => sorry diff --git a/Lean4Lean/Verify/Environment/Basic.lean b/Lean4Lean/Verify/Environment/Basic.lean index c4c6f181..dda2e62a 100644 --- a/Lean4Lean/Verify/Environment/Basic.lean +++ b/Lean4Lean/Verify/Environment/Basic.lean @@ -26,7 +26,43 @@ def TrConstVal (ci : ConstantInfo) (ci' : VConstVal) : Prop := variable (safety : DefinitionSafety) (env : VEnv) in def TrDefVal (ci : ConstantInfo) (ci' : VDefVal) : Prop := TrConstVal safety env ci ci'.toVConstVal ∧ - TrExprS env ci.levelParams [] ci.value! ci'.value + TrExprS env ci.levelParams [] (ci.value! (allowOpaque := true)) ci'.value + +/-- The step an abstract environment takes when `ci`, modelled by `ci'`, is added. + +At safety levels where the declaration is visible the constant is added; where it is not, the +environment is unchanged, matching `TrEnv'.ignore`. Stating this rather than just `venv ≤ venv'` +is what lets a caller see *which* constant a step added. -/ +def VEnv.AddConst (venv : VEnv) (safety : DefinitionSafety) (ci : ConstantInfo) + (ci' : VConstant) (venv' : VEnv) : Prop := + if safety ≤ ci.safety then + TrConstant safety venv ci ci' ∧ ci'.WF venv ∧ venv.addConst ci.name ci' = some venv' + else + venv' = venv + +theorem VEnv.AddConst.le {venv venv' : VEnv} {ci ci'} + (H : VEnv.AddConst venv safety ci ci' venv') : venv ≤ venv' := by + unfold VEnv.AddConst at H; split at H + · exact addConst_le H.2.2 + · exact H ▸ VEnv.LE.rfl + +/-- As `VEnv.AddConst`, for a definition: the constant is added and then its defining equation, +matching `TrEnv'.defn`. -/ +def VEnv.AddDef (venv : VEnv) (safety : DefinitionSafety) (ci : ConstantInfo) + (ci' : VDefVal) (venv' : VEnv) : Prop := + if safety ≤ ci.safety then + ∃ base, TrDefVal safety venv ci ci' ∧ ci'.WF venv ∧ + venv.addConst ci.name ci'.toVConstant = some base ∧ + venv' = base.addDefEq ci'.toDefEq + else + venv' = venv + +theorem VEnv.AddDef.le {venv venv' : VEnv} {ci ci'} + (H : VEnv.AddDef venv safety ci ci' venv') : venv ≤ venv' := by + unfold VEnv.AddDef at H; split at H + · obtain ⟨base, _, _, hadd, rfl⟩ := H + exact (addConst_le hadd).trans (VEnv.addDefEq_le ..) + · exact H ▸ VEnv.LE.rfl def AddQuot1 (name : Name) (kind : QuotKind) (ci' : VConstant) (P : ConstMap → VEnv → Prop) (m : ConstMap) (env : VEnv) : Prop := @@ -78,6 +114,10 @@ nonrec theorem AddInduct.to_addInduct variable (safety : DefinitionSafety) in inductive TrEnv' : ConstMap → Bool → VEnv → Prop where | empty : TrEnv' {} false .empty + | ignore : + C.find? ci.name = none → ¬safety ≤ ci.safety → + TrEnv' C Q env → + TrEnv' (C.insert ci.name ci) Q env | axiom : TrConstant safety env (.axiomInfo ci) ci' → C.find? ci.name = none → ci'.WF env → @@ -90,6 +130,13 @@ inductive TrEnv' : ConstMap → Bool → VEnv → Prop where env.addConst ci.name ci'.toVConstant = some env' → TrEnv' C Q env → TrEnv' (C.insert ci.name (.defnInfo ci)) Q (env'.addDefEq ci'.toDefEq) + | thm {ci' : VDefVal} : + TrDefVal safety env (.thmInfo ci) ci' → + C.find? ci.name = none → ci'.WF env → + env.HasType ci'.uvars [] ci'.type (.sort .zero) → + env.addConst ci.name ci'.toVConstant = some env' → + TrEnv' C Q env → + TrEnv' (C.insert ci.name (.thmInfo ci)) Q env' | opaque {ci' : VDefVal} : TrDefVal safety env (.opaqueInfo ci) ci' → C.find? ci.name = none → ci'.WF env → @@ -113,6 +160,7 @@ def TrEnv (safety : DefinitionSafety) (env : Environment) (venv : VEnv) : Prop : theorem TrEnv'.wf (H : TrEnv' safety C Q venv) : venv.WF := by induction H with | empty => exact ⟨_, .empty⟩ + | ignore _ _ _ ih => exact ih | «axiom» _ _ h1 h2 _ ih => have ⟨_, H⟩ := ih exact ⟨_, H.decl <| .axiom (ci := ⟨_, _⟩) h1 h2⟩ @@ -120,6 +168,11 @@ theorem TrEnv'.wf (H : TrEnv' safety C Q venv) : venv.WF := by have ⟨_, H⟩ := ih have := h1.1.2; dsimp [ConstantInfo.name, ConstantInfo.toConstantVal] at this exact ⟨_, H.decl <| .def h2 (this ▸ h3)⟩ + | thm h1 _ h2 h3 h4 _ ih => + have ⟨_, H⟩ := ih + have hn := h1.1.2 + dsimp [ConstantInfo.name, ConstantInfo.toConstantVal] at hn + exact ⟨_, (H.decl (.example h2)).decl (.axiom ⟨_, h3⟩ (hn ▸ h4))⟩ | «opaque» h1 _ h2 h3 _ ih => have ⟨_, H⟩ := ih have := h1.1.2; dsimp [ConstantInfo.name, ConstantInfo.toConstantVal] at this diff --git a/Lean4Lean/Verify/Environment/Boundaries.lean b/Lean4Lean/Verify/Environment/Boundaries.lean new file mode 100644 index 00000000..5b800d2a --- /dev/null +++ b/Lean4Lean/Verify/Environment/Boundaries.lean @@ -0,0 +1,35 @@ +import Lean4Lean.Verify.TypeChecker +import Lean4Lean.Environment + +/-! +This module contains the front-end-specific trust boundary for declaration verification. +The checker, extension, and declaration modules introduce no additional `sorry`-backed +assumptions. The imported type-checker and theory layers retain their own explicit +verification gaps. +-/ + +namespace Lean4Lean + +open Lean hiding Environment Exception +open Kernel + +/-- What the primitive-definition recognizer must establish beyond ordinary type checking. +This is kept separate from declaration checking so that the remaining metatheory does not +depend on the recognizer's syntactic implementation. Primitive semantics are claimed only +in well-formed extensions of the environment in which recognition ran. -/ +structure PrimitiveResult (checked : VEnv) (v : DefinitionVal) (allow : Bool) : Prop where + safe : allow = true → v.safety = .safe + no_level_params : allow = true → v.levelParams = [] + preserves : allow = true → ∀ {safety : DefinitionSafety} {venv env' : VEnv} {ci' : VDefVal}, + checked ≤ venv → venv.WF → + venv.HasPrimitives → + TrDefVal safety venv (.defnInfo v) ci' → ci'.WF venv → + venv.addConst v.name ci'.toVConstant = some env' → + (env'.addDefEq ci'.toDefEq).HasPrimitives + +/-- Verification boundary for Lean4Lean's syntactic primitive-definition recognizer. -/ +theorem checkPrimitiveDef.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (v : DefinitionVal) : + (Environment.checkPrimitiveDef v).WF (.mk' wf .safe v.levelParams) {} fun allow _ => + PrimitiveResult (ves.venv .safe) v allow := by + sorry diff --git a/Lean4Lean/Verify/Environment/Checker.lean b/Lean4Lean/Verify/Environment/Checker.lean new file mode 100644 index 00000000..86854844 --- /dev/null +++ b/Lean4Lean/Verify/Environment/Checker.lean @@ -0,0 +1,226 @@ +import Lean4Lean.Verify.Environment.Boundaries + +namespace Lean4Lean + +open Lean hiding Environment Exception +open Kernel + +theorem ConstantInfo.defnInfo_safety (v : DefinitionVal) : + (ConstantInfo.defnInfo v).safety = v.safety := by + simp [ConstantInfo.safety, ConstantInfo.isUnsafe, ConstantInfo.isPartial] + cases v.safety <;> rfl + +theorem checkName.WF (mapWF : env.constants.WF) (name : Name) (allowPrimitive : Bool) : + (Environment.checkName env name allowPrimitive).WF fun _ => + env.find? name = none ∧ (allowPrimitive = false → Environment.primitives.contains name = false) := by + intro _ h + have hn : env.contains name = false := by + cases hfind : env.contains name + · rfl + · simp [Environment.checkName, hfind, (· >>= ·), Except.bind] at h + change env.constants.contains name = false at hn + rw [SMap.find?_isSome] at hn + constructor + · rw [Kernel.Environment.find?, mapWF.find?'_eq_find?] + cases hfind : env.constants.find? name <;> simp_all + · intro ha + cases hp : Environment.primitives.contains name + · rfl + · have hc : env.contains name = false := by + change env.constants.contains name = false + rw [SMap.find?_isSome] + exact hn + simp only [Environment.checkName, hc, ha, hp, ↓reduceIte] at h + rw [show (pure PUnit.unit : Except Exception PUnit) = .ok PUnit.unit from rfl] at h + contradiction + +private theorem checkNoMVar.WF (env : Environment) (name : Name) (e : Expr) : + (Environment.checkNoMVar env name e).WF fun _ => e.hasMVar = false := by + intro _ h + cases hmv : e.hasMVar + · rfl + · simp [Environment.checkNoMVar, hmv] at h + +private theorem checkNoFVar.WF (env : Environment) (name : Name) (e : Expr) : + (Environment.checkNoFVar env name e).WF fun _ => e.hasFVar = false := by + intro _ h + cases hfv : e.hasFVar + · rfl + · simp [Environment.checkNoFVar, hfv] at h + +theorem checkNoMVarNoFVar.WF (env : Environment) (name : Name) (e : Expr) : + (Environment.checkNoMVarNoFVar env name e).WF fun _ => e.FVarsIn fun _ => False := by + unfold Environment.checkNoMVarNoFVar + refine (checkNoMVar.WF env name e).bind fun _ hm => + (checkNoFVar.WF env name e).mono fun _ hf => ?_ + apply fvarsIn_iff.2 + refine ⟨?_, fvarsIn_iff_hasMVar.2 hm⟩ + intro fv hmem + rw [fvarsList_eq_nil.2 hf] at hmem + simp at hmem + +private theorem Except.WF.trivial (x : Except ε α) : x.WF fun _ => True := + fun _ _ => True.intro + +private theorem TypeChecker.M.WF.pureBind {c : TypeChecker.VContext} + {s : TypeChecker.VState} {f : β → TypeChecker.M α} {Q} {x : β} + (H : (f x).WF c s Q) : ((Pure.pure x : TypeChecker.M β) >>= f).WF c s Q := H + +theorem checkConstantValCore.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (ci : ConstantInfo) (allowPrimitive : Bool) (state : TypeChecker.VState := {}) : + (checkConstantVal env ci.toConstantVal allowPrimitive).WF + (.mk' wf safety ci.levelParams) state fun _ _ => + ∃ ci' : VConstVal, + ci.levelParams.length = ci'.uvars ∧ + TrExprS (ves.venv safety) ci.levelParams [] ci.type ci'.type ∧ + ci.name = ci'.name ∧ + ci'.toVConstant.WF (ves.venv safety) ∧ env.find? ci.name = none ∧ + (allowPrimitive = false → Environment.primitives.contains ci.name = false) := by + unfold checkConstantVal + refine (TypeChecker.M.WF.liftExcept + (checkName.WF (wf.tr (safety := safety)).map_wf ci.name allowPrimitive)).bind + fun _ _ _ hname => ?_ + -- Duplicate level parameters are rejected operationally; no later proof needs that fact. + refine (TypeChecker.M.WF.liftExcept (Except.WF.trivial _)).bind fun _ _ _ _ => ?_ + refine (TypeChecker.M.WF.liftExcept + (checkNoMVarNoFVar.WF env ci.name ci.type)).bind fun _ _ _ hclosed => ?_ + have hclosed' : ci.type.FVarsIn (· ∈ (TypeChecker.VContext.mk' wf safety ci.levelParams).vlctx.fvars) := by + simpa [TypeChecker.VContext.mk'] using hclosed + refine (TypeChecker.checkType.WF hclosed').bind + fun _ _ _ ⟨type', sort', _, htype, hsort, hhasType⟩ => ?_ + refine (TypeChecker.ensureSort.WF hsort).bind + fun _ _ _ ⟨⟨_, hsort', hdefeq⟩, hsortEq⟩ => .pure ?_ + obtain ⟨u, rfl⟩ := hsortEq + cases hsort' with + | sort hu => + refine ⟨{ name := ci.name, uvars := ci.levelParams.length, type := type' }, + rfl, htype, rfl, ?_, hname⟩ + exact ⟨_, hhasType.defeqU_r (wf.tr (safety := safety)).wf (by trivial) hdefeq.symm⟩ + +theorem checkConstantVal.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (ci : ConstantInfo) (allowPrimitive : Bool) (hs : safety ≤ ci.safety) + (state : TypeChecker.VState := {}) : + (checkConstantVal env ci.toConstantVal allowPrimitive).WF + (.mk' wf safety ci.levelParams) state fun _ _ => + ∃ ci' : VConstVal, TrConstVal safety (ves.venv safety) ci ci' ∧ + ci'.toVConstant.WF (ves.venv safety) ∧ env.find? ci.name = none ∧ + (allowPrimitive = false → Environment.primitives.contains ci.name = false) := by + exact (checkConstantValCore.WF wf ci allowPrimitive state).mono fun _ _ _ h => by + obtain ⟨ci', hu, ht, hn', hci, hn, hp⟩ := h + exact ⟨ci', ⟨⟨hs, hu, ht⟩, hn'⟩, hci, hn, hp⟩ + +theorem checkBody.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (decl : Declaration) (name : Name) (levelParams : List Name) (type value : Expr) + (type' : VExpr) (hdeclType : TrExprS (ves.venv safety) levelParams [] type type') + (state : TypeChecker.VState := {}) : + ((do + Environment.checkNoMVarNoFVar env name value + let valueType ← TypeChecker.checkType value + if !(← TypeChecker.isDefEq valueType type) then + throw <| Exception.declTypeMismatch env decl valueType) : TypeChecker.M Unit).WF + (.mk' wf safety levelParams) state fun _ _ => + ∃ value', TrExprS (ves.venv safety) levelParams [] value value' ∧ + (ves.venv safety).HasType levelParams.length [] value' type' := by + refine (TypeChecker.M.WF.liftExcept + (checkNoMVarNoFVar.WF env name value)).bind fun _ _ _ hclosed => ?_ + have hclosed' : value.FVarsIn + (· ∈ (TypeChecker.VContext.mk' wf safety levelParams).vlctx.fvars) := by + simpa [TypeChecker.VContext.mk'] using hclosed + refine (TypeChecker.checkType.WF hclosed').bind + fun valueType _ _ ⟨value', valueType', _, hvalue, hvalueType, hhasType⟩ => ?_ + refine (TypeChecker.isDefEq.WF hvalueType hdeclType).bind fun equal _ _ hequal => ?_ + split + · exact .throw + · rename_i hnot + refine .pure ⟨value', hvalue, ?_⟩ + have heq : equal = true := by cases equal <;> simp_all + exact hhasType.defeqU_r (wf.tr (safety := safety)).wf (by trivial) (hequal heq) + +theorem checkTheorem.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (v : TheoremVal) : + ((do + checkConstantVal env v.toConstantVal + if !(← TypeChecker.isProp v.type) then + throw <| Exception.thmTypeIsNotProp env v.name v.type + Environment.checkNoMVarNoFVar env v.name v.value + let valueType ← TypeChecker.checkType v.value + if !(← TypeChecker.isDefEq valueType v.type) then + throw <| Exception.declTypeMismatch env (.thmDecl v) valueType) : TypeChecker.M Unit).WF + (.mk' wf .safe v.levelParams) {} fun _ _ => + ∃ ci' : VDefVal, TrDefVal .safe (ves.venv .safe) (.thmInfo v) ci' ∧ + ci'.WF (ves.venv .safe) ∧ + (ves.venv .safe).HasType ci'.uvars [] ci'.type (.sort .zero) ∧ + env.find? v.name = none ∧ Environment.primitives.contains v.name = false := by + refine (checkConstantVal.WF wf (.thmInfo v) false DefinitionSafety.le_rfl).bind + fun _ state _ ⟨ci', htr, hci, hn, hnonprim⟩ => ?_ + refine (TypeChecker.isProp.WF htr.1.2.2).bind fun isProp state' _ hprop => ?_ + split + · exact .throw + · rename_i hnot + have hisProp : isProp = true := by cases isProp <;> simp_all + refine .pureBind <| (checkBody.WF wf (.thmDecl v) v.name v.levelParams v.type + v.value ci'.type htr.1.2.2 state').mono fun _ _ _ ⟨value', hvalue, hvalueType⟩ => ?_ + let ci'' : VDefVal := { ci' with value := value' } + refine ⟨ci'', ⟨htr, hvalue⟩, ?_, ?_, hn, hnonprim rfl⟩ + · change (ves.venv .safe).HasType ci'.uvars [] value' ci'.type + rw [← htr.1.2.1] + exact hvalueType + · change (ves.venv .safe).HasType ci'.uvars [] ci'.type (.sort .zero) + rw [← htr.1.2.1] + exact hprop hisProp + +theorem checkDefinition.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (v : DefinitionVal) : + ((do + checkConstantVal env v.toConstantVal (← Environment.checkPrimitiveDef v) + Environment.checkNoMVarNoFVar env v.name v.value + let valueType ← TypeChecker.checkType v.value + if !(← TypeChecker.isDefEq valueType v.type) then + throw <| Exception.declTypeMismatch env (.defnDecl v) valueType) : TypeChecker.M Unit).WF + (.mk' wf .safe v.levelParams) {} fun _ _ => + ∃ allow : Bool, ∃ ci' : VDefVal, PrimitiveResult (ves.venv .safe) v allow ∧ + v.levelParams.length = ci'.uvars ∧ + TrExprS (ves.venv .safe) v.levelParams [] v.type ci'.type ∧ + v.name = ci'.name ∧ + TrExprS (ves.venv .safe) v.levelParams [] v.value ci'.value ∧ + ci'.WF (ves.venv .safe) ∧ env.find? v.name = none ∧ + (allow = false → Environment.primitives.contains v.name = false) := by + refine (checkPrimitiveDef.WF wf v).bind fun allow state _ hp => ?_ + refine (checkConstantValCore.WF (safety := .safe) wf (.defnInfo v) allow state).bind + fun _ state' _ ⟨ci', hu, ht, hname, hci, hfresh, hnonprim⟩ => ?_ + exact (checkBody.WF wf (.defnDecl v) v.name v.levelParams v.type v.value + ci'.type ht state').mono fun _ _ _ ⟨value', hvalue, hvalueType⟩ => by + let ci'' : VDefVal := { ci' with value := value' } + refine ⟨allow, ci'', hp, hu, ht, hname, hvalue, ?_, hfresh, hnonprim⟩ + change (ves.venv .safe).HasType ci'.uvars [] value' ci'.type + rw [← hu] + exact hvalueType + +/-- Verify the complete opaque-declaration check. The body is checked, so it is packaged into +the resulting `VDefVal`; `TrEnv'.opaque` consumes it. An opaque body still contributes no +definitional equality -- that is `TrEnv'.opaque` adding no `addDefEq`, not the body going +unrecorded. -/ +theorem checkOpaque.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (v : OpaqueVal) : + ((do + checkConstantVal env v.toConstantVal + Environment.checkNoMVarNoFVar env v.name v.value + let valueType ← TypeChecker.checkType v.value + if !(← TypeChecker.isDefEq valueType v.type) then + throw <| Exception.declTypeMismatch env (.opaqueDecl v) valueType) : TypeChecker.M Unit).WF + (.mk' wf .safe v.levelParams) {} fun _ _ => + ∃ ci' : VDefVal, + v.levelParams.length = ci'.uvars ∧ + TrExprS (ves.venv .safe) v.levelParams [] v.type ci'.type ∧ + v.name = ci'.name ∧ + TrExprS (ves.venv .safe) v.levelParams [] v.value ci'.value ∧ + ci'.toVConstant.WF (ves.venv .safe) ∧ + ci'.WF (ves.venv .safe) ∧ env.find? v.name = none ∧ + Environment.primitives.contains v.name = false := by + refine (checkConstantValCore.WF (safety := .safe) wf (.opaqueInfo v) false).bind + fun _ state _ ⟨ci', hu, ht, hname, hci, hfresh, hnonprim⟩ => ?_ + exact (checkBody.WF wf (.opaqueDecl v) v.name v.levelParams v.type v.value + ci'.type ht state).mono fun _ _ _ ⟨value', hvalue, hvalueType⟩ => by + let ci'' : VDefVal := { ci' with value := value' } + refine ⟨ci'', hu, ht, hname, hvalue, hci, ?_, hfresh, hnonprim rfl⟩ + rwa [VDefVal.WF, ← hu] diff --git a/Lean4Lean/Verify/Environment/Extension.lean b/Lean4Lean/Verify/Environment/Extension.lean new file mode 100644 index 00000000..d63da31f --- /dev/null +++ b/Lean4Lean/Verify/Environment/Extension.lean @@ -0,0 +1,295 @@ +import Lean4Lean.Verify.Environment.Checker + +namespace Lean4Lean + +open Lean hiding Environment Exception +open Kernel + +open private Lean.Kernel.Environment.add from Lean.Environment + +theorem TrEnv.exists_addConst (H : TrEnv safety env venv) (hn : env.find? name = none) + (ci' : VConstant) : ∃ venv', venv.addConst name ci' = some venv' := by + unfold VEnv.addConst + cases hfind : venv.constants name with + | none => simp + | some ci => obtain ⟨ci, hci, _⟩ := H.find?_iff.2 ⟨ci, hfind⟩; cases hn ▸ hci + +theorem TrEnv'.no_inductInfo (H : TrEnv' .unsafe C Q venv) : + C.find? name ≠ some (.inductInfo info) := by + induction H with + | empty => simp [SMap.find?] + | ignore hn hhidden H ih => + rename_i C' Q' env' ci + exact False.elim <| hhidden (by cases ci.safety <;> rfl) + | «axiom» _ _ _ _ H ih => rw [H.map_wf.find?_insert]; split <;> [simp; exact ih] + | defn _ _ _ _ H ih => rw [H.map_wf.find?_insert]; split <;> [simp; exact ih] + | thm _ _ _ _ _ H ih => rw [H.map_wf.find?_insert]; split <;> [simp; exact ih] + | «opaque» _ _ _ _ H ih => rw [H.map_wf.find?_insert]; split <;> [simp; exact ih] + | quot hready hadd H ih => + obtain ⟨lp₁, ty₁, env₁, _, hn₁, _, + lp₂, ty₂, env₂, _, hn₂, _, + lp₃, ty₃, env₃, _, hn₃, _, + lp₄, ty₄, env₄, _, hn₄, _, rfl, _⟩ := hadd + have wf₀ := H.map_wf + have wf₁ := wf₀.insert ``Quot + (.quotInfo { name := ``Quot, kind := .type, levelParams := lp₁, type := ty₁ }) hn₁ + have wf₂ := wf₁.insert ``Quot.mk + (.quotInfo { name := ``Quot.mk, kind := .ctor, levelParams := lp₂, type := ty₂ }) hn₂ + have wf₃ := wf₂.insert ``Quot.lift + (.quotInfo { name := ``Quot.lift, kind := .lift, levelParams := lp₃, type := ty₃ }) hn₃ + rw [wf₃.find?_insert]; split <;> [simp; skip] + rw [wf₂.find?_insert]; split <;> [simp; skip] + rw [wf₁.find?_insert]; split <;> [simp; skip] + rw [wf₀.find?_insert]; split <;> [simp; exact ih] + | induct _ hadd => cases hadd + +theorem VEnv.addConst_mono {env₁ env₂ env₁' env₂' : VEnv} (H : env₁ ≤ env₂) + (h₁ : env₁.addConst name ci = some env₁') (h₂ : env₂.addConst name ci = some env₂') : + env₁' ≤ env₂' := by + unfold VEnv.addConst at h₁ h₂ + split at h₁ <;> cases h₁ + split at h₂ <;> cases h₂ + refine { constants {n a} := ?_, defeqs := H.defeqs } + dsimp; split <;> [exact id; exact H.constants] + +theorem VEnv.addDefEq_mono {env₁ env₂ : VEnv} (H : env₁ ≤ env₂) : + env₁.addDefEq df ≤ env₂.addDefEq df where + constants := H.constants + defeqs := by rintro d (rfl | hd) <;> [exact .inl rfl; exact .inr (H.defeqs hd)] + +theorem VEnv.addConst_eq_of_ne + {env env' : VEnv} + (hadd : env.addConst name ci = some env') (hne : name ≠ n) : + env'.constants n = env.constants n := by + unfold VEnv.addConst at hadd + split at hadd <;> cases hadd + simp [hne] + +theorem VEnv.HasPrimitives.addConst {env env' : VEnv} (H : env.HasPrimitives) + (hname : Environment.primitives.contains name = false) + (hadd : env.addConst name ci = some env') : env'.HasPrimitives := by + have le := VEnv.addConst_le hadd + have same {n} (hp : Environment.primitives.contains n = true) : + env'.constants n = env.constants n := + VEnv.addConst_eq_of_ne hadd fun h => by subst h; simp_all + have oldContains {n} (hp : Environment.primitives.contains n = true) : + env'.contains n → env.contains n := fun ⟨ci, hci⟩ => ⟨ci, (same hp) ▸ hci⟩ + have newContains {n} : env.contains n → env'.contains n := fun ⟨ci, hci⟩ => ⟨ci, le.constants hci⟩ + refine let prims := _; have hprims : Environment.primitives = .ofList prims := rfl; ?_ + replace hprims {n} : n ∈ prims → Environment.primitives.contains n := by + simp [hprims, NameSet.contains, NameSet.ofList] + simp only [List.mem_cons, prims] at hprims + constructor + · intro h + let ⟨h1, h2⟩ := H.bool (oldContains (hprims (by simp)) h) + exact ⟨newContains h1, newContains h2⟩ + · intro ci h; apply H.boolFalse; rwa [← same (hprims (by simp))] + · intro ci h; apply H.boolTrue; rwa [← same (hprims (by simp))] + · intro h + let ⟨h1, h2⟩ := H.nat (oldContains (hprims (by simp)) h) + exact ⟨newContains h1, newContains h2⟩ + · intro ci h; apply H.natZero; rwa [← same (hprims (by simp))] + · intro ci h; apply H.natSucc; rwa [← same (hprims (by simp))] + · intro h a b; exact (H.natAdd (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natSub (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natMul (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natPow (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natGcd (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natMod (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natDiv (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natBEq (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natBLE (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natLAnd (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natLOr (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natXor (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natShiftLeft (oldContains (hprims (by simp)) h) a b).mono le + · intro h a b; exact (H.natShiftRight (oldContains (hprims (by simp)) h) a b).mono le + · intro ci h; apply H.charOfNat; rwa [← same (hprims (by simp))] + · intro ci h + obtain ⟨rfl, h2, h3⟩ := H.stringOfList (by rwa [← same (hprims (by simp))]) + exact ⟨rfl, h2.mono le, h3.mono le⟩ + +theorem VEnv.HasPrimitives.addDefEq {env : VEnv} (H : env.HasPrimitives) : + (env.addDefEq df).HasPrimitives := + { H with + natAdd h a b := (H.natAdd h a b).mono VEnv.addDefEq_le + natSub h a b := (H.natSub h a b).mono VEnv.addDefEq_le + natMul h a b := (H.natMul h a b).mono VEnv.addDefEq_le + natPow h a b := (H.natPow h a b).mono VEnv.addDefEq_le + natGcd h a b := (H.natGcd h a b).mono VEnv.addDefEq_le + natMod h a b := (H.natMod h a b).mono VEnv.addDefEq_le + natDiv h a b := (H.natDiv h a b).mono VEnv.addDefEq_le + natBEq h a b := (H.natBEq h a b).mono VEnv.addDefEq_le + natBLE h a b := (H.natBLE h a b).mono VEnv.addDefEq_le + natLAnd h a b := (H.natLAnd h a b).mono VEnv.addDefEq_le + natLOr h a b := (H.natLOr h a b).mono VEnv.addDefEq_le + natXor h a b := (H.natXor h a b).mono VEnv.addDefEq_le + natShiftLeft h a b := (H.natShiftLeft h a b).mono VEnv.addDefEq_le + natShiftRight h a b := (H.natShiftRight h a b).mono VEnv.addDefEq_le + stringOfList h := + let ⟨h1, h2, h3⟩ := H.stringOfList h + ⟨h1, h2.mono VEnv.addDefEq_le, h3.mono VEnv.addDefEq_le⟩ } + +theorem VEnvs.WF.safePrimitives_add {ves : VEnvs} {env : Environment} + (wf : ves.WF env) (ci : ConstantInfo) + (hfresh : env.find? ci.name = none) + (hok : Environment.primitives.contains ci.name → + ci.safety = .safe ∧ ci.levelParams = []) + (hfind : (env.add ci).find? (n : Name) = some ci') + (hp : Environment.primitives.contains n) : ci'.safety = .safe ∧ ci'.levelParams = [] := by + have mapWF := (wf.tr (safety := .safe)).map_wf + have hnone : env.constants.find? ci.name = none := by + rw [← mapWF.find?'_eq_find?] + exact hfresh + have mapWF' := mapWF.insert ci.name ci hnone + change SMap.find?' (env.constants.insert ci.name ci) n = some ci' at hfind + rw [mapWF'.find?'_eq_find?, mapWF.find?_insert] at hfind + split at hfind + · cases hfind; cases LawfulBEq.eq_of_beq ‹_›; exact hok hp + · refine wf.safePrimitives ?_ hp + rwa [Kernel.Environment.find?, mapWF.find?'_eq_find?] + +theorem addConstCore.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (ci : ConstantInfo) (ci' : VConstVal) (checkSafety : DefinitionSafety) + (visible_le : ∀ safety, safety ≤ ci.safety → safety ≤ checkSafety) + (htr : TrConstVal checkSafety (ves.venv checkSafety) ci ci') + (hci : ci'.toVConstant.WF (ves.venv checkSafety)) + (hn : env.find? ci.name = none) + (hprim : Environment.primitives.contains ci.name → + ci.safety = .safe ∧ ci.levelParams = []) + (preserves : ∀ safety venv', safety ≤ ci.safety → + (ves.venv safety).addConst ci.name ci'.toVConstant = some venv' → + (ves.venv safety).HasPrimitives → venv'.HasPrimitives) + (step : ∀ safety venv', + TrConstant safety (ves.venv safety) ci ci'.toVConstant → + ci'.toVConstant.WF (ves.venv safety) → + (ves.venv safety).addConst ci.name ci'.toVConstant = some venv' → + TrEnv' safety env.constants env.quotInit (ves.venv safety) → + TrEnv' safety (env.constants.insert ci.name ci) env.quotInit venv') : + ∃ ves' : VEnvs, ves'.WF (env.add ci) ∧ + ∀ safety, (ves.venv safety).AddConst safety ci ci'.toVConstant (ves'.venv safety) := by + have hnMap : env.constants.find? ci.name = none := by + rw [← (wf.tr (safety := .safe)).map_wf.find?'_eq_find?] + exact hn + have visible_tr (safety) (hvisible : safety ≤ ci.safety) : + TrConstant safety (ves.venv safety) ci ci'.toVConstant := + (htr.1.sf_mono (visible_le safety hvisible)).mono (wf.mono (visible_le safety hvisible)) + have visible_wf (safety) (hvisible : safety ≤ ci.safety) : + ci'.toVConstant.WF (ves.venv safety) := + hci.mono (wf.mono (visible_le safety hvisible)) + have hves' safety : ∃ venv', (ves.venv safety).AddConst safety ci ci'.toVConstant venv' := by + unfold VEnv.AddConst; split <;> [rename_i hvisible; exact ⟨ves.venv safety, rfl⟩] + have ⟨venv', hadd⟩ := (wf.tr (safety := safety)).exists_addConst hn ci'.toVConstant + exact ⟨venv', visible_tr safety hvisible, visible_wf safety hvisible, hadd⟩ + obtain ⟨ves', hves'⟩ := VEnvs.axiom_of_choice hves' + have hadd (safety) (hvisible : safety ≤ ci.safety) : + (ves.venv safety).addConst ci.name ci'.toVConstant = some (ves'.venv safety) := by + have h := hves' safety; unfold VEnv.AddConst at h; rw [if_pos hvisible] at h; exact h.2.2 + have hsame (safety) (hvisible : ¬ safety ≤ ci.safety) : ves'.venv safety = ves.venv safety := by + have h := hves' safety; unfold VEnv.AddConst at h; rwa [if_neg hvisible] at h + refine ⟨ves', ?_, hves'⟩ + exact { + tr {safety} := by + by_cases hvisible : safety ≤ ci.safety + · exact step safety _ (visible_tr safety hvisible) (visible_wf safety hvisible) + (hadd safety hvisible) (wf.tr (safety := safety)) + · rw [hsame safety hvisible] + exact TrEnv'.ignore (ci := ci) hnMap hvisible (wf.tr (safety := safety)) + hasPrimitives {safety} := by + by_cases hvisible : safety ≤ ci.safety + · exact preserves safety _ hvisible (hadd safety hvisible) (wf.hasPrimitives (safety := safety)) + · rw [hsame safety hvisible]; exact wf.hasPrimitives (safety := safety) + safePrimitives := wf.safePrimitives_add ci hn hprim + mono {safety safety'} hle := by + by_cases hvisible' : safety' ≤ ci.safety + · have hvisible := DefinitionSafety.le_trans hle hvisible' + exact VEnv.addConst_mono (wf.mono hle) (hadd safety' hvisible') (hadd safety hvisible) + rw [hsame safety' hvisible'] + by_cases hvisible : safety ≤ ci.safety + · exact (wf.mono hle).trans (VEnv.addConst_le (hadd safety hvisible)) + · rw [hsame safety hvisible]; exact wf.mono hle } + +theorem addConst.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (ci : ConstantInfo) (ci' : VConstVal) (checkSafety : DefinitionSafety) + (visible_le : ∀ safety, safety ≤ ci.safety → safety ≤ checkSafety) + (htr : TrConstVal checkSafety (ves.venv checkSafety) ci ci') + (hci : ci'.toVConstant.WF (ves.venv checkSafety)) + (hn : env.find? ci.name = none) + (hnonprim : Environment.primitives.contains ci.name = false) + (step : ∀ safety venv', + TrConstant safety (ves.venv safety) ci ci'.toVConstant → + ci'.toVConstant.WF (ves.venv safety) → + (ves.venv safety).addConst ci.name ci'.toVConstant = some venv' → + TrEnv' safety env.constants env.quotInit (ves.venv safety) → + TrEnv' safety (env.constants.insert ci.name ci) env.quotInit venv') : + ∃ ves' : VEnvs, ves'.WF (env.add ci) ∧ + ∀ safety, (ves.venv safety).AddConst safety ci ci'.toVConstant (ves'.venv safety) := + addConstCore.WF wf ci ci' checkSafety visible_le htr hci hn (by simp_all) + (fun _ _ _ hadd hp => hp.addConst hnonprim hadd) step + +theorem addDef.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (v : DefinitionVal) (ci' : VDefVal) (checkSafety : DefinitionSafety) + (visible_le : ∀ safety, safety ≤ (ConstantInfo.defnInfo v).safety → safety ≤ checkSafety) + (htr : TrDefVal checkSafety (ves.venv checkSafety) (.defnInfo v) ci') + (hci : ci'.WF (ves.venv checkSafety)) + (hn : env.find? v.name = none) + (hprim : Environment.primitives.contains v.name → + (ConstantInfo.defnInfo v).safety = .safe ∧ v.levelParams = []) + (preserves : ∀ safety base, + safety ≤ (ConstantInfo.defnInfo v).safety → + (ves.venv safety).addConst v.name ci'.toVConstant = some base → + (base.addDefEq ci'.toDefEq).HasPrimitives) : + ∃ ves' : VEnvs, ves'.WF (env.add (.defnInfo v)) ∧ + ∀ safety, (ves.venv safety).AddDef safety (.defnInfo v) ci' (ves'.venv safety) := by + have hnMap : env.constants.find? v.name = none := by + rwa [← (wf.tr (safety := .safe)).map_wf.find?'_eq_find?] + have visible_tr (safety) (hvisible : safety ≤ (ConstantInfo.defnInfo v).safety) : + TrDefVal safety (ves.venv safety) (.defnInfo v) ci' := + .mono (wf.mono (visible_le safety hvisible)) <| + ⟨⟨htr.1.1.sf_mono (visible_le safety hvisible), htr.1.2⟩, htr.2⟩ + have visible_wf safety hvisible := hci.mono (wf.mono (visible_le safety hvisible)) + have hves' safety : ∃ venv', (ves.venv safety).AddDef safety (.defnInfo v) ci' venv' := by + unfold VEnv.AddDef; split <;> [rename_i hvisible; exact ⟨ves.venv safety, rfl⟩] + have ⟨base, hadd⟩ := (wf.tr (safety := safety)).exists_addConst hn ci'.toVConstant + exact ⟨base.addDefEq ci'.toDefEq, + base, visible_tr safety hvisible, visible_wf safety hvisible, hadd, rfl⟩ + obtain ⟨ves', hves'⟩ := VEnvs.axiom_of_choice hves' + have hbase (safety) (hvisible : safety ≤ (ConstantInfo.defnInfo v).safety) : + ∃ base, (ves.venv safety).addConst v.name ci'.toVConstant = some base ∧ + ves'.venv safety = base.addDefEq ci'.toDefEq := by + have h := hves' safety; unfold VEnv.AddDef at h; rw [if_pos hvisible] at h + obtain ⟨base, _, _, hadd, heq⟩ := h; exact ⟨base, hadd, heq⟩ + have hsame (safety) (hvisible : ¬ safety ≤ (ConstantInfo.defnInfo v).safety) : + ves'.venv safety = ves.venv safety := by + have h := hves' safety; unfold VEnv.AddDef at h; rwa [if_neg hvisible] at h + refine ⟨ves', ?_, hves'⟩ + refine { + tr {safety} := by + change TrEnv' safety (env.constants.insert v.name (.defnInfo v)) env.quotInit _ + by_cases hvisible : safety ≤ (ConstantInfo.defnInfo v).safety + · obtain ⟨base, hadd, heq⟩ := hbase safety hvisible + exact heq ▸ TrEnv'.defn (visible_tr safety hvisible) + (by rwa [← (wf.tr (safety := safety)).map_wf.find?'_eq_find?]) + (visible_wf safety hvisible) hadd (wf.tr (safety := safety)) + · rw [hsame safety hvisible] + simpa [ConstantInfo.name, ConstantInfo.toConstantVal] using + TrEnv'.ignore (ci := .defnInfo v) hnMap hvisible (wf.tr (safety := safety)) + hasPrimitives {safety} := by + by_cases hvisible : safety ≤ (ConstantInfo.defnInfo v).safety + · obtain ⟨base, hadd, heq⟩ := hbase safety hvisible + rw [heq]; exact preserves safety base hvisible hadd + · rw [hsame safety hvisible]; exact wf.hasPrimitives (safety := safety) + safePrimitives := wf.safePrimitives_add (.defnInfo v) hn hprim + mono {safety safety'} hle := by + by_cases hvisible' : safety' ≤ (ConstantInfo.defnInfo v).safety + · have hvisible := DefinitionSafety.le_trans hle hvisible' + obtain ⟨base', hadd', heq'⟩ := hbase safety' hvisible' + obtain ⟨base, hadd, heq⟩ := hbase safety hvisible + rw [heq', heq] + exact VEnv.addDefEq_mono <| VEnv.addConst_mono (wf.mono hle) hadd' hadd + rw [hsame safety' hvisible'] + by_cases hvisible : safety ≤ (ConstantInfo.defnInfo v).safety + · obtain ⟨base, hadd, heq⟩ := hbase safety hvisible + rw [heq] + exact (wf.mono hle).trans <| (VEnv.addConst_le hadd).trans VEnv.addDefEq_le + · rw [hsame safety hvisible]; exact wf.mono hle } diff --git a/Lean4Lean/Verify/Environment/Lemmas.lean b/Lean4Lean/Verify/Environment/Lemmas.lean index 23cfd522..2a182628 100644 --- a/Lean4Lean/Verify/Environment/Lemmas.lean +++ b/Lean4Lean/Verify/Environment/Lemmas.lean @@ -70,7 +70,9 @@ theorem Aligned.addInduct (H : AddInduct C₁ venv₁ decl C₂ venv₂) : theorem TrEnv'.aligned (H : TrEnv' safety C Q venv) : Aligned safety C venv := by induction H with | empty => exact .empty + | ignore h1 h2 _ ih => exact ih.ignoreConst h1 h2 rfl | «axiom» h1 h2 _ h _ ih => exact ih.const h2 h1 h rfl + | thm h1 h2 _ _ h _ ih => exact ih.const h2 h1.1.1 h rfl | «opaque» h1 h2 _ h _ ih => exact ih.const h2 h1.1.1 h rfl | defn h1 h2 _ h _ ih => exact (ih.const h2 h1.1.1 h rfl).defeq | quot _ h _ ih => exact ih.addQuot h @@ -147,7 +149,11 @@ theorem TrEnv'.of_value (H : TrEnv' safety C Q venv) (h : C.find? name = some ci rw [hC.find?_insert]; simp; split <;> simp +contextual [*] induction H with | empty => simp [SMap.find?] at h - | «axiom» _ _ _ h1 H ih | «opaque» _ _ _ h1 H ih => + | ignore h1 h2 H ih => + obtain h | ⟨rfl, rfl⟩ := this H.map_wf h + · exact ih h + · exact (h2 hs).elim + | «axiom» _ _ _ h1 H ih => obtain h | ⟨rfl, rfl⟩ := this H.map_wf h · exact (ih h).mono (VEnv.addConst_le h1) · contradiction @@ -160,6 +166,23 @@ theorem TrEnv'.of_value (H : TrEnv' safety C Q venv) (h : C.find? name = some ci (H.defn h2 h3 h4 h1).wf.ordered.defEqWF VEnv.addDefEq_self let ⟨⟨⟨b1, b2, b3⟩, b4⟩, b5⟩ := h2 refine ⟨_, b5.mono le, b2.symm ▸ b4.symm ▸ ⟨_, this.symm⟩⟩ + | thm h2 h3 h4 h5 h1 H ih => + have' le := VEnv.addConst_le h1 + obtain h | ⟨rfl, rfl⟩ := this H.map_wf h + · exact (ih h).mono le + · cases hv + let ⟨⟨⟨b1, b2, b3⟩, b4⟩, b5⟩ := h2 + dsimp only [ConstantInfo.name, ConstantInfo.levelParams, ConstantInfo.toConstantVal] at b2 b4 ⊢ + have hp := h5.mono le + have hb := h4.mono le + have hc := VEnv.HasType.const0 (VEnv.addConst_self h1) ⟨_, hp⟩ + rw [b4] at hc + refine ⟨_, b5.mono le, b2.symm ▸ b4.symm ▸ ?_⟩ + exact ⟨_, .proofIrrel hp hb hc⟩ + | «opaque» _ _ _ h1 H ih => + obtain h | ⟨rfl, rfl⟩ := this H.map_wf h + · exact (ih h).mono (VEnv.addConst_le h1) + · contradiction | quot _ h1 H ih => suffices ∀ {n k ci' P}, (∀ C env, Aligned safety C env → P C env → C.find? name = some ci) → ∀ C env, Aligned safety C env → AddQuot1 n k ci' P C env → C.find? name = some ci by diff --git a/Lean4Lean/Verify/TypeChecker.lean b/Lean4Lean/Verify/TypeChecker.lean index 858cb755..d11b8828 100644 --- a/Lean4Lean/Verify/TypeChecker.lean +++ b/Lean4Lean/Verify/TypeChecker.lean @@ -17,6 +17,12 @@ structure VEnvs.WF (env : Environment) (ves : VEnvs) where Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = [] mono : safety ≤ safety' → ves.venv safety' ≤ ves.venv safety +/-- Assemble a `VEnvs` from a pointwise existential. `DefinitionSafety` has three elements, so +this is a finite case split rather than an appeal to choice -- the name records what it replaces. -/ +theorem VEnvs.axiom_of_choice {P : DefinitionSafety → VEnv → Prop} (H : ∀ sf, ∃ x, P sf x) : + ∃ x : VEnvs, ∀ sf, P sf (x.venv sf) := by + have ⟨x1, _⟩ := H .safe; have ⟨x2, _⟩ := H .partial; have ⟨x3, _⟩ := H .unsafe + exact ⟨⟨fun | .safe => x1 | .partial => x2 | .unsafe => x3⟩, by rintro ⟨⟩ <;> assumption⟩ namespace TypeChecker open Inner From bd9e576c5b92391bd2c3e768be1a6480db2d204d Mon Sep 17 00:00:00 2001 From: Mario Carneiro Date: Wed, 5 Aug 2026 07:27:49 +0200 Subject: [PATCH 08/51] verify: model unsafe and mutual definition blocks `addDecl.WF` now covers every declaration form except inductives. A recursive `unsafe`/`partial` body is checked in an environment holding the block, so the block's constants are added as axioms rather than as definitions: with the values present a body can delta-unfold the constant being defined, and the resulting judgment has no type-preserving model. `VDecl.mutualDef` adds a block's constants without their defining equations and `TrEnv'.mutualDef` relates it to the real environment, so a member may only be unfolded once the whole block is present. The temporary environment a `partial` block is checked in has no model at every safety level -- its members are present as axioms tagged `safe`, since an `AxiomVal` cannot be tagged `partial`, and their types were only checked at `partial`. `VEnvAt` is the single-level model the type checker actually consumes; `VContext.mk'` and `M.WF.run` are now wrappers over the `VEnvAt` forms. Also adds the three `forIn` rules `addMutual`'s loops need, and `NameSet.contains_insert` on top of the existing `TransCmp Name.quickCmp` instance -- the header loop's `found` set is what supplies the block's `Nodup`. Co-Authored-By: Claude Opus 5 --- Lean4Lean/Environment.lean | 27 +- Lean4Lean/Theory/Typing/Env.lean | 13 + Lean4Lean/Theory/Typing/EnvLemmas.lean | 110 ++++++- Lean4Lean/Theory/VDecl.lean | 1 + Lean4Lean/Verify/Environment.lean | 150 ++++++--- Lean4Lean/Verify/Environment/Basic.lean | 27 ++ Lean4Lean/Verify/Environment/Checker.lean | 53 +++- Lean4Lean/Verify/Environment/Extension.lean | 327 +++++++++++++++++++- Lean4Lean/Verify/Environment/Lemmas.lean | 82 +++++ Lean4Lean/Verify/Level.lean | 17 + Lean4Lean/Verify/TypeChecker.lean | 125 +++++++- divergences.md | 2 + 12 files changed, 832 insertions(+), 102 deletions(-) diff --git a/Lean4Lean/Environment.lean b/Lean4Lean/Environment.lean index f2e3babb..bd885361 100644 --- a/Lean4Lean/Environment.lean +++ b/Lean4Lean/Environment.lean @@ -31,23 +31,21 @@ def addDefinition (env : Environment) (v : DefinitionVal) if check then _ ← (checkConstantVal env v.toConstantVal).run env (safety := .unsafe) (lparams := v.levelParams) (fuel := fuel) - let env' := env.add (.defnInfo v) + let env' := env.add (.axiomInfo { v with isUnsafe := true }) if check then checkNoMVarNoFVar env' v.name v.value M.run env' (safety := .unsafe) (lctx := {}) (lparams := v.levelParams) (fuel := fuel) do let valType ← TypeChecker.checkType v.value if !(← isDefEq valType v.type) then throw <| .declTypeMismatch env' (.defnDecl v) valType - return env' - else - if check then - M.run env (safety := .safe) (lctx := {}) (lparams := v.levelParams) (fuel := fuel) do - checkConstantVal env v.toConstantVal (← checkPrimitiveDef v) - checkNoMVarNoFVar env v.name v.value - let valType ← TypeChecker.checkType v.value - if !(← isDefEq valType v.type) then - throw <| .declTypeMismatch env (.defnDecl v) valType - return env.add (.defnInfo v) + else if check then + M.run env (safety := .safe) (lctx := {}) (lparams := v.levelParams) (fuel := fuel) do + checkConstantVal env v.toConstantVal (← checkPrimitiveDef v) + checkNoMVarNoFVar env v.name v.value + let valType ← TypeChecker.checkType v.value + if !(← isDefEq valType v.type) then + throw <| .declTypeMismatch env (.defnDecl v) valType + return env.add (.defnInfo v) def addTheorem (env : Environment) (v : TheoremVal) (check := true) (fuel : FuelConfig := {}) : Except Exception Environment := do @@ -95,9 +93,8 @@ def addMutual (env : Environment) (vs : List DefinitionVal) throw <| .other s!"invalid mutual definition, duplicate declaration name '{v.name}'" found := found.insert v.name checkConstantVal env v.toConstantVal - let mut env' := env - for v in vs do - env' := env'.add (.defnInfo v) + let env' := vs.foldl (init := env) fun env' v => + env'.add (.axiomInfo { v with isUnsafe := v₀.safety == .unsafe }) if check then M.run env' (safety := v₀.safety) (lctx := {}) (lparams := v₀.levelParams) (fuel := fuel) do for v in vs do @@ -105,7 +102,7 @@ def addMutual (env : Environment) (vs : List DefinitionVal) let valType ← TypeChecker.checkType v.value if !(← isDefEq valType v.type) then throw <| .declTypeMismatch env' (.mutualDefnDecl vs) valType - return env' + return vs.foldl (fun env' v => env'.add (.defnInfo v)) env /-- Type check given declaration and add it to the environment -/ def addDecl (env : Environment) (decl : Declaration) (check := true) (fuel : FuelConfig := {}) : diff --git a/Lean4Lean/Theory/Typing/Env.lean b/Lean4Lean/Theory/Typing/Env.lean index 02306de7..e0eb8db5 100644 --- a/Lean4Lean/Theory/Typing/Env.lean +++ b/Lean4Lean/Theory/Typing/Env.lean @@ -7,6 +7,14 @@ namespace Lean4Lean def VDefVal.WF (env : VEnv) (ci : VDefVal) : Prop := env.HasType ci.uvars [] ci.value ci.type +/-- Add a block of constants, without their defining equations. -/ +def VEnv.addConsts (env : VEnv) (cis : List VDefVal) : Option VEnv := + cis.foldlM (fun env ci => env.addConst ci.name ci.toVConstant) env + +/-- Add the defining equations of a block, after all of its constants. -/ +def VEnv.addDefEqs (env : VEnv) (cis : List VDefVal) : VEnv := + cis.foldl (fun env ci => env.addDefEq ci.toDefEq) env + inductive VDecl.WF : VEnv → VDecl → VEnv → Prop where | axiom : ci.WF env → @@ -16,6 +24,11 @@ inductive VDecl.WF : VEnv → VDecl → VEnv → Prop where ci.WF env → env.addConst ci.name ci.toVConstant = some env' → VDecl.WF env (.def ci) (env'.addDefEq ci.toDefEq) + | mutualDef : + (∀ ci ∈ cis, ci.toVConstant.WF env) → + env.addConsts cis = some env' → + (∀ ci ∈ cis, ci.WF env') → + VDecl.WF env (.mutualDef cis) (env'.addDefEqs cis) | opaque : ci.WF env → env.addConst ci.name ci.toVConstant = some env' → diff --git a/Lean4Lean/Theory/Typing/EnvLemmas.lean b/Lean4Lean/Theory/Typing/EnvLemmas.lean index 3a7db5e1..bbbdc263 100644 --- a/Lean4Lean/Theory/Typing/EnvLemmas.lean +++ b/Lean4Lean/Theory/Typing/EnvLemmas.lean @@ -5,22 +5,102 @@ import Lean4Lean.Theory.Typing.InductiveLemmas namespace Lean4Lean +theorem VEnv.addConsts_le {env env' : VEnv} : ∀ {cis}, env.addConsts cis = some env' → env ≤ env' + | [], h => by cases h; exact .rfl + | _ :: _, h => by + simp [VEnv.addConsts, Option.bind_eq_some_iff] at h + obtain ⟨_, h1, h2⟩ := h + exact (addConst_le h1).trans (addConsts_le h2) + +theorem VEnv.addConst_eq_none {env : VEnv} {name ci} + (h : env.constants name = none) : ∃ env', env.addConst name ci = some env' := by + unfold VEnv.addConst; rw [h]; exact ⟨_, rfl⟩ + +theorem VEnv.addConst_constants_eq {env env' : VEnv} {name ci} + (h : env.addConst name ci = some env') : + env'.constants = fun n => if name = n then some ci else env.constants n := by + unfold VEnv.addConst at h; split at h <;> cases h; rfl + +/-- A block of constants can be added as long as each name is fresh and the block has no +duplicates; the latter is what `addMutual`'s `found` set checks. -/ +theorem VEnv.exists_addConsts {env : VEnv} : ∀ {cis : List VDefVal}, + (∀ ci ∈ cis, env.constants ci.name = none) → (cis.map (·.name)).Nodup → + ∃ env', env.addConsts cis = some env' + | [], _, _ => ⟨_, rfl⟩ + | ci :: cis, hfresh, hnd => by + obtain ⟨env₁, h₁⟩ := VEnv.addConst_eq_none (ci := ci.toVConstant) (hfresh _ (.head _)) + rw [List.map_cons, List.nodup_cons] at hnd + have ⟨env₂, h₂⟩ := VEnv.exists_addConsts (env := env₁) (cis := cis) (fun c hc => ?_) hnd.2 + · exact ⟨env₂, by simp [VEnv.addConsts, h₁]; exact h₂⟩ + · rw [VEnv.addConst_constants_eq h₁] + have : ci.name ≠ c.name := fun h => hnd.1 (List.mem_map.2 ⟨c, hc, h.symm⟩) + simp [this, hfresh c (.tail _ hc)] + +theorem VEnv.addConsts_congr {env : VEnv} : ∀ {cis cis' : List VDefVal}, + List.Forall₂ (fun a b => a.toVConstVal = b.toVConstVal) cis cis' → + env.addConsts cis = env.addConsts cis' + | [], [], _ => rfl + | a :: _, b :: _, .cons h t => by + have h1 : a.name = b.name := congrArg VConstVal.name h + have h2 : a.toVConstant = b.toVConstant := congrArg VConstVal.toVConstant h + show (env.addConst a.name a.toVConstant).bind _ = (env.addConst b.name b.toVConstant).bind _ + rw [h1, h2] + cases env.addConst b.name b.toVConstant + · rfl + · exact VEnv.addConsts_congr t + +theorem VEnv.addConsts_ordered {env env' : VEnv} : ∀ {cis}, Ordered env → + (∀ ci ∈ cis, ci.toVConstant.WF env) → env.addConsts cis = some env' → Ordered env' + | [], h, _, e => by cases e; exact h + | _ :: _, h, hw, e => by + simp [VEnv.addConsts, Option.bind_eq_some_iff] at e + obtain ⟨_, h1, h2⟩ := e + refine VEnv.addConsts_ordered (.const h (hw _ (.head _)) h1) (fun c hc => ?_) h2 + exact (hw c (.tail _ hc)).mono (VEnv.addConst_le h1) + +theorem VEnv.addConsts_constants {env env' : VEnv} : ∀ {cis}, env.addConsts cis = some env' → + ∀ ci ∈ cis, env'.constants ci.name = some ci.toVConstant + | [], _, _, hc => nomatch hc + | _ :: _, e, c, hc => by + simp [VEnv.addConsts, Option.bind_eq_some_iff] at e + obtain ⟨_, h1, h2⟩ := e + cases hc with + | head => exact (VEnv.addConsts_le h2).constants (VEnv.addConst_self h1) + | tail _ hc => exact VEnv.addConsts_constants h2 c hc + +theorem VEnv.addDefEqs_ordered : ∀ {env : VEnv} {cis}, Ordered env → + (∀ ci ∈ cis, env.constants ci.name = some ci.toVConstant) → + (∀ ci ∈ cis, ci.WF env) → Ordered (env.addDefEqs cis) + | _, [], h, _, _ => h + | env, ci :: cis, h, hmem, hw => by + have hci : ci.WF env := hw _ (.head _) + have hord : Ordered (env.addDefEq ci.toDefEq) := by + refine .defeq h ⟨?_, hci⟩ + simp [VDefVal.toDefEq] + rw [← (hci.levelWF ⟨⟩).2.2.instL_id] + exact .const (hmem _ (.head _)) VLevel.id_WF (by simp) + show Ordered ((env.addDefEq ci.toDefEq).addDefEqs cis) + refine VEnv.addDefEqs_ordered hord (fun c hc => ?_) (fun c hc => ?_) + · exact (VEnv.addDefEq_le (df := ci.toDefEq)).constants (hmem c (.tail _ hc)) + · exact (hw c (.tail _ hc)).mono VEnv.addDefEq_le + theorem VEnv.WF.ordered : WF env → Ordered env | ⟨ds, H⟩ => by - induction H with - | empty => exact .empty - | decl h _ ih => - cases h with - | «axiom» h1 h2 => exact .const ih h1 h2 - | @«def» env env' ci h1 h2 => - refine .defeq (.const ih (h1.isType ih ⟨⟩) h2) ⟨?_, ?_⟩ - · simp [VDefVal.toDefEq] - rw [← (h1.levelWF ⟨⟩).2.2.instL_id] - exact .const (addConst_self h2) VLevel.id_WF (by simp) - · exact h1.mono (addConst_le h2) - | «opaque» h1 h2 => exact .const ih (h1.isType ih ⟨⟩) h2 - | «example» _ => exact ih - | quot h1 h2 => exact addQuot_WF ih h1 h2 - | induct h1 h2 => exact addInduct_WF ih h1 h2 + induction H with | empty => exact .empty | decl h _ ih + cases h with + | «axiom» h1 h2 => exact .const ih h1 h2 + | @«def» env env' ci h1 h2 => + refine .defeq (.const ih (h1.isType ih ⟨⟩) h2) ⟨?_, ?_⟩ + · simp [VDefVal.toDefEq] + rw [← (h1.levelWF ⟨⟩).2.2.instL_id] + exact .const (addConst_self h2) VLevel.id_WF (by simp) + · exact h1.mono (addConst_le h2) + | mutualDef h0 h1 h2 => + exact VEnv.addDefEqs_ordered (VEnv.addConsts_ordered ih h0 h1) + (VEnv.addConsts_constants h1) h2 + | «opaque» h1 h2 => exact .const ih (h1.isType ih ⟨⟩) h2 + | «example» _ => exact ih + | quot h1 h2 => exact addQuot_WF ih h1 h2 + | induct h1 h2 => exact addInduct_WF ih h1 h2 instance : CoeOut (VEnv.WF env) env.Ordered := ⟨(·.ordered)⟩ diff --git a/Lean4Lean/Theory/VDecl.lean b/Lean4Lean/Theory/VDecl.lean index 0e0803bc..f6825406 100644 --- a/Lean4Lean/Theory/VDecl.lean +++ b/Lean4Lean/Theory/VDecl.lean @@ -26,3 +26,4 @@ inductive VDecl where | example (_ : VDefVal) | quot | induct (_ : VInductDecl) + | mutualDef (_ : List VDefVal) diff --git a/Lean4Lean/Verify/Environment.lean b/Lean4Lean/Verify/Environment.lean index f798e77b..1aa6e648 100644 --- a/Lean4Lean/Verify/Environment.lean +++ b/Lean4Lean/Verify/Environment.lean @@ -1,7 +1,7 @@ import Lean4Lean.Verify.Environment.Extension namespace Lean4Lean - +open Lean4Lean open Lean hiding Environment Exception open Kernel @@ -22,8 +22,7 @@ theorem addAxiom.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (v : Axi · exact .pure ⟨ves', hwf, ci', hstep⟩ · intro safety _ cases v.isUnsafe <;> cases safety <;> trivial - · exact .axiom htr - (by rwa [← old.map_wf.find?'_eq_find?]) hci hadd old + · exact .axiom htr (by rwa [← old.map_wf.find?'_eq_find?]) hci hadd old theorem addDefinition.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (v : DefinitionVal) : @@ -31,16 +30,27 @@ theorem addDefinition.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) ∃ ves' : VEnvs, ves'.WF env' ∧ (∀ safety, ves.venv safety ≤ ves'.venv safety) ∧ (v.safety ≠ .unsafe → ∃ ci' : VDefVal, ∀ safety, (ves.venv safety).AddDef safety (.defnInfo v) ci' (ves'.venv safety)) := by - unfold addDefinition - split - · extract_lets _ F1 F2 - refine (checkConstantVal.WF wf (.defnInfo v) false - DefinitionSafety.unsafe_le).run wf |>.bind fun _ h1 => ?_ - unfold F2 - refine (checkNoMVarNoFVar.WF _ _ _).bind fun _ h2 => ?_ - sorry - refine (checkDefinition.WF wf v).run wf |>.bind fun _ h => ?_ - obtain ⟨allow, ci', hp, hu, ht, hname, hvalue, hci, hfresh, hnonprim⟩ := h + unfold addDefinition; split + · refine checkConstantVal.WF wf (.defnInfo v) false DefinitionSafety.unsafe_le + |>.run wf |>.bind fun _ ⟨ci0, htr, hwfc, hn, hnonprim⟩ => ?_ + refine (checkNoMVarNoFVar.WF _ _ _).bind fun _ h => ?_ + have ⟨vesA, wfA, hstepA⟩ := addConst.WF wf (.axiomInfo { v with isUnsafe := true }) ci0 + .unsafe (fun _ => id) ⟨⟨DefinitionSafety.unsafe_le, htr.1.2.1, htr.1.2.2⟩, htr.2⟩ + hwfc hn (hnonprim rfl) fun _ _ htr' hci' hadd' old => + .axiom htr' (by rwa [← old.map_wf.find?'_eq_find?]) hci' hadd' old + have hadd := (hstepA .unsafe).2.2 + refine checkBodyCore.WF (wfA.toVEnvAt .unsafe) (.defnDecl v) + v.levelParams v.type v.value ci0.type (htr.1.2.2.mono (VEnv.addConst_le hadd)) h + |>.run1 _ |>.bind fun _ h3 => ?_ + obtain ⟨value', hvalue, hvalueType⟩ := h3 + have hciWF : (⟨ci0, value'⟩ : VDefVal).WF (vesA.venv .unsafe) := by + show (vesA.venv .unsafe).HasType ci0.uvars [] value' ci0.type + rw [← htr.1.2.1]; exact hvalueType + have ⟨ves', hwf', hmono'⟩ := addUnsafeDef.WF wf v ⟨ci0, value'⟩ (vesA.venv .unsafe) + ‹_› htr hwfc hadd hvalue hciWF hn (hnonprim rfl) + exact .pure ⟨ves', hwf', hmono', (nomatch · ‹_›)⟩ + refine (checkDefinition.WF wf v).run wf |>.bind + fun _ ⟨allow, ci', hp, hu, ht, hname, hvalue, hci, hfresh, hnonprim⟩ => ?_ have hle : v.safety ≤ .safe := DefinitionSafety.le_safe have hmono := wf.mono hle have htr : TrDefVal v.safety (ves.venv v.safety) (.defnInfo v) ci' := by @@ -50,26 +60,17 @@ theorem addDefinition.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) have ⟨ves', hwf, hstep⟩ := addDef.WF wf v ci' v.safety ?_ htr (hci.mono hmono) hfresh ?_ ?_ · exact .pure ⟨ves', hwf, (hstep · |>.le), fun _ => ⟨ci', hstep⟩⟩ · simp [ConstantInfo.defnInfo_safety] - · intro hnamePrim - have hallow : allow = true := by - cases allow - · simp_all - · rfl - exact ⟨by rw [ConstantInfo.defnInfo_safety, hp.safe hallow], hp.no_level_params hallow⟩ + · intro hnamePrim; have := mt hnonprim; simp [hnamePrim] at this + exact ⟨by rw [ConstantInfo.defnInfo_safety, hp.safe this], hp.no_level_params this⟩ · intro safety base hvisible hadd - have hs : safety ≤ v.safety := by - simpa [ConstantInfo.defnInfo_safety] using hvisible - have htr' : TrDefVal safety (ves.venv safety) (.defnInfo v) ci' := by - have hsf : TrDefVal safety (ves.venv v.safety) (.defnInfo v) ci' := - ⟨⟨htr.1.1.sf_mono hs, htr.1.2⟩, htr.2⟩ - exact hsf.mono (wf.mono hs) + have hs : safety ≤ v.safety := by simpa [ConstantInfo.defnInfo_safety] using hvisible + have hsf : TrDefVal safety (ves.venv v.safety) (.defnInfo v) ci' := + ⟨⟨htr.1.1.sf_mono hs, htr.1.2⟩, htr.2⟩ have hci' := hci.mono (hmono.trans (wf.mono hs)) - cases allow with - | false => exact (wf.hasPrimitives.addConst (hnonprim rfl) hadd).addDefEq - | true => - exact hp.preserves (safety := safety) (venv := ves.venv safety) - (env' := base) (ci' := ci') rfl (wf.mono DefinitionSafety.le_safe) - (wf.tr (safety := safety)).wf wf.hasPrimitives htr' hci' hadd + cases allow + · exact (wf.hasPrimitives.addConst (hnonprim rfl) hadd).addDefEq + · exact hp.preserves rfl (wf.mono DefinitionSafety.le_safe) wf.tr.wf wf.hasPrimitives + (hsf.mono (wf.mono hs)) (hci.mono (hmono.trans (wf.mono hs))) hadd theorem addTheorem.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (v : TheoremVal) : (addTheorem env v).WF fun env' => @@ -138,10 +139,89 @@ theorem addQuot.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) : · exact .pure ⟨ves, wf, fun _ => VEnv.LE.rfl⟩ · exact (checkEqType.WF wf).bind fun _ h => False.elim h +private theorem Except.WF.throw' {e : ε} {Q : α → Prop} : (throw e : Except ε α).WF Q := + fun _ h => nomatch h + +private theorem Except.WF.throwBind {e : ε} {f : α → Except ε β} {Q : β → Prop} : + ((throw e : Except ε α) >>= f).WF Q := fun _ h => nomatch h + +theorem addMutual.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (vs : List DefinitionVal) : + (addMutual env vs).WF fun env' => + ∃ ves' : VEnvs, ves'.WF env' ∧ ∀ safety, ves.venv safety ≤ ves'.venv safety := by + unfold addMutual + simp only [reduceIte] + split <;> [rename_i _ v₀ rest; exact Except.WF.throw'] + split <;> [exact Except.WF.throwBind; skip] + have hsf : v₀.safety ≤ (if v₀.safety == .unsafe then .unsafe else .safe) := by + cases v₀.safety with + | «partial» => exact DefinitionSafety.le_safe + | _ => exact DefinitionSafety.le_rfl + refine (TypeChecker.M.WF.run (Q := fun _ => + (∃ cis, (v₀ :: rest).Forall₂ (fun v ci => + TrMutualHeader v₀.safety (ves.venv v₀.safety) env v ci ∧ + v.safety = v₀.safety ∧ v.levelParams = v₀.levelParams) cis) ∧ + (((v₀ :: rest).map (·.name)).Nodup ∧ + ∀ v ∈ (v₀ :: rest), (∅ : NameSet).contains v.name = false)) wf ?_).bind fun _ h1 => ?_ + · refine (TypeChecker.M.WF.forInFresh fun v found s => ?_).bind fun _ _ _ h => .pure h + split <;> [exact .bindThrow .throw; rename_i hsafety] + split <;> [exact .bindThrow .throw; rename_i hlp] + split <;> [exact .bindThrow .throw; rename_i hfound] + simp at hsafety hlp hfound + rw [← hlp] + refine (checkConstantVal.WF wf (.defnInfo v) false ?_ s).bind ?_ + · rw [ConstantInfo.defnInfo_safety, hsafety]; exact DefinitionSafety.le_rfl + refine fun _ _ _ ⟨ci', htr, hciw, hn, hnp⟩ => .pure ?_ + exact ⟨hfound, ⟨⟨ci', .bvar 0⟩, ⟨htr, hciw, hn, hnp rfl⟩, hsafety, rfl⟩, rfl⟩ + obtain ⟨⟨cis0, hQ0⟩, hnd, -⟩ := h1 + have hhdr := hQ0.imp fun _ _ h => h.1 + have hpull {P : DefinitionVal → VDefVal → Prop} (h : List.Forall₂ P (v₀ :: rest) cis0) + {R : DefinitionVal → Prop} (H : ∀ v ci, P v ci → R v) : ∀ v ∈ v₀ :: rest, R v := + fun v hv => have ⟨ci, _, hp⟩ := h.forall_exists_l v hv; H v ci hp + have hbs := hpull hQ0 fun _ _ h => h.2.1 + have hfresh := hpull hhdr fun _ _ h => h.2.2.1 + have hnonprim := hpull hhdr fun _ _ h => h.2.2.2 + have hnameeq : (v₀ :: rest).map (·.name) = cis0.map (·.name) := by + rw [← List.forall₂_eq, List.forall₂_map_left_iff, List.forall₂_map_right_iff] + exact hhdr.imp fun _ _ h => h.1.2 + have hpullr {P : DefinitionVal → VDefVal → Prop} (h : List.Forall₂ P (v₀ :: rest) cis0) + {R : VDefVal → Prop} (H : ∀ v ci, P v ci → R ci) : ∀ ci ∈ cis0, R ci := + fun ci hc => have ⟨v, _, hp⟩ := h.forall_exists_r ci hc; H v ci hp + obtain ⟨base, hbase0⟩ := (wf.tr (safety := v₀.safety)).exists_addConsts + (hpullr hhdr fun _ _ h => h.1.2 ▸ h.2.2.1) (hnameeq ▸ hnd) + have wfA := VEnvAt.addAxioms hsf (wf.toVEnvAt v₀.safety) hhdr hnd hbase0 + refine (TypeChecker.M.WF.run1 (Q := fun _ => ∃ cis', + cis0.Forall₂ (fun (ci ci' : VDefVal) => ci.toVConstVal = ci'.toVConstVal) cis' ∧ + (v₀ :: rest).Forall₂ (fun v ci' => TrExprS base v.levelParams [] v.value ci'.value ∧ + ci'.WF base) cis') wfA ?_).bind fun _ h2 => ?_ + · refine (TypeChecker.M.WF.forInForall₂ (fun v ci s hd => ?_) hQ0).bind fun _ _ _ h => .pure h + have hdecl := hd.1.1.1.2.2.mono (VEnv.addConsts_le hbase0) + refine (TypeChecker.M.WF.liftExcept + (checkNoMVarNoFVar.WF _ v.name v.value)).bind fun _ _ _ hclosed => ?_ + have hclosed' : v.value.FVarsIn + (· ∈ (TypeChecker.VContext.mk1 wfA v.levelParams).vlctx.fvars) := by + simpa [TypeChecker.VContext.mk1] using hclosed + refine hd.2.2 ▸ (TypeChecker.checkType.WF hclosed').bind + fun valType _ _ ⟨value', valType', _, hval, hvalTy, hhasType⟩ => ?_ + refine (TypeChecker.isDefEq.WF hvalTy hdecl).bind fun equal _ _ hequal => ?_ + split <;> [exact .bindThrow .throw; rename_i heq] + refine .pure ⟨⟨⟨ci.toVConstVal, value'⟩, rfl, hval, ?_⟩, rfl⟩ + rw [VDefVal.WF, ← hd.1.1.1.2.1] + exact hhasType.defeqU_r wfA.tr.wf (by trivial) (hequal (by simpa using heq)) + obtain ⟨cis, hRR, hbody⟩ := h2 + rw [VEnv.addConsts_congr hRR] at hbase0 + have : List.Forall₂ (TrMutualHeader v₀.safety (ves.venv v₀.safety) env) (v₀ :: rest) cis := + hhdr.trans (h₂ := hRR) fun v ci ci' h1 h2 => by + have hc : ci.toVConstant = ci'.toVConstant := congrArg VConstVal.toVConstant h2 + exact ⟨h2 ▸ h1.1, hc ▸ h1.2.1, h1.2.2.1, h1.2.2.2⟩ + refine .pure <| addMutualBlock.WF wf v₀.safety (v₀ :: rest) cis base hbs hnd hfresh hnonprim + (fun ci hc => ?_) hbase0 ((this.and hbody).imp (fun _ _ h => ⟨h.1.1, h.2.1⟩)) (fun ci hc => ?_) + · obtain ⟨v, -, h⟩ := this.forall_exists_r ci hc; exact h.2.1 + · obtain ⟨v, -, h⟩ := hbody.forall_exists_r ci hc; exact h.2 + /-- Successful checked addition preserves well-formedness and extends every safety-indexed -abstract environment. The declaration forms still outstanding are recursive unsafe and mutual -definitions, which need a recursive-body relation, and inductives, which need a constructive -`AddInduct` model. -/ +abstract environment. The only declaration form still outstanding is inductives, which need a +constructive `AddInduct` model. -/ theorem addDecl.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (decl : Declaration) : (addDecl env decl (check := true) (fuel := {})).WF fun env' => ∃ ves' : VEnvs, ves'.WF env' ∧ ∀ safety, ves.venv safety ≤ ves'.venv safety := by @@ -152,5 +232,5 @@ theorem addDecl.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (decl : D | opaqueDecl v => exact (addOpaque.WF wf v).mono fun _ ⟨ves', hwf, _, h⟩ => ⟨ves', hwf, (h · |>.le)⟩ | quotDecl => exact addQuot.WF wf - | mutualDefnDecl _ => sorry + | mutualDefnDecl vs => exact addMutual.WF wf vs | inductDecl _ _ _ _ => sorry diff --git a/Lean4Lean/Verify/Environment/Basic.lean b/Lean4Lean/Verify/Environment/Basic.lean index dda2e62a..96e0e460 100644 --- a/Lean4Lean/Verify/Environment/Basic.lean +++ b/Lean4Lean/Verify/Environment/Basic.lean @@ -111,6 +111,19 @@ nonrec theorem AddInduct.to_addInduct (H : AddInduct m₁ env₁ decl m₂ env₂) : env₁.addInduct decl = some env₂ := nomatch H +/-- Insert a whole block of definitions into the constant map. -/ +def insertDefs (C : ConstMap) (cis : List DefinitionVal) : ConstMap := + cis.foldl (fun C ci => C.insert ci.name (.defnInfo ci)) C + +variable (safety : DefinitionSafety) (env env' : VEnv) in +/-- Translation data for a mutual block: the headers are translated against the environment +before the block is added, the values against the environment that already has every constant +of the block, mirroring the kernel adding them all as axioms first. -/ +def TrDefBlock (cis : List DefinitionVal) (cis' : List VDefVal) : Prop := + List.Forall₂ (fun ci ci' => + TrConstVal safety env (.defnInfo ci) ci'.toVConstVal ∧ + TrExprS env' ci.levelParams [] ci.value ci'.value) cis cis' + variable (safety : DefinitionSafety) in inductive TrEnv' : ConstMap → Bool → VEnv → Prop where | empty : TrEnv' {} false .empty @@ -130,6 +143,17 @@ inductive TrEnv' : ConstMap → Bool → VEnv → Prop where env.addConst ci.name ci'.toVConstant = some env' → TrEnv' C Q env → TrEnv' (C.insert ci.name (.defnInfo ci)) Q (env'.addDefEq ci'.toDefEq) + /-- A mutual block, and an unsafe definition as the one-element case. -/ + | mutualDef {cis : List DefinitionVal} {cis' : List VDefVal} : + TrDefBlock safety env env' cis cis' → + -- the block's names are distinct; `addMutual` checks this, as does lean4#14632 + (cis.map (·.name)).Nodup → + (∀ ci ∈ cis, C.find? ci.name = none) → + (∀ ci' ∈ cis', ci'.toVConstant.WF env) → + env.addConsts cis' = some env' → + (∀ ci' ∈ cis', ci'.WF env') → + TrEnv' C Q env → + TrEnv' (insertDefs C cis) Q (env'.addDefEqs cis') | thm {ci' : VDefVal} : TrDefVal safety env (.thmInfo ci) ci' → C.find? ci.name = none → ci'.WF env → @@ -168,6 +192,9 @@ theorem TrEnv'.wf (H : TrEnv' safety C Q venv) : venv.WF := by have ⟨_, H⟩ := ih have := h1.1.2; dsimp [ConstantInfo.name, ConstantInfo.toConstantVal] at this exact ⟨_, H.decl <| .def h2 (this ▸ h3)⟩ + | mutualDef _ _ _ h2 h3 h4 _ ih => + have ⟨_, H⟩ := ih + exact ⟨_, H.decl <| .mutualDef h2 h3 h4⟩ | thm h1 _ h2 h3 h4 _ ih => have ⟨_, H⟩ := ih have hn := h1.1.2 diff --git a/Lean4Lean/Verify/Environment/Checker.lean b/Lean4Lean/Verify/Environment/Checker.lean index 86854844..60e6cdb7 100644 --- a/Lean4Lean/Verify/Environment/Checker.lean +++ b/Lean4Lean/Verify/Environment/Checker.lean @@ -85,7 +85,7 @@ theorem checkConstantValCore.WF {env : Environment} {ves : VEnvs} (wf : ves.WF e refine (TypeChecker.M.WF.liftExcept (checkNoMVarNoFVar.WF env ci.name ci.type)).bind fun _ _ _ hclosed => ?_ have hclosed' : ci.type.FVarsIn (· ∈ (TypeChecker.VContext.mk' wf safety ci.levelParams).vlctx.fvars) := by - simpa [TypeChecker.VContext.mk'] using hclosed + simpa [TypeChecker.VContext.mk', TypeChecker.VContext.mk1] using hclosed refine (TypeChecker.checkType.WF hclosed').bind fun _ _ _ ⟨type', sort', _, htype, hsort, hhasType⟩ => ?_ refine (TypeChecker.ensureSort.WF hsort).bind @@ -109,23 +109,28 @@ theorem checkConstantVal.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) obtain ⟨ci', hu, ht, hn', hci, hn, hp⟩ := h exact ⟨ci', ⟨⟨hs, hu, ht⟩, hn'⟩, hci, hn, hp⟩ -theorem checkBody.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) - (decl : Declaration) (name : Name) (levelParams : List Name) (type value : Expr) - (type' : VExpr) (hdeclType : TrExprS (ves.venv safety) levelParams [] type type') +/-- The body check proper, with the mvar/fvar check already discharged. `addDefinition` runs +the two in the same `do` block for a safe definition but splits them for an unsafe one (the +mvar/fvar check happens before the constant is added as an axiom), so they are verified +separately. + +Stated against a single-level model (`VEnvAt`): a mutual block's bodies are checked in the +temporary environment holding the whole block as axioms, which has no model at every level. -/ +theorem checkBodyCore.WF {env : Environment} {venv : VEnv} (wf : VEnvAt env safety venv) + (decl : Declaration) (levelParams : List Name) (type value : Expr) + (type' : VExpr) (hdeclType : TrExprS venv levelParams [] type type') + (hclosed : value.FVarsIn fun _ => False) (state : TypeChecker.VState := {}) : ((do - Environment.checkNoMVarNoFVar env name value let valueType ← TypeChecker.checkType value if !(← TypeChecker.isDefEq valueType type) then throw <| Exception.declTypeMismatch env decl valueType) : TypeChecker.M Unit).WF - (.mk' wf safety levelParams) state fun _ _ => - ∃ value', TrExprS (ves.venv safety) levelParams [] value value' ∧ - (ves.venv safety).HasType levelParams.length [] value' type' := by - refine (TypeChecker.M.WF.liftExcept - (checkNoMVarNoFVar.WF env name value)).bind fun _ _ _ hclosed => ?_ + (.mk1 wf levelParams) state fun _ _ => + ∃ value', TrExprS venv levelParams [] value value' ∧ + venv.HasType levelParams.length [] value' type' := by have hclosed' : value.FVarsIn - (· ∈ (TypeChecker.VContext.mk' wf safety levelParams).vlctx.fvars) := by - simpa [TypeChecker.VContext.mk'] using hclosed + (· ∈ (TypeChecker.VContext.mk1 wf levelParams).vlctx.fvars) := by + simpa [TypeChecker.VContext.mk1] using hclosed refine (TypeChecker.checkType.WF hclosed').bind fun valueType _ _ ⟨value', valueType', _, hvalue, hvalueType, hhasType⟩ => ?_ refine (TypeChecker.isDefEq.WF hvalueType hdeclType).bind fun equal _ _ hequal => ?_ @@ -134,7 +139,23 @@ theorem checkBody.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) · rename_i hnot refine .pure ⟨value', hvalue, ?_⟩ have heq : equal = true := by cases equal <;> simp_all - exact hhasType.defeqU_r (wf.tr (safety := safety)).wf (by trivial) (hequal heq) + exact hhasType.defeqU_r wf.tr.wf (by trivial) (hequal heq) + +theorem checkBody.WF {env : Environment} {venv : VEnv} (wf : VEnvAt env safety venv) + (decl : Declaration) (name : Name) (levelParams : List Name) (type value : Expr) + (type' : VExpr) (hdeclType : TrExprS venv levelParams [] type type') + (state : TypeChecker.VState := {}) : + ((do + Environment.checkNoMVarNoFVar env name value + let valueType ← TypeChecker.checkType value + if !(← TypeChecker.isDefEq valueType type) then + throw <| Exception.declTypeMismatch env decl valueType) : TypeChecker.M Unit).WF + (.mk1 wf levelParams) state fun _ _ => + ∃ value', TrExprS venv levelParams [] value value' ∧ + venv.HasType levelParams.length [] value' type' := + (TypeChecker.M.WF.liftExcept + (checkNoMVarNoFVar.WF env name value)).bind fun _ _ _ hclosed => + checkBodyCore.WF wf decl levelParams type value type' hdeclType hclosed _ theorem checkTheorem.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (v : TheoremVal) : @@ -158,7 +179,7 @@ theorem checkTheorem.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) · exact .throw · rename_i hnot have hisProp : isProp = true := by cases isProp <;> simp_all - refine .pureBind <| (checkBody.WF wf (.thmDecl v) v.name v.levelParams v.type + refine .pureBind <| (checkBody.WF (wf.toVEnvAt .safe) (.thmDecl v) v.name v.levelParams v.type v.value ci'.type htr.1.2.2 state').mono fun _ _ _ ⟨value', hvalue, hvalueType⟩ => ?_ let ci'' : VDefVal := { ci' with value := value' } refine ⟨ci'', ⟨htr, hvalue⟩, ?_, ?_, hn, hnonprim rfl⟩ @@ -188,7 +209,7 @@ theorem checkDefinition.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) refine (checkPrimitiveDef.WF wf v).bind fun allow state _ hp => ?_ refine (checkConstantValCore.WF (safety := .safe) wf (.defnInfo v) allow state).bind fun _ state' _ ⟨ci', hu, ht, hname, hci, hfresh, hnonprim⟩ => ?_ - exact (checkBody.WF wf (.defnDecl v) v.name v.levelParams v.type v.value + exact (checkBody.WF (wf.toVEnvAt .safe) (.defnDecl v) v.name v.levelParams v.type v.value ci'.type ht state').mono fun _ _ _ ⟨value', hvalue, hvalueType⟩ => by let ci'' : VDefVal := { ci' with value := value' } refine ⟨allow, ci'', hp, hu, ht, hname, hvalue, ?_, hfresh, hnonprim⟩ @@ -219,7 +240,7 @@ theorem checkOpaque.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) Environment.primitives.contains v.name = false := by refine (checkConstantValCore.WF (safety := .safe) wf (.opaqueInfo v) false).bind fun _ state _ ⟨ci', hu, ht, hname, hci, hfresh, hnonprim⟩ => ?_ - exact (checkBody.WF wf (.opaqueDecl v) v.name v.levelParams v.type v.value + exact (checkBody.WF (wf.toVEnvAt .safe) (.opaqueDecl v) v.name v.levelParams v.type v.value ci'.type ht state).mono fun _ _ _ ⟨value', hvalue, hvalueType⟩ => by let ci'' : VDefVal := { ci' with value := value' } refine ⟨ci'', hu, ht, hname, hvalue, hci, ?_, hfresh, hnonprim rfl⟩ diff --git a/Lean4Lean/Verify/Environment/Extension.lean b/Lean4Lean/Verify/Environment/Extension.lean index d63da31f..c0358d02 100644 --- a/Lean4Lean/Verify/Environment/Extension.lean +++ b/Lean4Lean/Verify/Environment/Extension.lean @@ -1,7 +1,7 @@ import Lean4Lean.Verify.Environment.Checker namespace Lean4Lean - +open Lean4Lean open Lean hiding Environment Exception open Kernel @@ -25,6 +25,9 @@ theorem TrEnv'.no_inductInfo (H : TrEnv' .unsafe C Q venv) : | defn _ _ _ _ H ih => rw [H.map_wf.find?_insert]; split <;> [simp; exact ih] | thm _ _ _ _ _ H ih => rw [H.map_wf.find?_insert]; split <;> [simp; exact ih] | «opaque» _ _ _ _ H ih => rw [H.map_wf.find?_insert]; split <;> [simp; exact ih] + | mutualDef _ hnd hfr _ _ _ H ih => + intro h + obtain h | ⟨_, _, _, h2⟩ := insertDefs_find? H.map_wf hfr hnd h <;> [exact ih h; cases h2] | quot hready hadd H ih => obtain ⟨lp₁, ty₁, env₁, _, hn₁, _, lp₂, ty₂, env₂, _, hn₂, _, @@ -57,6 +60,19 @@ theorem VEnv.addDefEq_mono {env₁ env₂ : VEnv} (H : env₁ ≤ env₂) : constants := H.constants defeqs := by rintro d (rfl | hd) <;> [exact .inl rfl; exact .inr (H.defeqs hd)] +theorem VEnv.addConsts_mono {env₁ env₂ env₁' env₂' : VEnv} (H : env₁ ≤ env₂) : + ∀ {cis}, env₁.addConsts cis = some env₁' → env₂.addConsts cis = some env₂' → env₁' ≤ env₂' + | [], h₁, h₂ => by cases h₁; cases h₂; exact H + | _ :: _, h₁, h₂ => by + simp [VEnv.addConsts, Option.bind_eq_some_iff] at h₁ h₂ + obtain ⟨_, e₁, h₁⟩ := h₁; obtain ⟨_, e₂, h₂⟩ := h₂ + exact VEnv.addConsts_mono (VEnv.addConst_mono H e₁ e₂) h₁ h₂ + +theorem VEnv.addDefEqs_mono {env₁ env₂ : VEnv} (H : env₁ ≤ env₂) : + ∀ {cis}, env₁.addDefEqs cis ≤ env₂.addDefEqs cis + | [] => H + | _ :: _ => VEnv.addDefEqs_mono (VEnv.addDefEq_mono H) + theorem VEnv.addConst_eq_of_ne {env env' : VEnv} (hadd : env.addConst name ci = some env') (hne : name ≠ n) : @@ -130,24 +146,260 @@ theorem VEnv.HasPrimitives.addDefEq {env : VEnv} (H : env.HasPrimitives) : let ⟨h1, h2, h3⟩ := H.stringOfList h ⟨h1, h2.mono VEnv.addDefEq_le, h3.mono VEnv.addDefEq_le⟩ } -theorem VEnvs.WF.safePrimitives_add {ves : VEnvs} {env : Environment} - (wf : ves.WF env) (ci : ConstantInfo) - (hfresh : env.find? ci.name = none) - (hok : Environment.primitives.contains ci.name → - ci.safety = .safe ∧ ci.levelParams = []) +theorem safePrimitives_add' {env : Environment} (mapWF : env.constants.WF) + (old : ∀ {n : Name} {ci}, env.find? n = some ci → + Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = []) + (ci : ConstantInfo) (hfresh : env.find? ci.name = none) + (hok : Environment.primitives.contains ci.name → ci.safety = .safe ∧ ci.levelParams = []) (hfind : (env.add ci).find? (n : Name) = some ci') (hp : Environment.primitives.contains n) : ci'.safety = .safe ∧ ci'.levelParams = [] := by - have mapWF := (wf.tr (safety := .safe)).map_wf have hnone : env.constants.find? ci.name = none := by - rw [← mapWF.find?'_eq_find?] - exact hfresh + rw [← mapWF.find?'_eq_find?]; exact hfresh have mapWF' := mapWF.insert ci.name ci hnone change SMap.find?' (env.constants.insert ci.name ci) n = some ci' at hfind rw [mapWF'.find?'_eq_find?, mapWF.find?_insert] at hfind split at hfind · cases hfind; cases LawfulBEq.eq_of_beq ‹_›; exact hok hp - · refine wf.safePrimitives ?_ hp - rwa [Kernel.Environment.find?, mapWF.find?'_eq_find?] + · refine old ?_ hp; rwa [Kernel.Environment.find?, mapWF.find?'_eq_find?] + +theorem VEnvs.WF.safePrimitives_add {ves : VEnvs} {env : Environment} + (wf : ves.WF env) (ci : ConstantInfo) + (hfresh : env.find? ci.name = none) + (hok : Environment.primitives.contains ci.name → + ci.safety = .safe ∧ ci.levelParams = []) + (hfind : (env.add ci).find? (n : Name) = some ci') + (hp : Environment.primitives.contains n) : ci'.safety = .safe ∧ ci'.levelParams = [] := + safePrimitives_add' (wf.tr (safety := .safe)).map_wf wf.safePrimitives ci hfresh hok hfind hp + +theorem VEnvAt.safePrimitives_add {env : Environment} {venv : VEnv} + (wf : VEnvAt env safety venv) (ci : ConstantInfo) + (hfresh : env.find? ci.name = none) + (hok : Environment.primitives.contains ci.name → + ci.safety = .safe ∧ ci.levelParams = []) + (hfind : (env.add ci).find? (n : Name) = some ci') + (hp : Environment.primitives.contains n) : ci'.safety = .safe ∧ ci'.levelParams = [] := + safePrimitives_add' wf.tr.map_wf wf.safePrimitives ci hfresh hok hfind hp + +theorem VEnv.HasPrimitives.addConsts {env env' : VEnv} : ∀ {cis : List VDefVal}, + env.HasPrimitives → (∀ ci ∈ cis, Environment.primitives.contains ci.name = false) → + env.addConsts cis = some env' → env'.HasPrimitives + | [], H, _, e => by cases e; exact H + | _ :: _, H, hn, e => by + simp [VEnv.addConsts, Option.bind_eq_some_iff] at e + obtain ⟨_, h1, h2⟩ := e + exact addConsts (H.addConst (hn _ (.head _)) h1) (fun c hc => hn c (.tail _ hc)) h2 + +theorem VEnv.HasPrimitives.addDefEqs {env : VEnv} : ∀ {cis : List VDefVal}, + env.HasPrimitives → (env.addDefEqs cis).HasPrimitives + | [], H => H + | _ :: cis, H => addDefEqs (cis := cis) H.addDefEq + +theorem TrEnv.constants_eq_none (H : TrEnv safety env venv) (hn : env.find? name = none) : + venv.constants name = none := by + cases hfind : venv.constants name with + | none => rfl + | some ci => obtain ⟨ci, hci, _⟩ := H.find?_iff.2 ⟨ci, hfind⟩; cases hn ▸ hci + +theorem TrEnv.exists_addConsts (H : TrEnv safety env venv) {cis : List VDefVal} + (hfresh : ∀ ci ∈ cis, env.find? ci.name = none) + (hnd : (cis.map (·.name)).Nodup) : ∃ venv', venv.addConsts cis = some venv' := + VEnv.exists_addConsts (fun ci hci => H.constants_eq_none (hfresh ci hci)) hnd + +theorem insertDefs_wf : ∀ {cis : List DefinitionVal} {C : ConstMap}, C.WF → + (∀ d ∈ cis, C.find? d.name = none) → (cis.map (·.name)).Nodup → (insertDefs C cis).WF + | [], _, hC, _, _ => hC + | d :: ds, C, hC, hfr, hnd => by + rw [List.map_cons, List.nodup_cons] at hnd + refine insertDefs_wf (cis := ds) (hC.insert _ _ (hfr _ (.head _))) (fun e he => ?_) hnd.2 + rw [hC.find?_insert, if_neg]; · exact hfr e (.tail _ he) + simp only [beq_iff_eq]; intro hh + exact hnd.1 (List.mem_map.2 ⟨e, he, hh.symm⟩) + +theorem Environment.constants_addDefs : ∀ {vs : List DefinitionVal} {env : Environment}, + (vs.foldl (fun e v => Lean.Kernel.Environment.add e (.defnInfo v)) env).constants = + insertDefs env.constants vs + | [], _ => rfl + | v :: vs, env => Environment.constants_addDefs (vs := vs) (env := env.add (.defnInfo v)) + +theorem VEnvs.WF.safePrimitives_addDefs {ves : VEnvs} {env : Environment} + (wf : ves.WF env) {vs : List DefinitionVal} + (hfresh : ∀ v ∈ vs, env.find? v.name = none) + (hnd : (vs.map (·.name)).Nodup) + (hnonprim : ∀ v ∈ vs, Environment.primitives.contains v.name = false) + (hfind : (vs.foldl (fun e v => e.add (.defnInfo v)) env).find? n = some ci) + (hp : Environment.primitives.contains n) : ci.safety = .safe ∧ ci.levelParams = [] := by + have mapWF := (wf.tr (safety := .safe)).map_wf + have hfr : ∀ d ∈ vs, env.constants.find? d.name = none := fun d hd => by + rw [← mapWF.find?'_eq_find?]; exact hfresh d hd + rw [Kernel.Environment.find?, Environment.constants_addDefs, + (insertDefs_wf mapWF hfr hnd).find?'_eq_find?] at hfind + rcases insertDefs_find? mapWF hfr hnd hfind with h | ⟨d, hd, rfl, rfl⟩ + · exact wf.safePrimitives (by rwa [Kernel.Environment.find?, mapWF.find?'_eq_find?]) hp + · exact absurd hp (by simp [hnonprim d hd]) + +theorem Environment.quotInit_addDefs : ∀ {vs : List DefinitionVal} {env : Environment}, + (vs.foldl (fun e v => Lean.Kernel.Environment.add e (.defnInfo v)) env).quotInit = + env.quotInit + | [], _ => rfl + | _ :: vs, _ => quotInit_addDefs (vs := vs) + +/-- A block of definitions that is invisible at `safety` extends the constant map without +touching the model, one `TrEnv'.ignore` per member. -/ +theorem TrEnv'.ignoreDefs : ∀ {vs : List DefinitionVal} {C : ConstMap}, + (∀ v ∈ vs, ¬ safety ≤ (ConstantInfo.defnInfo v).safety) → + (∀ v ∈ vs, C.find? v.name = none) → (vs.map (·.name)).Nodup → + TrEnv' safety C Q venv → TrEnv' safety (insertDefs C vs) Q venv + | [], _, _, _, _, H => H + | d :: ds, C, hvis, hfr, hnd, H => by + rw [List.map_cons, List.nodup_cons] at hnd + have H' := TrEnv'.ignore (ci := .defnInfo d) (hfr _ (.head _)) (hvis _ (.head _)) H + show TrEnv' safety (insertDefs (SMap.insert C d.name (.defnInfo d)) ds) Q _ + refine TrEnv'.ignoreDefs (fun e he => hvis e (.tail _ he)) (fun e he => ?_) hnd.2 H' + rw [H.map_wf.find?_insert, if_neg]; · exact hfr e (.tail _ he) + simp only [beq_iff_eq]; intro hh + exact hnd.1 (List.mem_map.2 ⟨e, he, hh.symm⟩) + +theorem Environment.find?_add_of_ne {env : Environment} (mapWF : env.constants.WF) + (ci : ConstantInfo) (hfresh : env.find? ci.name = none) {n : Name} + (hne : ci.name ≠ n) (h : env.find? n = none) : (env.add ci).find? n = none := by + have hnone : env.constants.find? ci.name = none := by rwa [← mapWF.find?'_eq_find?] + have mapWF' := mapWF.insert ci.name ci hnone + change SMap.find?' (env.constants.insert ci.name ci) n = none + rw [mapWF'.find?'_eq_find?, mapWF.find?_insert, if_neg (by simpa using hne)] + rwa [Kernel.Environment.find?, mapWF.find?'_eq_find?] at h + +/-- Data produced by `addMutual`'s header loop for one block member. -/ +def TrMutualHeader (bs : DefinitionSafety) (venv : VEnv) (env : Environment) + (v : DefinitionVal) (ci : VDefVal) : Prop := + TrConstVal bs venv (.defnInfo v) ci.toVConstVal ∧ + ci.toVConstant.WF venv ∧ env.find? v.name = none ∧ + Environment.primitives.contains v.name = false + +/-- A model of the temporary environment in which a mutual block's bodies are checked: every +member has been added as an axiom, so a body may refer to any member of the block (including +itself) but cannot delta-unfold it. -/ +theorem VEnvAt.addAxioms {env : Environment} {venv : VEnv} {bs : DefinitionSafety} + (hsf : bs ≤ (if bs == .unsafe then DefinitionSafety.unsafe else .safe)) : + ∀ {vs : List DefinitionVal} {cis : List VDefVal} {venv' : VEnv}, + VEnvAt env bs venv → + List.Forall₂ (TrMutualHeader bs venv env) vs cis → + (vs.map (·.name)).Nodup → + venv.addConsts cis = some venv' → + VEnvAt (vs.foldl (fun e v => e.add (.axiomInfo { v with isUnsafe := bs == .unsafe })) env) + bs venv' + | [], _, _, wf, .nil, _, e => by cases e; exact wf + | v :: vs, ci :: cis, venv', wf, .cons hd tl, hnd, e => by + rw [List.map_cons, List.nodup_cons] at hnd + simp [VEnv.addConsts, Option.bind_eq_some_iff] at e + obtain ⟨venv₁, h₁, h₂⟩ := e + have hn : v.name = ci.name := hd.1.2 + have h₁' : venv.addConst v.name ci.toVConstant = some venv₁ := by rw [hn]; exact h₁ + have hle := VEnv.addConst_le h₁' + have hax : (ConstantInfo.axiomInfo { v with isUnsafe := bs == .unsafe }).name = v.name := rfl + have wf₁ : VEnvAt (env.add (.axiomInfo { v with isUnsafe := bs == .unsafe })) bs venv₁ := + { tr := TrEnv'.axiom (ci := { v with isUnsafe := bs == .unsafe }) (ci' := ci.toVConstant) + ⟨hsf, hd.1.1.2.1, hd.1.1.2.2⟩ + (by rw [← wf.tr.map_wf.find?'_eq_find?]; exact hd.2.2.1) hd.2.1 h₁' wf.tr + hasPrimitives := wf.hasPrimitives.addConst hd.2.2.2 h₁' + safePrimitives := wf.safePrimitives_add _ (hax ▸ hd.2.2.1) + (by rw [hax]; simp [hd.2.2.2]) } + show VEnvAt (vs.foldl (fun e v => e.add (.axiomInfo { v with isUnsafe := bs == .unsafe })) + (env.add (.axiomInfo { v with isUnsafe := bs == .unsafe }))) bs venv' + refine VEnvAt.addAxioms hsf wf₁ ?_ hnd.2 h₂ + refine tl.and_mem.imp fun w cj h => ?_ + obtain ⟨h, hw, -⟩ := h + have hne : v.name ≠ w.name := fun hh => hnd.1 (List.mem_map.2 ⟨w, hw, hh.symm⟩) + exact ⟨⟨⟨h.1.1.1, h.1.1.2.1, h.1.1.2.2.mono hle⟩, h.1.2⟩, h.2.1.mono hle, + Environment.find?_add_of_ne wf.tr.map_wf _ (hax ▸ hd.2.2.1) (hax ▸ hne) h.2.2.1, + h.2.2.2⟩ + +/-- Add a whole mutual block. The headers were checked in `env`, the bodies in the temporary +environment holding the entire block, which is `base` on the model side; `TrEnv'.mutualDef` +consumes exactly that split. + +Like `addUnsafeDef.WF` this cannot conclude `VEnv.AddDef` for the members: the bodies may +refer to each other, so they do not translate before the block is added. -/ +theorem addMutualBlock.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (bs : DefinitionSafety) (vs : List DefinitionVal) (cis : List VDefVal) (base : VEnv) + (hbs : ∀ v ∈ vs, v.safety = bs) + (hnd : (vs.map (·.name)).Nodup) + (hfresh : ∀ v ∈ vs, env.find? v.name = none) + (hnonprim : ∀ v ∈ vs, Environment.primitives.contains v.name = false) + (hwfc : ∀ ci ∈ cis, ci.toVConstant.WF (ves.venv bs)) + (hbase : (ves.venv bs).addConsts cis = some base) + (htr : TrDefBlock bs (ves.venv bs) base vs cis) + (hci : ∀ ci ∈ cis, ci.WF base) : + ∃ ves' : VEnvs, ves'.WF (vs.foldl (fun e v => e.add (.defnInfo v)) env) ∧ + ∀ safety, ves.venv safety ≤ ves'.venv safety := by + have hname := htr.imp (fun _ _ h => h.1.2) + have hmapeq : vs.map (·.name) = cis.map (·.name) := by + rwa [← List.forall₂_eq, List.forall₂_map_left_iff, List.forall₂_map_right_iff] + have hndCis : (cis.map (·.name)).Nodup := hmapeq ▸ hnd + have hpull {P : Name → Prop} (H : ∀ v ∈ vs, P v.name) : ∀ ci ∈ cis, P ci.name := by + intro ci hc + obtain ⟨v, hv, hn⟩ := hname.forall_exists_r ci hc + exact hn ▸ H v hv + have hfreshCis := hpull (P := fun n => env.find? n = none) hfresh + have hnonprimCis := hpull (P := fun n => Environment.primitives.contains n = false) hnonprim + have hfreshMap : ∀ v ∈ vs, env.constants.find? v.name = none := fun v hv => by + rw [← (wf.tr (safety := .safe)).map_wf.find?'_eq_find?]; exact hfresh v hv + have hvis_iff (sf) (hv : sf ≤ bs) (v) (hmem : v ∈ vs) : + sf ≤ (ConstantInfo.defnInfo v).safety := by + rw [ConstantInfo.defnInfo_safety, hbs v hmem]; exact hv + -- the model at each visible safety level + have hves' sf : ∃ venv', + if sf ≤ bs then ∃ b, (ves.venv sf).addConsts cis = some b ∧ venv' = b.addDefEqs cis + else venv' = ves.venv sf := by + split <;> [skip; exact ⟨_, rfl⟩] + obtain ⟨b, hb⟩ := (wf.tr (safety := sf)).exists_addConsts hfreshCis hndCis + exact ⟨_, b, hb, rfl⟩ + obtain ⟨ves', hves'⟩ := VEnvs.axiom_of_choice hves' + have hbaseSf (sf) (hv : sf ≤ bs) : ∃ b, (ves.venv sf).addConsts cis = some b ∧ + ves'.venv sf = b.addDefEqs cis := by + have h := hves' sf; rw [if_pos hv] at h; exact h + have hsame (sf) (hv : ¬ sf ≤ bs) : ves'.venv sf = ves.venv sf := by + have h := hves' sf; rwa [if_neg hv] at h + refine ⟨ves', ?_, fun sf => by + by_cases hv : sf ≤ bs + · obtain ⟨b, hb, heq⟩ := hbaseSf sf hv + exact heq ▸ (VEnv.addConsts_le hb).trans VEnv.addDefEqs_le + · rw [hsame sf hv]; exact VEnv.LE.rfl⟩ + exact { + tr {sf} := by + show TrEnv sf _ _ + unfold TrEnv + rw [Environment.constants_addDefs, Environment.quotInit_addDefs] + by_cases hv : sf ≤ bs + · obtain ⟨b, hb, heq⟩ := hbaseSf sf hv + have hmono : ves.venv bs ≤ ves.venv sf := wf.mono hv + have hbmono : base ≤ b := VEnv.addConsts_mono hmono hbase hb + refine heq ▸ TrEnv'.mutualDef (env := ves.venv sf) (env' := b) ?_ hnd hfreshMap + (fun ci hc => (hwfc ci hc).mono hmono) hb + (fun ci hc => (hci ci hc).mono hbmono) (wf.tr (safety := sf)) + exact htr.imp fun _ _ h => ⟨⟨(h.1.1.sf_mono hv).mono hmono, h.1.2⟩, h.2.mono hbmono⟩ + · rw [hsame sf hv] + exact TrEnv'.ignoreDefs + (fun v hmem => fun h => hv (by rwa [ConstantInfo.defnInfo_safety, hbs v hmem] at h)) + hfreshMap hnd (wf.tr (safety := sf)) + hasPrimitives {sf} := by + by_cases hv : sf ≤ bs + · obtain ⟨b, hb, heq⟩ := hbaseSf sf hv + exact heq ▸ ((wf.hasPrimitives (safety := sf)).addConsts hnonprimCis hb).addDefEqs + · rw [hsame sf hv]; exact wf.hasPrimitives + safePrimitives := wf.safePrimitives_addDefs hfresh hnd hnonprim + mono {sf sf'} hle := by + by_cases hv' : sf' ≤ bs + · have hv : sf ≤ bs := DefinitionSafety.le_trans hle hv' + obtain ⟨b', hb', heq'⟩ := hbaseSf sf' hv' + obtain ⟨b, hb, heq⟩ := hbaseSf sf hv + rw [heq', heq] + exact VEnv.addDefEqs_mono (VEnv.addConsts_mono (wf.mono hle) hb' hb) + · rw [hsame sf' hv'] + by_cases hv : sf ≤ bs + · obtain ⟨b, hb, heq⟩ := hbaseSf sf hv + rw [heq] + exact (wf.mono hle).trans ((VEnv.addConsts_le hb).trans VEnv.addDefEqs_le) + · rw [hsame sf hv]; exact wf.mono hle } theorem addConstCore.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (ci : ConstantInfo) (ci' : VConstVal) (checkSafety : DefinitionSafety) @@ -293,3 +545,56 @@ theorem addDef.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) rw [heq] exact (wf.mono hle).trans <| (VEnv.addConst_le hadd).trans VEnv.addDefEq_le · rw [hsame safety hvisible]; exact wf.mono hle } + +/-- The unsafe branch of `addDefinition`. The constant is added to the environment as an axiom +*before* its body is checked, so the body is translated in the extended environment `base` and +the whole step is justified by `TrEnv'.mutualDef` with a one-element block. + +Unlike `addDef.WF` this cannot conclude `VEnv.AddDef`: that would require the body to translate +in the environment *before* the addition, which is false for a recursive unsafe definition. -/ +theorem addUnsafeDef.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (v : DefinitionVal) (ci' : VDefVal) (base : VEnv) + (hunsafe : v.safety = .unsafe) + (htr : TrConstVal .unsafe (ves.venv .unsafe) (.defnInfo v) ci'.toVConstVal) + (hwfc : ci'.toVConstant.WF (ves.venv .unsafe)) + (hadd : (ves.venv .unsafe).addConst v.name ci'.toVConstant = some base) + (hvalue : TrExprS base v.levelParams [] v.value ci'.value) + (hci : ci'.WF base) + (hn : env.find? v.name = none) + (hnonprim : Environment.primitives.contains v.name = false) : + ∃ ves' : VEnvs, ves'.WF (env.add (.defnInfo v)) ∧ + ∀ safety, ves.venv safety ≤ ves'.venv safety := by + have hnMap : env.constants.find? v.name = none := by + rwa [← (wf.tr (safety := .safe)).map_wf.find?'_eq_find?] + have hle : ves.venv .unsafe ≤ base.addDefEq ci'.toDefEq := + (VEnv.addConst_le hadd).trans VEnv.addDefEq_le + have hname : (ConstantInfo.defnInfo v).name = ci'.name := htr.2 + have hadd' : (ves.venv .unsafe).addConsts [ci'] = some base := by + simp [VEnv.addConsts, ← hname]; exact hadd + refine ⟨⟨fun | .unsafe => base.addDefEq ci'.toDefEq | sf => ves.venv sf⟩, ?_, + by rintro ⟨⟩ <;> first | exact hle | exact .rfl⟩ + exact { + tr {safety} := by + change TrEnv' safety (env.constants.insert v.name (.defnInfo v)) env.quotInit _ + match safety with + | .unsafe => + have := TrEnv'.mutualDef (safety := .unsafe) (cis := [v]) (cis' := [ci']) + (C := env.constants) (Q := env.quotInit) (env := ves.venv .unsafe) (env' := base) + (.cons ⟨htr, hvalue⟩ .nil) (by simp) (by simpa using hnMap) (by simpa using hwfc) + hadd' (by simpa using hci) wf.tr + simpa [insertDefs, VEnv.addDefEqs] using this + | .safe | .partial => + refine TrEnv'.ignore (ci := .defnInfo v) hnMap ?_ wf.tr + rw [ConstantInfo.defnInfo_safety, hunsafe]; decide + hasPrimitives {safety} := + match safety with + | .unsafe => ((wf.hasPrimitives (safety := .unsafe)).addConst hnonprim hadd).addDefEq + | .safe | .partial => wf.hasPrimitives + safePrimitives := wf.safePrimitives_add (.defnInfo v) hn + (by simp [ConstantInfo.name, ConstantInfo.toConstantVal, hnonprim]) + mono {safety safety'} hsf := + match safety, safety' with + | .unsafe, .unsafe => .rfl + | .unsafe, .safe | .unsafe, .partial => (wf.mono hsf).trans hle + | .safe, .unsafe | .partial, .unsafe => absurd hsf (by decide) + | .safe, .safe | .safe, .partial | .partial, .safe | .partial, .partial => wf.mono hsf } diff --git a/Lean4Lean/Verify/Environment/Lemmas.lean b/Lean4Lean/Verify/Environment/Lemmas.lean index 2a182628..4aea3a54 100644 --- a/Lean4Lean/Verify/Environment/Lemmas.lean +++ b/Lean4Lean/Verify/Environment/Lemmas.lean @@ -67,6 +67,40 @@ theorem Aligned.addInduct (H : AddInduct C₁ venv₁ decl C₂ venv₂) : Aligned safety C₁ env₁ → Aligned safety C₂ env₂ := nomatch H +theorem Aligned.addDefEqs {C : ConstMap} : ∀ {cis' : List VDefVal} {venv}, + Aligned safety C venv → Aligned safety C (venv.addDefEqs cis') + | [], _, H => H + | ci :: cis, venv, H => by + show Aligned safety C (VEnv.addDefEqs (venv.addDefEq ci.toDefEq) cis) + exact Aligned.addDefEqs H.defeq + +theorem Aligned.insertDefs : ∀ {cis : List DefinitionVal} {cis' : List VDefVal} {C venv venv'}, + Aligned safety C venv → (cis.map (·.name)).Nodup → + (∀ ci ∈ cis, C.find? ci.name = none) → + List.Forall₂ (fun ci ci' => TrConstVal safety venv (.defnInfo ci) ci'.toVConstVal) cis cis' → + venv.addConsts cis' = some venv' → Aligned safety (insertDefs C cis) venv' + | [], _, _, _, _, H, _, _, hblk, e => by + cases hblk; simp [VEnv.addConsts] at e; cases e; exact H + | ci :: cis, _, C, venv, _, H, hnd, hfr, hblk, e => by + cases hblk with | @cons _ ci' _ _ htr hblk => ?_ + simp [VEnv.addConsts, Option.bind_eq_some_iff] at e + obtain ⟨venv₁, h1, h2⟩ := e + have hname := htr.2 + simp only [ConstantInfo.name, ConstantInfo.toConstantVal] at hname + simp only [List.map_cons, List.nodup_cons, List.mem_map] at hnd + have h1' : venv.addConst ci.name ci'.toVConstant = some venv₁ := by rw [hname]; exact h1 + show Aligned safety + (_root_.Lean4Lean.insertDefs (SMap.insert C ci.name (.defnInfo ci)) cis) _ + refine Aligned.insertDefs (H.const (hfr _ (.head _)) htr.1 h1' rfl) hnd.2 + (fun c hc => ?_) (Lean4Lean.List.Forall₂.imp + (fun _ _ h => h.mono (VEnv.addConst_le h1')) hblk) h2 + rw [H.map_wf.find?_insert] + have : ¬ (ci.name == c.name) = true := by + simp only [beq_iff_eq]; intro h + exact hnd.1 ⟨c, hc, h.symm⟩ + simp [this] + exact hfr c (.tail _ hc) + theorem TrEnv'.aligned (H : TrEnv' safety C Q venv) : Aligned safety C venv := by induction H with | empty => exact .empty @@ -75,6 +109,9 @@ theorem TrEnv'.aligned (H : TrEnv' safety C Q venv) : Aligned safety C venv := b | thm h1 h2 _ _ h _ ih => exact ih.const h2 h1.1.1 h rfl | «opaque» h1 h2 _ h _ ih => exact ih.const h2 h1.1.1 h rfl | defn h1 h2 _ h _ ih => exact (ih.const h2 h1.1.1 h rfl).defeq + | mutualDef hblk hnd hfr _ hadd _ _ ih => + exact Aligned.addDefEqs <| ih.insertDefs hnd hfr + (Lean4Lean.List.Forall₂.imp (fun _ _ h => h.1) hblk) hadd | quot _ h _ ih => exact ih.addQuot h | induct _ h _ ih => exact ih.addInduct h @@ -140,6 +177,41 @@ theorem TrEnv.find?_uniq (H : TrEnv safety env venv) ci.name = name ∧ TrConstant safety venv ci ci' := H.aligned.find?_uniq (H.map_wf.find?'_eq_find? _ ▸ h) hs +theorem VEnv.addDefEqs_le : ∀ {cis' : List VDefVal} {venv : VEnv}, venv ≤ venv.addDefEqs cis' + | [], _ => .rfl + | ci :: cis, venv => by + show venv ≤ VEnv.addDefEqs (venv.addDefEq ci.toDefEq) cis + exact VEnv.addDefEq_le.trans VEnv.addDefEqs_le + +theorem VEnv.addDefEqs_self : ∀ {cis' : List VDefVal} {venv : VEnv} {ci'}, ci' ∈ cis' → + (venv.addDefEqs cis').defeqs ci'.toDefEq + | ci :: cis, venv, _, hc => by + show (VEnv.addDefEqs (venv.addDefEq ci.toDefEq) cis).defeqs _ + cases hc with + | head => exact VEnv.addDefEqs_le.defeqs VEnv.addDefEq_self + | tail _ hc => exact VEnv.addDefEqs_self hc + +theorem insertDefs_find? : ∀ {cis : List DefinitionVal} {C : ConstMap} {name ci}, C.WF → + (∀ d ∈ cis, C.find? d.name = none) → (cis.map (·.name)).Nodup → + (insertDefs C cis).find? name = some ci → + C.find? name = some ci ∨ ∃ d ∈ cis, d.name = name ∧ ConstantInfo.defnInfo d = ci + | [], _, _, _, _, _, _, h => .inl h + | d :: ds, C, name, ci, hC, hfr, hnd, h => by + simp only [List.map_cons, List.nodup_cons, List.mem_map] at hnd + have hfr' : ∀ e ∈ ds, (SMap.insert C d.name (.defnInfo d)).find? e.name = none := by + intro e he + rw [hC.find?_insert] + have : ¬ (d.name == e.name) = true := by + simp only [beq_iff_eq]; intro hh; exact hnd.1 ⟨e, he, hh.symm⟩ + simp [this]; exact hfr e (.tail _ he) + have h : (insertDefs (SMap.insert C d.name (.defnInfo d)) ds).find? name = some ci := h + rcases insertDefs_find? (hC.insert _ _ (hfr _ (.head _))) hfr' hnd.2 h with h | ⟨e, he, h1, h2⟩ + · rw [hC.find?_insert] at h; split at h + · rename_i hb; cases h + exact .inr ⟨d, .head _, by simpa using hb, rfl⟩ + · exact .inl h + · exact .inr ⟨e, .tail _ he, h1, h2⟩ + theorem TrEnv'.of_value (H : TrEnv' safety C Q venv) (h : C.find? name = some ci) (hs : safety ≤ ci.safety) (hv : ci.deltaValue? = some v) : TrExpr venv ci.levelParams [] v (.const ci.name (VLevel.params ci.levelParams.length)) := by @@ -166,6 +238,16 @@ theorem TrEnv'.of_value (H : TrEnv' safety C Q venv) (h : C.find? name = some ci (H.defn h2 h3 h4 h1).wf.ordered.defEqWF VEnv.addDefEq_self let ⟨⟨⟨b1, b2, b3⟩, b4⟩, b5⟩ := h2 refine ⟨_, b5.mono le, b2.symm ▸ b4.symm ▸ ⟨_, this.symm⟩⟩ + | mutualDef hblk hnd hfr _ hadd _ H ih => + have' le := (VEnv.addConsts_le hadd).trans VEnv.addDefEqs_le + rcases insertDefs_find? H.map_wf hfr hnd h with h | ⟨d, hd, rfl, rfl⟩ + · exact (ih h).mono le + · obtain ⟨d', hd', htr, hval⟩ := Lean4Lean.List.Forall₂.forall_exists_l hblk _ hd + cases hv + have hdefeq := VEnv.IsDefEq.extra0 (VEnv.addDefEqs_self hd') + ((H.mutualDef hblk hnd hfr ‹_› hadd ‹_›).wf.ordered.defEqWF (VEnv.addDefEqs_self hd')) + let ⟨⟨b1, b2, b3⟩, b4⟩ := htr + exact ⟨_, hval.mono VEnv.addDefEqs_le, b2.symm ▸ b4.symm ▸ ⟨_, hdefeq.symm⟩⟩ | thm h2 h3 h4 h5 h1 H ih => have' le := VEnv.addConst_le h1 obtain h | ⟨rfl, rfl⟩ := this H.map_wf h diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index 1562b064..c022e5ba 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -85,6 +85,23 @@ instance : LawfulBEqCmp quickCmp where end Name +namespace NameSet +open _root_.Std + +theorem contains_insert {s : NameSet} {a b : Name} : + (s.insert a).contains b = (a == b || s.contains b) := by + have key : (Name.quickCmp a b == Ordering.eq) = (a == b) := by + have := @LawfulBEqCmp.compare_eq_iff_beq _ _ Name.quickCmp _ a b + cases h : Name.quickCmp a b <;> simp_all + have h : (s.insert a).contains b + = (Name.quickCmp a b == Ordering.eq || s.contains b) := + Std.TreeSet.contains_insert (t := s) (k := a) (a := b) + rw [h, key] + +@[simp] theorem contains_empty {a : Name} : (∅ : NameSet).contains a = false := rfl + +end NameSet + namespace Level open Lean4Lean diff --git a/Lean4Lean/Verify/TypeChecker.lean b/Lean4Lean/Verify/TypeChecker.lean index d11b8828..59af906c 100644 --- a/Lean4Lean/Verify/TypeChecker.lean +++ b/Lean4Lean/Verify/TypeChecker.lean @@ -24,6 +24,24 @@ theorem VEnvs.axiom_of_choice {P : DefinitionSafety → VEnv → Prop} (H : ∀ have ⟨x1, _⟩ := H .safe; have ⟨x2, _⟩ := H .partial; have ⟨x3, _⟩ := H .unsafe exact ⟨⟨fun | .safe => x1 | .partial => x2 | .unsafe => x3⟩, by rintro ⟨⟩ <;> assumption⟩ +/-- A model of `env` at a *single* safety level, which is all the type checker consumes. + +`VEnvs.WF` bundles one of these at every level, but not every environment the checker runs +against admits that: while a `partial` mutual block is being checked its members are present +as axioms tagged `safe` (an `AxiomVal` cannot be tagged `partial`), and their types were only +checked at `partial`, so there is no `safe`-level model of that environment. -/ +structure VEnvAt (env : Environment) (safety : DefinitionSafety) (venv : VEnv) : Prop where + tr : TrEnv safety env venv + hasPrimitives : VEnv.HasPrimitives venv + safePrimitives : env.find? n = some ci → + Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = [] + +theorem VEnvs.WF.toVEnvAt {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (safety : DefinitionSafety) : VEnvAt env safety (ves.venv safety) where + tr := wf.tr + hasPrimitives := wf.hasPrimitives + safePrimitives := wf.safePrimitives + namespace TypeChecker open Inner @@ -43,11 +61,10 @@ theorem Methods.withFuel.WF : ∀ {n}, (withFuel n).WF theorem RecM.WF.run {x : RecM α} (H : x.WF c s Q) : (RecM.run x).WF c s Q := H _ Methods.withFuel.WF -def VContext.mk' {env : Environment} {ves : VEnvs} (wf : ves.WF env) - (safety : DefinitionSafety := .safe) (lparams : List Name := []) +def VContext.mk1 {env : Environment} {safety : DefinitionSafety} {venv : VEnv} + (wf : VEnvAt env safety venv) (lparams : List Name := []) (fuel : FuelConfig := {}) : VContext where - env; safety; lparams; fuel - venv := ves.venv safety + env; safety; lparams; fuel; venv hasPrimitives := wf.hasPrimitives safePrimitives := wf.safePrimitives trenv := wf.tr @@ -55,9 +72,13 @@ def VContext.mk' {env : Environment} {ves : VEnvs} (wf : ves.WF env) mlctx_wf := trivial lctx_eq := rfl -theorem VState.WF.empty {env : Environment} {ves : VEnvs} {wf : ves.WF env} - {safety : DefinitionSafety} {lparams : List Name} {fuel : FuelConfig} : - VState.WF (.mk' wf safety lparams fuel) {} where +def VContext.mk' {env : Environment} {ves : VEnvs} (wf : ves.WF env) + (safety : DefinitionSafety := .safe) (lparams : List Name := []) + (fuel : FuelConfig := {}) : VContext := .mk1 (wf.toVEnvAt safety) lparams fuel + +theorem VState.WF.empty1 {env : Environment} {safety : DefinitionSafety} {venv : VEnv} + {wf : VEnvAt env safety venv} {lparams : List Name} {fuel : FuelConfig} : + VState.WF (.mk1 wf lparams fuel) {} where trctx := .nil ngen_wf := nofun ectx := ⟨[], .refl, trivial, .refl, .empty, nofun⟩ @@ -67,15 +88,99 @@ theorem VState.WF.empty {env : Environment} {ves : VEnvs} {wf : ves.WF env} whnf_wf := .empty unfold_wf _ := by simp -theorem M.WF.run {env : Environment} {ves : VEnvs} (wf : ves.WF env) - {x : M α} {Q} (H : x.WF (.mk' wf safety lparams fuel) {} fun a _ => Q a) : +theorem VState.WF.empty {env : Environment} {ves : VEnvs} {wf : ves.WF env} + {safety : DefinitionSafety} {lparams : List Name} {fuel : FuelConfig} : + VState.WF (.mk' wf safety lparams fuel) {} := by + unfold VContext.mk'; exact .empty1 + +theorem M.WF.run1 {env : Environment} {venv : VEnv} (wf : VEnvAt env safety venv) + {x : M α} {Q} (H : x.WF (.mk1 wf lparams fuel) {} fun a _ => Q a) : (M.run env safety {} lparams fuel x).WF Q := by intro a eq simp [M.run, Functor.map, Except.map] at eq split at eq <;> cases eq; rename_i eq - let ⟨_, _, _, _, H⟩ := H .empty _ _ eq + let ⟨_, _, _, _, H⟩ := H .empty1 _ _ eq exact H +theorem M.WF.run {env : Environment} {ves : VEnvs} (wf : ves.WF env) + {x : M α} {Q} (H : x.WF (.mk' wf safety lparams fuel) {} fun a _ => Q a) : + (M.run env safety {} lparams fuel x).WF Q := by + unfold VContext.mk' at H; exact M.WF.run1 _ H + +/-- Loop invariant rule for `for x in xs do ...`. `Inv` is indexed by the list still to be +processed, so the conclusion `Inv []` records that every element was handled. The body must +`yield`; a loop that can `break` is out of scope (none of the kernel's loops do). -/ +theorem M.WF.forIn {c : VContext} {f : α → β → M (ForInStep β)} + {Inv : List α → β → VState → Prop} + (H : ∀ v vs b s, Inv (v :: vs) b s → + (f v b).WF c s fun r s' => ∃ b', r = .yield b' ∧ Inv vs b' s') : + ∀ {vs : List α} {b : β} {s : VState}, Inv vs b s → + (forIn vs b f).WF c s fun b' s' => Inv [] b' s' + | [], _, _, h => .pure h + | v :: vs, b, s, h => by + rw [List.forIn_cons] + refine (H v vs b s h).bind fun r s' _ hr => ?_ + obtain ⟨b', rfl, hinv⟩ := hr + exact M.WF.forIn H hinv + +theorem M.WF.bindThrow {c : VContext} {s : VState} {x : M α} {f : α → M β} {Q} + (h : x.WF c s fun _ _ => False) : (x >>= f).WF c s Q := + h.bind fun _ _ _ hf => hf.elim + +/-- Loop rule for `addMutual`'s header loop, whose accumulator is the set of names seen so +far: each iteration rejects a name already in the set, so the whole block is duplicate-free. -/ +theorem M.WF.forInFresh {c : VContext} {Q : Lean.DefinitionVal → β → Prop} + {f : Lean.DefinitionVal → NameSet → M (ForInStep NameSet)} + (H : ∀ v found s, (f v found).WF c s fun r _ => + found.contains v.name = false ∧ (∃ b, Q v b) ∧ r = .yield (found.insert v.name)) : + ∀ {vs : List Lean.DefinitionVal} {found : NameSet} {s : VState}, + (ForIn.forIn vs found f).WF c s fun _ _ => + (∃ bs, List.Forall₂ Q vs bs) ∧ (vs.map (·.name)).Nodup ∧ + ∀ v ∈ vs, found.contains v.name = false + | [], _, _ => .pure ⟨⟨[], .nil⟩, by simp, by simp⟩ + | v :: vs, found, s => by + rw [List.forIn_cons] + refine (H v found s).bind fun r s' _ h => ?_ + obtain ⟨hfresh, ⟨b, hb⟩, rfl⟩ := h + refine (M.WF.forInFresh H (vs := vs) (found := found.insert v.name)).mono + fun _ _ _ h => ?_ + obtain ⟨⟨bs, hbs⟩, hnd, hmem⟩ := h + refine ⟨⟨b :: bs, .cons hb hbs⟩, ?_, ?_⟩ + · rw [List.map_cons, List.nodup_cons] + refine ⟨fun hm => ?_, hnd⟩ + obtain ⟨w, hw, hwn⟩ := List.mem_map.1 hm + have := hmem w hw + rw [NameSet.contains_insert, hwn] at this + simp at this + · intro w hw + cases hw with + | head => exact hfresh + | tail _ hw => + have := hmem w hw + rw [NameSet.contains_insert] at this + exact (by simpa using this : _ ∧ _).2 + +/-- Loop rule for a loop whose elements are already related to a list `cis`, so each iteration +may use the datum paired with the element it processes; each refines its `ci` to a `ci'` +related by `R`. -/ +theorem M.WF.forInForall₂ {c : VContext} {f : α → Unit → M (ForInStep Unit)} + {P : α → β → Prop} {R : β → β → Prop} {Q : α → β → Prop} + (H : ∀ v ci s, P v ci → (f v ()).WF c s fun r _ => + (∃ ci', R ci ci' ∧ Q v ci') ∧ r = .yield ()) : + ∀ {vs : List α} {cis : List β} {s : VState}, List.Forall₂ P vs cis → + (ForIn.forIn vs () f).WF c s fun _ _ => + ∃ cis', List.Forall₂ R cis cis' ∧ List.Forall₂ Q vs cis' := by + intro vs cis s h + induction h generalizing s with + | nil => exact .pure ⟨[], .nil, .nil⟩ + | @cons v ci vs cis hd tl ih => + rw [List.forIn_cons] + refine (H v ci s hd).bind fun r s' _ h => ?_ + obtain ⟨⟨ci', hR, hQ⟩, rfl⟩ := h + refine (ih (s := s')).mono fun _ _ _ h => ?_ + obtain ⟨cis', h1, h2⟩ := h + exact ⟨ci' :: cis', .cons hR h1, .cons hQ h2⟩ + nonrec theorem whnf.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : M.WF c s (whnf e) fun e₁ _ => c.TrExpr e₁ e' := (whnf.WF he).run.mono fun _ _ _ h => h.2 diff --git a/divergences.md b/divergences.md index b6d9eec0..76572379 100644 --- a/divergences.md +++ b/divergences.md @@ -14,3 +14,5 @@ This is a list of places where lean4lean deliberately has different behavior fro * [`Lean4Lean.checkNoNestedAux`](Lean4Lean/Inductive/Add.lean): [leanprover/lean4#14616](https://github.com/leanprover/lean4/pull/14616) rejects the reserved `_nested` prefix in both the inductive types and the constructor types of a declaration; lean4lean checks only the constructor types. The bug that check fixes is specific to constructors: nested occurrences are rewritten to the auxiliary types in constructor types only (`replaceAllNested`), and rewritten back the same way (`restoreNested`), so an inductive's own type is carried through both directions verbatim and cannot acquire a type it was not checked at. A `_nested` name written in an inductive type also cannot resolve in the first place: the auxiliary types are declared in the same block, so they are not in the environment while that block's types are checked (unlike constructor types, which are checked once the block's types, auxiliaries included, are present), and they never survive into the final environment. Lean's check additionally reserves the whole `_nested` namespace against unrelated user declarations, which lean4lean does not. * [`Lean4Lean.ElimNestedInductive.Result.restoreNested`](Lean4Lean/Inductive/Add.lean), `restoreCtorName`: [leanprover/lean4#14632](https://github.com/leanprover/lean4/pull/14632) turned the `lean_assert`s in the nested-inductive restoration into kernel exceptions; lean4lean keeps `unreachable!` and `assert!`. The branches are unreachable: `restoreCtorName` runs only for the recursors of the auxiliary types the elimination generates, whose constructors are exactly the keys of `aux2nested`, and the nested occurrences stored there are applications of a constant by construction. Upstream's stated motivation is that the assertions vanish in a release build and the C++ consumers then read out of bounds; the corresponding accesses here are total, so there is nothing to read out of bounds. Note that if one of these invariants were broken anyway, `unreachable!` would continue with a default value rather than reject; the restored constructor and recursor types are re-checked in the final environment ([#14621](https://github.com/leanprover/lean4/pull/14621)), which lean4lean retains, but a restored rule constructor *name* is not covered by that pass. * [`Lean4Lean.FuelConfig`](Lean4Lean/FuelConfig.lean): since [leanprover/lean4#13956](https://github.com/leanprover/lean4/pull/13956), the native kernel bounds mutually recursive checking through the `maxRecDepth` option. Lean4lean exposes several independent fuel counters instead, because its Lean definitions also need explicit termination witnesses. Replay comparison therefore uses each implementation's default bound unless an explicit lean4lean fuel configuration is supplied. +* [`Lean4Lean.addDefinition`](Lean4Lean/Environment.lean) (`unsafe` branch), [`addMutual`](Lean4Lean/Environment.lean): an `unsafe`/`partial` definition may be recursive, so its body is checked in an environment that already contains the declaration. The C++ kernel adds `constant_info(d)` there -- the full definition, value included -- so the body can delta-unfold the very constant being defined. Lean4lean adds it as an axiom of the same type instead: the body may still *refer* to the block's constants, but cannot unfold them. So for example `unsafe def foo : Nat := (fun (_ : foo = 1) => 1) rfl` is accepted by the C++ kernel, but rejected by L4L: checking the argument requires `foo =?= 1`, which succeeds by unfolding `foo` to its own body and reducing. Read literally, that rule makes a typing fact about the constant available while establishing it, and implementing this in `IsDefEq` directly degenerates completely, allowing even things like `unsafe def bar : Nat := "hi"` by using the typing judgment to justify itself. The gap is confined to `unsafe`/`partial` code, which carries no logical content. +* [`Lean4Lean.addMutual`](Lean4Lean/Environment.lean): lean4lean requires the declarations of a mutual block to carry the same universe parameters and to have distinct names. Both checks are in kernel PRs that are not yet released ([leanprover/lean4#14608](https://github.com/leanprover/lean4/pull/14608), [#14632](https://github.com/leanprover/lean4/pull/14632)); the released kernel checks only that the safety annotations agree. Lean4lean needs them rather than merely matching them: the block is checked under a single `M.run`, whose level parameters are fixed for the whole run, and the model adds the block's constants one at a time with `VEnv.addConsts`, which fails on a repeated name. From 1a16b72d2e35932a82aa501beb29ef2c3d072580 Mon Sep 17 00:00:00 2001 From: Kim Morrison <477956+kim-em@users.noreply.github.com> Date: Wed, 5 Aug 2026 17:26:00 +1000 Subject: [PATCH 09/51] Verify the standard library universe level operations (#23) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * prove soundness of the standard library level operations * level: replace the normalize axiom with a total copy `Lean.Level.normalize` and four of its helpers are `partial def`s. Add `Lean.Level.Total`, a clause-by-clause total copy of them, so the trust assumption in `Verify/Axioms.lean` is the syntactic `normalize_eq : normalize = Total.normalize` rather than a semantic claim about an opaque constant. `eval_normalize` is now an ordinary (still open) theorem. Termination is by `3 * size l + tag l`, where `tag l` is 1 iff `l.getLevelOffset` is an `imax`; that is what makes the `imax` branch's recursion on `mkLevelMax l₁ l₂` decrease when the offset is 0. `Lean4Lean.Tests.LevelStd` checks `normalize = Total.normalize` on all 7320 levels of depth at most 2 over 5 atoms, plus 28920 depth-3 samples. Co-authored-by: Mario Carneiro Co-authored-by: Claude Opus 5 --- Lean4Lean/Tests.lean | 1 + Lean4Lean/Tests/LevelStd.lean | 90 ++++++++++++++++ Lean4Lean/Verify/Axioms.lean | 139 +++++++++++++++++++++++++ Lean4Lean/Verify/Level.lean | 5 +- Lean4Lean/Verify/LevelStd.lean | 184 +++++++++++++++++++++++++++++++++ README.md | 1 + 6 files changed, 416 insertions(+), 4 deletions(-) create mode 100644 Lean4Lean/Tests/LevelStd.lean create mode 100644 Lean4Lean/Verify/LevelStd.lean diff --git a/Lean4Lean/Tests.lean b/Lean4Lean/Tests.lean index cf76d06b..5805ca0d 100644 --- a/Lean4Lean/Tests.lean +++ b/Lean4Lean/Tests.lean @@ -1,2 +1,3 @@ import Lean4Lean.Tests.Toolchain import Lean4Lean.Tests.Environment +import Lean4Lean.Tests.LevelStd diff --git a/Lean4Lean/Tests/LevelStd.lean b/Lean4Lean/Tests/LevelStd.lean new file mode 100644 index 00000000..324d08a0 --- /dev/null +++ b/Lean4Lean/Tests/LevelStd.lean @@ -0,0 +1,90 @@ +import Lean4Lean.Verify.LevelStd + +open Lean + +private def p : Level := .param `p +private def q : Level := .param `q +private def m : Level := .mvar ⟨`m⟩ +private def n : Level := .mvar ⟨`n⟩ + +private def atoms : Array Level := #[.zero, p, q, m, n] + +private def levels : Nat → Array Level + | 0 => atoms + | n + 1 => + let xs := levels n + xs ++ xs.map .succ ++ xs.flatMap fun a => + xs.flatMap fun b => #[.max a b, .imax a b] + +private def sampleEvery (step : Nat) : Nat → List Level → List Level + | _, [] => [] + | i, u :: us => + if i % step == 0 then u :: sampleEvery step (i + 1) us + else sampleEvery step (i + 1) us + +private def generatedSamples : Array Level := + (sampleEvery 12 0 (levels 2).toList).toArray + +-- Exercise the offset boundaries used when normalization drops explicit levels +-- or deduplicates levels with the same base. +private def trickySamples : Array Level := #[ + .max (.succ .zero) (.succ p), + .max (.succ (.succ .zero)) (.succ p), + .max (.succ (.succ .zero)) (.succ (.succ p)), + .max (.succ (.succ (.succ .zero))) (.succ (.succ p)), + .max (.succ p) (.succ (.succ p)), + .max (.succ (.succ p)) (.succ p), + .max (.max (.succ (.succ .zero)) (.succ q)) (.succ (.succ p)), + .succ (.max (.succ (.succ .zero)) (.imax p (.succ q))), + .imax (.succ (.succ p)) (.max (.succ (.succ .zero)) q)] + +private def samples := generatedSamples ++ trickySamples + +private def valuations : Array (Nat × Nat × Nat × Nat) := #[ + (0, 0, 0, 0), (0, 1, 0, 1), (1, 0, 1, 0), + (1, 1, 1, 1), (2, 5, 3, 7), (5, 2, 7, 3)] + +private def paramVal (v : Nat × Nat × Nat × Nat) : Name → Nat + | `p => v.1 + | `q => v.2.1 + | _ => 0 + +private def mvarVal (v : Nat × Nat × Nat × Nat) : LMVarId → Nat + | ⟨`m⟩ => v.2.2.1 + | ⟨`n⟩ => v.2.2.2 + | _ => 0 + +-- Finite regression coverage for `Level.Semantics.eval_normalize`. +#guard samples.all fun u => valuations.all fun v => + Level.eval (paramVal v) (mvarVal v) u.normalize == + Level.eval (paramVal v) (mvarVal v) u + +-- Finite regression coverage for `Level.normalize_eq`: exhaustive over the 7320 levels of depth +-- at most 2 over `atoms`, plus 28920 depth-3 levels built from a sample of them. +private def deeperSamples : Array Level := + let sample := (levels 2).zipIdx.filterMap fun (u, i) => if i % 61 == 0 then some u else none + sample.map .succ ++ sample.flatMap fun a => + (levels 1).flatMap fun b => #[.max a b, .imax a b, .max b a, .imax b a] + +#guard (levels 2).all fun u => u.normalize == Level.Total.normalize u +#guard deeperSamples.all fun u => u.normalize == Level.Total.normalize u + +/-- +info: 'Lean.Level.isEquiv_wf' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + Level.instLawfulBEqLevel, + Level.normalize_eq] +-/ +#guard_msgs in #print axioms Level.isEquiv_wf + +/-- +info: 'Lean.Level.geq_wf' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + Level.instLawfulBEqLevel, + Level.normalize_eq] +-/ +#guard_msgs in #print axioms Level.geq_wf diff --git a/Lean4Lean/Verify/Axioms.lean b/Lean4Lean/Verify/Axioms.lean index c145291d..0b4a05b3 100644 --- a/Lean4Lean/Verify/Axioms.lean +++ b/Lean4Lean/Verify/Axioms.lean @@ -113,6 +113,145 @@ end Syntax namespace Level +/-! +### A total copy of `Lean.Level.normalize` + +`Lean.Level.normalize` and four of its helpers are `partial def`s, so they are opaque and nothing +can be proved about them. The `Total` namespace below is a clause-by-clause copy of +[Lean's `Lean/Level.lean`](https://github.com/leanprover/lean4/blob/v4.33.0-rc2/src/Lean/Level.lean#L319-L404), +under the same names, with the termination proofs supplied. That makes `normalize_eq` below a +purely syntactic trust assumption, checkable by reading the two definitions side by side; +`Lean4Lean.Tests.LevelStd` also checks it on a finite corpus of levels. +-/ +namespace Total + +/-- The structural size of a level, used as the termination measure for `normalize`. -/ +private def size : Level → Nat + | .zero | .param _ | .mvar _ => 1 + | .succ l => size l + 1 + | .max l₁ l₂ => size l₁ + size l₂ + 1 + | .imax l₁ l₂ => size l₁ + size l₂ + 2 + +/-- Secondary termination measure for `normalize`: in the `imax` branch it recurses on +`mkLevelMax l₁ l₂`, which has the same `size` as `imax l₁ l₂` but a smaller `tag`. -/ +private def tag (l : Level) : Nat := + match l.getLevelOffset with + | .imax .. => 1 + | _ => 0 + +private theorem tag_le (l : Level) : tag l ≤ 1 := by unfold tag; split <;> omega + +private theorem one_le_size (l : Level) : 1 ≤ size l := by cases l <;> simp [size] + +private theorem getOffsetAux_eq (l : Level) (k) : getOffsetAux l k = getOffsetAux l 0 + k := by + induction l generalizing k with + | succ l ih => rw [getOffsetAux, ih (k+1), getOffsetAux, ih 1]; omega + | _ => simp [getOffsetAux] + +private theorem size_getLevelOffset (l : Level) : + size l.getLevelOffset + l.getOffset = size l := by + simp only [getOffset] + induction l with | succ l ih => ?_ | _ => rfl + show size l.getLevelOffset + getOffsetAux l 1 = size l + 1 + rw [getOffsetAux_eq l 1]; omega + +end Total +open private accMax mkIMaxAux mkMaxAux skipExplicit isExplicitSubsumedAux + isExplicitSubsumed from Lean.Level + +def Total.mkMaxAux (lvls : Array Level) (extraK : Nat) (i : Nat) + (prev : Level) (prevK : Nat) (result : Level) : Level := + if h : i < lvls.size then + let lvl := lvls[i] + let curr := lvl.getLevelOffset + let currK := lvl.getOffset + if curr == prev then mkMaxAux lvls extraK (i+1) curr currK result + else mkMaxAux lvls extraK (i+1) curr currK (accMax result prev (extraK + prevK)) + else accMax result prev (extraK + prevK) + +/-- Patch for `partial def Lean.Level.mkMaxAux`. -/ +@[simp] axiom mkMaxAux_eq : mkMaxAux = Total.mkMaxAux + +def Total.skipExplicit (lvls : Array Level) (i : Nat) : Nat := + if h : i < lvls.size then + if lvls[i].getLevelOffset.isZero then skipExplicit lvls (i+1) else i + else i + +/-- Patch for `partial def Lean.Level.skipExplicit`. -/ +@[simp] axiom skipExplicit_eq : skipExplicit = Total.skipExplicit + +def Total.isExplicitSubsumedAux (lvls : Array Level) (maxExplicit : Nat) (i : Nat) : Bool := + if h : i < lvls.size then + if lvls[i].getOffset ≥ maxExplicit then true + else isExplicitSubsumedAux lvls maxExplicit (i+1) + else false + +/-- Patch for `partial def Lean.Level.isExplicitSubsumedAux`. -/ +@[simp] axiom isExplicitSubsumedAux_eq : isExplicitSubsumedAux = Total.isExplicitSubsumedAux + +mutual + +/-- A total copy of `partial def Lean.Level.normalize`. -/ +def Total.normalize (l : Level) : Level := + if isAlreadyNormalizedCheap l then l else + let k := l.getOffset + match h : l.getLevelOffset with + | .max l₁ l₂ => + let lvls := getMaxArgsAux l₁ false #[] + let lvls := getMaxArgsAux l₂ false lvls + let lvls := lvls.qsort normLt + let firstNonExplicit := skipExplicit lvls 0 + let i := if isExplicitSubsumed lvls firstNonExplicit then firstNonExplicit + else firstNonExplicit - 1 + let lvl₁ := lvls[i]! + let prev := lvl₁.getLevelOffset + let prevK := lvl₁.getOffset + mkMaxAux lvls k (i+1) prev prevK Level.zero + | .imax l₁ l₂ => + if l₂.isNeverZero then addOffset (normalize (mkLevelMax l₁ l₂)) k + else addOffset (mkIMaxAux (normalize l₁) (normalize l₂)) k + | _ => unreachable! +termination_by (1, 3 * size l + tag l) +decreasing_by all_goals + refine .right _ ?_ + have hsz := size_getLevelOffset l + rw [h] at hsz + simp only [size] at hsz + have := one_le_size l₁ + have := one_le_size l₂ + have := tag_le l₁ + have := tag_le l₂ + first + | omega + | have ht : tag l = 1 := by simp [tag, h] + have e1 : size (mkLevelMax l₁ l₂) = size l₁ + size l₂ + 1 := rfl + have e2 : tag (mkLevelMax l₁ l₂) = 0 := rfl + omega + +def Total.getMaxArgsAux : Level → Bool → Array Level → Array Level + | .max l₁ l₂, norm, lvls => getMaxArgsAux l₂ norm (getMaxArgsAux l₁ norm lvls) + | l, false, lvls => getMaxArgsAux (normalize l) true lvls + | l, true, lvls => lvls.push l +termination_by l b => (if b then 0 else 1, 3 * size l + tag l + 1) +decreasing_by + any_goals cases norm + any_goals first | refine .right _ ?_ | exact .left _ _ (by decide) + all_goals first + | omega + | have e1 : size (Level.max l₁ l₂) = size l₁ + size l₂ + 1 := rfl + have e2 : tag (Level.max l₁ l₂) = 0 := rfl + have := one_le_size l₁ + have := one_le_size l₂ + have := tag_le l₁ + have := tag_le l₂ + omega + +end + +/-- `Lean.Level.normalize` is a `partial def`, so it is opaque; +`Total.normalize` above is a total copy of it. -/ +axiom normalize_eq : normalize = Total.normalize + def mkData' (h : UInt64) (depth : Nat := 0) (hasMVar hasParam : Bool := false) : Level.Data := if depth > Nat.pow 2 24 - 1 then panic! "universe level depth is too big" else diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index c022e5ba..4635157c 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -1,5 +1,6 @@ import Lean4Lean.Theory.VLevel import Lean4Lean.Level +import Lean4Lean.Verify.LevelStd import Lean4Lean.Verify.Axioms import Std.Tactic.BVDecide import Std.Data.TreeMap.Lemmas @@ -596,10 +597,6 @@ theorem NormLevel.eval_congr {a b : NormLevel} (H : a == b) : a.eval ls ρ = b.e end Normalize -theorem isEquiv_wf (h : isEquiv u v) - (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') : u' ≈ v' := by - sorry - theorem isEquivList_wf (H : Level.isEquivList us vs) : List.mapM (VLevel.ofLevel Us) us = some us' → List.mapM (VLevel.ofLevel Us) vs = some vs' → us'.Forall₂ (· ≈ ·) vs' := by diff --git a/Lean4Lean/Verify/LevelStd.lean b/Lean4Lean/Verify/LevelStd.lean new file mode 100644 index 00000000..8f2691e5 --- /dev/null +++ b/Lean4Lean/Verify/LevelStd.lean @@ -0,0 +1,184 @@ +import Batteries.Tactic.OpenPrivate +import Lean4Lean.Theory.VLevel +import Lean4Lean.Verify.Axioms + +open private go in Lean.Level.geq + +namespace Lean.Level + +open Lean4Lean + +/-! +Semantic soundness of the universe-level operations in Lean's standard library. +`normalize` is an opaque `partial def`, so `Lean4Lean.Verify.Axioms` assumes it +equals the total copy `Lean.Level.Total.normalize` defined there; the semantic +behavior of that copy is `eval_normalize` below, which is still open. The exact +correspondence between `geqCore` below and the private recursion used by +`Lean.Level.geq` is proved. +-/ + +variable (ρ : Name → Nat) (μ : LMVarId → Nat) in +def eval : Level → Nat + | .zero => 0 + | .param n => ρ n + | .mvar n => μ n + | .succ l => eval l + 1 + | .max l₁ l₂ => Nat.max (eval l₁) (eval l₂) + | .imax l₁ l₂ => Nat.imax (eval l₁) (eval l₂) + +private def offset : Level → Nat + | .succ l => offset l + 1 + | _ => 0 + +private theorem getOffsetAux_eq_offset : + l.getOffsetAux k = offset l + k := by + induction l generalizing k with + | succ l ih => simp only [Level.getOffsetAux, offset, ih]; omega + | _ => simp [Level.getOffsetAux, offset] + +private theorem getOffset_eq_offset : l.getOffset = offset l := by + simp [Level.getOffset, getOffsetAux_eq_offset] + +theorem eval_getLevelOffset : + eval ρ μ l = eval ρ μ l.getLevelOffset + l.getOffset := by + induction l with | succ l ih => ?_ | _ => rfl + simp only [eval, Level.getLevelOffset, getOffset_eq_offset, offset, ih] + omega + +theorem fallback_sound + (h : (u.getLevelOffset = v.getLevelOffset ∨ v.getLevelOffset.isZero = true) ∧ + v.getOffset ≤ u.getOffset) : + eval ρ μ v ≤ eval ρ μ u := by + rw [eval_getLevelOffset, eval_getLevelOffset (l := u)] + rcases h with ⟨hv | hv, hk⟩ + · rw [← hv]; omega + · have hv : v.getLevelOffset = .zero := by + generalize hbase : v.getLevelOffset = base at hv + cases base <;> simp_all [Level.isZero] + simp [hv, eval] + omega + +def geqCore : Level → Level → Bool + -- Keep this in the same source-shaped form as `go`'s `u == v || ...` prefix. + -- The apparently redundant `|| true` is therefore deliberate. + | u, .zero => u == .zero || true + | u, .max v₁ v₂ => u == .max v₁ v₂ || (geqCore u v₁ && geqCore u v₂) + | .max u₁ u₂, .imax v₁ v₂ => + (.max u₁ u₂ : Level) == .imax v₁ v₂ || + (geqCore u₁ (.imax v₁ v₂) || geqCore u₂ (.imax v₁ v₂) || + (geqCore (.max u₁ u₂) v₁ && geqCore (.max u₁ u₂) v₂)) + | .max u₁ u₂, v => + let u := .max u₁ u₂ + u == v || (geqCore u₁ v || geqCore u₂ v || + ((u.getLevelOffset == v.getLevelOffset || v.getLevelOffset.isZero) && + u.getOffset ≥ v.getOffset)) + | .imax u₁ u₂, v => (.imax u₁ u₂ : Level) == v || geqCore u₂ v + | .succ u, .succ v => (.succ u : Level) == .succ v || geqCore u v + | u, .imax v₁ v₂ => u == .imax v₁ v₂ || (geqCore u v₁ && geqCore u v₂) + | u, v => u == v || + ((u.getLevelOffset == v.getLevelOffset || v.getLevelOffset.isZero) && + u.getOffset ≥ v.getOffset) + termination_by u v => (u, v) + +private theorem geqCore_eq_go : geqCore u v = go u v := by + fun_induction go with | _ u v + cases u <;> cases v <;> simp_all [geqCore, go] + +theorem geqCore_sound (h : geqCore u v) : eval ρ μ v ≤ eval ρ μ u := by + induction u, v using geqCore.induct with + simp only [geqCore, Bool.or_eq_true, Bool.and_eq_true, beq_iff_eq, + decide_eq_true_eq] at h + | case1 => simp [eval] + | case2 _ _ _ ih₂ ih₁ => + rcases h with rfl | ⟨h₁, h₂⟩ + · exact Nat.le_refl _ + · exact (Nat.max_le).2 ⟨ih₂ h₁, ih₁ h₂⟩ + | case3 u₁ u₂ v₁ v₂ ih₄ ih₃ ih₂ ih₁ => + rcases h with heq | (h | h) | ⟨h₁, h₂⟩ + · exact Nat.le_of_eq (congrArg (eval ρ μ) heq).symm + · exact Nat.le_trans (ih₄ h) (Nat.le_max_left ..) + · exact Nat.le_trans (ih₃ h) (Nat.le_max_right ..) + · simp only [eval, Nat.imax] + split + · exact Nat.zero_le _ + · exact (Nat.max_le).2 ⟨ih₂ h₁, ih₁ h₂⟩ + | case4 u₁ u₂ v _ _ _ ih₂ ih₁ => + rcases h with rfl | h + · exact Nat.le_refl _ + · rcases h with (h | h) | h + · exact Nat.le_trans (ih₂ h) (Nat.le_max_left ..) + · exact Nat.le_trans (ih₁ h) (Nat.le_max_right ..) + · exact fallback_sound h + | case5 u₁ u₂ v _ _ ih => + rcases h with rfl | h + · exact Nat.le_refl _ + · simp only [eval, Nat.imax] + have hv := ih h + split <;> rename_i hz + · simpa [hz] using hv + · exact Nat.le_trans hv (Nat.le_max_right ..) + | case6 u v ih => + rcases h with heq | h + · exact Nat.le_of_eq (congrArg (eval ρ μ) heq).symm + · simpa [eval] using Nat.add_le_add_right (ih h) 1 + | case7 u v₁ v₂ _ _ ih₂ ih₁ => + rcases h with rfl | ⟨h₁, h₂⟩ + · exact Nat.le_refl _ + · simp only [eval, Nat.imax] + split + · exact Nat.zero_le _ + · exact (Nat.max_le).2 ⟨ih₂ h₁, ih₁ h₂⟩ + | case8 => + rcases h with heq | h + · exact Nat.le_of_eq (congrArg (eval ρ μ) heq).symm + · exact fallback_sound h + +theorem eval_normalize {ρ μ l} : eval ρ μ l.normalize = eval ρ μ l := by + rw [normalize_eq]; sorry + +theorem geq_eq_core : geq u v = geqCore (normalize u) (normalize v) := by + simp [geq, geqCore_eq_go] + +theorem isEquiv_sound (h : isEquiv u v) : eval ρ μ u = eval ρ μ v := by + simp only [Level.isEquiv, Bool.or_eq_true, beq_iff_eq] at h + rcases h with rfl | h + · rfl + · rw [← eval_normalize (l := u), ← eval_normalize (l := v), h] + +theorem geq_sound (h : geq u v) : eval ρ μ v ≤ eval ρ μ u := by + rw [geq_eq_core] at h + rw [← eval_normalize (l := u), ← eval_normalize (l := v)] + exact geqCore_sound h + +theorem eval_ofLevel (h : VLevel.ofLevel Us l = some l') : + l'.eval ns = eval (fun n => ns.getD (Us.idxOf n) 0) μ l := by + induction l generalizing l' with + | zero => simp [VLevel.ofLevel] at h; cases h; rfl + | succ l ih => + simp [VLevel.ofLevel, bind] at h + obtain ⟨l', hl, rfl⟩ := h + simp [VLevel.eval, eval, ih hl] + | max l₁ l₂ ih₁ ih₂ | imax l₁ l₂ ih₁ ih₂ => + simp [VLevel.ofLevel, bind] at h + obtain ⟨l₁', hl₁, l₂', hl₂, rfl⟩ := h + simp [VLevel.eval, eval, ih₁ hl₁, ih₂ hl₂] + | param n => + simp [VLevel.ofLevel] at h + obtain ⟨hidx, rfl⟩ := h + simp [VLevel.eval, eval] + | mvar n => simp [VLevel.ofLevel] at h + +theorem isEquiv_wf (h : isEquiv u v) + (hu : VLevel.ofLevel Us u = some u') (hv : VLevel.ofLevel Us v = some v') : u' ≈ v' := by + rw [VLevel.equiv_def] + intro ns + rw [eval_ofLevel (μ := fun _ => 0) hu, eval_ofLevel (μ := fun _ => 0) hv] + exact isEquiv_sound h + +theorem geq_wf (h : geq u v) + (hu : VLevel.ofLevel Us u = some u') (hv : VLevel.ofLevel Us v = some v') : v' ≤ u' := by + intro ns + rw [eval_ofLevel (μ := fun _ => 0) hv, eval_ofLevel (μ := fun _ => 0) hu] + exact geq_sound h + +end Lean.Level diff --git a/README.md b/README.md index 43441ddd..d4b6ae5b 100644 --- a/README.md +++ b/README.md @@ -74,6 +74,7 @@ If you run this as is (with no additional arguments), it will check every olean * `Axioms.lean`: theorems about upstream opaques that shouldn't be opaque * `Expr.lean`: correctness of basics on `Expr` * `Level.lean`: correctness of basics on `Level` + * `Level/Std.lean`: soundness of the standard-library level operations * `VLCtx.lean`: a "translation context" suitable for translating expressions * `LocalContext.lean`: properties of lean's `LocalContext` type * `NameGenerator.lean`: properties of the fresh name generator From c0b04d7446aa081ec27dbbc16927eb4010db18e1 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Sat, 8 Aug 2026 08:04:13 -0400 Subject: [PATCH 10/51] 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 2a5c6c21..f4e914c2 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 11/51] 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 314c604a..16ede05b 100644 --- a/Lean4Lean/Inductive/ValidationTrace.lean +++ b/Lean4Lean/Inductive/ValidationTrace.lean @@ -244,6 +244,62 @@ def buildExecution (stats : InductiveStats) (ctor : Name) (argIdx : Nat) | some targetIdx => .ok (.target context source result fuel targetIdx hwhnf hoccurs hforall hvalid) +/-- The transparent decomposition succeeds on every input accepted by the +executable positivity traversal, so retained-trace construction needs no +choice principle. -/ +theorem buildExecution_ok_of_run + (success : checkPositivity.loop stats ctor argIdx source fuel context = + .ok ()) : + ∃ trace, buildExecution stats ctor argIdx context source fuel = + .ok trace := by + induction fuel generalizing context source with + | zero => + rw [checkPositivity.loop.eq_1] at success + change Except.error Exception.deepRecursion = Except.ok () at success + contradiction + | succ fuel ih => + rw [checkPositivity.loop.eq_2] at success + simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply] at success + unfold buildExecution + split + next error heq => + rw [heq] at success + simp [Except.bind] at success + next result heq => + rw [heq] at success + simp only [Except.bind] at success + split + next hoccurs => exact ⟨_, rfl⟩ + next hoccurs => + rw [hoccurs] at success + simp only [Bool.not_true, Bool.false_eq_true, if_false, + ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind, + Except.bind, Except.pure] at success + cases result <;> simp only [Expr.isForall] <;> simp only at success + case forallE name domain body binderInfo => + split + next hdomain => + rw [hdomain] at success + change Except.error _ = Except.ok () at success + contradiction + next hdomain => + rw [hdomain] at success + have tailSuccess : + checkPositivity.loop stats ctor argIdx + (body.instantiate1 context.freshExpr) fuel + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) = .ok () := success + obtain ⟨tail, htail⟩ := ih tailSuccess + rw [htail] + exact ⟨_, rfl⟩ + all_goals + split + next hvalid => + rw [hvalid] at success + change Except.error _ = Except.ok () at success + contradiction + next targetIdx hvalid => exact ⟨_, rfl⟩ + /-- An exact positivity failure, including its diagnostic payload, excludes a successful trace at precisely that source/context/fuel position. -/ theorem not_nonempty_of_error @@ -353,6 +409,28 @@ def buildExecution (stats : InductiveStats) (isUnsafe : Bool) | .error error => .error error | .ok trace => .ok (.safe rfl trace) +/-- The retained safe/unsafe branch decomposition succeeds whenever the +executable positivity branch does. -/ +theorem buildExecution_ok_of_run + (success : + (if !isUnsafe then checkPositivity stats source ctor argIdx else pure ()) + context = .ok ()) : + ∃ trace, buildExecution stats isUnsafe ctor argIdx context source = + .ok trace := by + cases isUnsafe with + | true => exact ⟨_, rfl⟩ + | false => + simp only [Bool.not_false, if_true] at success + unfold checkPositivity at success + simp only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] at success + obtain ⟨trace, htrace⟩ := + ConstructorPositivityTrace.buildExecution_ok_of_run success + unfold buildExecution + rw [htrace] + exact ⟨_, rfl⟩ + /-- Failure of the exact safe/unsafe positivity branch excludes its retained mode trace without changing the executable diagnostic. -/ theorem not_nonempty_of_error @@ -696,6 +774,149 @@ def buildExecution (stats : InductiveStats) (isUnsafe : Bool) | _ => .error <| .other "constructor source shape disagrees with isForall" +/-- The transparent telescope decomposition succeeds on every constructor +type accepted by the inner executable validator. -/ +theorem buildExecution_ok_of_run + (success : + checkConstructorType.loop stats isUnsafe familyIdx ctor source argIdx fuel + context = .ok ()) : + ∃ trace, buildExecution stats isUnsafe familyIdx ctor context source + argIdx fuel = .ok trace := by + induction fuel generalizing context source argIdx with + | zero => + rw [checkConstructorType.loop.eq_1] at success + change Except.error Exception.deepRecursion = Except.ok () at success + contradiction + | succ fuel ih => + rw [show fuel + 1 = Nat.succ fuel by omega] at success + cases source + case forallE name domain body binderInfo => + rw [checkConstructorType.loop.eq_2] at success + simp only at success + unfold buildExecution + simp only [Expr.isForall] + split + next param hparam => + rw [hparam] at success + simp only [ReaderT.bind, Bind.bind] at success + split + next error heq => + rw [heq] at success + simp [Except.bind] at success + next parameterType heq => + rw [heq] at success + simp only [Except.bind, liftTypeChecker_apply] at success + split + next error heq2 => + rw [heq2] at success + simp [Except.bind] at success + next heq2 => + rw [heq2] at success + simp only [Except.bind] at success + change Except.error _ = Except.ok () at success + contradiction + next heq2 => + rw [heq2] at success + simp only [Except.bind, if_true, ReaderT.pure, Pure.pure, + ReaderT.bind, Bind.bind, Except.pure] at success + obtain ⟨tail, htail⟩ := ih success + rw [htail] + exact ⟨_, rfl⟩ + next hparam => + rw [hparam] at success + simp only [ReaderT.bind, Bind.bind, liftTypeChecker_apply] at success + split + next error heq => + rw [heq] at success + simp [Except.bind] at success + next sortResult heq => + rw [heq] at success + simp only [Except.bind] at success + have finish : + (do + if !isUnsafe then checkPositivity stats domain ctor argIdx + withLocalDecl name binderInfo (consumeTypeAnnotations domain) + fun arg => + checkConstructorType.loop stats isUnsafe familyIdx ctor + (body.instantiate1 arg) (argIdx + 1) fuel) + context = .ok () → + (∃ positivity, + ConstructorPositivityModeTrace.buildExecution stats isUnsafe + ctor argIdx context domain = .ok positivity) ∧ + ∃ tail, + buildExecution stats isUnsafe familyIdx ctor + (context.pushLocalDecl name binderInfo + (consumeTypeAnnotations domain)) + (body.instantiate1 context.freshExpr) (argIdx + 1) fuel = + .ok tail := by + intro restSuccess + cases isUnsafe with + | false => + simp only [Bool.not_false, if_true, + ReaderT.bind, Bind.bind] at restSuccess + cases hpos : checkPositivity stats domain ctor argIdx + context with + | error err => simp_all [Except.bind] + | ok posUnit => + cases posUnit + rw [hpos] at restSuccess + simp only [Except.bind, + withLocalDecl_apply] at restSuccess + have hpmSuccess : + (if !false then + checkPositivity stats domain ctor argIdx + else pure ()) context = .ok () := by + simpa using hpos + exact ⟨ConstructorPositivityModeTrace.buildExecution_ok_of_run + hpmSuccess, ih restSuccess⟩ + | true => + simp only [Bool.not_true, if_false, + ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind, + Except.bind, Except.pure, + withLocalDecl_apply] at restSuccess + have hpmSuccess : + (if !true then + checkPositivity stats domain ctor argIdx + else pure ()) context = .ok () := by + simp [ReaderT.pure, Pure.pure, Except.pure] + exact ⟨ConstructorPositivityModeTrace.buildExecution_ok_of_run + hpmSuccess, ih restSuccess⟩ + split + next hstruct => + rw [hstruct] at success + simp only [if_true, ReaderT.pure, Pure.pure, + ReaderT.bind, Bind.bind, Except.bind, Except.pure] at success + obtain ⟨⟨positivity, hpm⟩, tail, htail⟩ := finish success + rw [hpm, htail] + exact ⟨_, rfl⟩ + next hstruct => + rw [hstruct] at success + simp only [Bool.false_eq_true, if_false] at success + split + next hfallback => + rw [hfallback] at success + change Except.error _ = Except.ok () at success + contradiction + next hfallback => + rw [hfallback] at success + simp only [Bool.true_eq_false, Bool.not_true, if_false, + ReaderT.pure, Pure.pure, ReaderT.bind, Bind.bind, + Except.bind, Except.pure] at success + obtain ⟨⟨positivity, hpm⟩, tail, htail⟩ := finish success + rw [hpm, htail] + exact ⟨_, rfl⟩ + all_goals + unfold checkConstructorType.loop at success + simp only at success + unfold buildExecution + simp only [Expr.isForall] + split + next hvalid => + rw [hvalid] at success + change Except.error _ = Except.ok () at success + contradiction + next hvalid => exact ⟨_, rfl⟩ + /-- Erasing the inner trace also replays the public one-constructor checker, including its exact context-fuel read. -/ theorem check_run @@ -1026,6 +1247,71 @@ theorem exists_of_fold_run exact ⟨.cons seen head tail hfresh hclosed rootCheck typeTrace tailTrace⟩ +/-- The transparent list decomposition succeeds on every constructor list +accepted by the executable stateful fold. -/ +theorem buildExecution_ok_of_fold_run + (success : checkConstructorFold context.env stats isUnsafe familyIdx + seen ctors context = .ok result) : + ∃ trace, buildExecution stats isUnsafe familyIdx context seen ctors = + .ok trace := by + induction ctors generalizing seen result with + | nil => exact ⟨_, rfl⟩ + | cons head tail ih => + unfold checkConstructorFold at success + simp only at success + unfold buildExecution + split + next hfresh => + rw [hfresh] at success + change Except.error _ = Except.ok result at success + contradiction + next hfresh => + rw [hfresh] at success + simp only [Bool.false_eq_true, if_false, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] at success + split + next error heq => + rw [heq] at success + simp [liftExcept_apply, Except.bind] at success + next heq => + rw [heq] at success + simp only [liftExcept_apply, Except.bind] at success + rw [withEmptyLocalContext_apply, liftTypeChecker_apply] at success + split + next error heq2 => + rw [heq2] at success + simp [Except.bind] at success + next inferred heq2 => + rw [heq2] at success + simp only [Except.bind] at success + cases htype : checkConstructorType stats isUnsafe familyIdx + head.name head.type context with + | error err => simp_all [Except.bind] + | ok typeResult => + cases typeResult + rw [htype] at success + simp only [Except.bind, ReaderT.pure, Pure.pure, + Except.pure] at success + have htypeLoop : + checkConstructorType.loop stats isUnsafe familyIdx + head.name head.type 0 context.fuel.inductiveFuel + context = .ok () := by + unfold checkConstructorType at htype + simpa only [readThe, MonadReaderOf.read, ReaderT.read, + ReaderT.bind, Bind.bind, ReaderT.pure, Pure.pure, + Except.bind, Except.pure] using htype + obtain ⟨typeTrace, hT⟩ := + ConstructorTypeValidationTrace.buildExecution_ok_of_run + htypeLoop + rw [hT] + change checkConstructorFold context.env stats isUnsafe + familyIdx (seen.insert head.name) tail context = + .ok result at success + obtain ⟨tailTrace, htl⟩ := ih success + rw [htl] + exact ⟨_, rfl⟩ + /-- The stateful list fold's exact error value excludes a complete trace for that same source list and incoming duplicate-name accumulator. -/ theorem not_nonempty_of_fold_error @@ -1219,6 +1505,24 @@ def buildExecution (indType : InductiveType) (stats : InductiveStats) | .error error => .error error | .ok trace => .ok ⟨trace⟩ +/-- The transparent singleton decomposition succeeds on every source family +accepted by the real constructor validator. -/ +theorem buildExecution_ok_of_run + (success : checkConstructors #[indType] stats isUnsafe context = .ok ()) : + ∃ validation, buildExecution indType stats isUnsafe context = + .ok validation := by + rw [checkConstructors_singleton_eq_checkConstructorList] at success + unfold checkConstructorList at success + cases hfold : checkConstructorFold context.env stats isUnsafe 0 {} + indType.ctors context with + | error err => simp_all [Functor.map, Except.map] + | ok result => + obtain ⟨trace, htrace⟩ := + ConstructorListValidationTrace.buildExecution_ok_of_fold_run hfold + unfold buildExecution + rw [htrace] + exact ⟨_, rfl⟩ + /-- Recomposition: retained operational evidence replays the real singleton `checkConstructors` execution exactly. -/ theorem run @@ -1243,13 +1547,16 @@ theorem nonempty_of_run ConstructorListValidationTrace.exists_of_fold_run hfold exact ⟨⟨trace⟩⟩ -/-- Choose the unique-by-source operational shape supplied by a successful -run. The only nonconstructive ingredient is the project's existing baseline -`Classical.choice`; every retained equality comes from the executable run. -/ -noncomputable def of_run +/-- Choose the operational shape supplied by a successful run by replaying +the transparent decomposition. The success premise only discharges the +impossible error branch, so the retained evidence is computed by +`buildExecution` rather than selected through `Classical.choice`. -/ +def of_run (success : checkConstructors #[indType] stats isUnsafe context = .ok ()) : ConstructorValidationRun indType stats isUnsafe context := - Classical.choice (nonempty_of_run success) + match h : buildExecution indType stats isUnsafe context with + | .ok validation => validation + | .error _ => absurd (buildExecution_ok_of_run success) (by simp [h]) /-- Exact decomposition/recomposition contract for singleton constructor validation. -/ From 731d0f98eca3c4f25241bc7f51f4d51ffb0b5b0f Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Sat, 8 Aug 2026 08:29:51 -0400 Subject: [PATCH 12/51] 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 305bde7d..4b0463c5 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 13/51] 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 9e096ec3..d4ed93ba 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 b7eeac2a..da2c282c 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 330016e2..ab97a3ad 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 14/51] 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 a572fabd..f6acd64e 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 11f51804..9fe95a19 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 15/51] 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 4b0463c5..733a3734 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 d4ed93ba..322c5b5a 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 da2c282c..e1d6853d 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 ab97a3ad..0760087c 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 b5a87ea6..94396d73 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 16/51] 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 00000000..63b84c74 --- /dev/null +++ b/Lean4Lean/Verify/Environment/NestedRepresentation.lean @@ -0,0 +1,710 @@ +import Lean4Lean.Environment +import Lean4Lean.Theory.Inductive +import Lean4Lean.Theory.Meta + +/-! +# L4L-09A: nested-inductive representation audit and decision + +This file is the committed design note and the executable metadata probes +for the nested-inductive representation decision. Every claim below is +pinned by a build-failing probe in this file unless it is explicitly marked +as a forward-looking obligation. This checkpoint changes no acceptance +behavior: the probes only observe the implementation and the existing +Theory analyzers. + +## Audit: how the implementation represents nested inductives + +`Environment.addInductive` (Inductive/Add.lean) runs three phases: + +1. `ElimNestedInductive.run` rewrites the source declaration into a + flattened mutual block: every nested occurrence `I Ds is` whose + parametric arguments `Ds` mention a block family is replaced by + `auxI As is`, where `auxI` is a fresh auxiliary family abstracted over + the block parameters `As`, and one auxiliary family is created for each + family of `I`'s mutual block, with constructor types instantiated at + `Ds` (recursively rewritten). `aux2nested` records `auxI ↦ I Ds`, open + over the block parameters. Auxiliary names are uniquified against the + ambient environment (`mkUniqueName`). +2. `AddInductive.run` checks and generates the flattened block as an + ordinary mutual block, receiving `numNested` (the number of auxiliary + families) as opaque metadata. +3. When `numNested ≠ 0`, a restoration pass rebuilds the final environment + from the *pre-block* environment: source families and constructors are + re-added with every auxiliary constant replaced by its nested + restoration (`Result.restoreNested`), each auxiliary family's recursor + is re-added under the name `(mkRecName mainName).appendIndexAfter i` + with restored type and rules, and finally every `aux2nested` value + `I Ds` is type-checked (the lean4#14577 escape-hatch check, regression + tested in `Tests/NestedInductive.lean`). The auxiliary families, + constructors, and recursor names never enter the final environment. + +The stored metadata therefore has this shape (probes P1, P2): + +- The source `inductInfo` keeps `all` = the source family names only and + carries `numNested` = the number of auxiliary families; stored + constructor types are in restored form (they mention `I Ds`, e.g. + `List (RoseTree α)`). +- The recursor inventory is one recursor per source family plus one per + auxiliary family, all with `all` = source names, and with + `numMotives`/`numMinors` counting the *flattened* block's families and + minors. Auxiliary recursors have rules keyed by constructors of the + previously declared nested inductive (`List.nil`, `List.cons`, ...) with + `nfields` counting the instantiated auxiliary constructor's fields, and + every rule RHS references the restored recursor constants mutually. +- No `_nested.*` constant, and no auxiliary recursor under its original + name, survives into the final environment. + +## Decision: additive artifact type; `VInductDecl` unchanged + +The stored Theory payload for a nested declaration must be the *source* +`VInductDecl` (restored form), because that is what the implementation +stores and what Verify alignment must replay. Storing the flattened block +is unrepresentable: the final `ConstMap` contains neither the auxiliary +families nor their constructors (probe P2), and the stored constructor +types differ from the flattened ones (probe P1). `VInductDecl` needs no +new field: `numNested` is implementation metadata recoverable as the +number of auxiliary specifications, and parity fixtures pin it per row +exactly as they already pin `numNested == 0` for non-nested rows. + +Nested support is an additive checked-block artifact (built in L4L-09B/C), +coupling: + +1. the flattened block as an ordinary `VInductDecl` — probe P4 shows both + target fixtures' flattened blocks are already accepted by the existing + `identityBlockGeneration?` machinery, so flattening reuses the complete + L4L-08 block analyzer and generator unchanged; +2. one auxiliary specification per auxiliary family, in flattened family + order: the auxiliary name, the nested value `I Ds` open over the block + parameters (the Theory analog of `aux2nested`), and the restored + recursor name — plus executable coherence checks tying the flattened + block to the source declaration and to the environment's metadata for + `I` at `Ds`; +3. the restoration substitution σ, a structural constant substitution on + `VExpr` (probe P5, `restoreV09A`): on an application spine headed by an + auxiliary constant, the first `nparams` spine arguments are consumed + and replaced by the instantiated value `I Ds`; auxiliary constructor + constants are renamed by prefix into `I`'s constructors, applied to the + instantiated value's own arguments; auxiliary recursor constants are + renamed (checked *before* the constructor-prefix case, exactly like + `restoreNested`'s `auxRec` map); levels come from the recorded value, + not the auxiliary constant. + +σ has one level-world subtlety (probe P5): specification values live in +declaration level-world, while recursor types and rules live in recursor +level-world, so σ over generation artifacts splices +`value.instL (VLevel.params' uvars elimOffset)`. Constructor types are +restored with the unshifted value. With that splice, σ over the flattened +block's existing `BlockGenerationChecked` artifacts reproduces the stored +kernel metadata *exactly* — every recursor type and every rule RHS of all +three probe fixtures — and no auxiliary constant survives the image. +Probe P2 additionally shows the port's full nested path reproduces Lean's +stored metadata field-for-field, and that the final metadata is +independent of auxiliary-name collisions (the uniquified names are erased +by σ), so Theory may choose canonical auxiliary names as artifact data. + +Rejected alternatives: + +- *Flattened block as stored payload*: contradicts the stored metadata + (P1/P2); Verify alignment would have to invent constants the + implementation never stores. +- *Changing `VInductDecl` fields*: unnecessary — the probes demonstrate + the additive artifact expresses real rose-tree, nested-indexed, and + constant-universe metadata; a payload change would ripple through every + exported Theory API without demonstrated need. +- *A Prop-only pre-flattening relation without an artifact*: the + specifications and σ are data consumed by generation and replay; a + relation alone would force Verify to re-synthesize them. The artifact's + executable coherence checks subsume the relation. + +## Obligations recorded for L4L-09B/09C (not claimed here) + +- 09B: Theory-side flattening and auxiliary-specification validation — + positivity through the existing block analyzer on the flattened block; + executable instantiation checks of auxiliary family/constructor types + against `I`'s metadata at `Ds`; nearest rejection differentials + (ill-typed `Ds` — the lean4#14577 class — wrong specification order, + non-matching instantiation). +- 09C: σ as a total Theory function. The spine rule needs a simultaneous + `instantiateRev`-style multi-substitution for `nparams > 1`: iterating + single `VExpr.inst` is wrong once parameter arguments mention bvars. + Generation, preservation (typing transport along σ: auxiliary constants + behave as definitions `auxI := λ As, I Ds`, so staged flattened-block WF + transports to restored WF given environment lookup facts for `I`'s + families and constructors), insertion order, and replay of real + `Inductive.Add.run` output. +- The kernel's trailing `checkType (I Ds)` becomes a WF premise of the + auxiliary specification, never a trusted escape hatch. +-/ + +namespace Lean4Lean.NestedRepresentation + +open Lean + +/-! ## Probe fixtures + +`RoseTree` is the universe-polymorphic rose tree through `List`; `NVTree` +nests through the locally declared indexed family `PVec` (indices spelled +with `Nat.zero`/`Nat.succ` to keep the probe dependency maps free of +notation instances); `CURose` nests `List` at a constant universe, so its +auxiliary constant carries no block level while the restored `List` +carries level `1` — the level-instantiation case σ must represent. -/ + +inductive RoseTree (α : Type u) : Type u where + | node : α → List (RoseTree α) → RoseTree α + +inductive PVec (α : Type) : Nat → Type where + | nil : PVec α Nat.zero + | cons : α → {n : Nat} → PVec α n → PVec α (Nat.succ n) + +inductive NVTree : Type where + | node : (n : Nat) → PVec NVTree n → NVTree + +inductive CURose : Type 1 where + | node : List CURose → CURose + +/-! ## Quoted stored metadata + +Local pin records keep this file independent of the replay fixture +inventory; a change in Lean's emitted metadata is a compile failure. -/ + +structure InductPins where + name : Name + lparams : List Name + numParams : Nat + numIndices : Nat + all : List Name + ctors : List Name + numNested : Nat + isRec : Bool + isReflexive : Bool + isUnsafe : Bool + deriving ToExpr, BEq + +structure CtorPins where + name : Name + lparams : List Name + induct : Name + cidx : Nat + numParams : Nat + numFields : Nat + deriving ToExpr, BEq + +structure RecPins where + name : Name + lparams : List Name + all : List Name + numParams : Nat + numIndices : Nat + numMotives : Nat + numMinors : Nat + k : Bool + rules : List (Name × Nat) + deriving ToExpr, BEq + +open Elab Term in +elab "nestedInductPins09A%" n:ident : term => do + let name ← realizeGlobalConstNoOverloadWithInfo n + let .inductInfo i ← getConstInfo name | throwError "expected inductive {name}" + return toExpr (InductPins.mk i.name i.levelParams i.numParams i.numIndices + i.all i.ctors i.numNested i.isRec i.isReflexive i.isUnsafe) + +open Elab Term in +elab "nestedCtorPins09A%" n:ident : term => do + let name ← realizeGlobalConstNoOverloadWithInfo n + let .ctorInfo i ← getConstInfo name | throwError "expected constructor {name}" + return toExpr (CtorPins.mk i.name i.levelParams i.induct i.cidx + i.numParams i.numFields) + +open Elab Term in +elab "nestedRecPins09A%" n:ident : term => do + let name ← realizeGlobalConstNoOverloadWithInfo n + let .recInfo i ← getConstInfo name | throwError "expected recursor {name}" + return toExpr (RecPins.mk i.name i.levelParams i.all i.numParams i.numIndices + i.numMotives i.numMinors i.k (i.rules.map fun r => (r.ctor, r.nfields))) + +-- Quote a stored `ConstantInfo.type` in that record's own universe order. +open Elab Term in +elab "nestedConstVType09A%" n:ident : term => do + let name ← realizeGlobalConstNoOverloadWithInfo n + let info ← getConstInfo name + let type ← Lean4Lean.Meta.expandExpr info.type + return toExpr (← Lean4Lean.Meta.ofExpr info.levelParams {} type) + +/-! ## P1: stored-metadata pins + +The source family keeps `all` = source names and counts its auxiliary +families in `numNested`; constructor types are restored; the recursor +inventory reveals the flattened block through `numMotives`/`numMinors` and +through auxiliary recursors whose rules are keyed by the constructors of a +previously declared inductive. -/ + +def roseAux : Name := (`_nested ++ ``List).appendIndexAfter 1 +def nvAux : Name := (`_nested ++ ``PVec).appendIndexAfter 1 + +def roseInductPins : InductPins := nestedInductPins09A% RoseTree +def roseNodePins : CtorPins := nestedCtorPins09A% RoseTree.node +def roseRecPins : RecPins := nestedRecPins09A% RoseTree.rec +def roseRec1Pins : RecPins := nestedRecPins09A% RoseTree.rec_1 + +#guard roseInductPins.numNested == 1 +#guard roseInductPins.all == [``RoseTree] +#guard roseInductPins.ctors == [``RoseTree.node] +#guard roseInductPins.lparams == [`u] && roseInductPins.numParams == 1 +#guard roseInductPins.isRec && !roseInductPins.isReflexive && !roseInductPins.isUnsafe +#guard roseNodePins == + { name := ``RoseTree.node, lparams := [`u], induct := ``RoseTree, cidx := 0, + numParams := 1, numFields := 2 } +#guard roseRecPins == + { name := ``RoseTree.rec, lparams := [`u_1, `u], all := [``RoseTree], numParams := 1, + numIndices := 0, numMotives := 2, numMinors := 3, k := false, + rules := [(``RoseTree.node, 2)] } +#guard roseRec1Pins == + { name := (mkRecName ``RoseTree).appendIndexAfter 1, lparams := [`u_1, `u], + all := [``RoseTree], numParams := 1, numIndices := 0, numMotives := 2, numMinors := 3, + k := false, rules := [(``List.nil, 0), (``List.cons, 2)] } + +/-- The stored constructor type is the restored form: it mentions +`List (RoseTree α)`, not an auxiliary constant. -/ +def roseNodeStoredType : VExpr := nestedConstVType09A% RoseTree.node + +#guard roseNodeStoredType == + .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const ``List [.param 0]) (.app (.const ``RoseTree [.param 0]) (.bvar 1))) + (.app (.const ``RoseTree [.param 0]) (.bvar 2)))) + +def nvInductPins : InductPins := nestedInductPins09A% NVTree +def nvNodePins : CtorPins := nestedCtorPins09A% NVTree.node +def nvRecPins : RecPins := nestedRecPins09A% NVTree.rec +def nvRec1Pins : RecPins := nestedRecPins09A% NVTree.rec_1 + +#guard nvInductPins.numNested == 1 +#guard nvInductPins.all == [``NVTree] && nvInductPins.ctors == [``NVTree.node] +#guard nvNodePins == + { name := ``NVTree.node, lparams := [], induct := ``NVTree, cidx := 0, + numParams := 0, numFields := 2 } +#guard nvRecPins == + { name := ``NVTree.rec, lparams := [`u], all := [``NVTree], numParams := 0, + numIndices := 0, numMotives := 2, numMinors := 3, k := false, + rules := [(``NVTree.node, 2)] } +-- The auxiliary recursor keeps the auxiliary family's index and its rules +-- count the instantiated constructor's fields (`PVec.cons` retains its +-- implicit index field: 3 fields, not 2). +#guard nvRec1Pins == + { name := (mkRecName ``NVTree).appendIndexAfter 1, lparams := [`u], all := [``NVTree], + numParams := 0, numIndices := 1, numMotives := 2, numMinors := 3, k := false, + rules := [(``PVec.nil, 0), (``PVec.cons, 3)] } + +def nvNodeStoredType : VExpr := nestedConstVType09A% NVTree.node + +#guard nvNodeStoredType == + .forallE (.const ``Nat []) + (.forallE (.app (.app (.const ``PVec []) (.const ``NVTree [])) (.bvar 0)) + (.const ``NVTree [])) + +def cuInductPins : InductPins := nestedInductPins09A% CURose +def cuRecPins : RecPins := nestedRecPins09A% CURose.rec +def cuRec1Pins : RecPins := nestedRecPins09A% CURose.rec_1 + +#guard cuInductPins.numNested == 1 && cuInductPins.all == [``CURose] +#guard cuRecPins.rules == [(``CURose.node, 1)] && cuRecPins.numMotives == 2 +#guard cuRec1Pins.rules == [(``List.nil, 0), (``List.cons, 2)] + +/-- The restored constructor type instantiates `List` at the constant level +`1` even though the declaration has no level parameters. -/ +def cuNodeStoredType : VExpr := nestedConstVType09A% CURose.node + +#guard cuNodeStoredType == + .forallE (.app (.const ``List [.succ .zero]) (.const ``CURose [])) + (.const ``CURose []) + +/-! ## Shared probe plumbing -/ + +def sourceType09A (env : Environment) (n : Name) : InductiveType := Id.run do + let some (.inductInfo info) := env.find? n | panic! "expected inductive" + let ctors := info.ctors.map fun c => Id.run do + let some (.ctorInfo ci) := env.find? c | panic! "expected constructor" + return { name := c, type := ci.type : Constructor } + return { name := n, type := info.type, ctors } + +def depMap09A (env : Environment) (ns : List Name) : ConstMap := + ns.foldl (fun m n => m.insert n (env.find? n).get!) {} + +open ElimNestedInductive in +/-- Run the port's flattening phase, returning the flattened block and the +`aux2nested` values abstracted over the block parameters. -/ +def runElim09A (env : Kernel.Environment) (lparams : List Name) (nparams : Nat) + (types : List InductiveType) : + Except Kernel.Exception (List InductiveType × List (Name × Expr)) := do + let res : ElimNestedInductive.Result ← ElimNestedInductive.run 1000 nparams types env + |>.run' { lvls := lparams.map .param, newTypes := types.toArray } + return (res.types, res.aux2nested.toList.map fun (n, e) => (n, e.abstract res.params)) + +/-- Field-for-field stored/ported agreement for the constant kinds a nested +declaration emits. -/ +def sameConst09A (a b : ConstantInfo) : Bool := + a.name == b.name && a.levelParams == b.levelParams && a.type == b.type && + match a, b with + | .recInfo ra, .recInfo rb => + ra.all == rb.all && ra.numParams == rb.numParams && + ra.numIndices == rb.numIndices && ra.numMotives == rb.numMotives && + ra.numMinors == rb.numMinors && ra.k == rb.k && + ra.isUnsafe == rb.isUnsafe && + ra.rules.map (fun r => (r.ctor, r.nfields, r.rhs)) == + rb.rules.map (fun r => (r.ctor, r.nfields, r.rhs)) + | .inductInfo ia, .inductInfo ib => + ia.all == ib.all && ia.numParams == ib.numParams && + ia.numIndices == ib.numIndices && ia.ctors == ib.ctors && + ia.numNested == ib.numNested && ia.isRec == ib.isRec && + ia.isReflexive == ib.isReflexive && ia.isUnsafe == ib.isUnsafe + | .ctorInfo ca, .ctorInfo cb => + ca.induct == cb.induct && ca.cidx == cb.cidx && + ca.numParams == cb.numParams && ca.numFields == cb.numFields && + ca.isUnsafe == cb.isUnsafe + | _, _ => false + +def roseDeps : List Name := [``List, ``List.nil, ``List.cons] +def nvDeps : List Name := + [``Nat, ``Nat.zero, ``Nat.succ, ``PVec, ``PVec.nil, ``PVec.cons] + +def roseRestored : List Name := + [``RoseTree, ``RoseTree.node, mkRecName ``RoseTree, + (mkRecName ``RoseTree).appendIndexAfter 1] +def nvRestored : List Name := + [``NVTree, ``NVTree.node, mkRecName ``NVTree, + (mkRecName ``NVTree).appendIndexAfter 1] +def cuRestored : List Name := + [``CURose, ``CURose.node, mkRecName ``CURose, + (mkRecName ``CURose).appendIndexAfter 1] + +/-! ## P2: the port's nested path reproduces the stored metadata + +`Environment.addInductive`, run on a dependency-only kernel environment, +re-creates exactly the constants Lean stores — including every restored +type and rule RHS — and no auxiliary constant. The final output is +independent of auxiliary-name collisions: pre-seeding `_nested.List_1` +only shifts the uniquified internal names, which restoration erases. -/ + +open Elab in +run_meta do + let env ← getEnv + let checkPort (label : String) (main : Name) (lparams : List Name) (nparams : Nat) + (deps auxNames restored : List Name) (extra : ConstMap → ConstMap) : + MetaM Unit := do + let src := sourceType09A env main + let kenv := Kernel.Environment.ofConstants (`_l4l09A ++ main) (extra (depMap09A env deps)) + match Lean4Lean.Environment.addInductive kenv lparams nparams [src] false false with + | .error _ => throwError "{label}: port addInductive failed" + | .ok env' => + for n in restored do + let some stored := env.find? n | throwError "{label}: {n} not stored" + let some ported := env'.find? n | throwError "{label}: {n} missing from port output" + unless sameConst09A stored ported do + throwError "{label}: stored/ported metadata differ at {n}" + for n in auxNames do + unless (env'.find? n).isNone do + throwError "{label}: auxiliary constant {n} leaked into the final environment" + unless (env.find? n).isNone do + throwError "{label}: auxiliary constant {n} present in the ambient environment" + checkPort "rose" ``RoseTree [`u] 1 roseDeps + [roseAux, roseAux ++ `nil, roseAux ++ `cons, mkRecName roseAux, + (mkRecName ``RoseTree).appendIndexAfter 2] roseRestored id + checkPort "nv" ``NVTree [] 0 nvDeps + [nvAux, nvAux ++ `nil, nvAux ++ `cons, mkRecName nvAux, + (mkRecName ``NVTree).appendIndexAfter 2] nvRestored id + checkPort "cu" ``CURose [] 0 roseDeps + [roseAux, mkRecName roseAux] cuRestored id + -- auxiliary-name-collision independence + checkPort "rose-collision" ``RoseTree [`u] 1 roseDeps + [(`_nested ++ ``List).appendIndexAfter 2] roseRestored + (fun m => m.insert roseAux (env.find? ``Nat).get!) + +/-! ## P3: exact flattening pins + +The flattened blocks, translated to binder-erased `VExpr` form. These are +the descriptors the L4L-09B transformation must produce. -/ + +def roseFlatFamilies : List (Name × VExpr) := + [(``RoseTree, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0)))), + (roseAux, .forallE (.sort (.succ (.param 0))) (.sort (.succ (.param 0))))] + +def roseFlatCtors : List (Name × VExpr) := + [(``RoseTree.node, + .forallE (.sort (.succ (.param 0))) + (.forallE (.bvar 0) + (.forallE (.app (.const roseAux [.param 0]) (.bvar 1)) + (.app (.const ``RoseTree [.param 0]) (.bvar 2))))), + (roseAux ++ `nil, + .forallE (.sort (.succ (.param 0))) (.app (.const roseAux [.param 0]) (.bvar 0))), + (roseAux ++ `cons, + .forallE (.sort (.succ (.param 0))) + (.forallE (.app (.const ``RoseTree [.param 0]) (.bvar 0)) + (.forallE (.app (.const roseAux [.param 0]) (.bvar 1)) + (.app (.const roseAux [.param 0]) (.bvar 2)))))] + +/-- `aux2nested` for the rose tree: `List (RoseTree α)`, open over `α`. -/ +def roseAuxValue : VExpr := + .app (.const ``List [.param 0]) (.app (.const ``RoseTree [.param 0]) (.bvar 0)) + +def nvFlatFamilies : List (Name × VExpr) := + [(``NVTree, .sort (.succ .zero)), + (nvAux, .forallE (.const ``Nat []) (.sort (.succ .zero)))] + +def nvFlatCtors : List (Name × VExpr) := + [(``NVTree.node, + .forallE (.const ``Nat []) + (.forallE (.app (.const nvAux []) (.bvar 0)) (.const ``NVTree []))), + (nvAux ++ `nil, .app (.const nvAux []) (.const ``Nat.zero [])), + (nvAux ++ `cons, + .forallE (.const ``NVTree []) + (.forallE (.const ``Nat []) + (.forallE (.app (.const nvAux []) (.bvar 0)) + (.app (.const nvAux []) (.app (.const ``Nat.succ []) (.bvar 1))))))] + +/-- `aux2nested` for `NVTree`: the closed partial application `PVec NVTree` +(the index argument stays behind on each occurrence). -/ +def nvAuxValue : VExpr := .app (.const ``PVec []) (.const ``NVTree []) + +def cuFlatFamilies : List (Name × VExpr) := + [(``CURose, .sort (.succ (.succ .zero))), + (roseAux, .sort (.succ (.succ .zero)))] + +def cuFlatCtors : List (Name × VExpr) := + [(``CURose.node, .forallE (.const roseAux []) (.const ``CURose [])), + (roseAux ++ `nil, .const roseAux []), + (roseAux ++ `cons, + .forallE (.const ``CURose []) (.forallE (.const roseAux []) (.const roseAux [])))] + +/-- `aux2nested` for `CURose`: the block-level-free auxiliary constant +restores to `List` at the constant level `1`. -/ +def cuAuxValue : VExpr := .app (.const ``List [.succ .zero]) (.const ``CURose []) + +open Elab in +/-- Translate one flattened block and compare it with its pinned shape. -/ +def checkFlat09A (label : String) (main : Name) (lparams : List Name) (nparams : Nat) + (deps : List Name) (families ctors : List (Name × VExpr)) + (auxValues : List (Name × VExpr)) : MetaM (List VInductiveType) := do + let env ← getEnv + let src := sourceType09A env main + let kenv := Kernel.Environment.ofConstants (`_l4l09AFlat ++ main) (depMap09A env deps) + let .ok (flatTypes, aux) := runElim09A kenv lparams nparams [src] + | throwError "{label}: flattening failed" + let uvars := lparams.length + let mut vtypes : List VInductiveType := [] + let mut actualFamilies : List (Name × VExpr) := [] + let mut actualCtors : List (Name × VExpr) := [] + for t in flatTypes do + let vty ← Lean4Lean.Meta.ofExpr lparams {} t.type + actualFamilies := actualFamilies ++ [(t.name, vty)] + let mut vctors : List VConstVal := [] + for c in t.ctors do + let vc ← Lean4Lean.Meta.ofExpr lparams {} c.type + actualCtors := actualCtors ++ [(c.name, vc)] + vctors := vctors ++ [{ name := c.name, uvars, type := vc }] + vtypes := vtypes ++ [{ name := t.name, uvars, type := vty, ctors := vctors }] + unless actualFamilies == families do + throwError "{label}: flattened families differ from the pinned shape" + unless actualCtors == ctors do + throwError "{label}: flattened constructors differ from the pinned shape" + let mut actualValues : List (Name × VExpr) := [] + for (n, e) in aux do + actualValues := actualValues ++ [(n, ← Lean4Lean.Meta.ofExpr lparams {} e)] + unless actualValues == auxValues do + throwError "{label}: aux2nested values differ from the pinned shape" + return vtypes + +/-! ## P4: Theory viability, with acceptance behavior unchanged + +The flattened blocks are already inside the supported arbitrary-block +class, while the source declarations remain rejected by every current +analyzer and by the public transaction. -/ + +open Elab in +run_meta do + let checkViability (label : String) (main : Name) (lparams : List Name) + (nparams : Nat) (deps : List Name) (families ctors : List (Name × VExpr)) + (auxValues : List (Name × VExpr)) : MetaM Unit := do + let vtypes ← checkFlat09A label main lparams nparams deps families ctors auxValues + let uvars := lparams.length + let flatDecl : VInductDecl := { uvars, nparams, types := vtypes } + unless flatDecl.stage3 do + throwError "{label}: flattened block rejected by the block analyzer" + unless flatDecl.identityBlockGeneration?.isSome do + throwError "{label}: flattened block is not generation-ready" + let env ← getEnv + let src := sourceType09A env main + let vsrcTy ← Lean4Lean.Meta.ofExpr lparams {} src.type + let mut vctors : List VConstVal := [] + for c in src.ctors do + vctors := vctors ++ [{ name := c.name, uvars, type := ← Lean4Lean.Meta.ofExpr lparams {} c.type }] + let srcTy : VInductiveType := { name := main, uvars, type := vsrcTy, ctors := vctors } + let srcDecl : VInductDecl := { uvars, nparams, types := [srcTy] } + if srcDecl.stage3 then + throwError "{label}: source declaration unexpectedly accepted by stage3" + if srcDecl.checked?.isSome then + throwError "{label}: source declaration unexpectedly accepted by checked?" + if (VEnv.empty.addInduct srcDecl).isSome then + throwError "{label}: source declaration unexpectedly accepted by addInduct" + checkViability "rose" ``RoseTree [`u] 1 roseDeps + roseFlatFamilies roseFlatCtors [(roseAux, roseAuxValue)] + checkViability "nv" ``NVTree [] 0 nvDeps + nvFlatFamilies nvFlatCtors [(nvAux, nvAuxValue)] + checkViability "cu" ``CURose [] 0 roseDeps + cuFlatFamilies cuFlatCtors [(roseAux, cuAuxValue)] + +/-! ## P5: the restoration substitution σ + +`restoreV09A` mirrors `ElimNestedInductive.Result.restoreNested` on +`VExpr`. It is probe-local: the L4L-09C artifact path must define the +total Theory version (with a simultaneous parameter substitution once +`nparams > 1` is in scope; the probe fixtures have `nparams ≤ 1`, where +iterated `VExpr.inst` coincides with it). -/ + +structure AuxSpec09A where + aux : Name + np : Nat + value : VExpr + recName : Name + +def instParams09A (value : VExpr) : List VExpr → VExpr + | [] => value + | [a] => value.inst a + | _ => panic! "the probe fixtures have nparams ≤ 1" + +def findCtorSpec09A (specs : List AuxSpec09A) (c : Name) : Option (AuxSpec09A × Name) := + specs.findSome? fun spec => + if spec.aux.isPrefixOf c && c != spec.aux then + some (spec, c.replacePrefix spec.aux .anonymous) + else none + +/-- σ. The recursor-rename case is checked before the constructor-prefix +case, exactly like `restoreNested`'s `auxRec` map: an auxiliary recursor +name is prefixed by its auxiliary family name and would otherwise be +mangled by the constructor branch. -/ +partial def restoreV09A (specs : List AuxSpec09A) (recMap : List (Name × Name)) : + VExpr → VExpr + | .bvar i => .bvar i + | .sort l => .sort l + | .lam ty body => .lam (restoreV09A specs recMap ty) (restoreV09A specs recMap body) + | .forallE ty body => + .forallE (restoreV09A specs recMap ty) (restoreV09A specs recMap body) + | e@(.app ..) => restoreSpine (VExpr.appHead e) (e.appArgs []) + | e@(.const ..) => restoreSpine e [] + where + restoreSpine (head : VExpr) (args : List VExpr) : VExpr := + let args' := args.map (restoreV09A specs recMap) + match head with + | .const c ls => + match recMap.find? (·.1 == c) with + | some (_, newName) => (VExpr.const newName ls).appN args' + | none => + match specs.find? (·.aux == c) with + | some spec => + (instParams09A spec.value (args'.take spec.np)).appN (args'.drop spec.np) + | none => + match findCtorSpec09A specs c with + | some (spec, suffix) => + let value := instParams09A spec.value (args'.take spec.np) + match VExpr.appHead value with + | .const iname ils => + (VExpr.const (iname ++ suffix) ils).appN + (value.appArgs [] ++ args'.drop spec.np) + | _ => panic! "auxiliary value head is not a constant" + | none => (VExpr.const c ls).appN args' + | h => (restoreV09A specs recMap h).appN args' + +open Elab in +/-- σ over the flattened block's existing generation artifacts reproduces +the stored kernel metadata exactly: recursor names and types, and every +rule RHS in the globally flattened order, with no auxiliary constant in +the image. Constructor types are restored with the declaration-world +value; recursor artifacts use the value spliced by the elimination +offset. -/ +def checkRestore09A (label : String) (main : Name) (lparams : List Name) + (nparams : Nat) (deps : List Name) : MetaM Unit := do + let env ← getEnv + let src := sourceType09A env main + let kenv := Kernel.Environment.ofConstants (`_l4l09ARestore ++ main) (depMap09A env deps) + let .ok (flatTypes, aux) := runElim09A kenv lparams nparams [src] + | throwError "{label}: flattening failed" + let uvars := lparams.length + let mut vtypes : List VInductiveType := [] + for t in flatTypes do + let vty ← Lean4Lean.Meta.ofExpr lparams {} t.type + let mut vctors : List VConstVal := [] + for c in t.ctors do + vctors := vctors ++ [{ name := c.name, uvars, type := ← Lean4Lean.Meta.ofExpr lparams {} c.type }] + vtypes := vtypes ++ [{ name := t.name, uvars, type := vty, ctors := vctors }] + let flatDecl : VInductDecl := { uvars, nparams, types := vtypes } + let some gen := flatDecl.identityBlockGeneration? + | throwError "{label}: flattened block is not generation-ready" + let elimOffset := gen.recUvars - uvars + let mut declSpecs : List AuxSpec09A := [] + let mut recSpecs : List AuxSpec09A := [] + let mut recMap : List (Name × Name) := [] + let mut i := 1 + for t in flatTypes.drop 1 do + let some (_, value) := aux.find? (·.1 == t.name) + | throwError "{label}: no aux2nested value for {t.name}" + let v ← Lean4Lean.Meta.ofExpr lparams {} value + let recName := (mkRecName main).appendIndexAfter i + let recValue := v.instL (VLevel.params' uvars elimOffset) + declSpecs := declSpecs ++ [{ aux := t.name, np := nparams, value := v, recName }] + recSpecs := recSpecs ++ [{ aux := t.name, np := nparams, value := recValue, recName }] + recMap := recMap ++ [(mkRecName t.name, recName)] + i := i + 1 + let auxConsts := declSpecs.map (·.aux) ++ recMap.map (·.1) ++ + (flatTypes.drop 1).flatMap (fun t => t.ctors.map (·.name)) + -- declaration-world σ: restored source constructors + for (t, vt) in flatTypes.zip vtypes do + if t.name == main then + for c in vt.ctors do + let some stored := env.find? c.name | throwError "{label}: {c.name} not stored" + let storedType ← Lean4Lean.Meta.ofExpr stored.levelParams {} + (← Lean4Lean.Meta.expandExpr stored.type) + unless restoreV09A declSpecs recMap c.type == storedType do + throwError "{label}: σ(flattened {c.name}) differs from the stored type" + -- recursor-world σ: recursor types, names, and every rule RHS + let expectedNames := [mkRecName main] ++ recSpecs.map (·.recName) + for (r, expected) in gen.recursors.zip expectedNames do + let restoredName := match recMap.find? (·.1 == r.name) with + | some (_, n) => n + | none => r.name + unless restoredName == expected do + throwError "{label}: restored recursor name {restoredName}, expected {expected}" + let some (.recInfo stored) := env.find? expected + | throwError "{label}: stored recursor {expected} missing" + let storedType ← Lean4Lean.Meta.ofExpr stored.levelParams {} + (← Lean4Lean.Meta.expandExpr stored.type) + let restored := restoreV09A recSpecs recMap r.type + unless restored == storedType do + throwError "{label}: σ(recursor type) differs from stored for {expected}" + unless !VExpr.hasAnyConst auxConsts restored do + throwError "{label}: auxiliary constant survives σ in the type of {expected}" + let mut storedRules : List (Name × Expr) := [] + for n in expectedNames do + let some (.recInfo stored) := env.find? n + | throwError "{label}: stored recursor {n} missing" + for rule in stored.rules do + storedRules := storedRules ++ [(rule.ctor, rule.rhs)] + let genRules := gen.generatedRules + unless storedRules.length == genRules.length do + throwError "{label}: {genRules.length} generated rules, {storedRules.length} stored" + let some (.recInfo mainRec) := env.find? (mkRecName main) + | throwError "{label}: stored main recursor missing" + for (df, (ctor, storedRhs)) in genRules.zip storedRules do + let storedRhs ← Lean4Lean.Meta.ofExpr mainRec.levelParams {} + (← Lean4Lean.Meta.expandExpr storedRhs) + let restoredRhs := restoreV09A recSpecs recMap df.rhs + unless restoredRhs == storedRhs do + throwError "{label}: σ(rule rhs) differs from stored for {ctor}" + unless !VExpr.hasAnyConst auxConsts restoredRhs && + !VExpr.hasAnyConst auxConsts (restoreV09A recSpecs recMap df.lhs) do + throwError "{label}: auxiliary constant survives σ in the rule for {ctor}" + +run_meta do + checkRestore09A "rose" ``RoseTree [`u] 1 roseDeps + checkRestore09A "nv" ``NVTree [] 0 nvDeps + checkRestore09A "cu" ``CURose [] 0 roseDeps + +end Lean4Lean.NestedRepresentation diff --git a/plans/roadmap.md b/plans/roadmap.md index 0692fcda..d59d96b0 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 17/51] 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 00000000..efe60c01 --- /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 00000000..ceb004f5 --- /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 00000000..f460a130 --- /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 d59d96b0..a52f8ac4 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 18/51] 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 efe60c01..6be562fe 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 ceb004f5..4bcbd0e6 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 de6f89cb..0e957bab 100644 --- a/Lean4Lean/Theory/Typing/Env.lean +++ b/Lean4Lean/Theory/Typing/Env.lean @@ -2,6 +2,7 @@ import Lean4Lean.Theory.Typing.Basic import Lean4Lean.Theory.VDecl import Lean4Lean.Theory.Quot import Lean4Lean.Theory.Inductive +import Lean4Lean.Theory.NestedInductive namespace Lean4Lean @@ -35,6 +36,10 @@ inductive VDecl.WF : VEnv → VDecl → VEnv → Prop where gen.WF env blockEnv → env.addInductBlockGeneration gen = some env' → VDecl.WF env (.induct decl) env' + | inductNested {nested : decl.NestedBlockChecked} : + nested.WF env → + env.addInductNested nested = some env' → + VDecl.WF env (.induct decl) env' inductive VEnv.WF' : List VDecl → VEnv → Prop where | empty : VEnv.WF' [] .empty diff --git a/Lean4Lean/Theory/Typing/EnvLemmas.lean b/Lean4Lean/Theory/Typing/EnvLemmas.lean index cedcfc16..eba779d7 100644 --- a/Lean4Lean/Theory/Typing/EnvLemmas.lean +++ b/Lean4Lean/Theory/Typing/EnvLemmas.lean @@ -2,6 +2,7 @@ import Lean4Lean.Theory.Typing.Lemmas import Lean4Lean.Theory.Typing.Env import Lean4Lean.Theory.Typing.QuotLemmas import Lean4Lean.Theory.Typing.InductiveLemmas +import Lean4Lean.Theory.Typing.NestedInductiveLemmas namespace Lean4Lean @@ -23,5 +24,6 @@ theorem VEnv.WF.ordered : WF env → Ordered env | quot h1 h2 => exact addQuot_WF ih h1 h2 | induct h1 h2 => exact addInductGeneration_WF ih h1 h2 | inductBlock h1 h2 => exact addInductBlockGeneration_WF ih h1 h2 + | inductNested h1 h2 => exact VEnv.addInductNested_WF ih h1 h2 instance : CoeOut (VEnv.WF env) env.Ordered := ⟨(·.ordered)⟩ diff --git a/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean b/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean new file mode 100644 index 00000000..44c12a9f --- /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 c5102ead..ea7674f6 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 0af803b9..fea5ad70 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 f460a130..5cbee5d3 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 19/51] 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 5cbee5d3..320fed6f 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 a52f8ac4..4b5edb41 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 20/51] 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 00000000..b51751a2 --- /dev/null +++ b/Lean4Lean/Theory/Typing/NestedTransport.lean @@ -0,0 +1,222 @@ +import Lean4Lean.Theory.Typing.NestedInductiveLemmas +import Lean4Lean.Theory.Typing.Strong + +/-! +# Constant-interpretation substitution (L4L-09C transport, part 1) + +The clean compositional substitution σ̂ underlying nested restoration: +each interpreted constant is replaced by a closed value, level-instantiated +per occurrence. The spine-collapsed artifact substitution `restoreExpr` +is the β-image of σ̂ at fully applied auxiliary heads; the typed transport +built on σ̂ is the route from the flattened block's staged semantic +certificate to restored-artifact well-formedness recorded in the L4L-09A +design note. + +This file establishes σ̂, its commutation calculus with lifting, +instantiation, and level instantiation, context-lookup transport, the +`ConstInterp` environment morphism, and the typed transport +`IsDefEq.substConst` with its `HasType`/`IsType`/`VConstant.WF`/ +`VDefEq.WF` corollaries. The β-collapse bridge from σ̂ to the +spine-collapsed artifact substitution and the per-phase morphism +construction for a staged flattened block are the remaining transport +obligations. +-/ + +namespace Lean4Lean + +/-- σ̂: replace each interpreted constant by its closed value at the +occurrence's levels. -/ +def VExpr.substConst (interp : Name → Option VExpr) : VExpr → VExpr + | .bvar i => .bvar i + | .sort l => .sort l + | .const c ls => + match interp c with + | some v => v.instL ls + | none => .const c ls + | .app f a => .app (f.substConst interp) (a.substConst interp) + | .lam ty body => .lam (ty.substConst interp) (body.substConst interp) + | .forallE ty body => .forallE (ty.substConst interp) (body.substConst interp) + +/-- Every interpreted value is closed. -/ +def InterpClosed (interp : Name → Option VExpr) : Prop := + ∀ c v, interp c = some v → v.ClosedN 0 + +namespace VExpr + +variable {interp : Name → Option VExpr} + +theorem substConst_liftN (hc : InterpClosed interp) : + ∀ (e : VExpr) (k : Nat), + (e.liftN n k).substConst interp = (e.substConst interp).liftN n k + | .bvar _, _ => rfl + | .sort _, _ => rfl + | .const c ls, k => by + simp only [liftN, substConst] + cases h : interp c with + | none => simp [liftN] + | some v => + exact (((hc c v h).instL (ls := ls)).liftN_eq (Nat.zero_le k)).symm + | .app f a, k => by + simp only [liftN, substConst, substConst_liftN hc f k, + substConst_liftN hc a k] + | .lam ty body, k => by + simp only [liftN, substConst, substConst_liftN hc ty k, + substConst_liftN hc body (k+1)] + | .forallE ty body, k => by + simp only [liftN, substConst, substConst_liftN hc ty k, + substConst_liftN hc body (k+1)] + +theorem substConst_lift (hc : InterpClosed interp) (e : VExpr) : + (e.lift).substConst interp = (e.substConst interp).lift := + substConst_liftN hc e 0 + +theorem substConst_instN (hc : InterpClosed interp) : + ∀ (e a : VExpr) (k : Nat), + (e.inst a k).substConst interp = + (e.substConst interp).inst (a.substConst interp) k + | .bvar i, a, k => by + simp only [inst, substConst] + unfold instVar + split + · simp [substConst] + · split + · exact (substConst_liftN hc a 0).symm ▸ rfl + · simp [substConst] + | .sort _, _, _ => rfl + | .const c ls, a, k => by + simp only [inst, substConst] + cases h : interp c with + | none => simp [inst] + | some v => + exact (((hc c v h).instL (ls := ls)).instN_eq (Nat.zero_le k)).symm + | .app f b, a, k => by + simp only [inst, substConst, substConst_instN hc f a k, + substConst_instN hc b a k] + | .lam ty body, a, k => by + simp only [inst, substConst, substConst_instN hc ty a k, + substConst_instN hc body a (k+1)] + | .forallE ty body, a, k => by + simp only [inst, substConst, substConst_instN hc ty a k, + substConst_instN hc body a (k+1)] + +theorem substConst_inst (hc : InterpClosed interp) (e a : VExpr) : + (e.inst a).substConst interp = + (e.substConst interp).inst (a.substConst interp) := + substConst_instN hc e a 0 + +theorem substConst_instL : + ∀ (e : VExpr), + (e.instL ls).substConst interp = ((e.substConst interp).instL ls : VExpr) + | .bvar _ => rfl + | .sort _ => by simp [instL, substConst] + | .const c ls' => by + simp only [instL, substConst] + cases interp c with + | none => simp [instL] + | some v => exact (instL_instL).symm + | .app f a => by + simp only [instL, substConst, substConst_instL f, substConst_instL a] + | .lam ty body => by + simp only [instL, substConst, substConst_instL ty, substConst_instL body] + | .forallE ty body => by + simp only [instL, substConst, substConst_instL ty, substConst_instL body] + +end VExpr + +/-- Context-lookup transport along σ̂. -/ +theorem Lookup.substConst {interp : Name → Option VExpr} + (hc : InterpClosed interp) : + ∀ {Γ i A}, Lookup Γ i A → + Lookup (Γ.map (VExpr.substConst interp)) i (A.substConst interp) + | _, _, _, .zero => by + rw [List.map_cons, VExpr.substConst_lift hc] + exact .zero + | _, _, _, .succ h => by + rw [List.map_cons, VExpr.substConst_lift hc] + exact .succ (h.substConst hc) + +namespace VEnv + +/-- Environment morphism along a constant interpretation: interpreted +constants become closed values typed at their σ̂-image types in the target +environment; surviving constants and registered defeqs are σ̂-imaged. The +staged flattened environments of a nested block and their restored +counterparts form exactly such a morphism, with the auxiliary families, +constructors, and recursors interpreted by their restoration closures. -/ +structure ConstInterp (E E' : VEnv) (interp : Name → Option VExpr) : Prop where + ordered' : VEnv.Ordered E' + closed : InterpClosed interp + value : ∀ {c ci v}, E.constants c = some ci → interp c = some v → + E'.HasType ci.uvars [] v (ci.type.substConst interp) + keep : ∀ {c ci}, E.constants c = some ci → interp c = none → + E'.constants c = some ⟨ci.uvars, ci.type.substConst interp⟩ + defeq : ∀ {df}, E.defeqs df → + E'.defeqs ⟨df.uvars, df.lhs.substConst interp, + df.rhs.substConst interp, df.type.substConst interp⟩ + +/-- Typed transport along a constant interpretation: every Theory judgment +of the interpreted environment holds of the σ̂-images in the target +environment. -/ +theorem IsDefEq.substConst {E E' : VEnv} {interp : Name → Option VExpr} + (hi : ConstInterp E E' interp) (H : E.IsDefEq U Γ e1 e2 A) : + E'.IsDefEq U (Γ.map (VExpr.substConst interp)) + (e1.substConst interp) (e2.substConst interp) + (A.substConst interp) := by + induction H with + | bvar h => exact .bvar (h.substConst hi.closed) + | symm _ ih => exact .symm ih + | trans _ _ ih1 ih2 => exact .trans ih1 ih2 + | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3 + | @constDF c ci ls ls' _ h1 h2 h3 h4 h5 => + rw [VExpr.substConst_instL (e := ci.type)] + simp only [VExpr.substConst] + cases hv : interp c with + | none => exact .constDF (hi.keep h1 hv) h2 h3 h4 h5 + | some v => + have hval := hi.value h1 hv + have hnil : OnCtx ([] : List VExpr) (E'.IsType ci.uvars) := trivial + have hcore := hval.instL_r hi.ordered' hnil h2 h3 h5 + exact hcore.weak0 hi.ordered' + | appDF _ _ ih1 ih2 => + exact (VExpr.substConst_inst hi.closed ..).symm ▸ .appDF ih1 ih2 + | lamDF _ _ ih1 ih2 => exact .lamDF ih1 ih2 + | forallEDF _ _ ih1 ih2 => exact .forallEDF ih1 ih2 + | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2 + | beta _ _ ih1 ih2 => + simpa [VExpr.substConst, VExpr.substConst_inst hi.closed] using + VEnv.IsDefEq.beta ih1 ih2 + | eta _ ih => + simpa [VExpr.substConst, VExpr.substConst_lift hi.closed] using + VEnv.IsDefEq.eta ih + | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3 + | extra h1 h2 h3 => + simpa [VExpr.substConst_instL] using + VEnv.IsDefEq.extra (env := E') (hi.defeq h1) h2 (by simpa using h3) + +theorem HasType.substConst {E E' : VEnv} {interp : Name → Option VExpr} + (hi : ConstInterp E E' interp) (H : E.HasType U Γ e A) : + E'.HasType U (Γ.map (VExpr.substConst interp)) + (e.substConst interp) (A.substConst interp) := + IsDefEq.substConst hi H + +theorem IsType.substConst {E E' : VEnv} {interp : Name → Option VExpr} + (hi : ConstInterp E E' interp) (H : E.IsType U Γ A) : + E'.IsType U (Γ.map (VExpr.substConst interp)) (A.substConst interp) := + let ⟨_, h⟩ := H; ⟨_, IsDefEq.substConst hi h⟩ + +end VEnv + +/-- Constant well-formedness transports to the σ̂-image constant. -/ +theorem VConstant.WF.substConst {E E' : VEnv} {interp : Name → Option VExpr} + {ci : VConstant} (hi : VEnv.ConstInterp E E' interp) (H : ci.WF E) : + VConstant.WF E' ⟨ci.uvars, ci.type.substConst interp⟩ := + VEnv.IsType.substConst hi H + +/-- Rule well-formedness transports to the σ̂-image rule. -/ +theorem VDefEq.WF.substConst {E E' : VEnv} {interp : Name → Option VExpr} + {df : VDefEq} (hi : VEnv.ConstInterp E E' interp) (H : df.WF E) : + VDefEq.WF E' ⟨df.uvars, df.lhs.substConst interp, + df.rhs.substConst interp, df.type.substConst interp⟩ := + ⟨VEnv.IsDefEq.substConst hi H.1, VEnv.IsDefEq.substConst hi H.2⟩ + +end Lean4Lean From a77e358b5243f1956fa92c648cd8c7b8e99b0ee6 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 09:12:00 -0400 Subject: [PATCH 21/51] 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 6be562fe..b8d6a386 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 00000000..6fd081bc --- /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 22/51] 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 6fd081bc..f2617343 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 4b5edb41..f4c7a2bb 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 23/51] 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 00000000..26c19016 --- /dev/null +++ b/Lean4Lean/Theory/Typing/InductivePattern.lean @@ -0,0 +1,774 @@ +import Lean4Lean.Theory.Typing.InductiveLemmas +import Lean4Lean.Theory.Typing.Pattern + +/-! # Generated iota rules as patterns + +Every iota rule generated for a certified mutual block +(`BlockGenerationChecked.rule`) is a closed defeq between lambda telescopes +whose left body is a `SimplePattern.iota` spine: the owning family's recursor +applied to the shared parameters, all motives, all minors, and the +constructor's result indices, with a constructor-headed major premise. This +module makes that connection exact and proves the generic pattern facts the +Church–Rosser `Params` interface demands of one certified block: + +* `rulePattern` is the `SimplePattern` of one flattened constructor's rule, + and `ruleLhsBody_matches` matches the exact generated left body against it + at the rule's recursor levels. +* `IotaPat` is the block's pattern set, associating each rule's pattern with + an RHS template (the registered right tower applied to the captured common + arguments and fields) and a check list (parameter and result-index + agreement between the recursor spine and the major premise). +* `pat_simple`, `pat_uniq`, `pat_app_l`, `pat_app_l_uniq`, and + `pat_app_uniq` are exactly the `Params` obligations, specialized to + `IotaPat`; their name-freshness inputs come from the certified block's + `blockGeneratedNames` nodup bit, and the major-arity agreement between + same-recursor rules comes from the analyzer's terminal `blockTarget?` + arity equation. + +No open-environment `Params` instance is installed here; the block supplies +the facts, and soundness (`pat_wf`) plus the block-local environment +assembler belong to the pattern-soundness milestone. -/ + +namespace Lean4Lean + +open VExpr + +namespace VExpr + +@[simp] theorem bvarRevRange_length : ∀ (off m : Nat), + (bvarRevRange off m).length = m + | _, 0 => rfl + | off, m+1 => by simp [bvarRevRange, bvarRevRange_length off m] + +end VExpr + +/-- Extending a `HeadConstN` spine by an application spine. -/ +theorem HeadConstN.appN {c : Name} {ls : List VLevel} : + ∀ (as : List VExpr) {n : Nat} {f : VExpr}, HeadConstN c ls n f → + HeadConstN c ls (n + as.length) (VExpr.appN f as) + | [], _, _, h => h + | a :: as, n, f, h => by + have := HeadConstN.appN as (h.app (a := a)) + show HeadConstN c ls (n + (as.length + 1)) (VExpr.appN (f.app a) as) + rwa [(by omega : n + (as.length + 1) = n + 1 + as.length)] + +namespace VInductDecl + +/-! ## Positional facts about the checked pairings -/ + +theorem pairNormalizedFamilies_getElem? : + ∀ (raws : List VInductiveType) (views : List CheckedFamilyData) (t : Nat) + {family : NormalizedFamily}, + (pairNormalizedFamilies raws views)[t]? = some family → + raws[t]? = some family.raw ∧ views[t]? = some family.view + | raw :: raws, view :: views, 0, family => by + intro h + cases h + exact ⟨rfl, rfl⟩ + | raw :: raws, view :: views, t+1, family => by + intro h + simpa using pairNormalizedFamilies_getElem? raws views t + (by simpa [pairNormalizedFamilies] using h) + | [], _, t, _ => by intro h; simp [pairNormalizedFamilies] at h + | _ :: _, [], t, _ => by intro h; simp [pairNormalizedFamilies] at h + +theorem pairNormalizedCtors_getElem? : + ∀ (raws : List VConstVal) (views : List CheckedCtor) (t : Nat) + {ctor : NormalizedCtor}, + (pairNormalizedCtors raws views)[t]? = some ctor → + raws[t]? = some ctor.raw ∧ views[t]? = some ctor.view + | raw :: raws, view :: views, 0, ctor => by + intro h + cases h + exact ⟨rfl, rfl⟩ + | raw :: raws, view :: views, t+1, ctor => by + intro h + simpa using pairNormalizedCtors_getElem? raws views t + (by simpa [pairNormalizedCtors] using h) + | [], _, t, _ => by intro h; simp [pairNormalizedCtors] at h + | _ :: _, [], t, _ => by intro h; simp [pairNormalizedCtors] at h + +/-- The erased family-data spine reads back its exact member facts: ordinal +consecutiveness, the indexing family, the analyzer equations, and the +per-family acceptance bit. -/ +theorem CheckedFamilies.data_getElem? {source : VInductDecl} {params : List VExpr} : + ∀ {ord : Nat} {types : List VInductiveType} + (fs : CheckedFamilies source params ord types) (t : Nat) + {fd : CheckedFamilyData}, + fs.data[t]? = some fd → + ∃ type, types[t]? = some type ∧ fd.ordinal = ord + t ∧ fd.value = type ∧ + fd.indices = ctorFields (VExpr.dropN source.nparams type.type) ∧ + fd.constructors = type.ctors.map (CheckedCtor.ofBlock source) ∧ + blockFamilyCore source params (ord + t) type = true + | _, _, .nil, t, fd => by intro h; simp [CheckedFamilies.data] at h + | ord, _, .cons head tail, 0, fd => by + intro h + cases h + exact ⟨_, rfl, rfl, rfl, head.indices_eq, head.constructors_eq, head.accepted⟩ + | ord, _, .cons head tail, t+1, fd => by + intro h + obtain ⟨type, h1, h2, h3, h4, h5, h6⟩ := + CheckedFamilies.data_getElem? tail t (by simpa [CheckedFamilies.data] using h) + exact ⟨type, by simpa using h1, by omega, h3, h4, h5, + by rw [(by omega : ord + (t + 1) = ord + 1 + t)]; exact h6⟩ + +/-! ## Arity extraction from the analyzer's terminal target check -/ + +theorem blockTarget?_loop_length {U np j : Nat} {names : List Name} + {head : VExpr} {args : List VExpr} : + ∀ (headers : List FamilyHeader) (t : Nat) {target : Nat} {idxs : List VExpr}, + blockTarget?.loop U np j names head args t headers = some (target, idxs) → + t ≤ target ∧ ∃ header, headers[target - t]? = some header ∧ + args.length = np + header.indices ∧ idxs = args.drop np + | [], t, target, idxs => by intro h; simp [blockTarget?.loop] at h + | header :: headers, t, target, idxs => by + intro h + rw [blockTarget?.loop] at h + split at h + · rename_i hcond + cases h + simp only [Bool.and_eq_true, beq_iff_eq] at hcond + exact ⟨Nat.le_refl _, header, by simp, hcond.1.1.2, rfl⟩ + · obtain ⟨hle, header', h1, h2, h3⟩ := + blockTarget?_loop_length headers (t+1) h + refine ⟨Nat.le_of_succ_le hle, header', ?_, h2, h3⟩ + rw [(by omega : target - t = (target - (t+1)) + 1)] + simpa using h1 + +/-- A successful mutual target recognition pins the target's index arity to +its family header. -/ +theorem blockTarget?_length {U np j : Nat} {headers : List FamilyHeader} + {names : List Name} {B : VExpr} {target : Nat} {idxs : List VExpr} + (h : blockTarget? U np j headers names B = some (target, idxs)) : + ∃ header, headers[target]? = some header ∧ + (VExpr.appArgs B []).length = np + header.indices ∧ + idxs = (VExpr.appArgs B []).drop np := by + rw [blockTarget?] at h + obtain ⟨hle, header, h1, h2, h3⟩ := blockTarget?_loop_length headers 0 h + exact ⟨header, by simpa using h1, h2, h3⟩ + +/-- The terminal of an accepted mutual constructor shape is a successful +`blockTarget?` recognition of the owner family, past all fields. -/ +theorem blockStage3Ctor_result {U np : Nat} {headers : List FamilyHeader} + {names : List Name} {owner : Nat} : + ∀ (B : VExpr) (j : Nat), blockStage3Ctor U np headers names owner j B = true → + ∃ idxs, blockTarget? U np (j + (ctorFields B).length) headers names + (VExpr.resultOf B) = some (owner, idxs) := by + intro B + induction B with + (intro j h + simp only [blockStage3Ctor] at h + try (split at h + · rename_i target idxs heq + refine ⟨idxs, ?_⟩ + simp only [ctorFields, List.length_nil, Nat.add_zero, VExpr.resultOf] + rwa [(by simpa using h : target = owner)] at heq + · cases h)) + | forallE A rest _ ihR => + rw [Bool.and_eq_true] at h + obtain ⟨-, h2⟩ := h + obtain ⟨idxs, hidx⟩ := ihR (j+1) h2 + refine ⟨idxs, ?_⟩ + simp only [ctorFields, List.length_cons, VExpr.resultOf] + rwa [(by omega : j + ((ctorFields rest).length + 1) = j + 1 + (ctorFields rest).length)] + +/-! ## Name transport across the normalization boundary -/ + +theorem sameCtorHeaders_names : ∀ {cs cs' : List VConstVal}, + sameCtorHeaders cs cs' = true → cs.map (·.name) = cs'.map (·.name) + | [], [], _ => rfl + | c :: cs, c' :: cs', h => by + simp only [sameCtorHeaders, Bool.and_eq_true, beq_iff_eq] at h + simp only [List.map_cons, h.1.1, sameCtorHeaders_names h.2] + | [], _ :: _, h => by simp [sameCtorHeaders] at h + | _ :: _, [], h => by simp [sameCtorHeaders] at h + +theorem sameTypeHeaders_names : ∀ {tys tys' : List VInductiveType}, + sameTypeHeaders tys tys' = true → + tys.map (·.name) = tys'.map (·.name) ∧ + tys.flatMap (fun ty => ty.ctors.map (·.name)) = + tys'.flatMap (fun ty => ty.ctors.map (·.name)) + | [], [], _ => ⟨rfl, rfl⟩ + | ty :: tys, ty' :: tys', h => by + simp only [sameTypeHeaders, Bool.and_eq_true, beq_iff_eq] at h + have ih := sameTypeHeaders_names h.2 + simp only [List.map_cons, List.flatMap_cons, h.1.1.1, ih.1, ih.2, + sameCtorHeaders_names h.1.2, and_self] + | [], _ :: _, h => by simp [sameTypeHeaders] at h + | _ :: _, [], h => by simp [sameTypeHeaders] at h + +/-- The reserved generated names are unchanged by normalization: they are +computed from family and constructor identities only. -/ +theorem blockGeneratedNames_eq_of_sameTypeHeaders + {tys tys' : List VInductiveType} (h : sameTypeHeaders tys tys' = true) : + blockGeneratedNames tys = blockGeneratedNames tys' := by + obtain ⟨h1, h2⟩ := sameTypeHeaders_names h + have h3 : tys.map (fun ty => (.str ty.name "rec" : Name)) = + tys'.map (fun ty => (.str ty.name "rec" : Name)) := by + have := congrArg (List.map (fun n => (.str n "rec" : Name))) h1 + simpa [List.map_map, Function.comp_def] using this + simp only [blockGeneratedNames, h1, h2, h3] + +namespace BlockGenerationChecked + +variable {source : VInductDecl} (gen : source.BlockGenerationChecked) + +/-! ## Inventory facts from the certified block -/ + +include gen in +/-- The reserved generated names of the raw source are collision-free: the +analyzer certifies the view's inventory, and normalization retains every +identity. -/ +theorem blockGeneratedNames_nodup : + (blockGeneratedNames source.types).Nodup := by + have hshape := gen.block.normalization.shape_eq + simp only [normalizationShape, Bool.and_eq_true, beq_iff_eq] at hshape + rw [blockGeneratedNames_eq_of_sameTypeHeaders hshape.2] + have h := gen.block.checked.names_nodup + rwa [gen.block.checked.names_eq] at h + +/-! ## Named components of one generated iota rule -/ + +/-- Field count of one flattened constructor, as bound by its iota rule. -/ +def ruleFieldCount (constructor : NormalizedBlockCtor) : Nat := + (constructor.ctor.fieldsR source.uvars source.nparams gen.elimination).length + +/-- The result-index spine of one iota rule body, in the rule's binder +context. -/ +def ruleIdx (constructor : NormalizedBlockCtor) : List VExpr := + constructor.ctor.resultIndicesR source.uvars gen.elimination |>.map + fun e => e.liftN (gen.familyCount + gen.minorCount) + (gen.ruleFieldCount constructor) + +/-- The binder telescope shared by both towers of one iota rule. -/ +def ruleBinders (constructor : NormalizedBlockCtor) : List VExpr := + gen.paramsTel ++ gen.motiveTypes ++ gen.minorTypes ++ + VExpr.liftTelN (gen.familyCount + gen.minorCount) + (constructor.ctor.fieldsR source.uvars source.nparams gen.elimination) 0 + +/-- The constructor-headed major premise of one iota rule body. -/ +def ruleCtorApp (constructor : NormalizedBlockCtor) : VExpr := + VExpr.appN (.const constructor.ctor.raw.name gen.sourceLevels) + (VExpr.bvarRevRange + (gen.ruleFieldCount constructor + (gen.familyCount + gen.minorCount)) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.ruleFieldCount constructor)) + +/-- The exact left body of one generated iota rule: the owner's recursor +applied to the common arguments, the constructor's result indices, and the +constructor-headed major premise. -/ +def ruleLhsBody (constructor : NormalizedBlockCtor) : VExpr := + VExpr.appN (gen.recBase (gen.ruleFieldCount constructor) constructor.owner) + (gen.ruleIdx constructor ++ [gen.ruleCtorApp constructor]) + +/-- The generated rule's left side is exactly the shared binder telescope +over the `SimplePattern.iota` spine. -/ +theorem rule_lhs (i : Nat) (constructor : NormalizedBlockCtor) : + (gen.rule i constructor).lhs = + VExpr.lamN (gen.ruleBinders constructor) (gen.ruleLhsBody constructor) := rfl + +/-! ## The pattern of one generated iota rule -/ + +/-- The recursor constant owning one flattened constructor's iota rule. -/ +def ruleRecName (constructor : NormalizedBlockCtor) : Name := + .str (gen.familyNameAt constructor.owner) "rec" + +/-- Major-argument arity of one iota rule: shared parameters, all motives, +all minors, and the constructor's result indices. -/ +def ruleMajorArity (constructor : NormalizedBlockCtor) : Nat := + source.nparams + gen.familyCount + gen.minorCount + + (constructor.ctor.resultIndicesR source.uvars gen.elimination).length + +/-- Argument arity of one iota rule's constructor-headed major premise. -/ +def ruleArgArity (constructor : NormalizedBlockCtor) : Nat := + source.nparams + gen.ruleFieldCount constructor + +/-- The `SimplePattern` of one generated iota rule. -/ +def rulePattern (constructor : NormalizedBlockCtor) : SimplePattern := + .iota (gen.ruleRecName constructor) (gen.ruleMajorArity constructor) + constructor.ctor.raw.name (gen.ruleArgArity constructor) + +/-- The generated left body is matched by the rule's pattern, at exactly the +rule's recursor levels. -/ +theorem ruleLhsBody_matches (constructor : NormalizedBlockCtor) : + ∃ m2, ((gen.rulePattern constructor).toPattern).Matches + (gen.ruleLhsBody constructor) gen.recLevels m2 := by + rw [rulePattern, SimplePattern.toPattern_iota] + have hleft : HeadConstN (gen.ruleRecName constructor) gen.recLevels + (gen.ruleMajorArity constructor) + (VExpr.appN (gen.recBase (gen.ruleFieldCount constructor) constructor.owner) + (gen.ruleIdx constructor)) := by + have h0 : HeadConstN (gen.ruleRecName constructor) gen.recLevels 0 + (.const (gen.ruleRecName constructor) gen.recLevels) := .const + have h1 := (h0.appN (VExpr.bvarRevRange (gen.ruleFieldCount constructor) + (source.nparams + gen.familyCount + gen.minorCount))) + have h2 := h1.appN (as := gen.ruleIdx constructor) + rw [VExpr.bvarRevRange_length] at h2 + have harity : 0 + (source.nparams + gen.familyCount + gen.minorCount) + + (gen.ruleIdx constructor).length = gen.ruleMajorArity constructor := by + simp only [ruleIdx, ruleMajorArity, List.length_map]; omega + rwa [harity] at h2 + have hright : HeadConstN constructor.ctor.raw.name gen.sourceLevels + (gen.ruleArgArity constructor) (gen.ruleCtorApp constructor) := by + have h0 : HeadConstN constructor.ctor.raw.name gen.sourceLevels 0 + (.const constructor.ctor.raw.name gen.sourceLevels) := .const + have h1 := h0.appN (as := VExpr.bvarRevRange + (gen.ruleFieldCount constructor + (gen.familyCount + gen.minorCount)) + source.nparams ++ VExpr.bvarRevRange 0 (gen.ruleFieldCount constructor)) + rw [List.length_append, VExpr.bvarRevRange_length, VExpr.bvarRevRange_length] at h1 + have harity : 0 + (source.nparams + gen.ruleFieldCount constructor) = + gen.ruleArgArity constructor := by simp only [ruleArgArity]; omega + rwa [harity] at h1 + have hbody : gen.ruleLhsBody constructor = + .app (VExpr.appN (gen.recBase (gen.ruleFieldCount constructor) constructor.owner) + (gen.ruleIdx constructor)) + (gen.ruleCtorApp constructor) := by + rw [ruleLhsBody, VExpr.appN_append] + rfl + rw [hbody] + exact RecursorIotaPattern.matches_of hleft hright + +/-! ## Positional anatomy of the flattened constructors -/ + +/-- The checked spine assigns family ordinals positionally. -/ +theorem families_getElem?_ordinal {t : Nat} {family : NormalizedFamily} + (h : gen.families[t]? = some family) : family.view.ordinal = t := by + have h' : (pairNormalizedFamilies source.types + gen.block.checked.families.data)[t]? = some family := h + obtain ⟨-, hview⟩ := pairNormalizedFamilies_getElem? _ _ t h' + obtain ⟨type, -, hord, -, -, -, -⟩ := CheckedFamilies.data_getElem? _ t hview + simpa using hord + +/-- Position `t` of the paired family list is the `t`-th source family. -/ +theorem families_getElem?_raw {t : Nat} {family : NormalizedFamily} + (h : gen.families[t]? = some family) : source.types[t]? = some family.raw := + (pairNormalizedFamilies_getElem? source.types + gen.block.checked.families.data t h).1 + +/-- A family lookup names the owning recursor's family. -/ +theorem familyNameAt_eq {t : Nat} {family : NormalizedFamily} + (h : gen.families[t]? = some family) : + gen.familyNameAt t = family.raw.name := by + simp [familyNameAt, h] + +/-- One flattened constructor decomposes into its owner family lookup and +its position inside that family's pairing. -/ +theorem flatCtors_anatomy {constructor : NormalizedBlockCtor} + (hc : constructor ∈ gen.flatCtors) : + ∃ t family, gen.families[t]? = some family ∧ + constructor.owner = t ∧ + constructor.familyName = family.raw.name ∧ + constructor.familyIndices = family.view.indices ∧ + constructor.ctor ∈ family.ctorPairs := by + have hc' : constructor ∈ gen.families.flatMap (·.blockCtors) := hc + rw [List.mem_flatMap] at hc' + obtain ⟨family, hfamily, hmem⟩ := hc' + obtain ⟨t, ht⟩ := List.mem_iff_getElem?.1 hfamily + simp only [NormalizedFamily.blockCtors, List.mem_map] at hmem + obtain ⟨ctor, hctor, rfl⟩ := hmem + exact ⟨t, family, ht, gen.families_getElem?_ordinal ht, rfl, rfl, hctor⟩ + +/-! ## The analyzer's arity equation for pattern majors -/ + +/-- Every flattened constructor's checked result-index spine has exactly its +owner family's index arity: the analyzer's terminal `blockTarget?` equation +transports through the checked spine. -/ +theorem view_resultIndices_length {constructor : NormalizedBlockCtor} + (hc : constructor ∈ gen.flatCtors) : + constructor.ctor.view.resultIndices.length = + constructor.familyIndices.length := by + obtain ⟨t, family, ht, -, -, hindices, hmem⟩ := gen.flatCtors_anatomy hc + have ht' : (pairNormalizedFamilies source.types + gen.block.checked.families.data)[t]? = some family := ht + obtain ⟨-, hview⟩ := pairNormalizedFamilies_getElem? _ _ t ht' + obtain ⟨vtype, hvty, -, -, hvindices, hvctors, hvcore⟩ := + CheckedFamilies.data_getElem? _ t hview + rw [Nat.zero_add] at hvcore + obtain ⟨s, hs⟩ := List.mem_iff_getElem?.1 hmem + have hs' : (pairNormalizedCtors family.raw.ctors + family.view.constructors)[s]? = some constructor.ctor := hs + obtain ⟨-, hviewCtor⟩ := pairNormalizedCtors_getElem? _ _ s hs' + rw [hvctors, List.getElem?_map] at hviewCtor + obtain ⟨c₀, hc₀, hview_eq⟩ : ∃ c₀, vtype.ctors[s]? = some c₀ ∧ + CheckedCtor.ofBlock _ c₀ = constructor.ctor.view := by + cases h0 : vtype.ctors[s]? with + | none => rw [h0] at hviewCtor; cases hviewCtor + | some c₀ => rw [h0] at hviewCtor; exact ⟨c₀, rfl, by simpa using hviewCtor⟩ + simp only [blockFamilyCore, Bool.and_eq_true, beq_iff_eq, + List.all_eq_true] at hvcore + have hstage := (hvcore.2 c₀ (List.mem_of_getElem? hc₀)).2 + obtain ⟨idxs, htarget⟩ := blockStage3Ctor_result _ 0 hstage + obtain ⟨header, hheader, hlen, -⟩ := blockTarget?_length htarget + rw [familyHeaders, List.getElem?_map, hvty, Option.map_some] at hheader + have hri : constructor.ctor.view.resultIndices = + (VExpr.appArgs (VExpr.resultOf (VExpr.dropN + gen.block.normalization.view.nparams c₀.type)) []).drop + gen.block.normalization.view.nparams := by + rw [← hview_eq]; rfl + rw [hri, hindices, hvindices, List.length_drop, hlen] + cases hheader + show gen.block.normalization.view.nparams + + (ctorFields (VExpr.dropN gen.block.normalization.view.nparams + vtype.type)).length - + gen.block.normalization.view.nparams = + (ctorFields (VExpr.dropN gen.block.normalization.view.nparams + vtype.type)).length + omega + +/-- Pattern major arity through the owner family's index count. -/ +theorem ruleMajorArity_eq {constructor : NormalizedBlockCtor} + (hc : constructor ∈ gen.flatCtors) : + gen.ruleMajorArity constructor = + source.nparams + gen.familyCount + gen.minorCount + + constructor.familyIndices.length := by + simp only [ruleMajorArity, NormalizedCtor.resultIndicesR, List.length_map, + gen.view_resultIndices_length hc] + +/-! ## Name freshness of the generated inventory -/ + +include gen in +private theorem nodup_parts : + (source.types.map (·.name)).Nodup ∧ + (source.types.flatMap fun ty => ty.ctors.map (·.name)).Nodup ∧ + ∀ a ∈ (source.types.flatMap fun ty => ty.ctors.map (·.name)), + ∀ b ∈ source.types.map (fun ty => (.str ty.name "rec" : Name)), a ≠ b := by + have h := gen.blockGeneratedNames_nodup + rw [blockGeneratedNames, List.nodup_append] at h + obtain ⟨hAB, -, hdisj⟩ := h + rw [List.nodup_append] at hAB + exact ⟨hAB.1, hAB.2.1, fun a ha b hb => + hdisj a (List.mem_append.2 (.inr ha)) b hb⟩ + +/-- Family positions are recoverable from raw family names. -/ +theorem families_name_inj {t t' : Nat} {family family' : NormalizedFamily} + (h : gen.families[t]? = some family) (h' : gen.families[t']? = some family') + (hname : family.raw.name = family'.raw.name) : t = t' := by + have h1 := gen.families_getElem?_raw h + have h1' := gen.families_getElem?_raw h' + have hm : (source.types.map (·.name))[t]? = some family.raw.name := by + rw [List.getElem?_map, h1, Option.map_some] + have hm' : (source.types.map (·.name))[t']? = some family.raw.name := by + rw [List.getElem?_map, h1', Option.map_some, hname] + obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.1 hm + exact (List.getElem?_inj hlt gen.nodup_parts.1).1 (hm.trans hm'.symm) + +/-- Flattened positions are recoverable from raw constructor names. -/ +theorem flatCtors_name_inj {i i' : Nat} {c c' : NormalizedBlockCtor} + (h : gen.flatCtors[i]? = some c) (h' : gen.flatCtors[i']? = some c') + (hname : c.ctor.raw.name = c'.ctor.raw.name) : i = i' ∧ c = c' := by + have hnodup : ((source.blockConstructorConstants).map (·.name)).Nodup := by + rw [VInductDecl.blockConstructorConstants, List.map_flatMap] + exact gen.nodup_parts.2.1 + have hm : ((source.blockConstructorConstants).map (·.name))[i]? = + some c.ctor.raw.name := by + rw [List.getElem?_map, ← gen.flatCtors_map_raw, List.getElem?_map, h] + rfl + have hm' : ((source.blockConstructorConstants).map (·.name))[i']? = + some c.ctor.raw.name := by + rw [List.getElem?_map, ← gen.flatCtors_map_raw, List.getElem?_map, h', + hname] + rfl + obtain ⟨hlt, -⟩ := List.getElem?_eq_some_iff.1 hm + have hii : i = i' := (List.getElem?_inj hlt hnodup).1 (hm.trans hm'.symm) + subst hii + exact ⟨rfl, Option.some.inj (h.symm.trans h')⟩ + +/-- No family's recursor name collides with any flattened constructor's +name. -/ +theorem recName_ne_ctorName {family : NormalizedFamily} + (hfam : family ∈ gen.families) {constructor : NormalizedBlockCtor} + (hc : constructor ∈ gen.flatCtors) : + (.str family.raw.name "rec" : Name) ≠ constructor.ctor.raw.name := by + have hmemC : constructor.ctor.raw.name ∈ + source.types.flatMap fun ty => ty.ctors.map (·.name) := by + have h1 : constructor.ctor.raw ∈ source.blockConstructorConstants := by + rw [← gen.flatCtors_map_raw] + exact List.mem_map_of_mem hc + rw [VInductDecl.blockConstructorConstants, List.mem_flatMap] at h1 + obtain ⟨ty, hty, hmem⟩ := h1 + rw [List.mem_flatMap] + exact ⟨ty, hty, List.mem_map_of_mem hmem⟩ + have hmemR : (.str family.raw.name "rec" : Name) ∈ + source.types.map (fun ty => (.str ty.name "rec" : Name)) := by + have h1 : family.raw ∈ source.types := by + rw [← gen.families_map_raw] + exact List.mem_map_of_mem hfam + exact List.mem_map_of_mem h1 + intro heq + exact gen.nodup_parts.2.2 _ hmemC _ hmemR heq.symm + +/-- Two flattened constructors with the same owning recursor name share +their owner and their family's index telescope. -/ +theorem ruleRecName_inj {c c' : NormalizedBlockCtor} + (hc : c ∈ gen.flatCtors) (hc' : c' ∈ gen.flatCtors) + (h : gen.ruleRecName c = gen.ruleRecName c') : + c.owner = c'.owner ∧ c.familyIndices = c'.familyIndices := by + obtain ⟨t, family, ht, ho, -, hi, -⟩ := gen.flatCtors_anatomy hc + obtain ⟨t', family', ht', ho', -, hi', -⟩ := gen.flatCtors_anatomy hc' + rw [ruleRecName, ruleRecName, ho, ho', gen.familyNameAt_eq ht, + gen.familyNameAt_eq ht'] at h + have hnames : family.raw.name = family'.raw.name := by + injection h with h1 h2 + have ht2 : t = t' := gen.families_name_inj ht ht' hnames + subst ht2 + cases Option.some.inj (ht.symm.trans ht') + exact ⟨ho.trans ho'.symm, hi.trans hi'.symm⟩ + +/-- Rule distinctness: distinct flattened positions carry distinct +patterns. -/ +theorem rulePattern_inj {i i' : Nat} {c c' : NormalizedBlockCtor} + (h : gen.flatCtors[i]? = some c) (h' : gen.flatCtors[i']? = some c') + (heq : gen.rulePattern c = gen.rulePattern c') : i = i' ∧ c = c' := by + injection heq with h1 h2 h3 h4 + exact gen.flatCtors_name_inj h h' h3 + +/-! ## Rule payloads: RHS templates and agreement checks -/ + +/-- Closedness inputs for one certified block's rule payloads: the towers a +rule's RHS template and checks embed as fixed template constants. Concrete +fixtures discharge this bundle by `decide`; the pattern-soundness milestone +derives it from the staged environment's rule well-formedness. -/ +structure RuleClosure : Prop where + rhs_closed : ∀ ⦃i : Nat⦄ ⦃constructor : NormalizedBlockCtor⦄, + gen.flatCtors[i]? = some constructor → + ((gen.rule i constructor).rhs).ClosedN 0 + idxTower_closed : ∀ ⦃constructor : NormalizedBlockCtor⦄, + constructor ∈ gen.flatCtors → ∀ e ∈ gen.ruleIdx constructor, + (VExpr.lamN (gen.ruleBinders constructor) e).ClosedN 0 + +/-- The template capture list shared by every payload tower: the recursor +side's parameters, motives, and minors, then the major premise's fields. -/ +def captureArgs (constructor : NormalizedBlockCtor) : + List (((gen.rulePattern constructor).toPattern).RHS) := + ((Pattern.varNPaths (.const (gen.ruleRecName constructor)) + (gen.ruleMajorArity constructor)).take + (source.nparams + gen.familyCount + gen.minorCount)).map + (fun path => .var (.inl path)) ++ + ((Pattern.varNPaths (.const constructor.ctor.raw.name) + (gen.ruleArgArity constructor)).drop source.nparams).map + (fun path => .var (.inr path)) + +/-- The RHS template of one rule: the registered right tower applied to the +captured common arguments and fields. -/ +def ruleRHS (hcl : gen.RuleClosure) {i : Nat} {constructor : NormalizedBlockCtor} + (h : gen.flatCtors[i]? = some constructor) : + ((gen.rulePattern constructor).toPattern).RHS := + Pattern.RHS.appN (.fixed ((gen.rule i constructor).rhs) (hcl.rhs_closed h)) + (gen.captureArgs constructor) + +/-- The check list of one rule: the major premise's parameters must agree +with the recursor side's parameters, and the recursor side's index arguments +must agree with the constructor's computed result indices (as fixed index +towers applied to the captures). -/ +def ruleCheck (hcl : gen.RuleClosure) {constructor : NormalizedBlockCtor} + (hc : constructor ∈ gen.flatCtors) : + ((gen.rulePattern constructor).toPattern).Check := + let recPaths := Pattern.varNPaths (.const (gen.ruleRecName constructor)) + (gen.ruleMajorArity constructor) + let ctorPaths := Pattern.varNPaths (.const constructor.ctor.raw.name) + (gen.ruleArgArity constructor) + let common := source.nparams + gen.familyCount + gen.minorCount + let idxChecks := + ((gen.ruleIdx constructor).attach.zip (recPaths.drop common)).foldr + (fun ep rest => + .defeq (.var (.inl ep.2)) + (Pattern.RHS.appN + (.fixed (VExpr.lamN (gen.ruleBinders constructor) ep.1.1) + (hcl.idxTower_closed hc ep.1.1 ep.1.2)) + (gen.captureArgs constructor)) rest) + .true + ((ctorPaths.take source.nparams).zip (recPaths.take source.nparams)).foldr + (fun pr rest => .defeq (.var (.inr pr.1)) (.var (.inl pr.2)) rest) + idxChecks + +/-- Position `i` of the certified block's flattened constructor list. -/ +abbrev ruleEntry (i : Nat) (constructor : NormalizedBlockCtor) : Prop := + gen.flatCtors[i]? = some constructor + +/-- A decidable sufficient condition for `RuleClosure`, discharging concrete +fixtures by evaluation. -/ +theorem RuleClosure.of_all + (h1 : gen.flatCtors.zipIdx.all (fun ic => + decide (((gen.rule ic.2 ic.1).rhs).ClosedN 0)) = true) + (h2 : gen.flatCtors.all (fun c => (gen.ruleIdx c).all fun e => + decide ((VExpr.lamN (gen.ruleBinders c) e).ClosedN 0)) = true) : + gen.RuleClosure := by + constructor + · intro i constructor h + have hmem : (constructor, i) ∈ gen.flatCtors.zipIdx := by + apply List.mem_of_getElem? (i := i) + rw [List.getElem?_zipIdx, h, Option.map_some, Nat.zero_add] + exact of_decide_eq_true (List.all_eq_true.1 h1 _ hmem) + · intro constructor hc e he + exact of_decide_eq_true (List.all_eq_true.1 (List.all_eq_true.1 h2 _ hc) _ he) + +/-- The pattern set of one certified block: each flattened constructor's +rule pattern with its template and checks. -/ +inductive IotaPat (hcl : gen.RuleClosure) : + (p : Pattern) → p.RHS × p.Check → Prop where + | mk {i : Nat} {constructor : NormalizedBlockCtor} + (h : gen.ruleEntry i constructor) : + IotaPat hcl ((gen.rulePattern constructor).toPattern) + (gen.ruleRHS hcl h, gen.ruleCheck hcl (List.mem_of_getElem? h)) + +/-! ## The `Params` obligations for one certified block -/ + +/-- `Params.pat_simple` for the block's pattern set. -/ +theorem IotaPat.pat_simple {hcl : gen.RuleClosure} {p : Pattern} + {r : p.RHS × p.Check} (H : gen.IotaPat hcl p r) : + ∃ sp : SimplePattern, p = sp.toPattern := by + cases H with | mk h => exact ⟨_, rfl⟩ + +/-- Rule recovery: a pattern in the block's set determines its flattened +rule position and constructor. -/ +theorem IotaPat.recover {hcl : gen.RuleClosure} {p : Pattern} + {r : p.RHS × p.Check} (H : gen.IotaPat hcl p r) : + ∃ (i : Nat) (constructor : NormalizedBlockCtor), + gen.flatCtors[i]? = some constructor ∧ + p = (gen.rulePattern constructor).toPattern ∧ + ∀ (i' : Nat) (constructor' : NormalizedBlockCtor), + gen.flatCtors[i']? = some constructor' → + (gen.rulePattern constructor').toPattern = p → + i' = i ∧ constructor' = constructor := by + cases H with | @mk i constructor h => + refine ⟨i, constructor, h, rfl, ?_⟩ + intro i' constructor' h' heq + have := RecursorIotaPattern.inj heq + exact gen.flatCtors_name_inj h' h this.2.2.1 + +/-- `Params.pat_uniq` for the block's pattern set. -/ +theorem IotaPat.pat_uniq {hcl : gen.RuleClosure} {p₁ p₂ p₃ p₄ : Pattern} + {r : p₁.RHS × p₁.Check} {r' : p₂.RHS × p₂.Check} + (H1 : gen.IotaPat hcl p₁ r) (H2 : gen.IotaPat hcl p₂ r') + (H3 : Subpattern p₃ p₁) (H4 : p₂.inter p₃ = some p₄) : + p₁ = p₂ ∧ p₂ = p₃ ∧ r ≍ r' := by + cases H1 with | @mk i c h => + cases H2 with | @mk i' c' h' => + rcases RecursorIotaPattern.subpattern_inv H3 with rfl | ⟨j, hj, rfl⟩ | ⟨j, hj, rfl⟩ + · obtain ⟨hR, hM, hC, hN, rfl⟩ := RecursorIotaPattern.inter_some H4 + obtain ⟨rfl, rfl⟩ := gen.flatCtors_name_inj h' h hC + exact ⟨rfl, rfl, HEq.rfl⟩ + · obtain ⟨hb, hj'⟩ := RecursorIotaPattern.inter_varN_const_some H4 + obtain ⟨-, hIdx⟩ := gen.ruleRecName_inj (List.mem_of_getElem? h) + (List.mem_of_getElem? h') hb + have hM : gen.ruleMajorArity c' = gen.ruleMajorArity c := by + rw [gen.ruleMajorArity_eq (List.mem_of_getElem? h'), + gen.ruleMajorArity_eq (List.mem_of_getElem? h), hIdx] + omega + · obtain ⟨hb, -⟩ := RecursorIotaPattern.inter_varN_const_some H4 + obtain ⟨t', family', ht', ho', -, -, -⟩ := + gen.flatCtors_anatomy (List.mem_of_getElem? h') + have hrec : gen.ruleRecName c' = (.str family'.raw.name "rec" : Name) := by + rw [ruleRecName, ho', gen.familyNameAt_eq ht'] + refine absurd ?_ (gen.recName_ne_ctorName (List.mem_of_getElem? ht') + (List.mem_of_getElem? h)) + rw [← hrec, hb] + +/-- `Params.pat_app_l` for the block's pattern set. -/ +theorem IotaPat.pat_app_l {hcl : gen.RuleClosure} {p : Pattern} + {r : p.RHS × p.Check} {p₁ p₂ p₃ p₄ : Pattern} + (H : gen.IotaPat hcl p r) (h : Subpattern (.app p₁ p₂) p) : + ¬Subpattern (.app p₃ p₄) p₁ := by + cases H with | @mk i c hi => + obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h + intro hsub + obtain ⟨j', hj', heq'⟩ := hsub.varN_const_le + cases j' <;> exact absurd heq' (by simp [Pattern.varN]) + +/-- `Params.pat_app_l_uniq` for the block's pattern set. -/ +theorem IotaPat.pat_app_l_uniq {hcl : gen.RuleClosure} {p p' : Pattern} + {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check} {p₁ p₂ p₁' p₂' p₃ : Pattern} + (H : gen.IotaPat hcl p r) (H' : gen.IotaPat hcl p' r') + (h : Subpattern (.app p₁ p₂) p) (h' : Subpattern (.app p₁' p₂') p') + (h₃ : Subpattern (.var p₃) p₁) : p₁'.inter p₃ = none := by + cases H with | @mk i c hi => + cases H' with | @mk i' c' hi' => + obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h + obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h' + obtain ⟨j, hj, heq⟩ := h₃.varN_const_le + cases j with + | zero => exact absurd heq (by simp [Pattern.varN]) + | succ j'' => + rw [show Pattern.varN (.const (gen.ruleRecName c)) (j'' + 1) = + .var (Pattern.varN (.const (gen.ruleRecName c)) j'') from rfl] at heq + injection heq with heq' + subst heq' + by_cases hname : gen.ruleRecName c' = gen.ruleRecName c + · obtain ⟨-, hIdx⟩ := gen.ruleRecName_inj (List.mem_of_getElem? hi') + (List.mem_of_getElem? hi) hname + have hM : gen.ruleMajorArity c' = gen.ruleMajorArity c := by + rw [gen.ruleMajorArity_eq (List.mem_of_getElem? hi'), + gen.ruleMajorArity_eq (List.mem_of_getElem? hi), hIdx] + rw [hname] + exact Pattern.varN_const_inter_of_ne_arity (by omega) _ _ + · exact Pattern.varN_const_inter_of_ne_name hname _ _ + +/-- `Params.pat_app_uniq` for the block's pattern set. -/ +theorem IotaPat.pat_app_uniq {hcl : gen.RuleClosure} {p p' : Pattern} + {r : p.RHS × p.Check} {r' : p'.RHS × p'.Check} + {p₁ p₂ p₁' p₂' p₃ p₃' : Pattern} + (H : gen.IotaPat hcl p r) (H' : gen.IotaPat hcl p' r') + (h : Subpattern (.app p₁ p₂) p) (h' : Subpattern (.app p₁' p₂') p') + (h₃ : Subpattern p₃ p₁) (h₃' : Subpattern p₃' p₂') : p₃.inter p₃' = none := by + cases H with | @mk i c hi => + cases H' with | @mk i' c' hi' => + obtain ⟨rfl, -⟩ := RecursorIotaPattern.app_subpattern h + obtain ⟨-, rfl⟩ := RecursorIotaPattern.app_subpattern h' + obtain ⟨j, hj, rfl⟩ := h₃.varN_const_le + obtain ⟨j', hj', rfl⟩ := h₃'.varN_const_le + refine Pattern.varN_const_inter_of_ne_name ?_ _ _ + obtain ⟨t, family, ht, ho, -, -, -⟩ := + gen.flatCtors_anatomy (List.mem_of_getElem? hi) + have hrec : gen.ruleRecName c = (.str family.raw.name "rec" : Name) := by + rw [ruleRecName, ho, gen.familyNameAt_eq ht] + rw [hrec] + exact gen.recName_ne_ctorName (List.mem_of_getElem? ht) + (List.mem_of_getElem? hi') + +/-! ## Axiom closures of the generic pattern facts -/ + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.ruleLhsBody_matches' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms ruleLhsBody_matches + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.view_resultIndices_length' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms view_resultIndices_length + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.rulePattern_inj' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms rulePattern_inj + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_simple' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms IotaPat.pat_simple + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.recover' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms IotaPat.recover + +/-- +info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_uniq' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms IotaPat.pat_uniq + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_app_l' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms IotaPat.pat_app_l + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_app_l_uniq' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms IotaPat.pat_app_l_uniq + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.IotaPat.pat_app_uniq' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms IotaPat.pat_app_uniq + +end BlockGenerationChecked + +end VInductDecl + +end Lean4Lean diff --git a/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean b/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean new file mode 100644 index 00000000..4b8354ab --- /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 87e77492..2c2c5375 100644 --- a/Lean4Lean/Theory/Typing/Pattern.lean +++ b/Lean4Lean/Theory/Typing/Pattern.lean @@ -230,3 +230,215 @@ inductive SimplePattern where def SimplePattern.toPattern : SimplePattern → Pattern | .defn c => .const c | .iota r m c n => .app (.varN (.const r) m) (.varN (.const c) n) + +/-! ## Shape helpers for generated recursor patterns + +`HeadConstN`, `HeadConst`, `of_varN_matches`, `RecursorIotaPattern`, and +`matches_shape` form the implementation-independent shape layer consumed by +the generated iota patterns of a certified inductive block +(`Theory/Typing/InductivePattern.lean`). They characterize matching against +`Pattern.varN` towers and `SimplePattern.iota` patterns without referring to +any generator data. -/ + +/-- `HeadConstN c ls n e`: `e` is the constant `c` at levels `ls` applied to +exactly `n` arguments. This is the expression shape captured by matching the +pattern `Pattern.varN (.const c) n`. -/ +inductive HeadConstN (c : Name) (ls : List VLevel) : Nat → VExpr → Prop where + | const : HeadConstN c ls 0 (.const c ls) + | app : HeadConstN c ls n f → HeadConstN c ls (n+1) (.app f a) + +/-- `e` is an application spine headed by the constant `c`. -/ +def HeadConst (c : Name) (e : VExpr) : Prop := ∃ ls n, HeadConstN c ls n e + +/-- Matching a `varN` tower of a constant captures exactly a `HeadConstN` +spine whose head levels are the pattern's level assignment. -/ +theorem Pattern.of_varN_matches {c : Name} : + ∀ {n : Nat} {e : VExpr} {m2}, (Pattern.varN (.const c) n).Matches e m1 m2 → + HeadConstN c m1 n e := by + intro n + induction n with + | zero => intro e m2 H; cases H; exact .const + | succ n ih => intro e m2 H; cases H with | var h => exact .app (ih h) + +/-- Every `HeadConstN` spine matches its `varN` tower. -/ +theorem HeadConstN.matches : HeadConstN c ls n e → + ∃ m2, (Pattern.varN (.const c) n).Matches e ls m2 + | .const => ⟨_, .const⟩ + | .app h => let ⟨_, h'⟩ := h.matches; ⟨_, .var h'⟩ + +/-- The capture paths of an `n`-ary `varN` tower in argument order (outermost +application first): matching assigns the `t`-th entry the `t`-th spine +argument. -/ +def Pattern.varNPaths (p : Pattern) : ∀ n, List (Pattern.Path (p.varN n)) + | 0 => [] + | n+1 => (varNPaths p n).map some ++ [none] + +@[simp] theorem Pattern.varNPaths_length (p : Pattern) : + ∀ n, (varNPaths p n).length = n + | 0 => rfl + | n+1 => by + show ((varNPaths p n).map some ++ [none]).length = n + 1 + rw [List.length_append, List.length_map, varNPaths_length p n]; rfl + +/-- The exact pattern of one generated iota rule: the recursor constant +applied to `major` arguments (parameters, motives, minors, and the +constructor's result indices), with a `ctor`-headed major premise carrying +`args` arguments. Definitionally `(SimplePattern.iota recursor major ctor +args).toPattern`. -/ +def RecursorIotaPattern (recursor : Name) (major : Nat) + (ctor : Name) (args : Nat) : Pattern := + .app (.varN (.const recursor) major) (.varN (.const ctor) args) + +theorem SimplePattern.toPattern_iota : + (SimplePattern.iota r m c n).toPattern = RecursorIotaPattern r m c n := rfl + +/-- Match inversion for an iota pattern: the expression is exactly a +recursor-headed spine at the pattern's level assignment whose last argument +is a constructor-headed spine (at unconstrained levels). -/ +theorem RecursorIotaPattern.matches_shape + (H : (RecursorIotaPattern r mj c n).Matches e m1 m2) : + ∃ f a ls, e = .app f a ∧ HeadConstN r m1 mj f ∧ HeadConstN c ls n a := by + cases H with + | app h1 h2 => + exact ⟨_, _, _, rfl, Pattern.of_varN_matches h1, Pattern.of_varN_matches h2⟩ + +/-- Match construction for an iota pattern from the two head spines. -/ +theorem RecursorIotaPattern.matches_of + (h1 : HeadConstN r ls mj f) (h2 : HeadConstN c ls' n a) : + ∃ m2, (RecursorIotaPattern r mj c n).Matches (.app f a) ls m2 := + let ⟨_, hf⟩ := h1.matches + let ⟨_, ha⟩ := h2.matches + ⟨_, .app hf ha⟩ + +/-- Subpatterns of a constant `varN` tower are exactly its shorter towers. -/ +theorem Subpattern.varN_const_le : + ∀ {n}, Subpattern p (Pattern.varN (.const c) n) → + ∃ j, j ≤ n ∧ p = Pattern.varN (.const c) j := by + intro n + induction n with + | zero => intro H; cases H; exact ⟨0, Nat.le_refl _, rfl⟩ + | succ n ih => + intro H + cases H with + | refl => exact ⟨n+1, Nat.le_refl _, rfl⟩ + | varL h => + let ⟨j, hj, hp⟩ := ih h + exact ⟨j, Nat.le_succ_of_le hj, hp⟩ + +/-- Subpattern classification for an iota pattern: the whole pattern, a +prefix of the recursor head, or a prefix of the constructor spine. -/ +theorem RecursorIotaPattern.subpattern_inv + (H : Subpattern p (RecursorIotaPattern r mj c n)) : + p = RecursorIotaPattern r mj c n ∨ + (∃ j, j ≤ mj ∧ p = .varN (.const r) j) ∨ + (∃ j, j ≤ n ∧ p = .varN (.const c) j) := by + cases H with + | refl => exact .inl rfl + | appL h => exact .inr (.inl h.varN_const_le) + | appR h => exact .inr (.inr h.varN_const_le) + +/-- Two constant `varN` towers intersect only when they agree exactly. -/ +theorem Pattern.varN_const_inter_some : + ∀ {n n' p}, (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') = some p → + c = c' ∧ n = n' ∧ p = Pattern.varN (.const c) n := by + intro n + induction n with + | zero => + intro n' p h + cases n' with + | zero => + simp [Pattern.varN, Pattern.inter] at h + exact ⟨h.1, rfl, h.2.symm⟩ + | succ n' => simp [Pattern.varN, Pattern.inter] at h + | succ n ih => + intro n' p h + cases n' with + | zero => simp [Pattern.varN, Pattern.inter] at h + | succ n' => + simp only [Pattern.varN, Pattern.inter, bind, Option.bind_eq_some_iff, + Option.pure_def, Option.some.injEq] at h + obtain ⟨q, hq, rfl⟩ := h + obtain ⟨rfl, rfl, rfl⟩ := ih hq + exact ⟨rfl, rfl, rfl⟩ + +theorem Pattern.varN_const_inter_of_ne_name (h : c ≠ c') (n n' : Nat) : + (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') = none := by + cases e : (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') with + | none => rfl + | some p => exact absurd (varN_const_inter_some e).1 h + +theorem Pattern.varN_const_inter_of_ne_arity (h : n ≠ n') (c c' : Name) : + (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') = none := by + cases e : (Pattern.varN (.const c) n).inter (Pattern.varN (.const c') n') with + | none => rfl + | some p => exact absurd (varN_const_inter_some e).2.1 h + +/-- An application pattern intersects a constant `varN` tower only through a +positive tower whose inner tower intersects the function part. -/ +theorem Pattern.app_inter_varN_const_some {f a : Pattern} + (h : (Pattern.app f a).inter (Pattern.varN (.const c) n) = some p) : + ∃ n' q, n = n' + 1 ∧ f.inter (Pattern.varN (.const c) n') = some q ∧ + p = .app q a := by + cases n with + | zero => simp [Pattern.varN, Pattern.inter] at h + | succ n' => + simp only [Pattern.varN, Pattern.inter, bind, Option.bind_eq_some_iff, + Option.pure_def, Option.some.injEq] at h + obtain ⟨q, hq, rfl⟩ := h + exact ⟨n', q, rfl, hq, rfl⟩ + +/-- Two iota patterns intersect only when they agree exactly. -/ +theorem RecursorIotaPattern.inter_some + (h : (RecursorIotaPattern r mj c n).inter (RecursorIotaPattern r' mj' c' n') = some p) : + r = r' ∧ mj = mj' ∧ c = c' ∧ n = n' ∧ p = RecursorIotaPattern r mj c n := by + simp only [RecursorIotaPattern, Pattern.inter, bind, Option.bind_eq_some_iff, + Option.pure_def, Option.some.injEq] at h + obtain ⟨q1, h1, q2, h2, rfl⟩ := h + obtain ⟨rfl, rfl, rfl⟩ := Pattern.varN_const_inter_some h1 + obtain ⟨rfl, rfl, rfl⟩ := Pattern.varN_const_inter_some h2 + exact ⟨rfl, rfl, rfl, rfl, rfl⟩ + +/-- An iota pattern intersects a constant `varN` tower only at a tower whose +inner arity is the pattern's major arity with the recursor's name. -/ +theorem RecursorIotaPattern.inter_varN_const_some + (h : (RecursorIotaPattern r mj c n).inter (Pattern.varN (.const b) j) = some p) : + b = r ∧ j = mj + 1 := by + obtain ⟨j', q, rfl, hq, rfl⟩ := Pattern.app_inter_varN_const_some h + obtain ⟨rfl, rfl, rfl⟩ := Pattern.varN_const_inter_some hq + exact ⟨rfl, rfl⟩ + +/-- Constant `varN` towers are injective in the head name and the arity. -/ +theorem Pattern.varN_const_inj {c c' : Name} : + ∀ {n n' : Nat}, Pattern.varN (.const c) n = Pattern.varN (.const c') n' → + c = c' ∧ n = n' + | 0, 0, h => by cases h; exact ⟨rfl, rfl⟩ + | 0, n'+1, h => absurd h (by simp [Pattern.varN]) + | n+1, 0, h => absurd h (by simp [Pattern.varN]) + | n+1, n'+1, h => by + injection h with h1 + obtain ⟨rfl, rfl⟩ := Pattern.varN_const_inj h1 + exact ⟨rfl, rfl⟩ + +/-- Iota patterns are injective in all four components. -/ +theorem RecursorIotaPattern.inj + (h : RecursorIotaPattern r mj c n = RecursorIotaPattern r' mj' c' n') : + r = r' ∧ mj = mj' ∧ c = c' ∧ n = n' := by + injection h with h1 h2 + obtain ⟨rfl, rfl⟩ := Pattern.varN_const_inj h1 + obtain ⟨rfl, rfl⟩ := Pattern.varN_const_inj h2 + exact ⟨rfl, rfl, rfl, rfl⟩ + +/-- The only application subpattern of an iota pattern is the pattern +itself. -/ +theorem RecursorIotaPattern.app_subpattern + (H : Subpattern (.app p₁ p₂) (RecursorIotaPattern r mj c n)) : + p₁ = .varN (.const r) mj ∧ p₂ = .varN (.const c) n := by + rcases RecursorIotaPattern.subpattern_inv H with heq | ⟨j, hj, heq⟩ | ⟨j, hj, heq⟩ + · injection heq with h1 h2; exact ⟨h1, h2⟩ + · cases j <;> exact absurd heq (by simp [Pattern.varN]) + · cases j <;> exact absurd heq (by simp [Pattern.varN]) + +/-- Apply an RHS template head to a list of template arguments. -/ +def Pattern.RHS.appN {p : Pattern} (f : p.RHS) : List p.RHS → p.RHS + | [] => f + | a :: as => Pattern.RHS.appN (.app f a) as diff --git a/plans/roadmap.md b/plans/roadmap.md index f4c7a2bb..f59c6663 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 24/51] 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 00000000..d5c34712 --- /dev/null +++ b/Lean4Lean/Theory/Typing/InductivePatternEnv.lean @@ -0,0 +1,239 @@ +import Lean4Lean.Theory.Typing.InductivePatternWF + +/-! # The block-local pattern environment assembler + +`assembleEnv` builds an environment whose defeq set consists of exactly one +certified block's generated iota rules plus separately certified extension +rules over a defeq-free constant base. The exposed helpers are the ones +Church–Rosser instantiation and downstream consumers need: + +* `assembleEnv_defeqs` inverts the assembled defeq set exactly: a registered + defeq is a generated rule, an extension, or a base defeq — nothing else. +* `assembleEnv_WF` preserves ordering through the block phases and the + extension fold, given the block's semantic package and each extension's + well-formedness. +* `AssembledPat` is the union pattern set. The block half carries the full + L4L-10A obligations and `pat_wf`; the extension half carries each + certificate's own pattern payload, with `CertifiedExtension.covers` + recording the spine-level coverage equation that `extra_pat` demands of + it. No open-environment `Params` instance is installed. -/ + +namespace Lean4Lean + +namespace VInductDecl + +/-- One separately certified extension rule for an assembled environment: +its registered defeq, a simple pattern, the pattern payload, and the exact +spine-level coverage equation (every universe instantiation of the defeq's +left side matches the pattern, and its right side is the applied +template). Check obligations (`Check.OK`) are discharged by the consumer at +instantiation time. -/ +structure CertifiedExtension where + df : VDefEq + pat : SimplePattern + rhs : (pat.toPattern).RHS + check : (pat.toPattern).Check + covers : ∀ (ls : List VLevel), ls.length = df.uvars → + ∃ m1 m2, (pat.toPattern).Matches (df.lhs.instL ls) m1 m2 ∧ + df.rhs.instL ls = rhs.apply m1 m2 + +namespace BlockGenerationChecked + +variable {source : VInductDecl} (gen : source.BlockGenerationChecked) + +/-- The assembled block-local environment: dependency constants from the +base, the block's four insertion phases, and the certified extension +defeqs. -/ +def assembleEnv (base : VEnv) (exts : List CertifiedExtension) : + Option VEnv := do + let env ← base.addInductBlockGeneration gen + return exts.foldl (fun env ext => env.addDefEq ext.df) env + +/-! ## Defeq-set inversion -/ + +private theorem addConst_defeqs {env env' : VEnv} {n : Name} {ci : VConstant} + (h : env.addConst n ci = some env') {df : VDefEq} : + env'.defeqs df ↔ env.defeqs df := by + unfold VEnv.addConst at h + split at h + · cases h + · cases h + exact Iff.rfl + +private theorem foldlM_addConst_defeqs {α : Type _} (name : α → Name) + (ci : α → VConstant) : + ∀ (xs : List α) {env env' : VEnv}, + xs.foldlM (fun env x => env.addConst (name x) (ci x)) env = some env' → + ∀ {df : VDefEq}, (env'.defeqs df ↔ env.defeqs df) + | [], env, env', h, df => by cases h; exact Iff.rfl + | x :: xs, env, env', h, df => by + rw [List.foldlM_cons] at h + rcases Option.bind_eq_some_iff.1 h with ⟨envx, hx, hrest⟩ + exact (foldlM_addConst_defeqs name ci xs hrest).trans (addConst_defeqs hx) + +private theorem foldl_addDefEq_defeqs : + ∀ (dfs : List VDefEq) (env : VEnv) (df : VDefEq), + ((dfs.foldl VEnv.addDefEq env).defeqs df ↔ df ∈ dfs ∨ env.defeqs df) + | [], env, df => by simp + | d :: dfs, env, df => by + rw [List.foldl_cons, foldl_addDefEq_defeqs dfs (env.addDefEq d) df] + show _ ∨ (df = d ∨ _) ↔ _ + rw [List.mem_cons] + constructor + · rintro (h | h | h) + · exact .inl (.inr h) + · exact .inl (.inl h) + · exact .inr h + · rintro ((h | h) | h) + · exact .inr (.inl h) + · exact .inl h + · exact .inr (.inr h) + +/-- Registered defeqs of a completed block transaction are exactly the +generated rules over the base's. -/ +theorem addInductBlockGeneration_defeqs {base env₁ : VEnv} + (hadd : base.addInductBlockGeneration gen = some env₁) (df : VDefEq) : + env₁.defeqs df ↔ df ∈ gen.generatedRules ∨ base.defeqs df := by + rcases VEnv.addInductBlockGeneration_trace hadd with ⟨H⟩ + rw [← H.addRules, foldl_addDefEq_defeqs] + refine or_congr Iff.rfl ?_ + exact ((foldlM_addConst_defeqs _ _ _ H.addRecs).trans + ((foldlM_addConst_defeqs _ _ _ H.addCtors).trans + (foldlM_addConst_defeqs _ _ _ H.addTypes))) + +/-- The assembled defeq set, inverted exactly. -/ +theorem assembleEnv_defeqs {base env' : VEnv} + {exts : List CertifiedExtension} + (hadd : gen.assembleEnv base exts = some env') (df : VDefEq) : + env'.defeqs df ↔ + df ∈ gen.generatedRules ∨ (∃ ext ∈ exts, df = ext.df) ∨ + base.defeqs df := by + unfold assembleEnv at hadd + rcases Option.bind_eq_some_iff.1 hadd with ⟨env₁, h₁, h₂⟩ + cases Option.some.inj h₂ + have hfold : ∀ (es : List CertifiedExtension) (env : VEnv), + ((es.foldl (fun env ext => env.addDefEq ext.df) env).defeqs df ↔ + (∃ ext ∈ es, df = ext.df) ∨ env.defeqs df) := by + intro es + induction es with + | nil => intro env; simp + | cons e es ih => + intro env + rw [List.foldl_cons, ih (env.addDefEq e.df)] + show _ ∨ (df = e.df ∨ _) ↔ _ + constructor + · rintro (⟨ext, hm, rfl⟩ | rfl | hbase) + · exact .inl ⟨ext, .tail _ hm, rfl⟩ + · exact .inl ⟨e, .head _, rfl⟩ + · exact .inr hbase + · rintro (⟨ext, hm, rfl⟩ | hbase) + · rcases List.mem_cons.1 hm with rfl | hm + · exact .inr (.inl rfl) + · exact .inl ⟨ext, hm, rfl⟩ + · exact .inr (.inr hbase) + rw [hfold, gen.addInductBlockGeneration_defeqs h₁] + constructor + · rintro (h | h | h) + · exact .inr (.inl h) + · exact .inl h + · exact .inr (.inr h) + · rintro (h | h | h) + · exact .inr (.inl h) + · exact .inl h + · exact .inr (.inr h) + +/-- A defeq-free base makes the assembled defeq set exactly the generated +rules plus the certified extensions. -/ +theorem assembleEnv_defeq_cases {base env' : VEnv} + {exts : List CertifiedExtension} + (hadd : gen.assembleEnv base exts = some env') + (hbase : ∀ df, ¬base.defeqs df) {df : VDefEq} + (hdf : env'.defeqs df) : + df ∈ gen.generatedRules ∨ ∃ ext ∈ exts, df = ext.df := by + rcases (gen.assembleEnv_defeqs hadd df).1 hdf with h | h | h + · exact .inl h + · exact .inr h + · exact absurd h (hbase df) + +/-! ## Ordering -/ + +/-- The assembled environment is ordered: the block transaction preserves +ordering through its four phases, and each certified extension is well +formed over the post-block environment. -/ +theorem assembleEnv_WF {base : VEnv} (henv : base.Ordered) + {blockEnv : VEnv} (hgen : gen.WF base blockEnv) + {exts : List CertifiedExtension} {env₁ : VEnv} + (hadd₁ : base.addInductBlockGeneration gen = some env₁) + (hexts : ∀ ext ∈ exts, ext.df.WF env₁) : + ∃ env', gen.assembleEnv base exts = some env' ∧ env'.Ordered := by + refine ⟨exts.foldl (fun env ext => env.addDefEq ext.df) env₁, ?_, ?_⟩ + · unfold assembleEnv + rw [hadd₁] + rfl + · have hord₁ : env₁.Ordered := + VEnv.addInductBlockGeneration_WF henv hgen hadd₁ + have hmap : exts.foldl (fun env ext => env.addDefEq ext.df) env₁ = + (exts.map (·.df)).foldl VEnv.addDefEq env₁ := by + rw [List.foldl_map] + rw [hmap] + exact VInductDecl.rulesFold_WF _ hord₁ + (fun df hdf => by + rcases List.mem_map.1 hdf with ⟨ext, hm, rfl⟩ + exact hexts ext hm) + +/-! ## The union pattern set -/ + +/-- The assembled pattern set: the block's iota patterns with their L4L-10A +payloads, plus each certified extension's pattern payload. -/ +inductive AssembledPat (hcl : gen.RuleClosure) + (exts : List CertifiedExtension) : + (p : Pattern) → p.RHS × p.Check → Prop where + | rule {p : Pattern} {r : p.RHS × p.Check} : + gen.IotaPat hcl p r → AssembledPat hcl exts p r + | ext (ext : CertifiedExtension) (hmem : ext ∈ exts) : + AssembledPat hcl exts (ext.pat.toPattern) (ext.rhs, ext.check) + +/-- `Params.pat_simple` for the assembled set. -/ +theorem AssembledPat.pat_simple {hcl : gen.RuleClosure} + {exts : List CertifiedExtension} {p : Pattern} {r : p.RHS × p.Check} + (H : gen.AssembledPat hcl exts p r) : + ∃ sp : SimplePattern, p = sp.toPattern := by + cases H with + | rule h => exact h.pat_simple + | ext ext hmem => exact ⟨ext.pat, rfl⟩ + +/-- Extension defeqs of the assembled set satisfy the spine-level +`extra_pat` equation through their certificates. -/ +theorem AssembledPat.ext_covers {hcl : gen.RuleClosure} + {exts : List CertifiedExtension} {ext : CertifiedExtension} + (hmem : ext ∈ exts) {ls : List VLevel} (hls : ls.length = ext.df.uvars) : + ∃ p r m1 m2, gen.AssembledPat hcl exts p r ∧ + p.Matches (ext.df.lhs.instL ls) m1 m2 ∧ + ext.df.rhs.instL ls = r.1.apply m1 m2 := by + obtain ⟨m1, m2, hmatch, hrhs⟩ := ext.covers ls hls + exact ⟨ext.pat.toPattern, (ext.rhs, ext.check), m1, m2, + .ext ext hmem, hmatch, hrhs⟩ + +end BlockGenerationChecked + +end VInductDecl + +end Lean4Lean + +/-! ## Axiom closures -/ + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_defeqs' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_defeqs + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_WF' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_WF + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_simple' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.pat_simple + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.ext_covers' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.AssembledPat.ext_covers diff --git a/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean b/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean index 4b8354ab..ed0c9574 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 00000000..519253da --- /dev/null +++ b/Lean4Lean/Theory/Typing/InductivePatternWF.lean @@ -0,0 +1,872 @@ +import Lean4Lean.Theory.Typing.InductivePattern +import Lean4Lean.Theory.Typing.UniqueTyping + +/-! # Pattern soundness for generated iota rules + +The typed β-collapse layer for L4L-10B: applying a lambda tower to a +well-typed argument spine is definitionally equal to the iterated +instantiation of its body (`IsDefEq.appN_lamN`), applications are +congruent along spines (`IsDefEq.appN_congr`, `IsDefEq.appN_defEq` over +`SpineDefEq`), and a matched pattern's captures are exactly the spine +arguments (`varN_matches_paths`). `pat_wf` then proves that a successful +match whose checks hold is definitionally equal to its RHS template — by +applying the registered `addInduct` rule tower to the captured arguments +and β-collapsing both readings. -/ + +namespace Lean4Lean + +open VExpr + +namespace VExpr + +/-- Instantiation pushes under a lambda telescope, mirroring +`instN_forallN`. -/ +theorem instN_lamN (a : VExpr) : ∀ (tel : List VExpr) (X : VExpr) (k : Nat), + (lamN tel X).inst a k = lamN (instTelN a tel k) (X.inst a (k + tel.length)) + | [], _, _ => rfl + | A :: tel, X, k => by + show VExpr.lam _ _ = VExpr.lam _ _ + rw [instN_lamN a tel X (k+1), + show k+1+tel.length = k+(tel.length+1) from by omega] + rfl + +/-- Universe instantiation pushes under a lambda telescope. -/ +theorem instL_lamN (ls : List VLevel) : ∀ (As : List VExpr) (e : VExpr), + (lamN As e).instL ls = lamN (As.map (instL ls)) (e.instL ls) + | [], _ => rfl + | A :: As, e => by + show VExpr.lam _ _ = VExpr.lam _ _ + rw [instL_lamN ls As e] + +end VExpr + +/-- Matching a constant `varN` tower captures exactly the spine arguments: +the `varNPaths` read back the argument list. -/ +theorem Pattern.varN_matches_paths {c : Name} {m1 : List VLevel} : + ∀ (n : Nat) (as : List VExpr) {f : VExpr} {m2}, + (Pattern.varN (.const c) n).Matches (VExpr.appN f as) m1 m2 → + as.length = n → + (Pattern.varNPaths (.const c) n).map m2 = as := by + intro n + induction n with + | zero => + intro as f m2 H hlen + obtain rfl : as = [] := List.length_eq_zero_iff.1 hlen + rfl + | succ n ih => + intro as f m2 H hlen + have hne : as ≠ [] := by rintro rfl; simp at hlen + obtain ⟨as', a, rfl⟩ : ∃ as' a, as = as' ++ [a] := + ⟨as.dropLast, as.getLast hne, (List.dropLast_concat_getLast hne).symm⟩ + rw [VExpr.appN_append] at H + have has : as'.length = n := by simpa using hlen + cases H with + | var h => + show ((Pattern.varNPaths (.const c) n).map some ++ [none]).map _ = + as' ++ [a] + rw [List.map_append, List.map_map] + exact congrArg (· ++ [a]) (ih as' h has) + +/-- Applying an RHS template spine computes to the applied template +values. -/ +theorem Pattern.RHS.appN_apply {p : Pattern} (m1 : List VLevel) + (m2 : p.Path → VExpr) : + ∀ (f : p.RHS) (as : List (p.RHS)), + (Pattern.RHS.appN f as).apply m1 m2 = + VExpr.appN (f.apply m1 m2) (as.map (Pattern.RHS.apply m1 m2)) + | _, [] => rfl + | f, a :: as => by + show (Pattern.RHS.appN (.app f a) as).apply m1 m2 = _ + rw [Pattern.RHS.appN_apply m1 m2 (.app f a) as] + rfl + +/-- A `HeadConstN` spine names its argument list. -/ +theorem HeadConstN.exists_appN {c : Name} {ls : List VLevel} : + ∀ {n : Nat} {e : VExpr}, HeadConstN c ls n e → + ∃ as : List VExpr, e = VExpr.appN (.const c ls) as ∧ as.length = n + | _, _, .const => ⟨[], rfl, rfl⟩ + | _, _, .app (a := a) h => + let ⟨as, he, hl⟩ := h.exists_appN + ⟨as ++ [a], by rw [VExpr.appN_append, ← he]; rfl, by simp [hl]⟩ + +namespace VExpr + +/-- The value of a bound variable under iterated instantiation: the spine +argument at its reverse position. -/ +theorem instRev_bvar_lt : ∀ (es : List VExpr) {i : Nat} (h : i < es.length), + instRev (.bvar i) es = es[es.length - 1 - i]'(by omega) + | e :: es, i, h => by + rcases Nat.lt_or_ge i es.length with h' | h' + · rw [show instRev (.bvar i) (e :: es) = instRev (.bvar i) es from + instRev_bvar_lt_cons es e h', instRev_bvar_lt es h'] + simp only [show (e :: es).length - 1 - i = (es.length - 1 - i) + 1 from by + simp only [List.length_cons]; omega, List.getElem_cons_succ] + · obtain rfl : i = es.length := by + simp only [List.length_cons] at h; omega + show instRev (instVar es.length e es.length) es = _ + rw [show instVar es.length e es.length = liftN es.length e from by + simp [instVar]] + rw [instRev_liftN_len] + simp only [show (e :: es).length - 1 - es.length = 0 from by + simp only [List.length_cons]; omega, List.getElem_cons_zero] + +/-- Iterated instantiation of a reverse bound-variable segment reads back +the corresponding spine segment. -/ +theorem map_instRev_bvarRevRange_seg (es : List VExpr) : + ∀ (q off : Nat), off + q ≤ es.length → + (bvarRevRange off q).map (instRev · es) = + (es.drop (es.length - off - q)).take q := by + intro q + induction q with + | zero => intro off h; simp [VExpr.bvarRevRange] + | succ q ih => + intro off h + show instRev (.bvar (off + q)) es :: (bvarRevRange off q).map (instRev · es) = _ + rw [instRev_bvar_lt es (by omega), ih off (by omega)] + have hd : es.length - off - (q + 1) < es.length := by omega + simp only [show es.length - 1 - (off + q) = es.length - off - (q + 1) from by + omega, show es.length - off - q = (es.length - off - (q + 1)) + 1 from by + omega] + rw [List.drop_eq_getElem_cons hd, List.take_succ_cons] + +end VExpr + +/-! ## Typed β-collapse of applied telescopes -/ + +/-- Instantiating below a reversed telescope, mirroring +`Ctx.LiftN.consTel`. -/ +theorem Ctx.InstN.consTel {Γ₀ : List VExpr} {e₀ A₀ : VExpr} : + ∀ (As : List VExpr) {k : Nat} {Γ Γ' : List VExpr}, + Ctx.InstN Γ₀ e₀ A₀ k Γ Γ' → + Ctx.InstN Γ₀ e₀ A₀ (As.length + k) (As.reverse ++ Γ) + ((VExpr.instTelN e₀ As k).reverse ++ Γ') + | [], k, Γ, Γ', W => by simpa [VExpr.instTelN] using W + | A :: As, k, Γ, Γ', W => by + have h := Ctx.InstN.consTel As (Ctx.InstN.succ (A := A) W) + rw [show As.length + (k+1) = (A :: As).length + k from by simp; omega] at h + simpa [VExpr.instTelN, List.append_assoc] using h + +/-- Instantiating a telescope's context. -/ +theorem VEnv.OnTel.instN {env : VEnv} (henv : env.Ordered) {U : Nat} + {Γ₀ : List VExpr} {e₀ A₀ : VExpr} (h₀ : env.HasType U Γ₀ e₀ A₀) : + ∀ {As : List VExpr} {k : Nat} {Γ Γ' : List VExpr}, + Ctx.InstN Γ₀ e₀ A₀ k Γ Γ' → VEnv.OnTel env U Γ As → + VEnv.OnTel env U Γ' (VExpr.instTelN e₀ As k) + | [], _, _, _, _, _ => trivial + | _ :: _, _, _, _, W, ⟨⟨u, hA⟩, hT⟩ => + ⟨⟨u, hA.instN henv W h₀⟩, VEnv.OnTel.instN henv h₀ W.succ hT⟩ + +/-- Pointwise defeq of two application spines against a peeled pi type. -/ +inductive VEnv.SpineDefEq (env : VEnv) (U : Nat) (Γ : List VExpr) : + VExpr → List VExpr → List VExpr → VExpr → Prop where + | nil : VEnv.SpineDefEq env U Γ A [] [] A + | cons : env.IsDefEq U Γ a a' A₁ → + VEnv.SpineDefEq env U Γ (A₂.inst a) es es' B → + VEnv.SpineDefEq env U Γ (.forallE A₁ A₂) (a :: es) (a' :: es') B + +/-- Iterated application congruence along a pointwise defeq spine. -/ +theorem VEnv.IsDefEq.appN_defEq {env : VEnv} {U : Nat} {Γ : List VExpr} : + ∀ {es es' : List VExpr} {F B X Y : VExpr}, + env.IsDefEq U Γ X Y F → VEnv.SpineDefEq env U Γ F es es' B → + env.IsDefEq U Γ (VExpr.appN X es) (VExpr.appN Y es') B + | [], _, _, _, _, _, h, .nil => h + | a :: _, a' :: _, _, _, X, Y, h, .cons ha hrest => + VEnv.IsDefEq.appN_defEq (X := X.app a) (Y := Y.app a') (h.appDF ha) hrest + +/-- A well-typed spine is a reflexive defeq spine. -/ +theorem VEnv.SpineWF.toSpineDefEq {env : VEnv} {U : Nat} {Γ : List VExpr} : + ∀ {es : List VExpr} {F B : VExpr}, env.SpineWF U Γ F es B → + VEnv.SpineDefEq env U Γ F es es B + | [], _, _, h => h ▸ .nil + | _ :: _, _, _, ⟨_, _, hA, ha, hrest⟩ => hA ▸ .cons ha hrest.toSpineDefEq + +/-- Iterated application congruence in the function position. -/ +theorem VEnv.IsDefEq.appN_congr {env : VEnv} {U : Nat} {Γ : List VExpr} + {es : List VExpr} {F B X Y : VExpr} + (h : env.IsDefEq U Γ X Y F) (hs : env.SpineWF U Γ F es B) : + env.IsDefEq U Γ (VExpr.appN X es) (VExpr.appN Y es) B := + h.appN_defEq hs.toSpineDefEq + +/-- Applying a lambda telescope to a full well-typed spine collapses to the +iterated instantiation of its body. -/ +theorem VEnv.IsDefEq.appN_lamN {env : VEnv} (henv : env.Ordered) {U : Nat} : + ∀ {As : List VExpr} {Γ : List VExpr} {body T B : VExpr} {es : List VExpr}, + VEnv.OnTel env U Γ As → + env.HasType U (As.reverse ++ Γ) body T → + env.SpineWF U Γ (VExpr.forallN As T) es B → + es.length = As.length → + env.IsDefEq U Γ (VExpr.appN (VExpr.lamN As body) es) + (VExpr.instRev body es) B + | [], Γ, body, T, B, es, _, hb, hs, hlen => by + obtain rfl : es = [] := List.length_eq_zero_iff.1 hlen + obtain rfl : T = B := hs + exact hb + | A :: As, Γ, body, T, B, e :: es, ⟨⟨u, hA⟩, hT⟩, hb, + ⟨A₁, A₂, heq, he, hrest⟩, hlen => by + injection (show VExpr.forallE A (VExpr.forallN As T) = .forallE A₁ A₂ + from heq) with h1 h2 + subst h1; subst h2 + have hb' : env.HasType U (As.reverse ++ (A :: Γ)) body T := by + simpa [List.append_assoc] using hb + have hlam : env.HasType U (A :: Γ) (VExpr.lamN As body) + (VExpr.forallN As T) := VEnv.HasType.lamN hT hb' + have hbeta := VEnv.IsDefEq.beta hlam he + rw [VExpr.instN_lamN, Nat.zero_add] at hbeta + have hlen2 : es.length = As.length := by simpa using hlen + have hT' : VEnv.OnTel env U Γ (VExpr.instTelN e As 0) := + VEnv.OnTel.instN henv he .zero hT + have hb'' : env.HasType U ((VExpr.instTelN e As 0).reverse ++ Γ) + (body.inst e As.length) (T.inst e As.length) := by + have W := Ctx.InstN.consTel (Γ₀ := Γ) (e₀ := e) (A₀ := A) As .zero + have := hb'.instN henv W he + simpa using this + have hrest' : env.SpineWF U Γ + (VExpr.forallN (VExpr.instTelN e As 0) (T.inst e As.length)) es B := by + rw [VExpr.instN_forallN] at hrest + simpa using hrest + have hlen' : es.length = (VExpr.instTelN e As 0).length := by + rw [VExpr.instTelN_length]; exact hlen2 + have IH := VEnv.IsDefEq.appN_lamN henv hT' hb'' hrest' hlen' + have hstep := VEnv.IsDefEq.appN_congr hbeta hrest + show env.IsDefEq U Γ + (VExpr.appN ((VExpr.lam A (VExpr.lamN As body)).app e) es) + (VExpr.instRev (body.inst e es.length) es) B + rw [hlen2] + exact hstep.trans IH + +/-- Iterated inversion of a lambda tower's typing: the telescope is +well-formed and the body is typed under it. -/ +theorem VEnv.HasType.lamN_wf {env : VEnv} {U : Nat} (henv : env.Ordered) : + ∀ {As : List VExpr} {Γ : List VExpr} {body V : VExpr}, + OnCtx Γ (env.IsType U) → + env.HasType U Γ (VExpr.lamN As body) V → + VEnv.OnTel env U Γ As ∧ + ∃ T₀, env.HasType U (As.reverse ++ Γ) body T₀ + | [], Γ, body, V, _, H => ⟨trivial, V, H⟩ + | A :: As, Γ, body, V, hΓ, H => by + obtain ⟨⟨u, hA⟩, W, hrest⟩ := VEnv.HasType.lam_inv henv hΓ H + obtain ⟨hT, T₀, hbody⟩ := + VEnv.HasType.lamN_wf henv (As := As) (Γ := A :: Γ) ⟨hΓ, u, hA⟩ hrest + exact ⟨⟨⟨u, hA⟩, hT⟩, T₀, by simpa [List.append_assoc] using hbody⟩ + +/-- The levels of a `HeadConstN` spine are unique. -/ +theorem HeadConstN.levels_uniq {c : Name} : + ∀ {n : Nat} {e : VExpr} {ls ls' : List VLevel}, + HeadConstN c ls n e → HeadConstN c ls' n e → ls = ls' + | _, _, _, _, .const, .const => rfl + | _, _, _, _, .app h, .app h' => h.levels_uniq h' + +/-- Zip a well-typed spine with pointwise defeqs into a defeq spine. +Reflexive entries need no defeq evidence. -/ +theorem VEnv.SpineWF.defEq_of_pointwise {env : VEnv} (henv : env.WF) + {U : Nat} {Γ : List VExpr} (hΓ : OnCtx Γ (env.IsType U)) : + ∀ {es es' : List VExpr} {F B : VExpr}, + env.SpineWF U Γ F es B → + List.Forall₂ (fun a a' => a = a' ∨ env.IsDefEqU U Γ a a') es es' → + VEnv.SpineDefEq env U Γ F es es' B + | [], [], _, _, h, .nil => h ▸ .nil + | _ :: _, _ :: _, _, _, ⟨A₁, A₂, hF, he, hrest⟩, .cons hd htl => by + subst hF + refine .cons ?_ (hrest.defEq_of_pointwise henv hΓ htl) + rcases hd with rfl | hd + · exact he + · exact VEnv.IsDefEqU.of_l henv hΓ hd he + +/-- Unfold the `OK` predicate through a folded list of defeq checks. -/ +theorem Pattern.Check.OK.of_foldr {p : Pattern} {α : Type _} + {df : VExpr → VExpr → Prop} {m1 : List VLevel} {m2 : p.Path → VExpr} + (f g : α → p.RHS) : + ∀ {xs : List α} {rest : p.Check}, + ((xs.foldr (fun x acc => Pattern.Check.defeq (f x) (g x) acc) + rest).OK df m1 m2) → + (∀ x ∈ xs, df ((f x).apply m1 m2) ((g x).apply m1 m2)) ∧ + rest.OK df m1 m2 + | [], _, h => ⟨nofun, h⟩ + | _ :: xs, rest, h => by + obtain ⟨h1, h2⟩ := h + obtain ⟨h3, h4⟩ := Pattern.Check.OK.of_foldr f g (xs := xs) h2 + refine ⟨fun x hx => ?_, h4⟩ + rcases List.mem_cons.1 hx with rfl | hx + · exact h1 + · exact h3 x hx + +/-- Build a pointwise relation between two mapped lists from their zip. -/ +private theorem forall₂_zip_map {α β : Type _} (F : α → VExpr) (G : β → VExpr) + (R : VExpr → VExpr → Prop) : + ∀ (xs : List α) (ys : List β), xs.length = ys.length → + (∀ p ∈ xs.zip ys, R (F p.1) (G p.2)) → + List.Forall₂ R (xs.map F) (ys.map G) + | [], [], _, _ => .nil + | x :: xs, y :: ys, hlen, hall => + .cons (hall (x, y) (.head _)) + (forall₂_zip_map F G R xs ys (by simpa using hlen) + fun p hp => hall p (.tail _ hp)) + | [], _ :: _, hlen, _ => by simp at hlen + | _ :: _, [], hlen, _ => by simp at hlen + +/-- Universe instantiation fixes a reverse bound-variable range. -/ +theorem VExpr.bvarRevRange_map_instL (ls : List VLevel) : + ∀ (off m : Nat), + (VExpr.bvarRevRange off m).map (VExpr.instL ls) = + VExpr.bvarRevRange off m + | _, 0 => rfl + | off, m+1 => by + simp only [VExpr.bvarRevRange, List.map_cons, VExpr.instL, + VExpr.bvarRevRange_map_instL ls off m] + +/-- A well-formed telescope extends a well-formed context. -/ +theorem VEnv.OnTel.onCtx {env : VEnv} {U : Nat} : + ∀ {As Γ : List VExpr}, OnCtx Γ (env.IsType U) → + VEnv.OnTel env U Γ As → OnCtx (As.reverse ++ Γ) (env.IsType U) + | [], _, hΓ, _ => hΓ + | A :: As, Γ, hΓ, ⟨hA, hT⟩ => by + simpa [List.append_assoc] using + VEnv.OnTel.onCtx (As := As) (Γ := A :: Γ) ⟨hΓ, hA⟩ hT + +/-- Every argument of a well-typed application spine is well-typed. -/ +theorem VEnv.HasType.appN_args_wf {env : VEnv} (henv : env.WF) {U : Nat} + {Γ : List VExpr} (hΓ : OnCtx Γ (env.IsType U)) : + ∀ (n : Nat) (es : List VExpr), es.length = n → ∀ {f B : VExpr}, + env.HasType U Γ (VExpr.appN f es) B → + ∀ e ∈ es, ∃ T, env.HasType U Γ e T := by + intro n + induction n with + | zero => + intro es hlen f B H e he + obtain rfl := List.length_eq_zero_iff.1 hlen + cases he + | succ n ih => + intro es hlen f B H e he + have hne : es ≠ [] := by rintro rfl; simp at hlen + obtain ⟨es', a, rfl⟩ : ∃ es' a, es = es' ++ [a] := + ⟨es.dropLast, es.getLast hne, (List.dropLast_concat_getLast hne).symm⟩ + rw [VExpr.appN_append] at H + have H' : env.HasType U Γ ((VExpr.appN f es').app a) B := H + obtain ⟨A₁, B₁, hf, ha⟩ := H'.app_inv henv hΓ + rcases List.mem_append.1 he with he' | he' + · exact ih es' (by simpa using hlen) hf e he' + · obtain rfl : e = a := by simpa using he' + exact ⟨A₁, ha⟩ + +/-- Iterated inversion of a pi tower's typing: the telescope is well formed +and the body is typed under it. -/ +theorem VEnv.HasType.forallN_wf {env : VEnv} {U : Nat} (henv : env.Ordered) : + ∀ {As : List VExpr} {Γ : List VExpr} {body V : VExpr}, + env.HasType U Γ (VExpr.forallN As body) V → + VEnv.OnTel env U Γ As ∧ ∃ V', env.HasType U (As.reverse ++ Γ) body V' + | [], _, _, V, H => ⟨trivial, V, H⟩ + | A :: As, Γ, body, V, H => by + obtain ⟨⟨u, hA⟩, v, hB⟩ := VEnv.HasType.forallE_inv henv H + obtain ⟨hT, V', hbody⟩ := VEnv.HasType.forallN_wf henv (As := As) hB + exact ⟨⟨⟨u, hA⟩, hT⟩, V', by simpa [List.append_assoc] using hbody⟩ + +private theorem forall₂_refl_or {R : VExpr → VExpr → Prop} : + ∀ (l : List VExpr), List.Forall₂ (fun a a' => a = a' ∨ R a a') l l + | [] => .nil + | _ :: l => .cons (Or.inl rfl) (forall₂_refl_or l) + +private theorem forall₂_append {R : VExpr → VExpr → Prop} : + ∀ {l₁ l₂ l₁' l₂' : List VExpr}, List.Forall₂ R l₁ l₂ → + List.Forall₂ R l₁' l₂' → List.Forall₂ R (l₁ ++ l₁') (l₂ ++ l₂') + | [], [], _, _, .nil, h => h + | _ :: _, _ :: _, _, _, .cons hd htl, h => .cons hd (forall₂_append htl h) + +namespace VInductDecl + +namespace BlockGenerationChecked + +variable {source : VInductDecl} (gen : source.BlockGenerationChecked) + +/-! ## Named shapes of one generated rule -/ + +theorem rule_type (i : Nat) (c : NormalizedBlockCtor) : + (gen.rule i c).type = + VExpr.forallN (gen.ruleBinders c) + (VExpr.appN + (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount + + gen.ruleFieldCount c)) + (gen.ruleIdx c ++ [gen.ruleCtorApp c])) := rfl + +theorem rule_uvars (i : Nat) (c : NormalizedBlockCtor) : + (gen.rule i c).uvars = gen.recUvars := rfl + +theorem paramsTel_length : gen.paramsTel.length = source.nparams := by + show ((generationParams gen.block.rawParams gen.block.checked.params).map + (VExpr.instL gen.sourceLevels)).length = _ + rw [List.length_map] + exact (generationParams_length_of_eq gen.shape.2.1).trans gen.shape.1 + +theorem ruleBinders_length (c : NormalizedBlockCtor) : + (gen.ruleBinders c).length = + source.nparams + gen.familyCount + gen.minorCount + + gen.ruleFieldCount c := by + simp only [ruleBinders, List.length_append, gen.paramsTel_length, + motiveTypes, gen.motiveTypesAux_length, minorTypes, + gen.minorTypesAux_length, VExpr.liftTelN_length, ruleFieldCount] + try omega + +/-- The instantiated left body as one flattened application spine. -/ +theorem ruleLhsBody_instL (c : NormalizedBlockCtor) {m1 : List VLevel} + (hlen1 : m1.length = gen.recUvars) : + (gen.ruleLhsBody c).instL m1 = + VExpr.appN (.const (gen.ruleRecName c) m1) + (VExpr.bvarRevRange (gen.ruleFieldCount c) + (source.nparams + gen.familyCount + gen.minorCount) ++ + (gen.ruleIdx c).map (VExpr.instL m1) ++ + [(gen.ruleCtorApp c).instL m1]) := by + show (VExpr.appN + (VExpr.appN (.const (gen.ruleRecName c) gen.recLevels) + (VExpr.bvarRevRange (gen.ruleFieldCount c) + (source.nparams + gen.familyCount + gen.minorCount))) + (gen.ruleIdx c ++ [gen.ruleCtorApp c])).instL m1 = _ + rw [← VExpr.appN_append, VExpr.instL_appN] + show VExpr.appN (.const (gen.ruleRecName c) + (gen.recLevels.map (VLevel.inst m1))) _ = _ + rw [show gen.recLevels.map (VLevel.inst m1) = m1 from + VLevel.inst_map_id hlen1] + rw [List.map_append, List.map_append, VExpr.bvarRevRange_map_instL, + List.append_assoc] + rfl + +/-- The instantiated major premise of the rule body. -/ +theorem ruleCtorApp_instL (c : NormalizedBlockCtor) (m1 : List VLevel) : + (gen.ruleCtorApp c).instL m1 = + VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) + (VExpr.bvarRevRange + (gen.ruleFieldCount c + (gen.familyCount + gen.minorCount)) + source.nparams ++ + VExpr.bvarRevRange 0 (gen.ruleFieldCount c)) := by + show (VExpr.appN (.const c.ctor.raw.name gen.sourceLevels) _).instL m1 = _ + rw [VExpr.instL_appN, List.map_append, VExpr.bvarRevRange_map_instL, + VExpr.bvarRevRange_map_instL] + rfl + +/-- The captured template values are exactly the shared prefix of the +recursor spine and the field suffix of the major premise. -/ +private theorem captureArgs_apply {c : NormalizedBlockCtor} {m1 : List VLevel} + {g1 : Pattern.Path + (Pattern.varN (.const (gen.ruleRecName c)) (gen.ruleMajorArity c)) → VExpr} + {g2 : Pattern.Path + (Pattern.varN (.const c.ctor.raw.name) (gen.ruleArgArity c)) → VExpr} + {fArgs aArgs : List VExpr} + (hg1 : (Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).map g1 = fArgs) + (hg2 : (Pattern.varNPaths (.const c.ctor.raw.name) + (gen.ruleArgArity c)).map g2 = aArgs) : + (gen.captureArgs c).map + (Pattern.RHS.apply (p := (gen.rulePattern c).toPattern) m1 + (Sum.elim g1 g2)) = + fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams := by + rw [captureArgs, List.map_append, List.map_map, List.map_map] + show List.map g1 (List.take + (source.nparams + gen.familyCount + gen.minorCount) + (Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c))) ++ + List.map g2 (List.drop source.nparams + (Pattern.varNPaths (.const c.ctor.raw.name) + (gen.ruleArgArity c))) = _ + rw [List.map_take, List.map_drop, hg1, hg2] + +/-- Pattern soundness for one certified block (`pat_wf`): a successful match +of a rule's pattern whose checks hold is definitionally equal to the +instantiated RHS template, derived from the rule defeq registered by +`addInduct` via typed β-collapse. The redex arrives decomposed into its +recursor and constructor spines with spine-form typing, and the major +premise's levels pinned to the rule's source levels; both are exactly what +a verified reduction site holds. -/ +theorem pat_wf {env : VEnv} (henv : env.WF) {univs : Nat} {Γ : List VExpr} + (hΓ : OnCtx Γ (env.IsType univs)) + (hcl : gen.RuleClosure) + {i : Nat} {c : NormalizedBlockCtor} (h : gen.ruleEntry i c) + (hreg : env.defeqs (gen.rule i c)) + (hwf : (gen.rule i c).WF env) + {m1 : List VLevel} {m2} + (hm1 : ∀ l ∈ m1, l.WF univs) (hlen1 : m1.length = gen.recUvars) + {fArgs aArgs : List VExpr} + (hMlen : fArgs.length = gen.ruleMajorArity c) + (hNlen : aArgs.length = gen.ruleArgArity c) + (hm : ((gen.rulePattern c).toPattern).Matches + (.app (VExpr.appN (.const (gen.ruleRecName c) m1) fArgs) + (VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) aArgs)) m1 m2) + (hck : (gen.ruleCheck hcl (List.mem_of_getElem? h)).OK + (env.IsDefEqU univs Γ) m1 m2) + {Frec Ae : VExpr} + (hehead : env.HasType univs Γ (.const (gen.ruleRecName c) m1) Frec) + (hespine : env.SpineWF univs Γ Frec + (fArgs ++ [VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) aArgs]) Ae) + {Fctor Actor : VExpr} + (hctorhead : env.HasType univs Γ + (.const c.ctor.raw.name (gen.sourceLevels.map (VLevel.inst m1))) Fctor) + (hctorspine : env.SpineWF univs Γ Fctor aArgs Actor) + {B : VExpr} + (hcaps : env.SpineWF univs Γ ((gen.rule i c).type.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams) B) : + env.IsDefEqU univs Γ + (.app (VExpr.appN (.const (gen.ruleRecName c) m1) fArgs) + (VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) aArgs)) + ((gen.ruleRHS hcl h).apply m1 m2) := by + have henvo := henv.ordered + have hc := List.mem_of_getElem? h + cases hm with + | @app _ _ _ g1 _ _ f2 g2 h1 h2 => + -- canonical captures + have hg1 : (Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).map g1 = fArgs := + Pattern.varN_matches_paths _ fArgs h1 hMlen + have hg2 : (Pattern.varNPaths (.const c.ctor.raw.name) + (gen.ruleArgArity c)).map g2 = aArgs := + Pattern.varN_matches_paths _ aArgs h2 hNlen + have hcapsVals := gen.captureArgs_apply (m1 := m1) hg1 hg2 + -- length bookkeeping + have hcommon_le : source.nparams + gen.familyCount + gen.minorCount ≤ + gen.ruleMajorArity c := Nat.le_add_right _ _ + have hnp_le : source.nparams ≤ gen.ruleArgArity c := Nat.le_add_right _ _ + have htakelen : (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount)).length = + source.nparams + gen.familyCount + gen.minorCount := by + rw [List.length_take, hMlen]; omega + have hdroplen : (aArgs.drop source.nparams).length = + gen.ruleFieldCount c := by + rw [List.length_drop, hNlen] + show gen.ruleArgArity c - source.nparams = _ + simp only [ruleArgArity]; omega + have hcapslen : (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).length = + ((gen.ruleBinders c).map (VExpr.instL m1)).length := by + rw [List.length_append, htakelen, hdroplen, List.length_map, + gen.ruleBinders_length] + -- tower shapes + have htype' : (gen.rule i c).type.instL m1 = + VExpr.forallN ((gen.ruleBinders c).map (VExpr.instL m1)) + ((VExpr.appN + (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount + + gen.ruleFieldCount c)) + (gen.ruleIdx c ++ [gen.ruleCtorApp c])).instL m1) := by + rw [gen.rule_type, VExpr.instL_forallN] + have hlhs' : (gen.rule i c).lhs.instL m1 = + VExpr.lamN ((gen.ruleBinders c).map (VExpr.instL m1)) + ((gen.ruleLhsBody c).instL m1) := by + rw [gen.rule_lhs, VExpr.instL_lamN] + -- tower typing at the working context + have hlhsT : env.HasType univs Γ + (VExpr.lamN ((gen.ruleBinders c).map (VExpr.instL m1)) + ((gen.ruleLhsBody c).instL m1)) + ((gen.rule i c).type.instL m1) := by + rw [← hlhs'] + exact (hwf.1.instL hm1).weak0 henvo + obtain ⟨hTel, T₀, hbody⟩ := VEnv.HasType.lamN_wf henvo hΓ hlhsT + -- β-collapse of the applied left tower + have hcapsF : env.SpineWF univs Γ + (VExpr.forallN ((gen.ruleBinders c).map (VExpr.instL m1)) + ((VExpr.appN + (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount + + gen.ruleFieldCount c)) + (gen.ruleIdx c ++ [gen.ruleCtorApp c])).instL m1)) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams) B := htype' ▸ hcaps + have hretT0 := (VEnv.SpineWF.retarget hcapsF hcapslen) T₀ + have hcollapseL := VEnv.IsDefEq.appN_lamN henvo hTel hbody hretT0 hcapslen + -- the registered defeq, applied + have hex : env.IsDefEq univs Γ ((gen.rule i c).lhs.instL m1) + ((gen.rule i c).rhs.instL m1) ((gen.rule i c).type.instL m1) := + .extra hreg hm1 hlen1 + rw [hlhs'] at hex + have happlied := VEnv.IsDefEq.appN_congr hex hcaps + -- conclusion-side template computation + have hRHS : Pattern.RHS.apply (p := (gen.rulePattern c).toPattern) m1 + (Sum.elim g1 g2) (gen.ruleRHS hcl h) = + VExpr.appN ((gen.rule i c).rhs.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams) := by + rw [ruleRHS, Pattern.RHS.appN_apply, hcapsVals] + rfl + -- typing of the rule type's index spine + obtain ⟨u₀, htypeT⟩ := hlhsT.isType henvo hΓ + rw [htype'] at htypeT + obtain ⟨-, V', htypeBody⟩ := VEnv.HasType.forallN_wf henvo htypeT + have hCtxTel : OnCtx (((gen.ruleBinders c).map (VExpr.instL m1)).reverse ++ Γ) + (env.IsType univs) := VEnv.OnTel.onCtx hΓ hTel + rw [show ((VExpr.appN + (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount + + gen.ruleFieldCount c)) + (gen.ruleIdx c ++ [gen.ruleCtorApp c])).instL m1) = + VExpr.appN (.bvar (gen.familyCount - 1 - c.owner + gen.minorCount + + gen.ruleFieldCount c)) + ((gen.ruleIdx c ++ [gen.ruleCtorApp c]).map (VExpr.instL m1)) from by + rw [VExpr.instL_appN]; rfl] at htypeBody + have hargsWF := VEnv.HasType.appN_args_wf henv hCtxTel _ _ rfl htypeBody + -- check extraction + unfold ruleCheck at hck + obtain ⟨hparams, hidxOK⟩ := Pattern.Check.OK.of_foldr _ _ hck + obtain ⟨hidxs, -⟩ := Pattern.Check.OK.of_foldr _ _ hidxOK + -- per-index tower collapse and check composition + have hidxLink : ∀ x ∈ (gen.ruleIdx c).attach.zip + ((Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).drop + (source.nparams + gen.familyCount + gen.minorCount)), + env.IsDefEqU univs Γ (Sum.elim g1 g2 (Sum.inl x.2)) + (VExpr.instRev (x.1.1.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) := by + intro x hx + have hfact := hidxs x hx + rw [Pattern.RHS.appN_apply, hcapsVals] at hfact + have htower : Pattern.RHS.apply (p := (gen.rulePattern c).toPattern) m1 + (Sum.elim g1 g2) + (.fixed (VExpr.lamN (gen.ruleBinders c) x.1.1) + (hcl.idxTower_closed hc x.1.1 x.1.2)) = + VExpr.lamN ((gen.ruleBinders c).map (VExpr.instL m1)) + (x.1.1.instL m1) := by + show (VExpr.lamN (gen.ruleBinders c) x.1.1).instL m1 = _ + rw [VExpr.instL_lamN] + rw [htower] at hfact + obtain ⟨Tx, hTx⟩ := hargsWF (x.1.1.instL m1) + (by + rw [List.map_append] + exact List.mem_append.2 (.inl (List.mem_map_of_mem x.1.2))) + have hretTx := (VEnv.SpineWF.retarget hcapsF hcapslen) Tx + have hcollapseX := VEnv.IsDefEq.appN_lamN henvo hTel hTx hretTx hcapslen + exact VEnv.IsDefEqU.trans henv hΓ hfact ⟨_, hcollapseX⟩ + -- major premise: constructor spine against its rebuilt form + have hparamsF₂ : List.Forall₂ + (fun a a' => a = a' ∨ env.IsDefEqU univs Γ a a') + aArgs + (fArgs.take source.nparams ++ aArgs.drop source.nparams) := by + have hb := forall₂_zip_map (α := Pattern.Path + (Pattern.varN (.const c.ctor.raw.name) (gen.ruleArgArity c))) + (β := Pattern.Path + (Pattern.varN (.const (gen.ruleRecName c)) (gen.ruleMajorArity c))) + g2 g1 (fun a a' => a = a' ∨ env.IsDefEqU univs Γ a a') + ((Pattern.varNPaths (.const c.ctor.raw.name) + (gen.ruleArgArity c)).take source.nparams) + ((Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).take source.nparams) + (by + rw [List.length_take, List.length_take, + Pattern.varNPaths_length, Pattern.varNPaths_length] + omega) + (fun p hp => Or.inr (hparams p hp)) + rw [List.map_take, List.map_take, hg1, hg2] at hb + have hall := forall₂_append hb + (forall₂_refl_or (R := env.IsDefEqU univs Γ) + (aArgs.drop source.nparams)) + rwa [List.take_append_drop] at hall + have hmajorLink : env.IsDefEqU univs Γ + (VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) aArgs) + (VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) + (fArgs.take source.nparams ++ aArgs.drop source.nparams)) := + ⟨_, VEnv.IsDefEq.appN_defEq hctorhead + (VEnv.SpineWF.defEq_of_pointwise henv hΓ hctorspine hparamsF₂)⟩ + -- the collapsed left spine, computed + have hL : (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams).length = + gen.ruleFieldCount c + + (source.nparams + gen.familyCount + gen.minorCount) := by + rw [List.length_append, htakelen, hdroplen]; omega + have hcapsTake : (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).take + (source.nparams + gen.familyCount + gen.minorCount) = + fArgs.take (source.nparams + gen.familyCount + gen.minorCount) := by + rw [List.take_append_of_le_length (by omega : _ ≤ (fArgs.take + (source.nparams + gen.familyCount + gen.minorCount)).length)] + exact List.take_of_length_le (Nat.le_of_eq htakelen) + have hcapsTakeNp : (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).take source.nparams = + fArgs.take source.nparams := by + rw [List.take_append_of_le_length (by omega : _ ≤ (fArgs.take + (source.nparams + gen.familyCount + gen.minorCount)).length)] + rw [List.take_take] + congr 1 + omega + have hcapsDrop : (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).drop + (source.nparams + gen.familyCount + gen.minorCount) = + aArgs.drop source.nparams := by + have hdl := List.drop_left (l₁ := fArgs.take (source.nparams + gen.familyCount + gen.minorCount)) (l₂ := aArgs.drop source.nparams) + rwa [htakelen] at hdl + have hsegNp : (VExpr.bvarRevRange + (gen.ruleFieldCount c + (gen.familyCount + gen.minorCount)) + source.nparams).map (VExpr.instRev · + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) = fArgs.take source.nparams := by + rw [VExpr.map_instRev_bvarRevRange_seg _ source.nparams _ (by omega)] + rw [show (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).length - + (gen.ruleFieldCount c + (gen.familyCount + gen.minorCount)) - + source.nparams = 0 from by omega, List.drop_zero] + exact hcapsTakeNp + have hsegFld : (VExpr.bvarRevRange 0 (gen.ruleFieldCount c)).map + (VExpr.instRev · + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) = aArgs.drop source.nparams := by + rw [VExpr.map_instRev_bvarRevRange_seg _ (gen.ruleFieldCount c) 0 + (by omega)] + rw [show (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).length - 0 - + gen.ruleFieldCount c = + source.nparams + gen.familyCount + gen.minorCount from by omega] + rw [hcapsDrop] + exact List.take_of_length_le (Nat.le_of_eq hdroplen) + have hsegCommon : (VExpr.bvarRevRange (gen.ruleFieldCount c) + (source.nparams + gen.familyCount + gen.minorCount)).map + (VExpr.instRev · + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) = + fArgs.take (source.nparams + gen.familyCount + gen.minorCount) := by + rw [VExpr.map_instRev_bvarRevRange_seg _ + (source.nparams + gen.familyCount + gen.minorCount) + (gen.ruleFieldCount c) (by omega)] + rw [show (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams).length - + gen.ruleFieldCount c - + (source.nparams + gen.familyCount + gen.minorCount) = 0 from by + omega, List.drop_zero] + exact hcapsTake + have hctorImg : VExpr.instRev ((gen.ruleCtorApp c).instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams) = + VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) + (fArgs.take source.nparams ++ aArgs.drop source.nparams) := by + rw [gen.ruleCtorApp_instL, VExpr.instRev_appN, + VExpr.instRev_closedN (C := .const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) _ trivial, List.map_append, + hsegNp, hsegFld] + have hcollapsedEq : VExpr.instRev ((gen.ruleLhsBody c).instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams) = + VExpr.appN (.const (gen.ruleRecName c) m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + ((gen.ruleIdx c).map (fun x => VExpr.instRev (x.instL m1) + (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams)) ++ + [VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) + (fArgs.take source.nparams ++ aArgs.drop source.nparams)])) := by + rw [gen.ruleLhsBody_instL c hlen1, VExpr.instRev_appN, + VExpr.instRev_closedN (C := .const (gen.ruleRecName c) m1) _ trivial, + List.map_append, List.map_append, hsegCommon, List.map_map] + rw [show ((gen.ruleCtorApp c).instL m1 :: + ([] : List VExpr)).map (VExpr.instRev · + (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams)) = + [VExpr.instRev ((gen.ruleCtorApp c).instL m1) + (fArgs.take (source.nparams + gen.familyCount + + gen.minorCount) ++ aArgs.drop source.nparams)] from rfl] + rw [hctorImg] + simp only [Function.comp_def] + rw [List.append_assoc] + -- pointwise defeq between the redex spine and the collapsed spine + have hidxF₂ : List.Forall₂ (fun a a' => a = a' ∨ env.IsDefEqU univs Γ a a') + (fArgs.drop (source.nparams + gen.familyCount + gen.minorCount)) + ((gen.ruleIdx c).map (fun x => VExpr.instRev (x.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams))) := by + have hb := forall₂_zip_map + (α := {x // x ∈ gen.ruleIdx c}) + (β := Pattern.Path (Pattern.varN (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c))) + (fun s => VExpr.instRev (s.1.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) + (fun p => Sum.elim g1 g2 (Sum.inl p)) + (fun t v => v = t ∨ env.IsDefEqU univs Γ v t) + (gen.ruleIdx c).attach + ((Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).drop + (source.nparams + gen.familyCount + gen.minorCount)) + (by + rw [List.length_attach, List.length_drop, Pattern.varNPaths_length] + show (gen.ruleIdx c).length = gen.ruleMajorArity c - _ + simp only [ruleIdx, ruleMajorArity, List.length_map] + omega) + (fun p hp => Or.inr (hidxLink p hp)) + have hflip := List.Forall₂.flip hb + have hmapG : ((Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).drop + (source.nparams + gen.familyCount + gen.minorCount)).map + (fun p => Sum.elim g1 g2 (Sum.inl p)) = + fArgs.drop (source.nparams + gen.familyCount + gen.minorCount) := by + show ((Pattern.varNPaths (.const (gen.ruleRecName c)) + (gen.ruleMajorArity c)).drop + (source.nparams + gen.familyCount + gen.minorCount)).map g1 = _ + rw [List.map_drop, hg1] + have hmapF : ((gen.ruleIdx c).attach).map + (fun s => VExpr.instRev (s.1.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) = + (gen.ruleIdx c).map (fun x => VExpr.instRev (x.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) := by + exact List.attach_map_val + (f := fun x : VExpr => VExpr.instRev (x.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) .. + rw [hmapG, hmapF] at hflip + exact hflip + have hbigF₂ : List.Forall₂ (fun a a' => a = a' ∨ env.IsDefEqU univs Γ a a') + (fArgs ++ [VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) aArgs]) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + ((gen.ruleIdx c).map (fun x => VExpr.instRev (x.instL m1) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount) ++ + aArgs.drop source.nparams)) ++ + [VExpr.appN (.const c.ctor.raw.name + (gen.sourceLevels.map (VLevel.inst m1))) + (fArgs.take source.nparams ++ aArgs.drop source.nparams)])) := by + have hres := forall₂_append + (forall₂_refl_or (R := env.IsDefEqU univs Γ) + (fArgs.take (source.nparams + gen.familyCount + gen.minorCount))) + (forall₂_append hidxF₂ (.cons (Or.inr hmajorLink) .nil)) + rwa [← List.append_assoc, List.take_append_drop] at hres + -- the redex is defeq to the collapsed left spine + have hE := VEnv.IsDefEq.appN_defEq hehead + (VEnv.SpineWF.defEq_of_pointwise henv hΓ hespine hbigF₂) + rw [← hcollapsedEq, VExpr.appN_append] at hE + -- assemble + rw [hRHS] + exact VEnv.IsDefEqU.trans henv hΓ ⟨_, hE⟩ + (VEnv.IsDefEqU.trans henv hΓ ⟨_, hcollapseL.symm⟩ ⟨_, happlied⟩) + +end BlockGenerationChecked + +end VInductDecl + +end Lean4Lean + +/-! ## Axiom closures + +The typed β-collapse layer is sorry-free. `pat_wf` composes typed defeqs +through `IsDefEqU.of_l`/`IsDefEqU.trans` and therefore carries exactly the +transitional unique-typing closure the Church–Rosser development itself +carries; it sheds `sorryAx` automatically when the L4L-16/17 inversion +milestones land, with no restatement. -/ + +/-- info: 'Lean4Lean.VEnv.IsDefEq.appN_lamN' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VEnv.IsDefEq.appN_lamN + +/-- info: 'Lean4Lean.VEnv.IsDefEq.appN_defEq' depends on axioms: [propext] -/ +#guard_msgs in +#print axioms Lean4Lean.VEnv.IsDefEq.appN_defEq + +/-- info: 'Lean4Lean.Pattern.varN_matches_paths' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.Pattern.varN_matches_paths + +/-- +info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.pat_wf' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.pat_wf diff --git a/plans/roadmap.md b/plans/roadmap.md index f59c6663..f39a9657 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 25/51] 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 c5be36d3..489b62e7 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 dc420f92..18089ba4 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 00000000..4e1e82d6 --- /dev/null +++ b/Lean4Lean/Tests/NotationPreludeFixture.lean @@ -0,0 +1,32 @@ +/-! +# Notation-heavy prelude fixture + +Unlike the older `IndexedVec` fixture, these declarations deliberately keep +ordinary numeral, arithmetic, list, array, product, conditional, comparison, +and string notation in the source. Their compiled metadata therefore pulls +the real `OfNat`/`HAdd` and literal dependency prefix into fresh replay. +-/ + +namespace Lean4Lean.Tests.NotationPreludeFixture + +inductive NotationVec (α : Type u) : Nat → Type u where + | nil : NotationVec α 0 + | cons {n : Nat} : α → NotationVec α n → NotationVec α (n + 1) + +def sample : NotationVec Nat (1 + 1) := + .cons 37 (.cons 5 .nil) + +def notationList : List (Nat × String) := + [(0, "zero"), (1 + 1, "two"), (if 2 < 3 then 3 else 4, "three")] + +def notationArray : Array (Nat × String) := + #[(5, "five"), (2 + 4, "six")] + +/-- One root whose type and value retain the complete fixture dependency +closure for replay. -/ +def bundled : + NotationVec Nat (1 + 1) × + (List (Nat × String) × Array (Nat × String)) := + (sample, notationList, notationArray) + +end Lean4Lean.Tests.NotationPreludeFixture diff --git a/Lean4Lean/Tests/NotationPreludeReplay.lean b/Lean4Lean/Tests/NotationPreludeReplay.lean new file mode 100644 index 00000000..0ceb0f28 --- /dev/null +++ b/Lean4Lean/Tests/NotationPreludeReplay.lean @@ -0,0 +1,54 @@ +import Lean4Lean.Replay +import Lean4Lean.Tests.NotationPreludeFixture + +/-! +# Fresh notation-prelude replay + +This is an executable replay from an empty kernel environment over the real +compiled dependency closure of `bundled`. In particular, no hand-built +Theory environment or abstract existence witness stands in for the prelude +prefix selected by the stored metadata. +-/ + +namespace Lean4Lean.Tests.NotationPreludeReplay + +open Lean + +private def fixtureModule : Name := + `Lean4Lean.Tests.NotationPreludeFixture + +private def fixtureRoot : Name := + ``Lean4Lean.Tests.NotationPreludeFixture.bundled + +/-- Return the actual fresh kernel environment as well as the count so the +test can check that the notation-selected prelude prefix was really installed. +This is the same operation as `Replay.replayFromFresh` specialized to one +dependency root. -/ +private unsafe def replayNotationPrefix : + IO (Nat × Lean.Kernel.Environment) := do + Lean.withImportModules #[fixtureModule] {} (trustLevel := 0) fun env => do + let context : Lean4Lean.Replay.Context := { + newConstants := env.constants.map₁ + checkQuot := false } + Lean4Lean.Replay.replay context (.empty fixtureModule) (some fixtureRoot) + +run_cmd do + let (count, replayed) ← replayNotationPrefix + unless count = 296 do + throwError "notation-heavy fresh replay added {count} declarations; expected 296" + let required := #[ + ``OfNat.ofNat, + ``HAdd.hAdd, + ``String.ofList, + ``Char.ofNat, + ``Lean4Lean.Tests.NotationPreludeFixture.NotationVec, + ``Lean4Lean.Tests.NotationPreludeFixture.NotationVec.nil, + ``Lean4Lean.Tests.NotationPreludeFixture.NotationVec.cons, + ``Lean4Lean.Tests.NotationPreludeFixture.NotationVec.rec, + fixtureRoot] + for name in required do + unless (replayed.constants.find? name).isSome do + throwError "notation-heavy fresh replay omitted {name}" + logInfo m!"notation-heavy fresh replay OK ({count} declarations)" + +end Lean4Lean.Tests.NotationPreludeReplay diff --git a/Lean4Lean/Theory.lean b/Lean4Lean/Theory.lean index 67c3c0f5..3892e02f 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 00000000..f7ea85eb --- /dev/null +++ b/Lean4Lean/Theory/Typing/InductiveCertificate.lean @@ -0,0 +1,517 @@ +import Lean4Lean.Theory.Typing.EnvLemmas +import Lean4Lean.Theory.Typing.InductivePattern +import Lean4Lean.Theory.Typing.NestedInductiveLemmas + +/-! +# Consumer certificates for completed inductive blocks + +`BlockGenerationCertificate` is the semantic input to the block transaction. +This module packages that input with one successful transaction and a +well-formed dependency environment, then exports the stable consequences a +consumer needs. The package contains only Theory values and proofs: no +implementation metadata, checker state, or normalization execution crosses +this boundary. + +In particular, `BlockCertificate.ruleClosure` derives the closed payload +required by the generated-pattern API from the registered, well-formed iota +rules in the completed environment. A consumer therefore does not need a +second closedness assumption in order to use `IotaPat`. +-/ + +namespace Lean4Lean + +namespace VInductDecl + +/-- One successful proof-carrying block transaction over an explicit +dependency environment. -/ +structure BlockCertificate (source : VInductDecl) (before after : VEnv) where + semantic : source.BlockGenerationCertificate before + success : before.addInductBlockCertified semantic = some after + beforeWF : before.WF + +namespace BlockCertificate + +variable {source : VInductDecl} {before after : VEnv} + +/-- Package the ordinary raw `addInduct` entry point once its accepted block +descriptor and semantic proof are known. This is the compatibility bridge +for consumers that still execute `addInduct`; no second transaction is run. -/ +def ofAddInduct + (generation : source.BlockGenerationChecked) (blockEnv : VEnv) + (hidentity : source.identityBlockGeneration? = some generation) + (hwf : generation.WF before blockEnv) (hbefore : before.WF) + (hadd : before.addInduct source = some after) : + BlockCertificate source before after where + semantic := ⟨generation, blockEnv, hwf⟩ + success := by + unfold VEnv.addInduct at hadd + rw [hidentity] at hadd + exact hadd + beforeWF := hbefore + +/-- The exact generation descriptor retained by a completed block. -/ +abbrev generation (certificate : BlockCertificate source before after) : + source.BlockGenerationChecked := + certificate.semantic.generation + +/-- Recover the four exact insertion phases of the completed block. -/ +theorem trace (certificate : BlockCertificate source before after) : + Nonempty (VEnv.AddInductBlockGenerationTrace before after + certificate.generation) := + VEnv.addInductBlockCertified_trace certificate.success + +/-- The completed transaction is a genuine block declaration step. -/ +theorem declWF (certificate : BlockCertificate source before after) : + VDecl.WF before (.induct source) after := by + apply VDecl.WF.inductBlock certificate.semantic.wf + simpa only [VEnv.addInductBlockCertified_eq_addInductBlockGeneration] using + certificate.success + +/-- Extend the dependency-environment history with the certified block. -/ +theorem afterWF (certificate : BlockCertificate source before after) : + after.WF := by + rcases certificate.beforeWF with ⟨decls, hdecls⟩ + exact ⟨.induct source :: decls, hdecls.decl certificate.declWF⟩ + +/-- A completed block only grows its dependency environment. -/ +theorem envLE (certificate : BlockCertificate source before after) : + before ≤ after := by + rcases certificate.trace with ⟨trace⟩ + exact trace.le + +/-- Compatibility spelling for consumers of the historical +`addInduct_le` growth theorem. -/ +theorem addInduct_le (certificate : BlockCertificate source before after) : + before ≤ after := + certificate.envLE + +/-- Compatibility spelling for the preservation result traditionally +exported as `addInduct_WF`. -/ +theorem addInduct_WF (certificate : BlockCertificate source before after) : + after.WF := + certificate.afterWF + +/-- Recover success through the ordinary raw API when this certificate's +descriptor is the declaration's identity descriptor. -/ +theorem addInduct + (certificate : BlockCertificate source before after) + (hidentity : source.identityBlockGeneration? = + some certificate.generation) : + before.addInduct source = some after := by + unfold VEnv.addInduct + rw [hidentity] + simpa [VEnv.addInductBlockCertified] using certificate.success + +/-- Every source family has its exact stored Theory value in the completed +environment. -/ +theorem familyLookup (certificate : BlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) : + after.constants family.name = some family.toVConstant := by + rcases certificate.trace with ⟨trace⟩ + exact trace.family_lookup hfamily + +/-- Every flattened source constructor has its exact stored Theory value in +the completed environment. -/ +theorem constructorLookup + (certificate : BlockCertificate source before after) + {constructor : VConstVal} + (hconstructor : constructor ∈ source.blockConstructorConstants) : + after.constants constructor.name = some constructor.toVConstant := by + rcases certificate.trace with ⟨trace⟩ + exact trace.ctor_lookup hconstructor + +/-- Every generated family recursor has its exact Theory value in the +completed environment. -/ +theorem recursorLookup + (certificate : BlockCertificate source before after) + {recursor : VConstVal} + (hrecursor : recursor ∈ certificate.generation.recursors) : + after.constants recursor.name = some recursor.toVConstant := by + rcases certificate.trace with ⟨trace⟩ + exact trace.rec_lookup hrecursor + +/-- A source family name was fresh at the dependency boundary. -/ +theorem familyFresh (certificate : BlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) : + before.constants family.name = none := by + rcases certificate.trace with ⟨trace⟩ + exact trace.family_fresh hfamily + +/-- A flattened source constructor name was fresh at the dependency +boundary. -/ +theorem constructorFresh + (certificate : BlockCertificate source before after) + {constructor : VConstVal} + (hconstructor : constructor ∈ source.blockConstructorConstants) : + before.constants constructor.name = none := by + rcases certificate.trace with ⟨trace⟩ + exact trace.ctor_fresh hconstructor + +/-- A generated recursor name was fresh at the dependency boundary. -/ +theorem recursorFresh + (certificate : BlockCertificate source before after) + {recursor : VConstVal} + (hrecursor : recursor ∈ certificate.generation.recursors) : + before.constants recursor.name = none := by + rcases certificate.trace with ⟨trace⟩ + exact trace.rec_fresh hrecursor + +/-- Every generated rule is registered by the completed transaction. -/ +theorem ruleRegistered + (certificate : BlockCertificate source before after) + {rule : VDefEq} + (hrule : rule ∈ certificate.generation.generatedRules) : + after.defeqs rule := by + rcases certificate.trace with ⟨trace⟩ + exact trace.rule_mem hrule + +/-- Every generated rule is well formed in the completed environment. -/ +theorem ruleWF + (certificate : BlockCertificate source before after) + {rule : VDefEq} + (hrule : rule ∈ certificate.generation.generatedRules) : + rule.WF after := + certificate.afterWF.ordered.defEqWF (certificate.ruleRegistered hrule) + +/-- An exact family lookup is unique. This small eliminator is convenient +for consumers that translate their own family representation to a Theory +constant and then compare it with the certificate inventory. -/ +theorem familyLookup_unique + (certificate : BlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) + {constant : VConstant} + (hlookup : after.constants family.name = some constant) : + constant = family.toVConstant := by + exact Option.some.inj (hlookup.symm.trans (certificate.familyLookup hfamily)) + +/-- An exact constructor lookup is unique. -/ +theorem constructorLookup_unique + (certificate : BlockCertificate source before after) + {constructor : VConstVal} + (hconstructor : constructor ∈ source.blockConstructorConstants) + {constant : VConstant} + (hlookup : after.constants constructor.name = some constant) : + constant = constructor.toVConstant := by + exact Option.some.inj + (hlookup.symm.trans (certificate.constructorLookup hconstructor)) + +/-- An exact generated-recursor lookup is unique. -/ +theorem recursorLookup_unique + (certificate : BlockCertificate source before after) + {recursor : VConstVal} + (hrecursor : recursor ∈ certificate.generation.recursors) + {constant : VConstant} + (hlookup : after.constants recursor.name = some constant) : + constant = recursor.toVConstant := by + exact Option.some.inj + (hlookup.symm.trans (certificate.recursorLookup hrecursor)) + +private theorem rule_mem_generatedRules + (generation : source.BlockGenerationChecked) + {i : Nat} {constructor : NormalizedBlockCtor} + (hentry : generation.flatCtors[i]? = some constructor) : + generation.rule i constructor ∈ generation.generatedRules := by + apply List.mem_map.2 + refine ⟨(constructor, i), ?_, rfl⟩ + apply List.mem_of_getElem? (i := i) + rw [List.getElem?_zipIdx, hentry, Option.map_some, Nat.zero_add] + +private theorem closedN_lamN_body : + ∀ {binders : List VExpr} {body : VExpr} {k : Nat}, + (VExpr.lamN binders body).ClosedN k → + body.ClosedN (k + binders.length) + | [], _, _, h => by + simpa only [VExpr.lamN, List.length_nil, Nat.add_zero] using h + | _ :: binders, body, k, h => by + have hbody := closedN_lamN_body (binders := binders) + (body := body) (k := k + 1) h.2 + simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hbody + +private theorem closedN_lamN_replace : + ∀ {binders : List VExpr} {body body' : VExpr} {k : Nat}, + (VExpr.lamN binders body).ClosedN k → + body'.ClosedN (k + binders.length) → + (VExpr.lamN binders body').ClosedN k + | [], _, _, _, _, hbody' => by + simpa only [VExpr.lamN, List.length_nil, Nat.add_zero] using hbody' + | _ :: binders, body, body', k, h, hbody' => by + refine ⟨h.1, closedN_lamN_replace (binders := binders) + (body := body) (body' := body') (k := k + 1) h.2 ?_⟩ + simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using hbody' + +private theorem closedN_appN_function : + ∀ {function : VExpr} {arguments : List VExpr} {k : Nat}, + (VExpr.appN function arguments).ClosedN k → function.ClosedN k + | _, [], _, h => by simpa only [VExpr.appN] using h + | function, argument :: arguments, k, h => + (closedN_appN_function (function := function.app argument) + (arguments := arguments) (k := k) h).1 + +private theorem closedN_appN_argument + {function : VExpr} {arguments : List VExpr} {k : Nat} + (hclosed : (VExpr.appN function arguments).ClosedN k) + {argument : VExpr} (hargument : argument ∈ arguments) : + argument.ClosedN k := by + induction arguments generalizing function with + | nil => simp at hargument + | cons head tail ih => + rcases List.mem_cons.1 hargument with heq | htail + · rw [heq] + exact (closedN_appN_function + (function := function.app head) (arguments := tail) + (k := k) hclosed).2 + · exact ih (function := function.app head) hclosed htail + +/-- The successful block transaction supplies the closedness bundle required +by `IotaPat`. Closedness is derived from the registered rules and the +completed environment's ordinary WF history; it is not an additional +consumer assumption. -/ +theorem ruleClosure + (certificate : BlockCertificate source before after) : + certificate.generation.RuleClosure := by + constructor + · intro i constructor hentry + have hmem := rule_mem_generatedRules certificate.generation hentry + exact (certificate.ruleWF hmem).2.closedN + certificate.afterWF.ordered trivial + · intro constructor hconstructor expression hexpression + obtain ⟨i, hentry⟩ := List.mem_iff_getElem?.1 hconstructor + have hmem := rule_mem_generatedRules certificate.generation hentry + have hlhs := (certificate.ruleWF hmem).1.closedN + certificate.afterWF.ordered trivial + rw [certificate.generation.rule_lhs i constructor] at hlhs + have hbody := closedN_lamN_body hlhs + have hexpression' : expression ∈ + certificate.generation.ruleIdx constructor ++ + [certificate.generation.ruleCtorApp constructor] := + List.mem_append.2 (.inl hexpression) + have hclosed : expression.ClosedN + (certificate.generation.ruleBinders constructor).length := by + apply closedN_appN_argument + (function := certificate.generation.recBase + (certificate.generation.ruleFieldCount constructor) + constructor.owner) + (arguments := certificate.generation.ruleIdx constructor ++ + [certificate.generation.ruleCtorApp constructor]) + · simpa only [BlockGenerationChecked.ruleLhsBody, List.length_nil, + Nat.zero_add] using hbody + · exact hexpression' + apply closedN_lamN_replace hlhs + simpa using hclosed + +/-- The exact generated pattern and payload associated with one flattened +rule entry. -/ +theorem recursorPattern + (certificate : BlockCertificate source before after) + {i : Nat} {constructor : NormalizedBlockCtor} + (hentry : certificate.generation.ruleEntry i constructor) : + certificate.generation.IotaPat certificate.ruleClosure + ((certificate.generation.rulePattern constructor).toPattern) + (certificate.generation.ruleRHS certificate.ruleClosure hentry, + certificate.generation.ruleCheck certificate.ruleClosure + (List.mem_of_getElem? hentry)) := + .mk hentry + +/-- Rule-level consumer bundle: exact global position, generated-list +membership, registration, well-formedness, and the corresponding L4L-10 +pattern all come from the same completed block. -/ +structure RecursorRuleFacts + (certificate : BlockCertificate source before after) + (i : Nat) (constructor : NormalizedBlockCtor) : Prop where + entry : certificate.generation.ruleEntry i constructor + member : certificate.generation.rule i constructor ∈ + certificate.generation.generatedRules + registered : after.defeqs (certificate.generation.rule i constructor) + wf : (certificate.generation.rule i constructor).WF after + pattern : certificate.generation.IotaPat certificate.ruleClosure + ((certificate.generation.rulePattern constructor).toPattern) + (certificate.generation.ruleRHS certificate.ruleClosure entry, + certificate.generation.ruleCheck certificate.ruleClosure + (List.mem_of_getElem? entry)) + +/-- Assemble all rule facts without a consumer-supplied semantic premise. -/ +theorem recursorRuleFacts + (certificate : BlockCertificate source before after) + {i : Nat} {constructor : NormalizedBlockCtor} + (hentry : certificate.generation.ruleEntry i constructor) : + certificate.RecursorRuleFacts i constructor := by + have hmember := rule_mem_generatedRules certificate.generation hentry + exact { + entry := hentry + member := hmember + registered := certificate.ruleRegistered hmember + wf := certificate.ruleWF hmember + pattern := certificate.recursorPattern hentry } + +end BlockCertificate + +/-! ## Completed nested transactions -/ + +/-- One successful proof-carrying nested transaction over an explicit +dependency environment. As with `BlockCertificate`, this package contains +only Theory artifacts. -/ +structure NestedBlockCertificate + (source : VInductDecl) (before after : VEnv) where + nested : source.NestedBlockChecked + semantic : nested.WF before + success : before.addInductNested nested = some after + beforeWF : before.WF + +namespace NestedBlockCertificate + +variable {source : VInductDecl} {before after : VEnv} + +/-- Recover the exact four-phase nested transaction trace. -/ +theorem trace (certificate : NestedBlockCertificate source before after) : + Nonempty (VEnv.AddInductNestedTrace before after certificate.nested) := + VEnv.addInductNested_trace certificate.success + +/-- The nested completion is a genuine inductive declaration step. -/ +theorem declWF (certificate : NestedBlockCertificate source before after) : + VDecl.WF before (.induct source) after := + .inductNested certificate.semantic certificate.success + +/-- Extend the dependency-environment history with the nested block. -/ +theorem afterWF (certificate : NestedBlockCertificate source before after) : + after.WF := by + rcases certificate.beforeWF with ⟨decls, hdecls⟩ + exact ⟨.induct source :: decls, hdecls.decl certificate.declWF⟩ + +/-- A completed nested transaction only grows its dependency environment. -/ +theorem envLE (certificate : NestedBlockCertificate source before after) : + before ≤ after := + VEnv.addInductNested_le certificate.success + +/-- Nested analogue of the public block growth result. -/ +theorem addInduct_le + (certificate : NestedBlockCertificate source before after) : + before ≤ after := + certificate.envLE + +/-- Nested analogue of the public block preservation result. -/ +theorem addInduct_WF + (certificate : NestedBlockCertificate source before after) : + after.WF := + certificate.afterWF + +/-- Every stored source family has its exact final value. -/ +theorem familyLookup (certificate : NestedBlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) : + after.constants family.name = some family.toVConstant := by + rcases certificate.trace with ⟨trace⟩ + exact trace.family_lookup hfamily + +/-- Every stored source constructor has its exact final value. -/ +theorem constructorLookup + (certificate : NestedBlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) + {constructor : VConstVal} (hconstructor : constructor ∈ family.ctors) : + after.constants constructor.name = some constructor.toVConstant := by + rcases certificate.trace with ⟨trace⟩ + exact trace.ctor_lookup hfamily hconstructor + +/-- Every restored recursor has its exact final value. -/ +theorem recursorLookup + (certificate : NestedBlockCertificate source before after) + {recursor : VConstVal} (hrecursor : recursor ∈ certificate.nested.recursors) : + after.constants recursor.name = some recursor.toVConstant := by + rcases certificate.trace with ⟨trace⟩ + exact trace.rec_lookup hrecursor + +/-- Every source family name was fresh at the dependency boundary. -/ +theorem familyFresh (certificate : NestedBlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) : + before.constants family.name = none := by + rcases certificate.trace with ⟨trace⟩ + exact trace.family_fresh hfamily + +/-- Every flattened source constructor name was fresh at the dependency +boundary. -/ +theorem constructorFresh + (certificate : NestedBlockCertificate source before after) + {constructor : VConstVal} + (hconstructor : constructor ∈ source.blockConstructorConstants) : + before.constants constructor.name = none := by + rcases certificate.trace with ⟨trace⟩ + exact trace.ctor_fresh hconstructor + +/-- Every restored recursor name was fresh at the dependency boundary. -/ +theorem recursorFresh + (certificate : NestedBlockCertificate source before after) + {recursor : VConstVal} (hrecursor : recursor ∈ certificate.nested.recursors) : + before.constants recursor.name = none := by + rcases certificate.trace with ⟨trace⟩ + exact trace.rec_fresh hrecursor + +/-- Every restored rule is registered in the completed environment. -/ +theorem ruleRegistered + (certificate : NestedBlockCertificate source before after) + {rule : VDefEq} (hrule : rule ∈ certificate.nested.generatedRules) : + after.defeqs rule := by + rcases certificate.trace with ⟨trace⟩ + exact trace.rule_mem hrule + +/-- Every registered restored rule is well formed. -/ +theorem ruleWF + (certificate : NestedBlockCertificate source before after) + {rule : VDefEq} (hrule : rule ∈ certificate.nested.generatedRules) : + rule.WF after := + certificate.afterWF.ordered.defEqWF (certificate.ruleRegistered hrule) + +/-- Exact family lookups are unique. -/ +theorem familyLookup_unique + (certificate : NestedBlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) + {constant : VConstant} + (hlookup : after.constants family.name = some constant) : + constant = family.toVConstant := + Option.some.inj (hlookup.symm.trans (certificate.familyLookup hfamily)) + +/-- Exact constructor lookups are unique. -/ +theorem constructorLookup_unique + (certificate : NestedBlockCertificate source before after) + {family : VInductiveType} (hfamily : family ∈ source.types) + {constructor : VConstVal} (hconstructor : constructor ∈ family.ctors) + {constant : VConstant} + (hlookup : after.constants constructor.name = some constant) : + constant = constructor.toVConstant := + Option.some.inj + (hlookup.symm.trans (certificate.constructorLookup hfamily hconstructor)) + +/-- Exact restored-recursor lookups are unique. -/ +theorem recursorLookup_unique + (certificate : NestedBlockCertificate source before after) + {recursor : VConstVal} (hrecursor : recursor ∈ certificate.nested.recursors) + {constant : VConstant} + (hlookup : after.constants recursor.name = some constant) : + constant = recursor.toVConstant := + Option.some.inj + (hlookup.symm.trans (certificate.recursorLookup hrecursor)) + +end NestedBlockCertificate + +end VInductDecl + +end Lean4Lean + +/-! ## Exact Theory trust guards -/ + +/-- info: 'Lean4Lean.VInductDecl.BlockCertificate.afterWF' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockCertificate.afterWF + +/-- info: 'Lean4Lean.VInductDecl.BlockCertificate.ruleClosure' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockCertificate.ruleClosure + +/-- info: 'Lean4Lean.VInductDecl.BlockCertificate.recursorRuleFacts' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockCertificate.recursorRuleFacts + +/-- info: 'Lean4Lean.VInductDecl.NestedBlockCertificate.afterWF' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.NestedBlockCertificate.afterWF + +/-- info: 'Lean4Lean.VInductDecl.NestedBlockCertificate.ruleWF' depends on axioms: [propext, Classical.choice, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.NestedBlockCertificate.ruleWF diff --git a/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean b/Lean4Lean/Theory/Typing/NestedInductiveLemmas.lean index 44c12a9f..095bc531 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 d9faa29f..5e476764 100644 --- a/Lean4Lean/Verify.lean +++ b/Lean4Lean/Verify.lean @@ -1 +1,2 @@ import Lean4Lean.Verify.Typing.Lemmas +import Lean4Lean.Verify.Environment.InductiveReplayMatrix diff --git a/Lean4Lean/Verify/Environment/DeepNestedReplay.lean b/Lean4Lean/Verify/Environment/DeepNestedReplay.lean new file mode 100644 index 00000000..1db0c7d8 --- /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 0760087c..768cd2e5 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 00000000..f4c8d3d9 --- /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 fea5ad70..c8f7f82f 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 f4e914c2..392b4bb1 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 f39a9657..7606ef21 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 72006f13..bf1fb0a3 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 26/51] 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 489b62e7..019d1ae1 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 3892e02f..617a433f 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 00000000..045ea039 --- /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 00000000..a196f315 --- /dev/null +++ b/Lean4Lean/Theory/LocalContext.lean @@ -0,0 +1,149 @@ +import Lean4Lean.Theory.Typing.UniqueTyping + +/-! # Theory local declarations + +The implementation-independent core of a local context. `VLocalDecl` only +mentions Theory expressions; the `Lean.FVarId` bookkeeping used by the +verified Lean-expression translator remains in `Lean4Lean.Verify.VLCtx`. +-/ + +namespace Lean4Lean +open VEnv + +inductive VLocalDecl where + | vlam (type : VExpr) + | vlet (type value : VExpr) + +def VLocalDecl.depth : VLocalDecl → Nat + | .vlam .. => 1 + | .vlet .. => 0 + +def VLocalDecl.value : VLocalDecl → VExpr + | .vlam .. => .bvar 0 + | .vlet _ e => e + +def VLocalDecl.type' : VLocalDecl → VExpr + | .vlam A + | .vlet A _ => A + +def VLocalDecl.type : VLocalDecl → VExpr + | .vlam A => A.lift + | .vlet A _ => A + +def VLocalDecl.lift' : VLocalDecl → Lift → VLocalDecl + | .vlam A, n => .vlam (A.lift' n) + | .vlet A e, n => .vlet (A.lift' n) (e.lift' n) + +def VLocalDecl.liftN : VLocalDecl → Nat → Nat → VLocalDecl + | .vlam A, n, k => .vlam (A.liftN n k) + | .vlet A e, n, k => .vlet (A.liftN n k) (e.liftN n k) + +def VLocalDecl.inst : VLocalDecl → VExpr → (k : Nat := 0) → VLocalDecl + | .vlam A, e₀, k => .vlam (A.inst e₀ k) + | .vlet A e, e₀, k => .vlet (A.inst e₀ k) (e.inst e₀ k) + +def VLocalDecl.instL : VLocalDecl → List VLevel → VLocalDecl + | .vlam A, ls => .vlam (A.instL ls) + | .vlet A e, ls => .vlet (A.instL ls) (e.instL ls) + +def VLocalDecl.WF (env : VEnv) (U : Nat) (Γ : List VExpr) : VLocalDecl → Prop + | .vlam type => env.IsType U Γ type + | .vlet type value => env.HasType U Γ value type + +def VLocalDecl.ClosedN : VLocalDecl → (k : Nat := 0) → Prop + | .vlam A, k => A.ClosedN k + | .vlet A e, k => A.ClosedN k ∧ e.ClosedN k + +variable! (env : VEnv) (U : Nat) (Γ : List VExpr) in +inductive VLocalDecl.IsDefEq : VLocalDecl → VLocalDecl → Prop + | vlam : env.IsDefEq U Γ type₁ type₂ (.sort u) → + VLocalDecl.IsDefEq (.vlam type₁) (.vlam type₂) + | vlet : + env.IsDefEq U Γ value₁ value₂ type₁ → env.IsDefEq U Γ type₁ type₂ (.sort u) → + VLocalDecl.IsDefEq (.vlet type₁ value₁) (.vlet type₂ value₂) + +theorem VLocalDecl.lift'_consN_skipN {d : VLocalDecl} : + d.lift' (.consN (.skipN .refl n) k) = d.liftN n k := by + cases d <;> simp [VLocalDecl.lift', VLocalDecl.liftN, VExpr.lift'_consN_skipN] + +nonrec theorem VLocalDecl.WF.weakN (henv : env.Ordered) (W : Ctx.LiftN n k Γ Γ') : + ∀ {d}, WF env U Γ d → WF env U Γ' (d.liftN n k) + | .vlam _, H | .vlet .., H => H.weakN henv W + +nonrec theorem VLocalDecl.WF.instN (henv : env.Ordered) (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) + (h₀ : env.HasType U Γ₀ e₀ A₀) : ∀ {d}, WF env U Γ₁ d → WF env U Γ (d.inst e₀ k) + | .vlam _, H | .vlet .., H => H.instN henv W h₀ + +nonrec theorem VLocalDecl.WF.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U') : + ∀ {d}, WF env ls.length Γ d → WF env U' (Γ.map (·.instL ls)) (d.instL ls) + | .vlam _, H | .vlet .., H => H.instL hls + +@[simp] theorem VLocalDecl.lift'_depth {d : VLocalDecl} : (d.lift' n).depth = d.depth := by + cases d <;> rfl + +theorem VLocalDecl.lift'_comp {d : VLocalDecl} : + d.lift' (.comp l₁ l₂) = (d.lift' l₁).lift' l₂ := by + cases d <;> simp [VLocalDecl.lift', VExpr.lift'_comp] + +variable! (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U)) + (W : Ctx.Lift' n Γ Γ') in +theorem VLocalDecl.weak'_iff : + VLocalDecl.WF env U Γ' (d.lift' n) ↔ VLocalDecl.WF env U Γ d := + match d with + | .vlam .. => IsType.weak'_iff henv hΓ' W + | .vlet .. => HasType.weak'_iff henv hΓ' W + +variable! (henv : VEnv.WF env) (hΓ' : OnCtx Γ' (env.IsType U)) + (W : Ctx.LiftN n k Γ Γ') in +theorem VLocalDecl.weakN_iff : + VLocalDecl.WF env U Γ' (d.liftN n k) ↔ VLocalDecl.WF env U Γ d := + match d with + | .vlam .. => IsType.weakN_iff henv hΓ' W + | .vlet .. => HasType.weakN_iff henv hΓ' W + +variable! (henv : Ordered env) (hΓ : OnCtx Γ (IsType env U)) in +theorem VLocalDecl.IsDefEq.refl : + ∀ {d}, VLocalDecl.WF env U Γ d → VLocalDecl.IsDefEq env U Γ d d + | .vlam _, ⟨_, h1⟩ => .vlam h1 + | .vlet .., h1 => let ⟨_, h2⟩ := h1.isType henv hΓ; .vlet h1 h2 + +theorem VLocalDecl.IsDefEq.wf : + VLocalDecl.IsDefEq env U Γ d₁ d₂ → VLocalDecl.WF env U Γ d₁ + | .vlam h3 => ⟨_, h3.hasType.1⟩ + | .vlet h3 _ => h3.hasType.1 + +theorem VLocalDecl.IsDefEq.mono (henv : env ≤ env') : + VLocalDecl.IsDefEq env U Γ d₁ d₂ → VLocalDecl.IsDefEq env' U Γ d₁ d₂ + | .vlam h => .vlam (h.mono henv) + | .vlet h₁ h₂ => .vlet (h₁.mono henv) (h₂.mono henv) + +theorem VLocalDecl.IsDefEq.symm : + VLocalDecl.IsDefEq env U Γ d₁ d₂ → VLocalDecl.IsDefEq env U Γ d₂ d₁ + | .vlam h1 => .vlam h1.symm + | .vlet h1 h2 => .vlet (h2.defeqDF h1.symm) h2.symm + +theorem VLocalDecl.IsDefEq.defeqDFC (henv : Ordered env) + (hΓ : IsDefEqCtx env U Γ₀ Γ₁ Γ₂) : + VLocalDecl.IsDefEq env U Γ₁ d₁ d₂ → VLocalDecl.IsDefEq env U Γ₂ d₁ d₂ + | .vlam h1 => .vlam (h1.defeqDFC henv hΓ) + | .vlet h1 h2 => .vlet (h1.defeqDFC henv hΓ) (h2.defeqDFC henv hΓ) + +/-- +info: 'Lean4Lean.VLocalDecl.WF.weakN' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VLocalDecl.WF.weakN + +/-- +info: 'Lean4Lean.VLocalDecl.weakN_iff' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms VLocalDecl.weakN_iff + +/-- +info: 'Lean4Lean.VLocalDecl.IsDefEq.defeqDFC' depends on axioms: [propext, Quot.sound] +-/ +#guard_msgs in +#print axioms VLocalDecl.IsDefEq.defeqDFC + +end Lean4Lean diff --git a/Lean4Lean/Verify/Typing/Expr.lean b/Lean4Lean/Verify/Typing/Expr.lean index f6acd64e..aadebcf0 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 9fe95a19..305886c2 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 f6c6d08c..3eb52f37 100644 --- a/Lean4Lean/Verify/VLCtx.lean +++ b/Lean4Lean/Verify/VLCtx.lean @@ -1,46 +1,10 @@ import Lean4Lean.Verify.Expr -import Lean4Lean.Theory.VExpr +import Lean4Lean.Theory.LocalContext namespace Lean4Lean open Lean (FVarId Expr) -inductive VLocalDecl where - | vlam (type : VExpr) - | vlet (type value : VExpr) - -def VLocalDecl.depth : VLocalDecl → Nat - | .vlam .. => 1 - | .vlet .. => 0 - -def VLocalDecl.value : VLocalDecl → VExpr - | .vlam .. => .bvar 0 - | .vlet _ e => e - -def VLocalDecl.type' : VLocalDecl → VExpr - | .vlam A - | .vlet A _ => A - -def VLocalDecl.type : VLocalDecl → VExpr - | .vlam A => A.lift - | .vlet A _ => A - -def VLocalDecl.lift' : VLocalDecl → Lift → VLocalDecl - | .vlam A, n => .vlam (A.lift' n) - | .vlet A e, n => .vlet (A.lift' n) (e.lift' n) - -def VLocalDecl.liftN : VLocalDecl → Nat → Nat → VLocalDecl - | .vlam A, n, k => .vlam (A.liftN n k) - | .vlet A e, n, k => .vlet (A.liftN n k) (e.liftN n k) - -def VLocalDecl.inst : VLocalDecl → VExpr → (k : Nat := 0) → VLocalDecl - | .vlam A, e₀, k => .vlam (A.inst e₀ k) - | .vlet A e, e₀, k => .vlet (A.inst e₀ k) (e.inst e₀ k) - -def VLocalDecl.instL : VLocalDecl → List VLevel → VLocalDecl - | .vlam A, ls => .vlam (A.instL ls) - | .vlet A e, ls => .vlet (A.instL ls) (e.instL ls) - def VLCtx := List (Option (FVarId × List FVarId) × VLocalDecl) namespace VLCtx diff --git a/plans/roadmap.md b/plans/roadmap.md index 7606ef21..93294cd6 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 bf1fb0a3..edb4d5eb 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 27/51] 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 18089ba4..e69d2ba1 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 00000000..fae0db67 --- /dev/null +++ b/Lean4Lean/Tests/LiteralReadiness.lean @@ -0,0 +1,99 @@ +import Lean4Lean.Theory.InductiveFixtures +import Lean4Lean.Theory.Literals +import Lean4Lean.Verify.Typing.Lemmas + +/-! # Literal readiness fixtures + +These checks pin the consumer-neutral prelude descriptors used by +`VEnv.PreludeReady` to Lean's real compiled metadata, then exercise direct and +constructor-unfolded literals with notation-heavy values. +-/ + +namespace Lean4Lean.Tests.LiteralReadiness + +open Lean + +/-! The manual Theory descriptors are exactly the declarations already +checked against the kernel by `Theory.InductiveFixtures`. -/ + +example : LiteralPrelude.boolType = InductiveFixtures.boolType := rfl +example : LiteralPrelude.natType = InductiveFixtures.natType := rfl +example : LiteralPrelude.listType = InductiveFixtures.listType := rfl + +example : LiteralPrelude.char = vconst(type_of% @Char) := rfl +example : LiteralPrelude.charOfNat = vconst(type_of% @Char.ofNat) := rfl +example : LiteralPrelude.string = vconst(type_of% @String) := rfl +example : LiteralPrelude.stringOfList = vconst(type_of% @String.ofList) := rfl + +/-! The readiness contract's recursor and iota descriptors also agree +definitionally with the kernel declarations. List's two universe parameters +use the same explicit occurrence-to-kernel permutation as the underlying +inductive adequacy fixture. -/ + +private def permC (ci : VConstant) (ls : List VLevel) : VConstant := + ⟨ci.uvars, ci.type.instL ls⟩ + +private def permE (df : VDefEq) (ls : List VLevel) : VDefEq := + ⟨df.uvars, df.lhs.instL ls, df.rhs.instL ls, df.type.instL ls⟩ + +example : LiteralPrelude.boolRec = vconst(type_of% @Bool.rec) := rfl +example : LiteralPrelude.boolIotas[0]? = + some (vdefeq(motive f t => @Bool.rec motive f t .false ≡ f)) := rfl +example : LiteralPrelude.boolIotas[1]? = + some (vdefeq(motive f t => @Bool.rec motive f t .true ≡ t)) := rfl + +example : LiteralPrelude.natRec = vconst(type_of% @Nat.rec) := rfl +example : LiteralPrelude.natIotas[0]? = + some (vdefeq(motive z s => @Nat.rec motive z s .zero ≡ z)) := rfl +example : LiteralPrelude.natIotas[1]? = + some (vdefeq(motive z s n => + @Nat.rec motive z s (.succ n) ≡ s n (@Nat.rec motive z s n))) := rfl + +example : LiteralPrelude.listRec = + permC (vconst(type_of% @List.rec)) [.param 1, .param 0] := rfl +example : LiteralPrelude.listIotas[0]? = + some (permE (vdefeq(α motive n c => @List.rec α motive n c (@List.nil α) ≡ n)) + [.param 1, .param 0]) := rfl +example : LiteralPrelude.listIotas[1]? = + some (permE (vdefeq(α motive n c hd tl => + @List.rec α motive n c (@List.cons α hd tl) ≡ + c hd tl (@List.rec α motive n c tl))) + [.param 1, .param 0]) := rfl + +section + +variable {env : VEnv} (ready : env.PreludeReady) + +example {env' : VEnv} (henv : env ≤ env') (hordered : env'.Ordered) : + env'.PreludeReady := + ready.mono henv hordered + +example {env' : VEnv} (name : Name) (ci : VConstant) (hci : ci.WF env) + (hadd : env.addConst name ci = some env') : env'.PreludeReady := + ready.addConst hci hadd + +example (df : VDefEq) (hdf : df.WF env) : + (env.addDefEq df).PreludeReady := + ready.addDefEq hdf + +example : VExpr.WF env 0 [] (VExpr.trLiteral (.natVal 1_234_567)) := + ready.trLiteral_wf _ (ready.containsLits _) + +example : VExpr.WF env 3 [] + (VExpr.trLiteral (.strVal "Lean 4: λ → ☃ — 12,345")) := + ready.trLiteral_wf _ (ready.containsLits _) + +example (h : TrExprS env [] [] + (Literal.toConstructor (.strVal "constructor ↔ direct")) w) : + w = VExpr.trLiteral (.strVal "constructor ↔ direct") ∧ + VExpr.WF env 0 [] w := + h.toConstructor_ready ready (ready.containsLits _) + +example {l : Literal} + (h : TrExprS env [] [] (Literal.toConstructor l) w) : + w = VExpr.trLiteral l := + h.toConstructor_eq + +end + +end Lean4Lean.Tests.LiteralReadiness diff --git a/Lean4Lean/Theory/Literals.lean b/Lean4Lean/Theory/Literals.lean index 045ea039..ae8afeec 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 305886c2..cae1e392 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 93294cd6..9a19b44d 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 edb4d5eb..48fef911 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 28/51] 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 019d1ae1..fe11665e 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 e69d2ba1..540a95e5 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 00000000..d8d9d298 --- /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 617a433f..2a063b5c 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 00000000..d2151dd6 --- /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 ea7674f6..1c921cba 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 733a3734..45df0455 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 1db0c7d8..39a76804 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 30465a28..f963b5e5 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecCandidate.lean @@ -1604,7 +1604,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.candidateIsDefEqSelfValid' depends on a /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecFamily_candidateTrace' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -1628,7 +1627,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecFamily_candidateTrace' depend /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVec_checkInductiveTypes' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -1653,7 +1651,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVec_checkInductiveTypes' depends /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecCandidateInductiveStats_nindices' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, @@ -1677,7 +1674,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.indexedVecCandidateInductiveStats_nindi /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecCandidateInductiveStats_params' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, diff --git a/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean index 4cd4666b..00c3600d 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecOuterReplay.lean @@ -1739,7 +1739,6 @@ theorem indexedVecNormalizationCandidateProduced : /-- info: 'Lean4Lean.InductiveReplayFixtures.indexedVecNormalizationCandidateProduced' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Expr.eqv_eq, diff --git a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean index e1d6853d..81c5e561 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 768cd2e5..27cdeb7d 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 f4c8d3d9..0daafb22 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 c8f7f82f..fd6a9a60 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 32f09cb3..fd1b8bb2 100644 --- a/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean +++ b/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean @@ -3120,12 +3120,11 @@ info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeFinalEnv_ordered' depe #guard_msgs in #print axioms indexedTreeFinalEnv_ordered -/- The implementation metadata replay inherits only the already classified -Verify relation and persistent-map contracts; fixture-local native-decision +/- The implementation metadata replay is now `sorryAx`-free and inherits only +the already classified persistent-map contracts; fixture-local native-decision axioms are deliberately absent. -/ /-- info: 'Lean4Lean.MutualInductiveReplayFixtures.treeAddInductBlock' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -3137,7 +3136,6 @@ info: 'Lean4Lean.MutualInductiveReplayFixtures.treeAddInductBlock' depends on ax /-- info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeAddInductBlock' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -3149,7 +3147,6 @@ info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTreeAddInductBlock' depend /-- info: 'Lean4Lean.MutualInductiveReplayFixtures.tree_verify_aligned' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, @@ -3161,7 +3158,6 @@ info: 'Lean4Lean.MutualInductiveReplayFixtures.tree_verify_aligned' depends on a /-- info: 'Lean4Lean.MutualInductiveReplayFixtures.indexedTree_verify_aligned' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, diff --git a/Lean4Lean/Verify/Environment/NestedReplay.lean b/Lean4Lean/Verify/Environment/NestedReplay.lean index f2617343..c31f091f 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 94396d73..77d2462c 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 d9b4ce14..d90eb1f8 100644 --- a/Lean4Lean/Verify/Environment/NormalizationMatrix.lean +++ b/Lean4Lean/Verify/Environment/NormalizationMatrix.lean @@ -723,12 +723,12 @@ theorem normalizationMatrix_rec_lookup_unique : normalizationMatrixFinalEnv_rec_lookup /-! The semantic generation helpers used above are guarded in -`Theory.Typing.InductiveLemmas`; these two guards pin the separate transitional -Verify closure of metadata translation and final environment replay. -/ +`Theory.Typing.InductiveLemmas`; these two guards pin the separate, now +`sorryAx`-free Verify closure of metadata translation and final environment +replay. -/ /-- info: 'Lean4Lean.InductiveReplayFixtures.normalizationMatrixInfo_tr' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound] -/ @@ -737,7 +737,6 @@ info: 'Lean4Lean.InductiveReplayFixtures.normalizationMatrixInfo_tr' depends on /-- info: 'Lean4Lean.InductiveReplayFixtures.normalizationMatrix_trEnv'' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, PersistentHashMap.findAux_isSome, diff --git a/Lean4Lean/Verify/Environment/SingletonParityReplay.lean b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean index 392b4bb1..8501ee68 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 aadebcf0..26132245 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 cae1e392..ab3ecbfb 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 715bfaff552c3e901ea767636d7975b7d5e17eba Mon Sep 17 00:00:00 2001 From: Mario Carneiro Date: Tue, 11 Aug 2026 01:41:18 +0200 Subject: [PATCH 29/51] verify: prove soundness of the standard library normalize MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Closes the last gap in the soundness of Lean's own level operations: eval_normalize (hence isEquiv_wf and geq_wf) is now proved, so those no longer depend on sorryAx — only on the syntactic Total.normalize patch axioms, as the axiom tests now record. The proof is a strong induction on Total.size. The mutual recursion with getMaxArgsAux is untangled by two standalone lemmas parameterized by the induction hypothesis for normalize. The max branch needs two facts about the sort: that it permutes, and that entries with equal level base come out ordered by offset; everything else (mkMaxAux dropping an entry when the next has the same base, and skipExplicit/isExplicitSubsumed dropping subsumed constants) follows from those. Supporting files: * Verify/QSort.lean: verification of Array.qsort, adapted from leanprover/lean4#14658, which the standard library does not yet ship. * Verify/NormLt.lean: normLt is a strict weak order, as qsort_sorted requires. normLt is identified with an Ordering-valued normCmp that compares levels by (base, offset) lexicographically, bases compared structurally; normCmp carries the Std order instances (ReflCmp, TransCmp, LawfulEqCmp), from which normLt's properties follow. * Std/Ord.lean: Rot, the lexicographic-product device transitivity needs. Transitivity of a lexicographic product requires knowing the first components are equal in both directions before consulting the second, so a recursion that visits components in different orders must carry all three rotations of transitivity at a triple. This was already being done by hand for Name.cmp; both now share it. * Verify/Name.lean: the Name.cmp/quickCmp order instances and the NameSet lemmas, split out of Verify/Level.lean so both level files can use them. Name.cmp's TransCmp instance loses its bespoke copy of the above, including the manual rotation shuffling, since Rot.then produces all three rotations of a product at once. Co-Authored-By: Claude Fable 5 --- Lean4Lean/Std/Ord.lean | 52 +++++ Lean4Lean/Tests/LevelStd.lean | 4 +- Lean4Lean/Verify/Axioms.lean | 6 +- Lean4Lean/Verify/Level.lean | 104 +-------- Lean4Lean/Verify/LevelStd.lean | 370 ++++++++++++++++++++++++++++++- Lean4Lean/Verify/Name.lean | 90 ++++++++ Lean4Lean/Verify/NormLt.lean | 364 ++++++++++++++++++++++++++++++ Lean4Lean/Verify/QSort.lean | 392 +++++++++++++++++++++++++++++++++ 8 files changed, 1270 insertions(+), 112 deletions(-) create mode 100644 Lean4Lean/Std/Ord.lean create mode 100644 Lean4Lean/Verify/Name.lean create mode 100644 Lean4Lean/Verify/NormLt.lean create mode 100644 Lean4Lean/Verify/QSort.lean diff --git a/Lean4Lean/Std/Ord.lean b/Lean4Lean/Std/Ord.lean new file mode 100644 index 00000000..f7913172 --- /dev/null +++ b/Lean4Lean/Std/Ord.lean @@ -0,0 +1,52 @@ +import Init.Data.Order.Ord + +/-! +A device for proving `Std.TransCmp` for comparisons defined by *lexicographic products*, used for +`Lean.Name.cmp` in `Lean4Lean.Verify.Name` and for the level order in `Lean4Lean.Verify.NormLt`. + +Transitivity of a lexicographic product needs more than transitivity of its components: when the +first components compare `.eq` one has to know they compare `.eq` *in both directions* before the +second components can be consulted. Recursive comparisons therefore do not prove `isLE_trans` at a +triple `(a, b, c)` from `isLE_trans` at the sub-triple alone; one needs its rotations too. `Rot` +below packages the three rotations, which is exactly the statement that goes through the induction. +-/ + +namespace Lean4Lean +open Std + +/-- The three rotations of transitivity for a comparison at a triple `a`, `b`, `c`, where +`x = cmp a b`, `y = cmp b c`, `z = cmp a c`. Note that the second and third components are the +first one at the rotated triples `(c, a, b)` and `(b, c, a)`, rewritten with `Ordering.swap`. -/ +def Rot (x y z : Ordering) : Prop := + (x.isLE → y.isLE → z.isLE) ∧ + (z.swap.isLE → x.isLE → y.swap.isLE) ∧ + (y.isLE → z.swap.isLE → x.swap.isLE) + +/-- Lexicographic products satisfy `Rot` if the components do. The second component's rotations +are only required when the first components are all `.eq`; this matters when the second component +is a comparison that is only meaningful where the first component does not already decide, as for +the level order, whose structural component compares unrelated constructors as `.eq`. -/ +theorem Rot.then' : Rot x y z → (x = .eq → y = .eq → z = .eq → Rot x' y' z') → + Rot (x.then x') (y.then y') (z.then z') := by + cases x <;> cases y <;> simp_all [Rot]; cases z <;> simp + +theorem Rot.then {x y z x' y' z' : Ordering} + (R : Rot x y z) (R' : Rot x' y' z') : Rot (x.then x') (y.then y') (z.then z') := + R.then' fun _ _ _ => R' + +/-- Any `TransCmp` gives `Rot` at every triple: the rotations are `isLE_trans` at the rotated +triples, rewritten with `OrientedCmp.eq_swap`. -/ +theorem Rot.of_transCmp {α} {cmp : α → α → Ordering} [TransCmp cmp] (a b c : α) : + Rot (cmp a b) (cmp b c) (cmp a c) := by + refine ⟨fun h₁ h₂ => TransCmp.isLE_trans h₁ h₂, fun h₁ h₂ => ?_, fun h₁ h₂ => ?_⟩ <;> + rw [← OrientedCmp.eq_swap (cmp := cmp)] at * <;> + exact TransCmp.isLE_trans h₁ h₂ + +/-- `Rot` at every triple, plus orientedness, is exactly `TransCmp`. -/ +theorem TransCmp.of_rot {α} {cmp : α → α → Ordering} + (swap : ∀ a b : α, cmp a b = (cmp b a).swap) + (rot : ∀ a b c : α, Rot (cmp a b) (cmp b c) (cmp a c)) : TransCmp cmp where + eq_swap := swap .. + isLE_trans h₁ h₂ := (rot ..).1 h₁ h₂ + +end Lean4Lean diff --git a/Lean4Lean/Tests/LevelStd.lean b/Lean4Lean/Tests/LevelStd.lean index 324d08a0..b87368c7 100644 --- a/Lean4Lean/Tests/LevelStd.lean +++ b/Lean4Lean/Tests/LevelStd.lean @@ -71,20 +71,20 @@ private def deeperSamples : Array Level := /-- info: 'Lean.Level.isEquiv_wf' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Level.instLawfulBEqLevel, + Level.isExplicitSubsumedAux_eq, Level.normalize_eq] -/ #guard_msgs in #print axioms Level.isEquiv_wf /-- info: 'Lean.Level.geq_wf' depends on axioms: [propext, - sorryAx, Classical.choice, Quot.sound, Level.instLawfulBEqLevel, + Level.isExplicitSubsumedAux_eq, Level.normalize_eq] -/ #guard_msgs in #print axioms Level.geq_wf diff --git a/Lean4Lean/Verify/Axioms.lean b/Lean4Lean/Verify/Axioms.lean index 0b4a05b3..8429d294 100644 --- a/Lean4Lean/Verify/Axioms.lean +++ b/Lean4Lean/Verify/Axioms.lean @@ -126,7 +126,7 @@ purely syntactic trust assumption, checkable by reading the two definitions side namespace Total /-- The structural size of a level, used as the termination measure for `normalize`. -/ -private def size : Level → Nat +def size : Level → Nat | .zero | .param _ | .mvar _ => 1 | .succ l => size l + 1 | .max l₁ l₂ => size l₁ + size l₂ + 1 @@ -141,14 +141,14 @@ private def tag (l : Level) : Nat := private theorem tag_le (l : Level) : tag l ≤ 1 := by unfold tag; split <;> omega -private theorem one_le_size (l : Level) : 1 ≤ size l := by cases l <;> simp [size] +theorem one_le_size (l : Level) : 1 ≤ size l := by cases l <;> simp [size] private theorem getOffsetAux_eq (l : Level) (k) : getOffsetAux l k = getOffsetAux l 0 + k := by induction l generalizing k with | succ l ih => rw [getOffsetAux, ih (k+1), getOffsetAux, ih 1]; omega | _ => simp [getOffsetAux] -private theorem size_getLevelOffset (l : Level) : +theorem size_getLevelOffset (l : Level) : size l.getLevelOffset + l.getOffset = size l := by simp only [getOffset] induction l with | succ l ih => ?_ | _ => rfl diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index 4635157c..8aafe8eb 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -1,5 +1,6 @@ import Lean4Lean.Theory.VLevel import Lean4Lean.Level +import Lean4Lean.Verify.Name import Lean4Lean.Verify.LevelStd import Lean4Lean.Verify.Axioms import Std.Tactic.BVDecide @@ -7,102 +8,6 @@ import Std.Data.TreeMap.Lemmas namespace Lean -namespace Name -open _root_.Std - -instance : TransCmp cmp := by - have eq_swap {a b : Name} : a.cmp b = (b.cmp a).swap := by - induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [cmp] - | str a₁ a₂ ih | num a₁ a₂ ih => - rw [ih]; cases b₁.cmp a₁ <;> simp [← OrientedOrd.eq_swap] - refine { eq_swap, isLE_trans {a b c} := ?_ } - have {α} [Ord α] [TransOrd α] {a₁ b₁ c₁} {a₂ b₂ c₂ : α} - (H1 : (cmp a₁ b₁).isLE → (cmp b₁ c₁).isLE → (cmp a₁ c₁).isLE) - (H2 : (cmp c₁ a₁).isLE → (cmp a₁ b₁).isLE → (cmp c₁ b₁).isLE) - (H3 : (cmp b₁ c₁).isLE → (cmp c₁ a₁).isLE → (cmp b₁ a₁).isLE) : - ((cmp a₁ b₁).then (compare a₂ b₂)).isLE → - ((cmp b₁ c₁).then (compare b₂ c₂)).isLE → - ((cmp a₁ c₁).then (compare a₂ c₂)).isLE := by - simp [Ordering.isLE_then_iff_and] - intro h1 h2 h3 h4 - refine have := H1 h1 h3; ⟨this, ?_⟩ - obtain eq | eq := Ordering.isLE_iff_eq_lt_or_eq_eq.1 this; · exact .inl eq - obtain h2 | h2 := h2 - · rw [@eq_swap c₁, eq, @eq_swap _ a₁, h2] at H3; simp [h3] at H3 - obtain h4 | h4 := h4 - · rw [eq_swap, eq, @eq_swap c₁, h4] at H2; simp [h1] at H2 - exact .inr (TransCmp.isLE_trans h2 h4) - refine (?_ : _ ∧ ((cmp c a).isLE → (cmp a b).isLE → (cmp c b).isLE) ∧ - ((cmp b c).isLE → (cmp c a).isLE → (cmp b a).isLE)).1 - induction a generalizing b c with - obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [cmp] at * <;> - obtain _|⟨c₁,c₂⟩|⟨c₁,c₂⟩ := c <;> simp [cmp] at * - | str a₁ a₂ ih | num a₁ a₂ ih => - let ⟨h1, h2, h3⟩ := @ih b₁ c₁ - exact ⟨this h1 h2 h3, this h2 h3 h1, this h3 h1 h2⟩ - -instance : LawfulBEqCmp cmp where - compare_eq_iff_beq {a b} := by - simp; refine ⟨?_, fun h => h ▸ ReflCmp.compare_self⟩ - induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [cmp] - | str a₁ a₂ ih | num a₁ a₂ ih => - refine ?_ ∘ Ordering.then_eq_eq.1 - simp +contextual; exact fun h _ => ih h - -instance : TransCmp quickCmp where - eq_swap {a b} := by - simp [quickCmp] - rw [OrientedOrd.eq_swap] - cases compare b.hash a.hash <;> simp - induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [quickCmpAux] - | str a₁ a₂ ih | num a₁ a₂ ih => - rw [OrientedOrd.eq_swap] - cases compare b₂ a₂ <;> simp [ih] - isLE_trans {a b c} := by - have {α} [Ord α] [TransOrd α] {a₁ b₁ c₁ : α} {a₂ b₂ c₂} - (H : (quickCmpAux a₂ b₂).isLE → (quickCmpAux b₂ c₂).isLE → (quickCmpAux a₂ c₂).isLE) : - ((compare a₁ b₁).then (quickCmpAux a₂ b₂)).isLE → - ((compare b₁ c₁).then (quickCmpAux b₂ c₂)).isLE → - ((compare a₁ c₁).then (quickCmpAux a₂ c₂)).isLE := by - simp [Ordering.isLE_then_iff_and] - intro h1 h2 h3 h4 - refine ⟨TransCmp.isLE_trans h1 h3, ?_⟩ - refine h2.elim (fun h2 => .inl <| TransCmp.lt_of_lt_of_isLE h2 h3) fun h2 => ?_ - refine h4.elim (fun h4 => .inl <| TransCmp.lt_of_isLE_of_lt h1 h4) fun h4 => .inr (H h2 h4) - apply this - induction a generalizing b c with - obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [quickCmpAux] at * <;> - obtain _|⟨c₁,c₂⟩|⟨c₁,c₂⟩ := c <;> simp [quickCmpAux] at * - | str a₁ a₂ ih | num a₁ a₂ ih => apply this ih - -instance : LawfulBEqCmp quickCmp where - compare_eq_iff_beq {a b} := by - simp; refine ⟨fun h => ?_, fun h => h ▸ ReflCmp.compare_self⟩ - replace h := (Ordering.then_eq_eq.1 h).2; revert h - induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [quickCmpAux] - | str a₁ a₂ ih | num a₁ a₂ ih => - refine ?_ ∘ Ordering.then_eq_eq.1 - simp +contextual; exact fun _ => ih - -end Name - -namespace NameSet -open _root_.Std - -theorem contains_insert {s : NameSet} {a b : Name} : - (s.insert a).contains b = (a == b || s.contains b) := by - have key : (Name.quickCmp a b == Ordering.eq) = (a == b) := by - have := @LawfulBEqCmp.compare_eq_iff_beq _ _ Name.quickCmp _ a b - cases h : Name.quickCmp a b <;> simp_all - have h : (s.insert a).contains b - = (Name.quickCmp a b == Ordering.eq || s.contains b) := - Std.TreeSet.contains_insert (t := s) (k := a) (a := b) - rw [h, key] - -@[simp] theorem contains_empty {a : Name} : (∅ : NameSet).contains a = false := rfl - -end NameSet - namespace Level open Lean4Lean @@ -197,12 +102,11 @@ theorem getUndefParam_none {l : Level} (hmv : l.hasMVar' = false) : l.getUndefParam Us = none → ∃ u', VLevel.ofLevel Us l = some u' := by suffices ∀ s, ((l.forEach (getUndefParam.F Us)).run s).run.snd = none → s = none ∧ _ from (this _ · |>.2) - have {l} (hmv : l.hasMVar' = false) - {g} (H : ∀ {s'}, (g.run s').run.snd = none → s' = none ∧ + have {l} (hmv : l.hasMVar' = false) {g} + (H : ∀ {s'}, (g.run s').run.snd = none → s' = none ∧ (((getUndefParam.F Us l).run none).run = (true, none) → ∃ u', VLevel.ofLevel Us l = some u')) (s) : - ((do if (!(← getUndefParam.F Us l)) = true then pure PUnit.unit else g) - |>.run s).run.snd = none → + ((do if !(← getUndefParam.F Us l) then pure () else g) |>.run s).run.snd = none → s = none ∧ ∃ u', VLevel.ofLevel Us l = some u' := by simp; split <;> rename_i h · simp; revert h diff --git a/Lean4Lean/Verify/LevelStd.lean b/Lean4Lean/Verify/LevelStd.lean index 8f2691e5..ca30d7df 100644 --- a/Lean4Lean/Verify/LevelStd.lean +++ b/Lean4Lean/Verify/LevelStd.lean @@ -1,8 +1,10 @@ import Batteries.Tactic.OpenPrivate import Lean4Lean.Theory.VLevel -import Lean4Lean.Verify.Axioms +import Lean4Lean.Verify.QSort +import Lean4Lean.Verify.NormLt open private go in Lean.Level.geq +open private accMax mkIMaxAux isExplicitSubsumed from Lean.Level namespace Lean.Level @@ -133,17 +135,372 @@ theorem geqCore_sound (h : geqCore u v) : eval ρ μ v ≤ eval ρ μ u := by · exact Nat.le_of_eq (congrArg (eval ρ μ) heq).symm · exact fallback_sound h +/-! +### Soundness of `normalize` + +The proof is by strong induction on `Total.size`. The mutual recursion with +`getMaxArgsAux` is untangled by observing that `getMaxArgsAux l true` recurses only +structurally, and `getMaxArgsAux l false` calls `normalize` only on levels of size at +most `size l`, so both can be handled by standalone lemmas parameterized by the +induction hypothesis for `normalize`. + +The `max` branch sorts the collected arguments with `qsort normLt` and then drops +dominated entries: `mkMaxAux` drops an entry when the next one has the same level base +(relying on offsets being sorted within a base class), and the explicit (constant) +entries in the sorted prefix are dropped when subsumed by the largest explicit or by +some offset to its right. All of this is justified by a single consequence of +sortedness: entries with equal `getLevelOffset` occur in order of `getOffset` +(`explicit` entries all have base `zero`, so this also orders the explicit prefix). +That fact, together with the fact that `qsort` permutes the array, are the only +properties of sorting used; they are `qsort_perm_toList` and `pairwise_qsort_normLt` +below, currently unproved because `Array.qsort` has no specification in the standard +library. +-/ + +theorem le_ext_le {n m : Nat} (H : ∀ x, n ≤ x → m ≤ x) : m ≤ n := H _ (Nat.le_refl _) + +theorem nat_ext_le {n m : Nat} (H : ∀ x, n ≤ x ↔ m ≤ x) : n = m := + Nat.le_antisymm ((H _).2 (Nat.le_refl _)) ((H _).1 (Nat.le_refl _)) + +theorem eval_addOffset : eval ρ μ (addOffset l k) = eval ρ μ l + k := by + suffices ∀ k l, eval ρ μ (addOffsetAux k l) = eval ρ μ l + k from this .. + intro k; induction k with intro l + | zero => rfl + | succ k ih => rw [addOffsetAux, ih]; simp [eval, mkLevelSucc]; omega + +theorem isZero_iff : isZero l ↔ l = .zero := by cases l <;> simp [Level.isZero] + +theorem isNeverZero_sound (h : l.isNeverZero = true) : 0 < eval ρ μ l := by + induction l with + | zero | param | mvar => simp [isNeverZero] at h + | succ l => simp [eval] + | max l₁ l₂ ih₁ ih₂ => + simp only [isNeverZero, Bool.or_eq_true] at h + simp only [eval, Nat.max_eq_max] + obtain h | h := h + · have := ih₁ h; omega + · have := ih₂ h; omega + | imax l₁ l₂ _ ih₂ => + simp only [isNeverZero] at h + have := ih₂ h + simp only [eval, Nat.imax, Nat.max_eq_max]; split <;> omega + +theorem eval_accMax : eval ρ μ (accMax r p k) = Nat.max (eval ρ μ r) (eval ρ μ p + k) := by + rw [accMax]; split <;> rename_i h + · rw [isZero_iff.1 h, eval_addOffset]; simp [eval] + · simp [mkLevelMax, eval, eval_addOffset] + +theorem eval_mkIMaxAux : + eval ρ μ (mkIMaxAux a b) = Nat.imax (eval ρ μ a) (eval ρ μ b) := by + unfold mkIMaxAux; split + · simp [eval, Nat.imax] + · simp only [eval, Nat.imax]; split <;> [omega; simp] + · simp only [eval, Nat.imax, Nat.max_eq_max]; split <;> [omega; rw [Nat.max_eq_right (by omega)]] + · split <;> rename_i h + · cases eq_of_beq h; simp only [Nat.imax, Nat.max_eq_max] + split <;> [omega; rw [Nat.max_self]] + · simp [mkLevelIMax, eval] + +/-- The maximum of the evaluations of a list of levels. -/ +def evalList (ρ : Name → Nat) (μ : LMVarId → Nat) (ls : List Level) : Nat := + ls.foldr (fun l n => Nat.max (eval ρ μ l) n) 0 + +theorem evalList_le_iff : evalList ρ μ ls ≤ n ↔ ∀ l ∈ ls, eval ρ μ l ≤ n := by + induction ls with + | nil => simp [evalList, Nat.zero_le] + | cons l ls ih => + show Nat.max (eval ρ μ l) (evalList ρ μ ls) ≤ n ↔ _ + rw [Nat.max_eq_max, Nat.max_le, ih]; simp + +theorem le_evalList (h : l ∈ ls) : eval ρ μ l ≤ evalList ρ μ ls := + evalList_le_iff.1 (Nat.le_refl _) _ h + +theorem evalList_perm (h : ls₁.Perm ls₂) : evalList ρ μ ls₁ = evalList ρ μ ls₂ := by + refine nat_ext_le fun _ => ?_; simp only [evalList_le_iff, h.mem_iff] + +theorem evalList_append : evalList ρ μ (ls₁ ++ ls₂) = + Nat.max (evalList ρ μ ls₁) (evalList ρ μ ls₂) := by + induction ls₁ with | nil => simp [evalList] | cons l ls ih + show Nat.max _ (evalList ρ μ (ls ++ ls₂)) = Nat.max (Nat.max _ (evalList ρ μ ls)) _ + rw [ih]; simp only [Nat.max_eq_max]; rw [Nat.max_assoc] + +/-- `Array.qsort` returns a permutation of its input (`Array.qsort_perm`). -/ +theorem qsort_perm (as : Array Level) : (as.qsort normLt).toList.Perm as.toList := + Array.perm_iff_toList_perm.1 (Array.qsort_perm normLt 0 (as.size - 1) as) + +/-- Entries with equal level base come out of `qsort normLt` ordered by offset: a +consequence of sortedness (`Array.qsort_sorted`), since `normLt` compares levels with +equal bases by offset. -/ +theorem pairwise_qsort (as : Array Level) : + (as.qsort normLt).toList.Pairwise fun a b => + a.getLevelOffset = b.getLevelOffset → a.getOffset ≤ b.getOffset := by + rw [List.pairwise_iff_getElem] + intro i j hi hj hij hb + simp only [Array.getElem_toList] at hb + simpa [normLt_same_base hb.symm] using + Array.qsort_sorted normLt normLt_asymm normLt_le_trans as i j hij hj + +theorem offset_le_eval : l.getOffset ≤ eval ρ μ l := by + rw [eval_getLevelOffset]; omega + +theorem eval_of_isZero (h : l.getLevelOffset.isZero) : eval ρ μ l = l.getOffset := by + rw [eval_getLevelOffset, isZero_iff.1 h]; simp [eval] + +theorem skipExplicit_spec {lvls : Array Level} : i ≤ lvls.size → + i ≤ Total.skipExplicit lvls i ∧ Total.skipExplicit lvls i ≤ lvls.size ∧ + ∀ j (_ : j < lvls.size), i ≤ j → j < Total.skipExplicit lvls i → + lvls[j].getLevelOffset.isZero := by + fun_induction Total.skipExplicit lvls i with + | case1 i hi hz ih => + intro h + obtain ⟨ih1, ih2, ih3⟩ := ih (by omega) + refine ⟨by omega, ih2, fun j hj hij hlt => ?_⟩ + rcases Nat.eq_or_lt_of_le hij with rfl | hij' + · exact hz + · exact ih3 j hj (by omega) hlt + | case2 i hi hz => exact fun h => ⟨Nat.le_refl _, by omega, fun j hj hij hlt => by omega⟩ + | case3 i hi => exact fun h => ⟨Nat.le_refl _, by omega, fun j hj hij hlt => by omega⟩ + +theorem isExplicitSubsumedAux_spec {lvls : Array Level} : + Total.isExplicitSubsumedAux lvls mx i = true ↔ + ∃ j, i ≤ j ∧ ∃ (_ : j < lvls.size), mx ≤ lvls[j].getOffset := by + fun_induction Total.isExplicitSubsumedAux lvls mx i with + | case1 i hi hge => simpa using ⟨i, Nat.le_refl _, hi, by omega⟩ + | case2 i hi hlt ih => + rw [ih] + constructor <;> rintro ⟨j, hij, hj, hle⟩ <;> refine ⟨j, ?_, hj, hle⟩ + · omega + · obtain rfl | h := Nat.eq_or_lt_of_le hij <;> omega + | case3 i hi => simp; rintro j hij hj; omega + +theorem eval_mkMaxAux {lvls : Array Level} + (hs : ∀ (i j : Nat) (hi : i < lvls.size) (hj : j < lvls.size), i < j → + lvls[i].getLevelOffset = lvls[j].getLevelOffset → lvls[i].getOffset ≤ lvls[j].getOffset) + (hfuel : lvls.size ≤ i + fuel) + (hi0 : 0 < i) (hile : i ≤ lvls.size) + (hp : ∀ h : i - 1 < lvls.size, prev = lvls[i-1].getLevelOffset ∧ prevK = lvls[i-1].getOffset) : + eval ρ μ (Total.mkMaxAux lvls extraK i prev prevK result) = + Nat.max (eval ρ μ result) (evalList ρ μ (lvls.toList.drop (i-1)) + extraK) := by + induction fuel generalizing i result prev prevK with + | zero => + have hie : i = lvls.size := by omega + obtain ⟨hp, hpk⟩ := hp (by omega) + rw [Total.mkMaxAux.eq_def, dif_neg (by omega), eval_accMax] + have hlast : i - 1 < lvls.size := by omega + have hdrop : lvls.toList.drop (i-1) = [lvls[i-1]] := by + rw [List.drop_eq_getElem_cons (by simp only [Array.length_toList]; omega)] + simp [hie]; omega + have : eval ρ μ lvls[i-1] = eval ρ μ prev + prevK := by + rw [eval_getLevelOffset (l := lvls[i-1]), hp, hpk] + rw [hdrop] + simp only [evalList, List.foldr_cons, List.foldr_nil, this, Nat.max_eq_max] + omega + | succ fuel ih => + rw [Total.mkMaxAux.eq_def] + split <;> rename_i hlt + · obtain ⟨hp, hpk⟩ := hp (by omega) + have hlast : i - 1 < lvls.size := by omega + have hdrop : lvls.toList.drop (i-1) = lvls[i-1] :: lvls.toList.drop i := by + rw [List.drop_eq_getElem_cons (by simp only [Array.length_toList]; omega)] + simp; congr 1; omega + have heval : eval ρ μ lvls[i-1] = eval ρ μ prev + prevK := by + rw [eval_getLevelOffset (l := lvls[i-1]), hp, hpk] + have hmem : eval ρ μ lvls[i] ≤ evalList ρ μ (lvls.toList.drop i) := + le_evalList (by rw [List.drop_eq_getElem_cons (by simp only [Array.length_toList]; omega)]; exact .head _) + dsimp only + split <;> rename_i hbeq + · -- equal bases: drop the previous entry + rw [ih (i := i+1) (by omega) (by omega) (by omega) (fun h => by simp)] + have hb : lvls[i].getLevelOffset = prev := eq_of_beq hbeq + have hk : prevK ≤ lvls[i].getOffset := by + rw [hpk]; exact hs (i-1) i hlast hlt (by omega) (by rw [hb, hp]) + have hle : eval ρ μ lvls[i-1] ≤ evalList ρ μ (lvls.toList.drop i) := by + refine Nat.le_trans ?_ hmem + rw [heval, eval_getLevelOffset (l := lvls[i]), hb, hp] + omega + rw [Nat.add_sub_cancel, hdrop] + have : evalList ρ μ (lvls[i-1] :: lvls.toList.drop i) = + evalList ρ μ (lvls.toList.drop i) := by + exact Nat.max_eq_right hle + rw [this] + · -- new base: accumulate the previous entry + rw [ih (i := i+1) (by omega) (by omega) (by omega) (fun h => by simp)] + rw [Nat.add_sub_cancel, eval_accMax, hdrop] + simp only [evalList, List.foldr_cons, Nat.max_eq_max, heval] + omega + · have hie : i = lvls.size := by omega + obtain ⟨hp, hpk⟩ := hp (by omega) + rw [eval_accMax] + have hlast : i - 1 < lvls.size := by omega + have hdrop : lvls.toList.drop (i-1) = [lvls[i-1]] := by + rw [List.drop_eq_getElem_cons (by simp only [Array.length_toList]; omega)] + simp [hie]; omega + have : eval ρ μ lvls[i-1] = eval ρ μ prev + prevK := by + rw [eval_getLevelOffset (l := lvls[i-1]), hp, hpk] + rw [hdrop] + simp only [evalList, List.foldr_cons, List.foldr_nil, this, Nat.max_eq_max] + omega + +theorem size_lt_getMaxArgsAux_true : + lvls.size < (Total.getMaxArgsAux l true lvls).size := by + induction l generalizing lvls with + | max _ _ ih₁ ih₂ => exact Total.getMaxArgsAux.eq_def .. ▸ Nat.lt_trans ih₁ ih₂ + | _ => rw [Total.getMaxArgsAux.eq_def]; simp + +theorem size_lt_getMaxArgsAux_false : + lvls.size < (Total.getMaxArgsAux l false lvls).size := by + induction l generalizing lvls with + | max _ _ ih₁ ih₂ => exact Total.getMaxArgsAux.eq_def .. ▸ Nat.lt_trans ih₁ ih₂ + | _ => exact Total.getMaxArgsAux.eq_def .. ▸ size_lt_getMaxArgsAux_true .. + +theorem evalList_getMaxArgsAux_true : + evalList ρ μ (Total.getMaxArgsAux l true lvls).toList = + Nat.max (evalList ρ μ lvls.toList) (eval ρ μ l) := by + induction l generalizing lvls with + | max l₁ l₂ ih₁ ih₂ => + rw [Total.getMaxArgsAux, ih₂, ih₁] + simp only [eval, Nat.max_eq_max]; omega + | _ => + rw [Total.getMaxArgsAux.eq_def, Array.toList_push, evalList_append] + simp only [evalList, List.foldr_cons, List.foldr_nil, Nat.max_eq_max]; omega + +theorem evalList_getMaxArgsAux_false {l : Level} + (IH : ∀ u, Total.size u ≤ Total.size l → eval ρ μ (Total.normalize u) = eval ρ μ u) : + evalList ρ μ (Total.getMaxArgsAux l false lvls).toList = + Nat.max (evalList ρ μ lvls.toList) (eval ρ μ l) := by + induction l generalizing lvls with + | max l₁ l₂ ih₁ ih₂ => + rw [Total.getMaxArgsAux.eq_def] + show evalList ρ μ (Total.getMaxArgsAux l₂ false (Total.getMaxArgsAux l₁ false lvls)).toList = _ + rw [ih₂ (fun u hu => IH u (by simp only [Total.size] at *; omega)), + ih₁ (fun u hu => IH u (by simp only [Total.size] at *; omega))] + simp only [eval, Nat.max_eq_max]; omega + | _ => rw [Total.getMaxArgsAux.eq_def, evalList_getMaxArgsAux_true, IH _ (Nat.le_refl _)] + +/-- Dropping a dominated prefix does not change the maximum. -/ +theorem evalList_drop_eq {ls : List Level} (hstart : start ≤ ls.length) + (hdom : ∀ j (hj : j < ls.length), j < start → + eval ρ μ ls[j] ≤ evalList ρ μ (ls.drop start)) : + evalList ρ μ (ls.drop start) = evalList ρ μ ls := by + refine nat_ext_le fun n => ?_ + simp only [evalList_le_iff] + constructor <;> intro H l hl + · obtain ⟨j, hj, rfl⟩ := List.mem_iff_getElem.1 hl + by_cases hjs : j < start + · exact Nat.le_trans (hdom j hj hjs) (evalList_le_iff.2 H) + · refine H _ (List.mem_iff_getElem.2 ⟨j - start, by simp; omega, ?_⟩) + rw [List.getElem_drop]; congr 1; omega + · exact H l (List.drop_subset _ _ hl) + +/-- The level base of a level that is not already normalized is a `max` or an `imax`. -/ +theorem base_of_not_cheap {l : Level} (h : ¬l.isAlreadyNormalizedCheap = true) : + (∃ a b, l.getLevelOffset = .max a b) ∨ (∃ a b, l.getLevelOffset = .imax a b) := by + induction l with + | succ l ih => apply ih; simpa [isAlreadyNormalizedCheap] using h + | max l₁ l₂ => exact .inl ⟨_, _, rfl⟩ + | imax l₁ l₂ => exact .inr ⟨_, _, rfl⟩ + | _ => simp [isAlreadyNormalizedCheap] at h + +theorem eval_normalize_total {l : Level} : eval ρ μ (Total.normalize l) = eval ρ μ l := by + generalize hn : Total.size l = n + induction n using Nat.strongRecOn generalizing l with | _ n IH + subst hn + rw [Total.normalize.eq_def] + split <;> [rfl; rename_i hcheap] + have hsz := Total.size_getLevelOffset l + split <;> [rename_i l₁ l₂ hbase; rename_i l₁ l₂ hbase; skip] + · -- max + rw [eval_getLevelOffset (l := l), hbase] + rw [hbase] at hsz; simp only [Total.size] at hsz + have hs₁ := Total.one_le_size l₁ + have hs₂ := Total.one_le_size l₂ + have IH₁ u (hu : Total.size u ≤ Total.size l₁) : eval ρ μ (Total.normalize u) = eval ρ μ u := + IH _ (by omega) rfl + have IH₂ u (hu : Total.size u ≤ Total.size l₂) : eval ρ μ (Total.normalize u) = eval ρ μ u := + IH _ (by omega) rfl + extract_lets k lvls₁ L1 L i₀ i lvl₁ prev prevK + have hevalL1 : evalList ρ μ L1.toList = Nat.max (eval ρ μ l₁) (eval ρ μ l₂) := by + rw [evalList_getMaxArgsAux_false IH₂, evalList_getMaxArgsAux_false IH₁] + simp [evalList, Nat.max_eq_max] + have hL1pos : 0 < L1.size := + Nat.lt_trans (size_lt_getMaxArgsAux_false (lvls := #[])) size_lt_getMaxArgsAux_false + have hperm : L.toList.Perm L1.toList := qsort_perm L1 + have hpair : List.Pairwise _ L.toList := pairwise_qsort L1 + have hLsize : L.size = L1.size := by + simpa [Array.length_toList] using hperm.length_eq + have hLpos : 0 < L.size := hLsize ▸ hL1pos + have hevalL : evalList ρ μ L.toList = Nat.max (eval ρ μ l₁) (eval ρ μ l₂) := by + rw [evalList_perm hperm, hevalL1] + have hs : ∀ (i j : Nat) (hi : i < L.size) (hj : j < L.size), i < j → + L[i].getLevelOffset = L[j].getLevelOffset → L[i].getOffset ≤ L[j].getOffset := by + intro i j hi hj hij hb + have := (List.pairwise_iff_getElem.1 hpair) i j (by simpa using hi) (by simpa using hj) hij + simpa using this (by simpa using hb) + obtain ⟨-, hskle, hskz⟩ := skipExplicit_spec (lvls := L) (i := 0) (Nat.zero_le _) + -- the start index and its bound + have main i (hi : i < L.size) + (hdom : ∀ j (hj : j < L.size), j < i → eval ρ μ L[j] ≤ evalList ρ μ (L.toList.drop i)) : + eval ρ μ (Total.mkMaxAux L (l.getOffset) (i+1) L[i]!.getLevelOffset L[i]!.getOffset + Level.zero) = Nat.max (eval ρ μ l₁) (eval ρ μ l₂) + l.getOffset := by + rw [getElem!_pos L i hi, + eval_mkMaxAux hs (fuel := L.size) (by omega) (by omega) (by omega) (fun _ => by simp), + Nat.add_sub_cancel, evalList_drop_eq (by rw [Array.length_toList]; omega) hdom, hevalL] + simp [eval, Nat.max_eq_max] + subst i lvl₁ prevK prev; split <;> rename_i hsub + · -- explicits subsumed: start at the first non-explicit + rw [isExplicitSubsumed] at hsub + split at hsub <;> [cases hsub; let (eq := eq) i'+1 := i₀]; subst i₀ + simp only [isExplicitSubsumedAux_eq, isExplicitSubsumedAux_spec] at hsub + obtain ⟨j, hij, hjs, hmax⟩ := hsub; dsimp at hmax + refine main (i'+1) (by omega) fun m hm hmi => ?_ + -- every dropped explicit is at most the witness entry + have hzm : L[m].getLevelOffset.isZero := hskz m hm (Nat.zero_le _) (eq ▸ hmi) + have hz₁ := hskz i' (by omega) (Nat.zero_le _) (by omega) + have h2 : L[m].getOffset ≤ L[i'].getOffset := by + rcases Nat.eq_or_lt_of_le (Nat.le_pred_of_lt hmi) with h | h + · subst h; exact Nat.le_refl _ + · exact hs m i' hm (by omega) h (by rw [isZero_iff.1 hzm, isZero_iff.1 hz₁]) + have h3 : L[i'].getOffset ≤ eval ρ μ L[j] := + Nat.le_trans (getElem!_pos L i' (by omega) ▸ hmax) offset_le_eval + refine eval_of_isZero hzm ▸ Nat.le_trans (Nat.le_trans h2 h3) (le_evalList ?_) + refine List.mem_iff_getElem.2 ⟨j - (i' + 1), ?_, ?_⟩ + · simp only [List.length_drop, Array.length_toList]; omega + · rw [List.getElem_drop]; simp only [Array.getElem_toList]; congr 1; omega + · -- keep the largest explicit + cases eq : i₀ with | zero => exact main 0 (by omega) (fun m hm hmi => by omega) | succ i' + have hstart : i' < L.size := by omega + refine main i' hstart fun m hm hmi => ?_ + have hzm : L[m].getLevelOffset.isZero := hskz m hm (Nat.zero_le _) (by omega) + have hz₁ : L[i'].getLevelOffset.isZero := + hskz i' hstart (Nat.zero_le _) (by omega) + refine eval_of_isZero hzm ▸ Nat.le_trans (hs m i' hm hstart (by omega) ?_) ?_ + · rw [isZero_iff.1 hzm, isZero_iff.1 hz₁] + refine eval_of_isZero hz₁ ▸ le_evalList ?_ + rw [List.drop_eq_getElem_cons (by omega)]; exact .head _ + · -- imax + rw [eval_getLevelOffset (l := l), hbase] + rw [hbase] at hsz; simp only [Total.size] at hsz + have hs₁ := Total.one_le_size l₁ + have hs₂ := Total.one_le_size l₂ + split <;> rename_i hnz + · rw [eval_addOffset, IH (Total.size (mkLevelMax l₁ l₂)) + (by simp only [mkLevelMax, Total.size]; omega) rfl] + have := isNeverZero_sound (ρ := ρ) (μ := μ) hnz + simp only [mkLevelMax, eval, Nat.imax] + rw [if_neg (by omega)] + · rw [eval_addOffset, eval_mkIMaxAux, IH _ (by omega) rfl, IH _ (by omega) rfl]; rfl + · grind [base_of_not_cheap] + theorem eval_normalize {ρ μ l} : eval ρ μ l.normalize = eval ρ μ l := by - rw [normalize_eq]; sorry + rw [normalize_eq]; exact eval_normalize_total theorem geq_eq_core : geq u v = geqCore (normalize u) (normalize v) := by simp [geq, geqCore_eq_go] theorem isEquiv_sound (h : isEquiv u v) : eval ρ μ u = eval ρ μ v := by simp only [Level.isEquiv, Bool.or_eq_true, beq_iff_eq] at h - rcases h with rfl | h - · rfl - · rw [← eval_normalize (l := u), ← eval_normalize (l := v), h] + rcases h with rfl | h <;> [rfl; skip] + rw [← eval_normalize (l := u), ← eval_normalize (l := v), h] theorem geq_sound (h : geq u v) : eval ρ μ v ≤ eval ρ μ u := by rw [geq_eq_core] at h @@ -170,8 +527,7 @@ theorem eval_ofLevel (h : VLevel.ofLevel Us l = some l') : theorem isEquiv_wf (h : isEquiv u v) (hu : VLevel.ofLevel Us u = some u') (hv : VLevel.ofLevel Us v = some v') : u' ≈ v' := by - rw [VLevel.equiv_def] - intro ns + refine VLevel.equiv_def.2 fun ns => ?_ rw [eval_ofLevel (μ := fun _ => 0) hu, eval_ofLevel (μ := fun _ => 0) hv] exact isEquiv_sound h diff --git a/Lean4Lean/Verify/Name.lean b/Lean4Lean/Verify/Name.lean new file mode 100644 index 00000000..05dee4ee --- /dev/null +++ b/Lean4Lean/Verify/Name.lean @@ -0,0 +1,90 @@ +import Lean.Data.NameMap.Basic +import Lean4Lean.Std.Ord +import Std.Data.TreeSet.Lemmas + +/-! +Order properties of `Lean.Name.cmp` and `Lean.Name.quickCmp`. +-/ + +namespace Lean + +namespace Name +open _root_.Std Lean4Lean + +theorem cmp_eq_swap {a b : Name} : a.cmp b = (b.cmp a).swap := by + induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [cmp] + | str a₁ a₂ ih | num a₁ a₂ ih => + rw [ih]; cases b₁.cmp a₁ <;> simp [← OrientedOrd.eq_swap] + +instance : TransCmp cmp := by + refine TransCmp.of_rot (fun _ _ => cmp_eq_swap) fun a b c => ?_ + induction a generalizing b c with + | anonymous => + obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> obtain _|⟨c₁,c₂⟩|⟨c₁,c₂⟩ := c <;> simp [cmp, Rot] + | str a₁ a₂ ih | num a₁ a₂ ih => + obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> obtain _|⟨c₁,c₂⟩|⟨c₁,c₂⟩ := c <;> + first + | exact (ih ..).then (Rot.of_transCmp ..) + | simp [cmp, Rot] + +instance : LawfulBEqCmp cmp where + compare_eq_iff_beq {a b} := by + simp; refine ⟨?_, fun h => h ▸ ReflCmp.compare_self⟩ + induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [cmp] + | str a₁ a₂ ih | num a₁ a₂ ih => + refine ?_ ∘ Ordering.then_eq_eq.1 + simp +contextual; exact fun h _ => ih h + +instance : TransCmp quickCmp where + eq_swap {a b} := by + simp [quickCmp] + rw [OrientedOrd.eq_swap] + cases compare b.hash a.hash <;> simp + induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [quickCmpAux] + | str a₁ a₂ ih | num a₁ a₂ ih => + rw [OrientedOrd.eq_swap] + cases compare b₂ a₂ <;> simp [ih] + isLE_trans {a b c} := by + have {α} [Ord α] [TransOrd α] {a₁ b₁ c₁ : α} {a₂ b₂ c₂} + (H : (quickCmpAux a₂ b₂).isLE → (quickCmpAux b₂ c₂).isLE → (quickCmpAux a₂ c₂).isLE) : + ((compare a₁ b₁).then (quickCmpAux a₂ b₂)).isLE → + ((compare b₁ c₁).then (quickCmpAux b₂ c₂)).isLE → + ((compare a₁ c₁).then (quickCmpAux a₂ c₂)).isLE := by + simp [Ordering.isLE_then_iff_and] + intro h1 h2 h3 h4 + refine ⟨TransCmp.isLE_trans h1 h3, ?_⟩ + refine h2.elim (fun h2 => .inl <| TransCmp.lt_of_lt_of_isLE h2 h3) fun h2 => ?_ + refine h4.elim (fun h4 => .inl <| TransCmp.lt_of_isLE_of_lt h1 h4) fun h4 => .inr (H h2 h4) + apply this + induction a generalizing b c with + obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [quickCmpAux] at * <;> + obtain _|⟨c₁,c₂⟩|⟨c₁,c₂⟩ := c <;> simp [quickCmpAux] at * + | str a₁ a₂ ih | num a₁ a₂ ih => apply this ih + +instance : LawfulBEqCmp quickCmp where + compare_eq_iff_beq {a b} := by + simp; refine ⟨fun h => ?_, fun h => h ▸ ReflCmp.compare_self⟩ + replace h := (Ordering.then_eq_eq.1 h).2; revert h + induction a generalizing b with obtain _|⟨b₁,b₂⟩|⟨b₁,b₂⟩ := b <;> simp [quickCmpAux] + | str a₁ a₂ ih | num a₁ a₂ ih => + refine ?_ ∘ Ordering.then_eq_eq.1 + simp +contextual; exact fun _ => ih + +end Name + +namespace NameSet +open _root_.Std + +theorem contains_insert {s : NameSet} {a b : Name} : + (s.insert a).contains b = (a == b || s.contains b) := by + have key : (Name.quickCmp a b == Ordering.eq) = (a == b) := by + have := @LawfulBEqCmp.compare_eq_iff_beq _ _ Name.quickCmp _ a b + cases h : Name.quickCmp a b <;> simp_all + have h : (s.insert a).contains b + = (Name.quickCmp a b == Ordering.eq || s.contains b) := + Std.TreeSet.contains_insert (t := s) (k := a) (a := b) + rw [h, key] + +@[simp] theorem contains_empty {a : Name} : (∅ : NameSet).contains a = false := rfl + +end NameSet diff --git a/Lean4Lean/Verify/NormLt.lean b/Lean4Lean/Verify/NormLt.lean new file mode 100644 index 00000000..446ee0fd --- /dev/null +++ b/Lean4Lean/Verify/NormLt.lean @@ -0,0 +1,364 @@ +import Lean.Level +import Lean4Lean.Verify.Name +import Lean4Lean.Std.Ord +import Lean4Lean.Verify.Axioms + +/-! +`Lean.Level.normLt` is the order used to sort the arguments of a `max` in +`Lean.Level.normalize`. This file shows it is a strict weak order, which is what the +`Array.qsort` specification requires. + +The proof identifies `normLt` with an `Ordering`-valued comparison `normCmp`, which compares +levels by (base, offset) lexicographically, bases being compared structurally. `normCmp` is +then given the `Std` order instances (`ReflCmp`, `TransCmp`, `LawfulEqCmp`), from which the +strict weak order properties `normLt` needs follow. Transitivity uses `Lean4Lean.Rot`, the +lexicographic-product device shared with `Name.cmp` in `Lean4Lean.Verify.Name`. +-/ + +open Std Lean4Lean + +namespace Lean.Level + +instance : LawfulBEq LMVarId where + eq_of_beq := @fun ⟨a⟩ ⟨b⟩ h => by cases LawfulBEq.eq_of_beq (α := Name) h; rfl + rfl := BEq.rfl (α := Name) + +/-- The structural size of a level. -/ +private def size : Level → Nat + | .zero | .param _ | .mvar _ => 1 + | .succ l => size l + 1 + | .max a b | .imax a b => size a + size b + 1 + +private theorem size_max {a b : Level} : size (.max a b) = size a + size b + 1 := rfl +private theorem size_imax {a b : Level} : size (.imax a b) = size a + size b + 1 := rfl + +private theorem one_le_size : ∀ l : Level, 1 ≤ size l + | .zero | .param _ | .mvar _ => Nat.le_refl _ + | .succ l => Nat.le_succ_of_le (one_le_size l) + | .max a b | .imax a b => by have := one_le_size a; simp only [size]; omega + +private theorem size_getLevelOffset_le : ∀ l : Level, size l.getLevelOffset ≤ size l + | .succ l => Nat.le_trans (size_getLevelOffset_le l) (Nat.le_succ _) + | .zero | .param _ | .mvar _ | .max .. | .imax .. => Nat.le_refl _ + +/-- Structural comparison of level *bases* (levels that are not `succ`s). +Sub-levels are compared by `normCmp`, i.e. base first, then offset. -/ +def baseCmp : Level → Level → Ordering + | .max a b, .max c d => + ((baseCmp a.getLevelOffset c.getLevelOffset).then (compare a.getOffset c.getOffset)).then + ((baseCmp b.getLevelOffset d.getLevelOffset).then (compare b.getOffset d.getOffset)) + | .imax a b, .imax c d => + ((baseCmp a.getLevelOffset c.getLevelOffset).then (compare a.getOffset c.getOffset)).then + ((baseCmp b.getLevelOffset d.getLevelOffset).then (compare b.getOffset d.getOffset)) + | .param n₁, .param n₂ => Name.cmp n₁ n₂ + | .mvar n₁, .mvar n₂ => Name.cmp n₁.name n₂.name + | l₁, l₂ => compare l₁.ctorToNat l₂.ctorToNat +termination_by l₁ l₂ => size l₁ + size l₂ +decreasing_by + all_goals + first + | (exact Nat.lt_of_le_of_lt + (Nat.add_le_add (size_getLevelOffset_le _) (size_getLevelOffset_le _)) + (by simp only [size]; omega)) + +/-- Comparison of levels: base first, then offset. -/ +def normCmp (l₁ l₂ : Level) : Ordering := + (baseCmp l₁.getLevelOffset l₂.getLevelOffset).then (compare l₁.getOffset l₂.getOffset) + +/-- The same-constructor part of `baseCmp`. It is `.eq` when the constructors differ, in which +case the `ctorToNat` comparison of `baseCmp_eq` already decides the comparison. -/ +private def structCmp : Level → Level → Ordering + | .max a b, .max c d => (normCmp a c).then (normCmp b d) + | .imax a b, .imax c d => (normCmp a c).then (normCmp b d) + | .param n₁, .param n₂ => Name.cmp n₁ n₂ + | .mvar n₁, .mvar n₂ => Name.cmp n₁.name n₂.name + | _, _ => .eq + +/-- `baseCmp` is the lexicographic product of the constructor tags with `structCmp`. -/ +private theorem baseCmp_eq : ∀ l₁ l₂ : Level, + baseCmp l₁ l₂ = (compare l₁.ctorToNat l₂.ctorToNat).then (structCmp l₁ l₂) := by + intro l₁ l₂ + cases l₁ <;> cases l₂ <;> simp [baseCmp, structCmp, normCmp, ctorToNat] + +private theorem baseCmp_swap : ∀ l₁ l₂ : Level, baseCmp l₂ l₁ = (baseCmp l₁ l₂).swap := by + intro l₁ l₂ + induction l₁, l₂ using baseCmp.induct with + | case1 a b c d ih₁ ih₂ | case2 a b c d ih₁ ih₂ => + rw [baseCmp, baseCmp] + simp only [Ordering.swap_then] + rw [← ih₁, ← ih₂, + ← OrientedCmp.eq_swap (cmp := compare (α := Nat)) (a := c.getOffset) (b := a.getOffset), + ← OrientedCmp.eq_swap (cmp := compare (α := Nat)) (a := d.getOffset) (b := b.getOffset)] + | case3 n₁ n₂ | case4 n₁ n₂ => + rw [baseCmp, baseCmp]; exact OrientedCmp.eq_swap + | case5 l₁ l₂ h₁ h₂ h₃ h₄ => + rw [baseCmp, baseCmp] + · exact OrientedCmp.eq_swap + all_goals grind + +theorem normCmp_swap (l₁ l₂ : Level) : normCmp l₂ l₁ = (normCmp l₁ l₂).swap := by + rw [normCmp, normCmp, Ordering.swap_then, ← baseCmp_swap, + ← OrientedCmp.eq_swap (cmp := compare (α := Nat))] + +private theorem normCmp_rot_of {a b c : Level} + (h : Rot (baseCmp a.getLevelOffset b.getLevelOffset) + (baseCmp b.getLevelOffset c.getLevelOffset) (baseCmp a.getLevelOffset c.getLevelOffset)) : + Rot (normCmp a b) (normCmp b c) (normCmp a c) := + h.then (Rot.of_transCmp a.getOffset b.getOffset c.getOffset) + +private theorem baseCmp_rot : ∀ l₁ l₂ l₃ : Level, + Rot (baseCmp l₁ l₂) (baseCmp l₂ l₃) (baseCmp l₁ l₃) := by + suffices key : ∀ n l₁ l₂ l₃, size l₁ + size l₂ + size l₃ ≤ n → + Rot (baseCmp l₁ l₂) (baseCmp l₂ l₃) (baseCmp l₁ l₃) from + fun l₁ l₂ l₃ => key _ l₁ l₂ l₃ (Nat.le_refl _) + intro n + induction n with + | zero => + intro l₁ l₂ l₃ h + have := one_le_size l₁; have := one_le_size l₂; have := one_le_size l₃ + omega + | succ n ih => + intro l₁ l₂ l₃ hn + rw [baseCmp_eq, baseCmp_eq, baseCmp_eq] + refine (Rot.of_transCmp ..).then' fun e₁ e₂ e₃ => ?_ + -- the sub-level comparisons are on strictly smaller levels + have small : ∀ x y z : Level, size x + size y + size z < size l₁ + size l₂ + size l₃ → + Rot (normCmp x y) (normCmp y z) (normCmp x z) := by + intro x y z hxyz + refine normCmp_rot_of (ih _ _ _ ?_) + have := size_getLevelOffset_le x + have := size_getLevelOffset_le y + have := size_getLevelOffset_le z + omega + -- all three constructor tags agree, so all three levels share a constructor + have hc₁ : l₁.ctorToNat = l₂.ctorToNat := Nat.compare_eq_eq.1 e₁ + have hc₂ : l₂.ctorToNat = l₃.ctorToNat := Nat.compare_eq_eq.1 e₂ + clear e₁ e₂ e₃ hn + cases l₁ <;> cases l₂ <;> cases hc₁ <;> cases l₃ <;> cases hc₂ <;> simp only [structCmp] + · exact ⟨fun _ _ => rfl, fun _ _ => rfl, fun _ _ => rfl⟩ + · exact ⟨fun _ _ => rfl, fun _ _ => rfl, fun _ _ => rfl⟩ + · refine Rot.then (small _ _ _ ?_) (small _ _ _ ?_) <;> (simp only [size_max]; omega) + · refine Rot.then (small _ _ _ ?_) (small _ _ _ ?_) <;> (simp only [size_imax]; omega) + · exact Rot.of_transCmp .. + · exact Rot.of_transCmp .. + +theorem normCmp_rot (a b c : Level) : Rot (normCmp a b) (normCmp b c) (normCmp a c) := + normCmp_rot_of (baseCmp_rot ..) + +instance : TransCmp baseCmp := TransCmp.of_rot (fun a b => baseCmp_swap b a) baseCmp_rot +instance : TransCmp normCmp := TransCmp.of_rot (fun a b => normCmp_swap b a) normCmp_rot + +private theorem getOffsetAux_eq : ∀ (l : Level) (k), l.getOffsetAux k = l.getOffset + k := by + intro l + induction l with + | succ l ih => + intro k + show l.getOffsetAux (k+1) = l.getOffsetAux 1 + k + rw [ih (k+1), ih 1]; omega + | _ => intro k; simp [getOffsetAux, getOffset] + +private theorem getOffset_succ {l : Level} : (Level.succ l).getOffset = l.getOffset + 1 := by + show l.getOffsetAux 1 = _ + rw [getOffsetAux_eq] + +private theorem getLevelOffset_succ {l : Level} : + (Level.succ l).getLevelOffset = l.getLevelOffset := rfl + +/-! ### Reflexivity and antisymmetry -/ + +private theorem baseCmp_refl : ∀ l : Level, baseCmp l l = .eq := by + suffices key : ∀ n l, size l ≤ n → baseCmp l l = .eq from fun l => key _ l (Nat.le_refl _) + intro n + induction n with + | zero => intro l h; have := one_le_size l; omega + | succ n ih => + intro l hn + have hnorm x (hx : size x ≤ n) : normCmp x x = .eq := by + rw [normCmp, ih _ (Nat.le_trans (size_getLevelOffset_le x) hx), Nat.compare_eq_eq.2 rfl]; rfl + rw [baseCmp_eq, Nat.compare_eq_eq.2 rfl] + show structCmp l l = .eq + cases l with simp only [structCmp] + | max a b | imax a b => + rw [hnorm a, hnorm b]; rfl + all_goals simp only [size] at hn ⊢; omega + | _ => exact LawfulBEqCmp.compare_eq_iff_beq.2 (beq_self_eq_true _) + +theorem normCmp_refl (l : Level) : normCmp l l = .eq := by + rw [normCmp, baseCmp_refl, Nat.compare_eq_eq.2 rfl]; rfl + +instance : ReflCmp baseCmp where compare_self := baseCmp_refl _ +instance : ReflCmp normCmp where compare_self := normCmp_refl _ + +/-- A level is determined by its base and its offset. -/ +private theorem level_ext : ∀ {l₁ l₂ : Level}, l₁.getLevelOffset = l₂.getLevelOffset → + l₁.getOffset = l₂.getOffset → l₁ = l₂ := by + intro l₁ + induction l₁ with + | succ a ih => + intro l₂ + cases l₂ with + | succ b => + intro h₁ h₂ + rw [getLevelOffset_succ, getLevelOffset_succ] at h₁ + rw [getOffset_succ, getOffset_succ] at h₂ + exact congrArg Level.succ (ih h₁ (by omega)) + | _ => intro h₁ h₂; rw [getOffset_succ] at h₂; simp [getOffset, getOffsetAux] at h₂ + | _ => + intro l₂ + cases l₂ with + | succ b => intro h₁ h₂; rw [getOffset_succ] at h₂; simp [getOffset, getOffsetAux] at h₂ + | _ => intro h₁ h₂; exact h₁ + +private theorem getLevelOffset_ne_succ : ∀ (l a : Level), l.getLevelOffset ≠ .succ a := by + intro l + induction l with + | succ b ih => exact ih + | _ => intro a h; cases h + +theorem eq_of_normCmp_eq : ∀ {l₁ l₂ : Level}, normCmp l₁ l₂ = .eq → l₁ = l₂ := by + suffices key : ∀ n (l₁ l₂ : Level), size l₁ + size l₂ ≤ n → normCmp l₁ l₂ = .eq → l₁ = l₂ from + fun {l₁ l₂} h => key _ l₁ l₂ (Nat.le_refl _) h + intro n + induction n with + | zero => intro l₁ l₂ h; have := one_le_size l₁; have := one_le_size l₂; omega + | succ n ih => + intro l₁ l₂ hn h + rw [normCmp, baseCmp_eq] at h + obtain ⟨h₁, hoff⟩ := Ordering.then_eq_eq.1 h + obtain ⟨hc, hs⟩ := Ordering.then_eq_eq.1 h₁ + refine level_ext ?_ (Nat.compare_eq_eq.1 hoff) + have hb₁ := size_getLevelOffset_le l₁ + have hb₂ := size_getLevelOffset_le l₂ + have hns₁ := getLevelOffset_ne_succ l₁ + have hns₂ := getLevelOffset_ne_succ l₂ + clear h h₁ hoff + generalize l₁.getLevelOffset = b₁ at * + generalize l₂.getLevelOffset = b₂ at * + replace hc := Nat.compare_eq_eq.1 hc + cases b₁ <;> cases b₂ <;> try simp only [ctorToNat, Nat.reduceEqDiff] at hc + · rfl + · exact absurd rfl (hns₁ _) + · obtain ⟨e₁, e₂⟩ := Ordering.then_eq_eq.1 hs + rw [ih _ _ _ e₁, ih _ _ _ e₂] <;> (simp only [size_max] at hb₁ hb₂ ⊢; omega) + · obtain ⟨e₁, e₂⟩ := Ordering.then_eq_eq.1 hs + rw [ih _ _ _ e₁, ih _ _ _ e₂] <;> (simp only [size_imax] at hb₁ hb₂ ⊢; omega) + · simp only [structCmp] at hs + rw [eq_of_beq (LawfulBEqCmp.compare_eq_iff_beq.1 hs)] + · rename_i x y + have : x.name = y.name := eq_of_beq (LawfulBEqCmp.compare_eq_iff_beq.1 hs) + cases x; cases y; simp_all + +instance : LawfulEqCmp normCmp where eq_of_compare := eq_of_normCmp_eq + +/-! ### `normLt` in terms of `normCmp` -/ + +private theorem compare_beq_lt (a b : Nat) : (compare a b == Ordering.lt) = decide (a < b) := by + apply Bool.eq_iff_iff.2; simp [Nat.compare_eq_lt] + +private theorem base_max {a b : Level} : (Level.max a b).getLevelOffset = .max a b := rfl +private theorem base_imax {a b : Level} : (Level.imax a b).getLevelOffset = .imax a b := rfl +private theorem off_max {a b : Level} : (Level.max a b).getOffset = 0 := rfl +private theorem off_imax {a b : Level} : (Level.imax a b).getOffset = 0 := rfl + +/-- `normLtAux` accumulates the `succ`s into the offsets and then runs `normCmp`. -/ +private theorem normLtAux_eq : ∀ (l₁ : Level) (k₁ : Nat) (l₂ : Level) (k₂ : Nat), + normLtAux l₁ k₁ l₂ k₂ = + ((baseCmp l₁.getLevelOffset l₂.getLevelOffset).then + (compare (l₁.getOffset + k₁) (l₂.getOffset + k₂)) == .lt) := by + intro l₁ k₁ l₂ k₂ + induction l₁, k₁, l₂, k₂ using normLtAux.induct with + | case1 l₁ k₁ l₂ k₂ ih => + rw [normLtAux, ih] + simp only [getLevelOffset_succ, getOffset_succ] + rw [show l₁.getOffset + 1 + k₁ = l₁.getOffset + (k₁ + 1) by omega] + | case2 l₁ k₁ l₂ k₂ hns ih => + rw [normLtAux, ih] + simp only [getLevelOffset_succ, getOffset_succ] + rw [show l₂.getOffset + 1 + k₂ = l₂.getOffset + (k₂ + 1) by omega] + exact hns + | case3 a b k₁ c d k₂ hbeq | case6 a b k₁ c d k₂ hbeq => + -- the two levels are syntactically equal: the offsets decide + rw [normLtAux, if_pos hbeq, Bool.eq_iff_iff] + cases eq_of_beq hbeq + show _ ↔ ((baseCmp _ _).then (compare (0 + k₁) (0 + k₂)) == _) + rw [baseCmp_refl] + simp only [decide_eq_true_eq, Ordering.then, Nat.zero_add, beq_iff_eq, Nat.compare_eq_lt] + | case4 a b k₁ c d k₂ hbeq hne ih | case7 a b k₁ c d k₂ hbeq hne ih => + -- the heads differ, so the head comparison decides + rw [normLtAux, if_neg (by simpa using hbeq), if_pos hne, ih] + have hne' : a ≠ c := by simpa using hne + have hac : normCmp a c ≠ .eq := fun h => hne' (eq_of_normCmp_eq h) + simp only [base_max, base_imax, off_max, off_imax, Nat.add_zero, Nat.zero_add] + rw [baseCmp] + show ((normCmp a c) == _) = (((normCmp a c).then (normCmp b d)).then (compare k₁ k₂) == _) + cases h : normCmp a c <;> simp_all [Ordering.then] + | case5 a b k₁ c d k₂ hbeq hne ih | case8 a b k₁ c d k₂ hbeq hne ih => + -- the heads agree, so the tail comparison decides + rw [normLtAux, if_neg (by simpa using hbeq), if_neg hne, ih] + have hac : a = c := by simpa using hne + subst hac + have hne' : b ≠ d := by rintro rfl; exact absurd (by simp) hbeq + have hbd : normCmp b d ≠ .eq := fun h => hne' (eq_of_normCmp_eq h) + simp only [base_max, base_imax, off_max, off_imax, Nat.add_zero, Nat.zero_add] + rw [baseCmp] + show ((normCmp b d) == _) = (((normCmp a a).then (normCmp b d)).then (compare k₁ k₂) == _) + rw [normCmp_refl] + cases h : normCmp b d <;> simp_all [Ordering.then] + | case9 n₁ k₁ n₂ k₂ hbeq => + rw [normLtAux, if_pos hbeq, Bool.eq_iff_iff] + cases eq_of_beq hbeq + show _ ↔ ((baseCmp (Level.param n₁) (Level.param n₁)).then (compare (0 + k₁) (0 + k₂)) == _) + rw [baseCmp_refl] + simp only [decide_eq_true_eq, Ordering.then, Nat.zero_add, beq_iff_eq, Nat.compare_eq_lt] + | case11 n₁ k₁ n₂ k₂ hbeq => + rw [normLtAux, if_pos hbeq, Bool.eq_iff_iff] + cases eq_of_beq hbeq + show _ ↔ ((baseCmp (Level.mvar n₁) (Level.mvar n₁)).then (compare (0 + k₁) (0 + k₂)) == _) + rw [baseCmp_refl] + simp only [decide_eq_true_eq, Ordering.then, Nat.zero_add, beq_iff_eq, Nat.compare_eq_lt] + | case10 n₁ k₁ n₂ k₂ hbeq => + rw [normLtAux, if_neg hbeq] + show _ = ((baseCmp (Level.param n₁) (Level.param n₂)).then + (compare (0 + k₁) (0 + k₂)) == _) + rw [baseCmp] + have : Name.cmp n₁ n₂ ≠ .eq := fun h => + hbeq (LawfulBEqCmp.compare_eq_iff_beq.1 h) + cases h : Name.cmp n₁ n₂ <;> simp_all [Name.lt, Ordering.then] + | case12 n₁ k₁ n₂ k₂ hbeq => + rw [normLtAux, if_neg hbeq] + show _ = ((baseCmp (Level.mvar n₁) (Level.mvar n₂)).then + (compare (0 + k₁) (0 + k₂)) == _) + rw [baseCmp] + have : Name.cmp n₁.name n₂.name ≠ .eq := fun h => hbeq (by + have := eq_of_beq (LawfulBEqCmp.compare_eq_iff_beq.1 h) + cases n₁; cases n₂; simp_all) + cases h : Name.cmp n₁.name n₂.name <;> simp_all [Name.lt, Ordering.then] + | case13 l₁ k₁ l₂ k₂ hs₁ hs₂ hmax himax hpar hmvar hbeq + | case14 l₁ k₁ l₂ k₂ hs₁ hs₂ hmax himax hpar hmvar hbeq => + -- neither level is a `succ` and their constructors differ, so the tags decide + rw [normLtAux, baseCmp_eq] + · cases l₁ <;> cases l₂ <;> + simp_all [structCmp, ctorToNat, Ordering.then, compare_beq_lt, getLevelOffset, getOffset, + getOffsetAux] <;> grind + all_goals assumption + +theorem normLt_eq (l₁ l₂ : Level) : normLt l₁ l₂ = (normCmp l₁ l₂ == .lt) := by + rw [normLt, normLtAux_eq, normCmp, Nat.add_zero, Nat.add_zero] + +/-! ### `normLt` is a strict weak order -/ + +theorem normLt_asymm {a b : Level} (h : normLt a b) : ¬normLt b a := by + simp only [normLt_eq, beq_iff_eq] at h ⊢ + exact OrientedCmp.not_lt_of_lt h + +theorem normLt_le_trans {a b c : Level} (h₁ : ¬normLt b a) (h₂ : ¬normLt c b) : ¬normLt c a := by + simp only [normLt_eq, beq_iff_eq, ← Ordering.isGE_iff_ne_lt] at h₁ h₂ ⊢ + exact TransCmp.isGE_trans h₂ h₁ + +/-- On levels with equal bases, `normLt` compares the offsets. -/ +theorem normLt_same_base {l₁ l₂ : Level} (h : l₁.getLevelOffset = l₂.getLevelOffset) : + normLt l₁ l₂ = decide (l₁.getOffset < l₂.getOffset) := by + rw [normLt_eq, normCmp, h, baseCmp_refl] + simp only [Ordering.then, compare_beq_lt] + +end Lean.Level diff --git a/Lean4Lean/Verify/QSort.lean b/Lean4Lean/Verify/QSort.lean new file mode 100644 index 00000000..f5fd0cd8 --- /dev/null +++ b/Lean4Lean/Verify/QSort.lean @@ -0,0 +1,392 @@ +/- +Copyright (c) 2025 Lean FRO, LLC. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Kim Morrison +-/ +module +public import Init.Data.Array.Basic +import all Init.Data.Array.QSort.Basic + +/-! +# Verification of `Array.qsort` + +Adapted from the verification in leanprover/lean4#14658 +(tests/elab/grind_qsort.lean on the `qsort_verification` branch). + +This file contains a verification of the `Array.qsort` function, +using the `grind` tactic. + +The theorems are: +* `size_qsort : (qsort as lt lo hi).size = as.size` +* `qsort_perm : qsort as lt lo hi ~ as` + +And when `lt` is antisymmetric and `¬ lt a b` is transitive, we have: +* `qsort_sorted' : lo ≤ i < j ≤ hi → ¬ lt (as.qsort lt lo hi)[j] (as.qsort lt lo hi)[i]` +* `qsort_sorted : i < j → ¬ lt (as.qsort lt)[j] (as.qsort lt)[i]` + +(There is not currently a public theorem that `(qsort as lt lo hi)[i] = as[i]` when `i < lo` or `hi < i`.) + +-/ +namespace Array + +open List Vector + +-- These attributes still need to be moved to the standard library. + +-- set_option trace.grind.ematch.pattern true in +-- attribute [grind] Vector.getElem?_eq_getElem -- This one requires some consideration! -- Probably not need, see Vector.Perm.extract' below. + +-- Hmm, we don't seem to have the Array analogues of these! +attribute [grind =] Vector.toArray_perm_iff +attribute [grind =] Vector.perm_toArray_iff + +attribute [grind .] Vector.swap_perm + +attribute [grind .] List.Perm.refl +attribute [grind .] Array.Perm.refl +attribute [grind .] Vector.Perm.refl + +-- attribute [grind] Array.Perm.extract +-- attribute [grind] Vector.Perm.extract + +-- These are just the patterns resulting from `grind`, but the behaviour should be explained! +grind_pattern List.Perm.trans => l₁ ~ l₂, l₁ ~ l₃ +grind_pattern Array.Perm.trans => xs ~ ys, xs ~ zs +grind_pattern Vector.Perm.trans => xs ~ ys, xs ~ zs + +/-- Variant of `List.Perm.take` specifying the permutation is constant after `i` elementwise. -/ +theorem _root_.List.Perm.take_of_getElem {l₁ l₂ : List α} (h : l₁ ~ l₂) {i : Nat} + (w : ∀ j, i ≤ j → (_ : j < l₁.length) → l₁[j] = l₂[j]'(by have := h.length_eq; omega)) : + l₁.take i ~ l₂.take i := by + apply h.take_of_getElem? + intro j hij + by_cases h_length₁ : j < l₁.length + <;> have h_length₂ := h.length_eq ▸ h_length₁ + <;> grind + +/-- Variant of `List.Perm.drop` specifying the permutation is constant before `i` elementwise. -/ +theorem _root_.List.Perm.drop_of_getElem {l₁ l₂ : List α} (h : l₁ ~ l₂) {i : Nat} + (w : ∀ j, j < i → (_ : j < l₁.length) → l₁[j] = l₂[j]'(by have := h.length_eq; omega)) : + l₁.drop i ~ l₂.drop i := by + apply h.drop_of_getElem? + intro j hij + by_cases h_length₁ : j < l₁.length + <;> have h_length₂ := h.length_eq ▸ h_length₁ + <;> grind + +private theorem getElem_mk {l : List α} {i : Nat} (h : i < l.length) : + (Array.mk l)[i]'(by simpa using h) = l[i] := by + rw [← Array.getElem_toList] + +theorem _root_.Array.Perm.extract' {xs ys : Array α} (h : xs ~ ys) {lo hi : Nat} + (wlo : ∀ i, i < lo → (_ : i < xs.size) → xs[i] = ys[i]'(by have := h.size_eq; omega)) + (whi : ∀ i, hi ≤ i → (_ : i < xs.size) → xs[i] = ys[i]'(by have := h.size_eq; omega)) : + xs.extract lo hi ~ ys.extract lo hi := by + rcases xs with ⟨xs⟩ + rcases ys with ⟨ys⟩ + simp_all only [perm_iff_toList_perm, List.extract_toArray] + apply List.Perm.take_of_getElem + (w := fun i h₁ h₂ => by + rw [List.getElem_drop, List.getElem_drop, ← getElem_mk, ← getElem_mk] + exact whi (lo + i) (by omega) (by grind)) + apply List.Perm.drop_of_getElem + (w := fun i h₁ h₂ => by + rw [← getElem_mk, ← getElem_mk] + exact wlo i h₁ (by grind)) + simpa using List.perm_iff_toArray_perm.mpr h + +theorem _root_.Vector.Perm.extract' {xs ys : Vector α n} (h : xs ~ ys) {lo hi : Nat} + (wlo : ∀ i, i < lo → (_ : i < n) → xs[i] = ys[i]) (whi : ∀ i, hi ≤ i → (_ : i < n) → xs[i] = ys[i]) : + xs.extract lo hi ~ ys.extract lo hi := by + rcases xs with ⟨xs, rfl⟩ + rcases ys with ⟨ys, h⟩ + exact ⟨Array.Perm.extract' h.toArray (by simpa using wlo) (by simpa using whi)⟩ + +attribute [grind .] Array.Perm.extract' +attribute [grind .] Vector.Perm.extract' + +variable (lt : α → α → Bool) (lo hi : Nat) + +@[simp, grind =] public theorem size_qsort (as : Array α) : + (qsort as lt lo hi).size = as.size := by + grind [qsort] + +private theorem qpartition_loop_perm (as : Vector α n) + (hhi : hi < n) (ilo : lo ≤ i) (ik : i ≤ k) (w : k ≤ hi) : + (qpartition.loop lt lo hi hhi pivot as i k).2 ~ as := by + fun_induction qpartition.loop with grind + +@[local grind .] +private theorem qpartition_perm + (as : Vector α n) (w : lo ≤ hi) (hlo : lo < n) (hhi : hi < n) : + (qpartition as lt lo hi).2 ~ as := by + unfold qpartition + refine Vector.Perm.trans (qpartition_loop_perm ..) ?_ + repeat' first + | split + | grind + | refine Vector.Perm.trans (Vector.swap_perm ..) ?_ + +private theorem qsort_sort_perm + (as : Vector α n) (w : lo ≤ hi) (hlo : lo < n) (hhi : hi < n) : + qsort.sort lt as lo hi w hlo hhi ~ as := by + fun_induction qsort.sort with grind + +grind_pattern qsort_sort_perm => qsort.sort lt as lo hi w hlo hhi + +public theorem qsort_perm (as : Array α) : qsort as lt lo hi ~ as := by + grind [qsort] + +private theorem getElem_qpartition_loop_snd_of_lt_lo + (hhi : hi < n) (as : Vector α n) (i k : Nat) (ilo : lo ≤ i) (ik : i ≤ k) (w : k ≤ hi) (w' : lo ≤ hi) + (l : Nat) (h : l < lo) : (qpartition.loop lt lo hi hhi pivot as i k).2[l] = as[l] := by + fun_induction qpartition.loop <;> grind + +private theorem getElem_qpartition_snd_of_lt_lo (as : Vector α n) + (hhi : hi < n) (w : lo ≤ hi) + (k : Nat) (h : k < lo) : (qpartition as lt lo hi).2[k] = as[k] := by + grind [qpartition, getElem_qpartition_loop_snd_of_lt_lo] + +@[local grind =] private theorem getElem_qsort_sort_of_lt_lo + (as : Vector α n) + (hlo : lo < n) (hhi : hi < n) (w : lo ≤ hi) + (i : Nat) (h : i < lo) : (qsort.sort lt as lo hi)[i] = as[i] := by + fun_induction qsort.sort with grind [getElem_qpartition_snd_of_lt_lo] + +private theorem getElem_qpartition_loop_snd_of_hi_lt + (hhi : hi < n) (as : Vector α n) (i k) + (ilo : lo ≤ i) (ik : i ≤ k) (w : k ≤ hi) (z : i ≤ hi) + (l : Nat) (h : hi < l) (h' : l < n) : (qpartition.loop lt lo hi hhi pivot as i k).2[l] = as[l] := by + fun_induction qpartition.loop <;> grind + +private theorem getElem_qpartition_snd_of_hi_lt (as : Vector α n) + (hhi : hi < n) (w : lo ≤ hi) + (k : Nat) (h : hi < k) (h' : k < n) : (qpartition as lt lo hi).2[k] = as[k] := by + grind [qpartition, getElem_qpartition_loop_snd_of_hi_lt] + +@[local grind =] private theorem getElem_qsort_sort_of_hi_lt + (as : Vector α n) (w : lo ≤ hi) + (hlo : lo < n) (hhi : hi < n) (w : lo ≤ hi) + (i : Nat) (h : hi < i) (h' : i < n) : (qsort.sort lt as lo hi)[i] = as[i] := by + fun_induction qsort.sort with grind [getElem_qpartition_snd_of_hi_lt] + +private theorem extract_qsort_sort_perm (as : Vector α n) (lt : α → α → Bool) + (hlo := by grind) (hhi := by grind) (w : lo ≤ hi := by grind) : + ((qsort.sort lt as lo hi).extract lo (hi + 1)) ~ (as.extract lo (hi + 1)) := by + grind + +private theorem getElem_qsort_sort_mem + (as : Vector α n) (hhi : hi < n) (i : Nat) (h : i < n) (_ : lo ≤ i) (_ : i ≤ hi) : + (qsort.sort lt as lo hi)[i] ∈ as.extract lo (hi + 1) := by + rw [← (extract_qsort_sort_perm lo hi as lt).mem_iff, Vector.mem_extract_iff_getElem] + exact ⟨i - lo, by grind⟩ + +private theorem qpartition_loop_spec₁ + (hhi : hi < n) (ilo : lo ≤ i) (ik : i ≤ k) (w : k < n) (khi : k ≤ hi) + (as : Vector α n) (hpivot : pivot = as[hi]) + (q : ∀ l, (hk₁ : lo ≤ l) → (hk₂ : l < i) → lt as[l] as[hi]) (mid as') + (w_mid : mid = (qpartition.loop lt lo hi hhi pivot as i k).fst.1) (hmid : mid < n) + (w_as : as' = (qpartition.loop lt lo hi hhi pivot as i k).2) : + ∀ l, (h₁ : lo ≤ l) → (h₂ : l < mid) → lt as'[l] as'[mid] := by + fun_induction qpartition.loop with unfold qpartition.loop at w_mid w_as + | case1 + | case2 => apply_assumption <;> grind + | case3 => grind + +private theorem qpartition_loop_spec₂ + (hhi : hi < n) (ilo : lo ≤ i) (ik : i ≤ k) (w : k < n) (khi : k ≤ hi) + (as : Vector α n) (hpivot : pivot = as[hi]) + (q : ∀ l, (hk₁ : i ≤ l) → (hk₂ : l < k) → !lt as[l] as[hi]) (mid as') + (w_mid : mid = (qpartition.loop lt lo hi hhi pivot as i k).fst.1) (hmid : mid < n) + (w_as : as' = (qpartition.loop lt lo hi hhi pivot as i k).2) : + ∀ l, (h₁ : mid < l) → (h₂ : l ≤ hi) → lt as'[l] as'[mid] = false := by + fun_induction qpartition.loop with grind + +/-- +All elements in the active range before the pivot, are less than the pivot. +-/ +private theorem qpartition_spec₁ + (hhi : hi < n) (w : lo ≤ hi) + (as : Vector α n) (mid as') + (w_mid : mid = (qpartition as lt lo hi).fst.1) (hmid : mid < n) + (w_as : as' = (qpartition as lt lo hi).2) : + ∀ i, (h₁ : lo ≤ i) → (h₂ : i < mid) → lt as'[i] as'[mid] := by + grind [qpartition, qpartition_loop_spec₁] + +/-- +All elements in the active range after the pivot, are greater than or equal to the pivot. +-/ +private theorem qpartition_spec₂ + (hhi : hi < n) (w : lo ≤ hi) + (as : Vector α n) (mid as') + (w_mid : mid = (qpartition as lt lo hi).fst.1) (hmid : mid < n) + (w_as : as' = (qpartition as lt lo hi).2) : + ∀ i, (h₁ : mid < i) → (h₂ : i ≤ hi) → lt as'[i] as'[mid] = false := by + grind [qpartition, qpartition_loop_spec₂] + +/-! +We now need to deal with a corner case: +we need to show that `qpartition` only returns a value `≥ hi` when `hi ≤ lo` +(and hence the slice of the array between `lo` and `hi` (inclusive) is trivially already sorted). + +We prove two preliminary lemmas about `qpartition.loop`. +-/ + +/-- If we already have `i < k`, then we're sure to return something less than `hi`. -/ +private theorem qpartition_loop_lt_hi₁ + (ilo : lo ≤ i) (ik : i < k) (w : k ≤ hi) (z : k ≤ hi) (ik' : i ≤ k) : + (qpartition.loop lt lo hi hhi pivot as i k).1.val < hi := by + fun_induction qpartition.loop with grind + +/-- +Otherwise, if there is some position `k' ≥ k` which is greater than or equal to the pivot, +then when we reach that we'll be sure `i < k`, and hence the previous lemma will apply, +and so we're sure to return something less than `hi`. + -/ +private theorem qpartition_loop_lt_hi₂ + {as : Vector α n} (ilo : lo ≤ i) (ik : i ≤ k) (w : k < n) (z : k ≤ hi) + (q : ∃ (k' : Nat) (hj' : k' < n), k' ≥ k ∧ k' < hi ∧ ¬ lt as[k'] pivot) : + (qpartition.loop lt lo hi hhi pivot as i k).1.val < hi := by + fun_induction qpartition.loop with + | case1 => + -- It would be nice if a more aggressive mode in `grind` would do this. + apply_assumption <;> grind + | case2 => grind [qpartition_loop_lt_hi₁] + | case3 => grind + +/-- The only way `qpartition` returns a pivot position `≥ hi` is if `hi ≤ lo`. -/ +private theorem qpartition_fst_lt_hi (lt_asymm : ∀ {a b}, lt a b → ¬ lt b a) + (as : Vector α n) (hhi : hi < n) (w : lo < hi) : (qpartition as lt lo hi).fst.1 < hi := by + apply qpartition_loop_lt_hi₂ lt lo hi + · grind + · exact ⟨(lo + hi)/2, by grind⟩ + +private theorem qsort_sort_spec + (lt_asymm : ∀ {a b}, lt a b → ¬ lt b a) + (le_trans : ∀ {a b c}, ¬ lt b a → ¬ lt c b → ¬ lt c a) + (as : Vector α n) (lo hi : Nat) (hhi : hi < n) (w : lo ≤ hi) + (as' : Vector α n) (w_as : as' = qsort.sort lt as lo hi) : + ∀ i, (h₁ : lo ≤ i) → (h₂ : i < hi) → ¬ lt (as')[i + 1] as'[i] := by + unfold qsort.sort at w_as + split at w_as <;> rename_i w₁ + · -- The interesting case, where `lo < hi`. + intro i h₁ h₂ + -- Decompose `qpartition as lt lo hi` into `mid` (the pivot) and `as'` (the partitioned array). + split at w_as <;> rename_i mid hmid as' w₂ + split at w_as <;> rename_i w₃ + · -- If the pivot was at least `hi`, then we get a contradiction from `lo < hi`. + simp only [Prod.ext_iff, Subtype.ext_iff] at w₂ + obtain ⟨rfl, rfl⟩ := w₂ + have := qpartition_fst_lt_hi lt lo hi lt_asymm as hhi w₁ + grind + · -- Now we know `lo ≤ mid < hi`. + subst w_as + if p₁ : i < mid then + -- If `i < mid`, then the second stage of sorting is only + -- moving elements above where we're looking. + rw [getElem_qsort_sort_of_lt_lo (i := i)] + rw [getElem_qsort_sort_of_lt_lo (i := i + 1)] + -- And so we can apply the theorem recursively replacing `hi` with `mid`. + apply qsort_sort_spec lt_asymm le_trans as' lo mid + -- The remaining arithmetic side conditions are easily resolved. + all_goals grind + else + replace p₁ : mid ≤ i := by grind + -- If `mid ≤ i`, we need to consider two cases. + if p₃ : mid = i then + -- The tricky case, where `mid = i`. + subst i + -- On the right hand side, the index is below the range where the second stage of sorting is happening, + -- so we can drop that sort. + rw [getElem_qsort_sort_of_lt_lo (i := mid)] + -- The `mid` element of `qsort.sort lt as' lo mid ⋯` + -- is *some* element `lo + k` of `as'` in the range `lo ≤ lo + k ≤ mid`. + have z := getElem_qsort_sort_mem lt lo mid as' ?_ mid ?_ ?_ ?_ + rw [Vector.mem_extract_iff_getElem] at z + obtain ⟨k, hk, z⟩ := z + rw [← z] + clear z + -- Similarly, the `mid + 1` element on the left hand side + -- is some element `mid + 1 + k'` of `qsort.sort lt as' lo mid ⋯` + -- in the range `mid + 1 ≤ mid + 1 + k' ≤ hi` + have z := getElem_qsort_sort_mem lt (mid + 1) hi + (qsort.sort lt as' lo mid ?_ ?_) ?_ (mid + 1) ?_ ?_ ?_ + rw [Vector.mem_extract_iff_getElem] at z + obtain ⟨k', hk', z⟩ := z + rw [← z] + clear z + -- And then the first stage sort on the left hand side can't have any effect, + -- as it only moves elements between `lo` and `mid` inclusive. + rw [getElem_qsort_sort_of_hi_lt] + · by_cases p : lo + k = mid + · -- Now if `lo + k = mid`, + -- the element `as'[mid + 1 + k']` is in the top part of the partitioned array, + -- and `as[lo + k]` is the pivot, so we get the inequality from the specification of `qpartition`. + grind [qpartition_spec₂] + · -- Otherwise, we use transitivity: + -- `as[lo + k']` is in the bottom part, so is strictly less than the pivot, + -- while `as'[mid + 1 + k']` is in the top, so greater than or equal to the pivot. + apply le_trans (b := as'[mid]) + · grind [qpartition_spec₁] + · grind [qpartition_spec₂] + -- Various arithmetic side conditions remain from the rewriting, + -- but are now all easy to resolve. + all_goals grind + else + -- If `i < mid`, we can apply the theorem recursively replacing + -- `as` with `qsort.sort lt as' lo mid ⋯` and `lo` with `mid + 1`. + apply qsort_sort_spec lt_asymm le_trans _ _ _ (w_as := rfl) <;> grind + · -- Just an arithmetical contradiction. + grind + +/-- +The slice of `as.qsort lt lo hi` from `lo` to `hi` (inclusive) is sorted. + +This variant states that adjacent elements are non-decreasing. +See `qsort_sorted'` for a variant about arbitrary pairs of indices. +-/ +public theorem qsort_sorted₁' (lt : α → α → Bool) (lt_asymm : ∀ {a b}, lt a b → ¬ lt b a) + (le_trans : ∀ {a b c}, ¬ lt b a → ¬ lt c b → ¬ lt c a) + (as : Array α) (lo hi : Nat) (i) (h₁ : lo ≤ i) (h₂ : i < hi) (h₃ : i + 1 < as.size) : + ¬ lt ((as.qsort lt lo hi)[i + 1]'(by grind)) ((as.qsort lt lo hi)[i]'(by grind)) := by + unfold qsort + split <;> rename_i w + · grind + · apply qsort_sort_spec lt lt_asymm le_trans (w_as := rfl) <;> grind + +/-- +`Array.qsort` returns a sorted array, i.e. adjacent elements are non-decreasing. + +See `qsort_sorted` for a variant about arbitrary pairs of indices. +-/ +public theorem qsort_sorted₁ (lt : α → α → Bool) (lt_asymm : ∀ {a b}, lt a b → ¬ lt b a) + (le_trans : ∀ {a b c}, ¬ lt b a → ¬ lt c b → ¬ lt c a) (as : Array α) + (i) (h : i + 1 < (qsort as lt).size) : + ¬ lt (as.qsort lt)[i + 1] (as.qsort lt)[i] := by + have := qsort_sorted₁' lt lt_asymm le_trans + grind + +/-- The slice of `as.qsort lt lo hi` from `lo` to `hi` (inclusive) is sorted. -/ +public theorem qsort_sorted' (lt : α → α → Bool) (lt_asymm : ∀ {a b}, lt a b → ¬ lt b a) + (le_trans : ∀ {a b c}, ¬ lt b a → ¬ lt c b → ¬ lt c a) + (as : Array α) (lo hi : Nat) (i j) (h₁ : lo ≤ i) (h₂ : i < j) (h₃ : j ≤ hi) (h₄ : j < as.size) : + ¬ lt ((as.qsort lt lo hi)[j]'(by grind)) ((as.qsort lt lo hi)[i]'(by grind)) := by + induction j with + | zero => grind + | succ j ih => + if p : i = j then + subst p + apply qsort_sorted₁' <;> grind + else + apply le_trans (b := (as.qsort lt lo hi)[j]'(by grind)) + · grind + · apply qsort_sorted₁' <;> grind + +public theorem qsort_sorted (lt : α → α → Bool) (lt_asymm : ∀ {a b}, lt a b → ¬ lt b a) + (le_trans : ∀ {a b c}, ¬ lt b a → ¬ lt c b → ¬ lt c a) (as : Array α) : + ∀ i j, (h₁ : i < j) → (h₂ : j < (qsort as lt).size) → + ¬ lt (as.qsort lt)[j] (as.qsort lt)[i] := by + have := qsort_sorted' lt lt_asymm le_trans + grind + +end Array From c62085da9a7e5c9f2136418fb855a089d8520cd4 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 17:00:47 -0400 Subject: [PATCH 30/51] 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 fe11665e..75c3d5a7 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 d8d9d298..349b682a 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 d2151dd6..501dd383 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 ab3ecbfb..85d2d84f 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 4172c0fadafa54a8cb39787843f262883bb20e5b Mon Sep 17 00:00:00 2001 From: Mario Carneiro Date: Tue, 11 Aug 2026 06:47:05 +0200 Subject: [PATCH 31/51] fix: make level normalization reconstruction canonical MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The reconstruction of a Level from a NormLevel picked the imax chain for each sublevel condition set via parent pointers into the key set of the map (findParent/buildPaths). But the keys record which imax chains appeared syntactically in the input, and are not canonical: equivalent levels can produce the same sublevels with different scaffolding keys, yielding different parent choices and hence different reified levels, e.g. max v (max w (imax (imax (imax u v) w) x)) max v (max w (imax (imax (imax u w) v) x)) normalized to distinct levels (and isEquiv' answered false). Replace the parent-pointer scheme with a chain computation that depends only on the sublevels: an edge adding v to condition set S is admissible iff some V(T, v+k) with T ⊆ S is among the sublevels, and each condition set is built by its lexicographically least admissible chain (greedy, with a feasibility check on the remainder; admissibility is monotone in the condition set, so greedy search is complete). Empty nodes are gone from normal forms, so that BEq, and hence isEquiv', cannot see scaffolding keys. There were two sources. `normalize` seeded the map with `[] => default`, because `addConst` used `modify`, which silently drops the constant when the key is absent; it uses `alter` now, as `addNode` already did, and starts from the empty map, so every insertion carries content (measured over all levels of size <= 7 in 4 parameters, `normalizeAux` adds no empty node at all). The other source is inherent: subsumption drains a node when every sublevel at its key is dominated, so that key is erased rather than left empty. This is load-bearing -- at 4356 of those same levels a node drains, the smallest being `imax u (max u v)`, where keeping the key makes `isEquiv'` reject it against `max u v`. NormLevel.le now compares per sublevel rather than per node, which is what Theorem 39 says: a node bundles a constant sublevel with several variable ones, and they may need different dominators. For imax 2 v <= max 2 v the left side is the single node {v} => { const := 2, var := [v+0] } whose sublevels C({v},2) and V({v},v+0) are dominated at different keys of the right side, so geq' answered false. This is reachable: geq' has one caller, the constructor universe check in Inductive/Add.lean, and it made lean4lean reject inductive Foo.{v} (b : Sort v) : Sort (max 2 v) | mk : (Type -> b) -> Foo b which Lean accepts. Rather than searching l2 for one dominator, carry the sublevels still outstanding and let each entry of l2 discharge what it can -- the same domination step minimization performs, so Node.subsume is split into the test that the condition sets are comparable and Node.subsumeBy, which does the discharging and is shared. Its `same` flag distinguishes the two callers, since a node being minimized must not have its variables discharge themselves. Nothing is left to discharge exactly when the node is dominated, so the fold stops there, recovering the early exit of the old single-pass search. leVars is no longer needed: subsumeVars already removes dominated variables in one O(n) merge. Also: fix a typo in the constant subsumption rule, which compared the constant against the node's own variable offsets instead of the subsuming node's (C(E, L) <= V(F, x, K) iff F subseteq E and L <= K + 1); and factor the subsumption step into Node.subsume and NormLevel.minimize, which is behavior-preserving but lets the proofs name the steps. Proof side: `addConst_eval` no longer needs `acc.contains path`, since `alter` creates the entry. In exchange the invariant threaded through `normalizeAux_eval` weakens to `path = [] or acc.contains path`: the root is no longer a key until something is written there, and `addVar`, the one step that still needs the key to exist, is only reached with `path` nonempty. Fuzzed: exhaustive over all levels of size <= 7 (4 params) for soundness of normalize' and round-tripping; exhaustive cross-comparison of all equivalent pairs of size <= 7 (3 params) for canonicity of normalize' and completeness of isEquiv'; exhaustive geq' vs semantic order on all pairs of size <= 5 (3 params), 0 unsound and 0 incomplete; 100k random levels closed under random equivalence-preserving rewrites. Regressions for all of the above go in Tests/Level.lean, together with a bounded exhaustive check that equivalent levels of size at most 5 reify to the same level and are accepted by isEquiv' -- canonicity and completeness are what the proofs do not cover. Co-Authored-By: Claude Fable 5 --- Lean4Lean/Level.lean | 197 +++++++++++++++++++++--------------- Lean4Lean/Tests/Level.lean | 123 ++++++++++++++++++++++ Lean4Lean/Verify/Level.lean | 76 ++++++++------ 3 files changed, 288 insertions(+), 108 deletions(-) create mode 100644 Lean4Lean/Tests/Level.lean diff --git a/Lean4Lean/Level.lean b/Lean4Lean/Level.lean index 4550fe26..eeb6bcb3 100644 --- a/Lean4Lean/Level.lean +++ b/Lean4Lean/Level.lean @@ -38,13 +38,10 @@ structure VarNode where offset : Nat deriving BEq, Ord, Repr -/-- An key-value pair `vs => { path, const, var }` in NormLevel represents +/-- A key-value pair `vs => { const, var }` in NormLevel represents the max of `C(vs, const)` and `V(vs, v, n)` for each `v+n ∈ var`, using the `C` and `V` sublevel -functions from . -The `path` assists in ensuring the invariant that for each suffix `vs' <:+ path`, -`vs'` is also in the `NormLevel` map. -/ +functions from . -/ structure Node where - path : List Name := [] const : Nat := 0 var : List VarNode := [] deriving Repr, Inhabited @@ -54,6 +51,8 @@ instance : BEq Node where instance : Ord Node where compare n₁ n₂ := compare n₁.const n₂.const |>.then <| compare n₁.var n₂.var +def Node.isEmpty (n : Node) : Bool := n.const == 0 && n.var.isEmpty + def subset (cmp : α → α → Ordering) : List α → List α → Bool | [], _ => true | _, [] => false @@ -97,7 +96,9 @@ def NormLevel.addNode (v : Name) (k : Nat) (path' : List Name) (s : NormLevel) : def NormLevel.addConst (k : Nat) (path : List Name) (acc : NormLevel) : NormLevel := if k = 0 || k = 1 && !path.isEmpty then acc else - acc.modify path fun n => { n with const := k.max n.const } + acc.alter path fun + | none => some { const := k } + | some n => some { n with const := k.max n.const } def normalizeAux (l : Level) (path : List Name) (k : Nat) (acc : NormLevel) : NormLevel := match l with @@ -128,67 +129,110 @@ def subsumeVars : List VarNode → List VarNode → List VarNode | .eq => if x.offset ≤ y.offset then subsumeVars xs ys else x :: subsumeVars xs ys | .gt => subsumeVars (x :: xs) ys -def findParent (f : List Name → Bool) : (l₁ l₂ : List Name) → List Name - | _, [] => [] - | l₁, a :: l₂ => if f (l₁.reverseAux l₂) then [a] else findParent f (a :: l₁) l₂ - -def NormLevel.subsumption (acc : NormLevel) (paths := false) : NormLevel := +/-- Remove from `n₁` the sublevels dominated by `n₂`, whose condition set is a subset of +`n₁`'s: `C(c)` is dominated by `C(c')` when `c ≤ c'` and by `V(x+k)` when `c ≤ k + 1`, and +`V(x+k)` is dominated by `V(x+k')` when `k ≤ k'`. + +`same` says the two sit at the *same* condition set, where a variable may still discharge the +constant but the variables must not discharge themselves. -/ +def Node.subsumeBy (same : Bool) (n₁ n₂ : Node) : Node := + let n₁ := + if n₁.const = 0 || + (same || n₁.const > n₂.const) && + (n₂.var.isEmpty || n₁.const > n₂.var.foldl (·.max ·.offset) 0 + 1) + then n₁ else { n₁ with const := 0 } + if same || n₂.var.isEmpty then n₁ else { n₁ with var := subsumeVars n₁.var n₂.var } + +/-- Remove the parts of the sublevels at `(p₁, n₁)` that are dominated by the sublevels +at `(p₂, n₂)`. -/ +def Node.subsume (p₁ : List Name) (n₁ : Node) (p₂ : List Name) (n₂ : Node) : Node := + if subset compare p₂ p₁ then n₁.subsumeBy (p₁.length == p₂.length) n₂ else n₁ + +/-- Remove the parts of the sublevels at `(p₁, n₁)` dominated by other entries of the map. -/ +def NormLevel.minimize (acc : NormLevel) (p₁ : List Name) (n₁ : Node) : Node := + acc.foldl (init := n₁) (Node.subsume p₁) + +def NormLevel.subsumption (acc : NormLevel) : NormLevel := acc.foldl (init := acc) fun acc p₁ n₁ => - let n₁ := acc.foldl (init := n₁) fun n₁ p₂ n₂ => - if !subset compare p₂ p₁ then n₁ else - let same := p₁.length == p₂.length - let n₁ := - if n₁.const = 0 || - (same || n₁.const > n₂.const) && - (n₂.var.isEmpty || n₁.const > n₁.var.foldl (·.max ·.offset) 0 + 1) - then n₁ else { n₁ with const := 0 } - if same || n₂.var.isEmpty then n₁ else { n₁ with var := subsumeVars n₁.var n₂.var } - let n₁ := if paths then - let path := findParent acc.contains [] p₁ - let var := if let [v] := path then subsumeVars n₁.var [⟨v, 0⟩] else n₁.var - { n₁ with path, var } - else n₁ - acc.insert p₁ n₁ - -def normalize (l : Level) (paths := false) : NormLevel := - Normalize.normalizeAux l [] 0 (.insert {} [] default) |>.subsumption paths - -def leVars : List VarNode → List VarNode → Bool - | [], _ => true - | _, [] => false - | x :: xs, y :: ys => - match Name.cmp x.var y.var with - | .lt => false - | .eq => x.offset ≤ y.offset && leVars xs ys - | .gt => leVars (x :: xs) ys - + let n := acc.minimize p₁ n₁ + if n.isEmpty then acc.erase p₁ else acc.insert p₁ n + +def normalize (l : Level) : NormLevel := + Normalize.normalizeAux l [] 0 {} |>.subsumption + +/-- Sublevel comparison, following Theorem 39 of the paper: `l₁ ≤ l₂` iff every sublevel +of `l₁` is dominated by some sublevel of `l₂`, where +`C(E, L) ≤ C(F, K) ↔ F ⊆ E ∧ L ≤ K`, `C(E, L) ≤ V(F, x, K) ↔ F ⊆ E ∧ L ≤ K + 1`, +and `V(E, x, L) ≤ V(F, y, K) ↔ F ⊆ E ∧ x = y ∧ L ≤ K`. + +Each sublevel picks its own dominator, and a node bundles several of them, so it is not +enough to look for a single entry of `l₂` dominating a whole node of `l₁`: for +`imax 2 v ≤ max 2 v` the constant is dominated at `∅` and the variable at `{v}`. Instead +each entry of `l₂` discharges what it can from the sublevels of `n₁` that are still +outstanding, which is the same `subsumeBy` step minimization uses; the node is dominated +once nothing is left, and the fold stops there. -/ def NormLevel.le (l₁ l₂ : NormLevel) : Bool := l₁.all fun p₁ n₁ => - if n₁.const = 0 && n₁.var.isEmpty then true else - l₂.any fun p₂ n₂ => - (!n₂.var.isEmpty || n₁.var.isEmpty) && - subset compare p₂ p₁ && - (n₁.const ≤ n₂.const || n₂.var.any (n₁.const ≤ ·.offset + 1)) && - leVars n₁.var n₂.var - -def NormLevel.buildPaths : StateM NormLevel Unit := do - (← get).foldlM (init := ()) fun _ p _ => do - let n := (← get).get! p - if let [v] := n.path then - let l ← getPath (p.erase v) p.length - setPath p (v :: l) + -- `none` means nothing is left to discharge, which stops the fold + Option.isNone <| l₂.foldlM (init := n₁) (m := Option) fun n p₂ n₂ => + if subset compare p₂ p₁ then + let n := n.subsumeBy false n₂ + if n.isEmpty then none else some n + else some n + +/-! +Reconstruction of a `Level` from a `NormLevel`. + +The paper's canonical form is a set of sublevels `C(S, k)`, `V(S, v+k)`; it does not address +which such sets are expressible as level expressions. Reifying a sublevel with conditions `S` +requires nesting it under an imax chain `imax (… imax (imax (_) v₁) …) vₙ` where +`{v₁, …, vₙ} = S`, and each edge of such a chain itself contributes the sublevel +`V(S', vᵢ, 0)` where `S'` is the set of conditions up to that point. So a chain order is +admissible only if each such edge contribution is dominated by the canonical form, i.e. +there is some `V(T, vᵢ+k)` with `T ⊆ S'` among the sublevels. Canonical forms produced by +`normalizeAux` always admit at least one such order for every key +(each key is the condition set of some `imax` chain suffix of the input, whose edges put +the required `V` entries at subsets of the key, and subsumption only moves coverage to +smaller sets). + +To make the output canonical, the choice of chain must depend only on the canonical +sublevels, not on incidental map keys (which record which `imax` chains appeared +syntactically in the input). For each key we take the lexicographically least admissible +chain, computed greedily. This is well-defined: domination of `V(S', v, 0)` is monotone +in `S'`, so extending the set of conditions added so far never invalidates other elements, +and a greedy choice never needs to be revisited (checking that the remainder stays +completable before committing to each element). -/ + +/-- Is the edge contribution `V(acc ∪ {a}, a, 0)` dominated by the normal form? +True iff some `V(T, a+k)` with `T ⊆ acc ∪ {a}` is present. -/ +def NormLevel.addable (s : NormLevel) (a : Name) (acc : List Name) : Bool := + s.any fun p n => n.var.any (·.var == a) && subset compare (p.erase a) acc + +/-- Can the elements of `rem` be added to the condition set `acc` one at a time, each +addition being `addable` at that point? Since `addable` is monotone in `acc`, adding any +addable element preserves completability, so a greedy check is complete. -/ +def NormLevel.feasible (s : NormLevel) (acc rem : List Name) : Bool := + go rem.length acc rem where - setPath (p path : List Name) : StateM NormLevel Unit := - modify (·.modify p ({ · with path })) - - getPath (p : List Name) (depth : Nat) : StateM NormLevel (List Name) := do - let n := (← get).get! p - if let [v] := n.path then - if let depth + 1 := depth then - let l ← getPath (p.erase v) depth - setPath p (v :: l) - return v :: l - return n.path + go : Nat → List Name → List Name → Bool + | 0, _, rem => rem.isEmpty + | fuel+1, acc, rem => + match rem.find? (s.addable · acc) with + | none => rem.isEmpty + | some a => go fuel ((orderedInsert Name.cmp a acc).getD acc) (rem.erase a) + +/-- The lexicographically least admissible imax chain building the condition set `p`, +listed innermost (last-added) first: at each step, remove the least element that is +`addable` on top of the rest and whose remainder is still completable. +This depends only on the sublevels of `s`, not on its key set, so equal normal forms +reify to equal levels. (The fallback returns the remaining set in sorted order; +it is not reachable for normal forms produced by `normalizeAux`.) -/ +def NormLevel.lexChain (s : NormLevel) : Nat → List Name → List Name + | 0, p => p + | fuel+1, p => + match p.find? fun a => s.addable a (p.erase a) && s.feasible [] (p.erase a) with + | some a => a :: s.lexChain fuel (p.erase a) + | none => p structure Tree where const : Nat @@ -210,22 +254,17 @@ def Tree.modify (path : List Name) (f : Tree → Tree) (t : Tree) : Tree := | a :: p => modify p (t := t) fun t => { t with child := modifyAt f a t.child } def NormLevel.toTree (acc : NormLevel) : Tree := - (buildPaths.run acc).run.2.foldl (init := ⟨0, [], []⟩) fun t _ n => - t.modify n.path fun t => { t with const := n.const, var := n.var } - -def treeVarDedup : List VarNode → List (Name × Tree) → List VarNode - | [], _ => [] - | xs, [] => xs - | x :: xs, y :: ys => - match Name.cmp x.1 y.1 with - | .lt => x :: treeVarDedup xs (y :: ys) - | .eq => if x.2 = 0 then treeVarDedup xs ys else x :: treeVarDedup xs ys - | .gt => treeVarDedup (x :: xs) ys + acc.foldl (init := ⟨0, [], []⟩) fun t p n => + let path := acc.lexChain p.length p + -- the edge into this tree node already contributes `V(p, v, 0)` for the innermost + -- chain element `v`, so an explicit `v+0` entry would be redundant + let var := if let v :: _ := path then subsumeVars n.var [⟨v, 0⟩] else n.var + t.modify path fun t => { t with const := n.const, var } def Tree.reify : Tree → Level | { const, var, child } => let l := child.foldr mkChild none - let l := (treeVarDedup var child).foldr (init := l) fun n r => + let l := var.foldr (init := l) fun n r => some (mkMax (addOffset (.param n.var) n.offset) r) match l with | none => ofNat const @@ -242,7 +281,7 @@ where end Normalize -def normalize' (l : Level) : Level := (Normalize.normalize l (paths := true)).toTree.reify +def normalize' (l : Level) : Level := (Normalize.normalize l).toTree.reify def isEquiv' (u v : Level) : Bool := u == v || Normalize.normalize u == Normalize.normalize v @@ -266,7 +305,7 @@ def geq' (u v : Level) : Bool := (Normalize.normalize v).le (Normalize.normalize -- #guard_msgs in normalize max u 1 -- /-- info: u -/ -- #guard_msgs in normalize imax 1 u --- /-- info: max 1 (imax (u+1) u) -/ +-- /-- info: max 1 (imax (u + 1) u) -/ -- #guard_msgs in normalize u+1 -- /-- info: imax 2 u -/ -- #guard_msgs in normalize imax 2 u @@ -276,7 +315,7 @@ def geq' (u v : Level) : Bool := (Normalize.normalize v).le (Normalize.normalize -- #guard_msgs in normalize max (imax (imax u v) w) (imax (imax u w) v) -- /-- info: u -/ -- #guard_msgs in normalize imax u u --- /-- info: max 1 (imax (u+1) u) -/ +-- /-- info: max 1 (imax (u + 1) u) -/ -- #guard_msgs in normalize imax u (u+1) --- /-- info: max 1 (imax (max (v+1) (imax (u+1) u)) v) -/ +-- /-- info: max 1 (imax (max (v + 1) (imax (u + 1) u)) v) -/ -- #guard_msgs in normalize imax u v + 1 diff --git a/Lean4Lean/Tests/Level.lean b/Lean4Lean/Tests/Level.lean new file mode 100644 index 00000000..e231a323 --- /dev/null +++ b/Lean4Lean/Tests/Level.lean @@ -0,0 +1,123 @@ +import Lean4Lean.Level + +open Lean + +/-! +# Regressions for the experimental level normalization + +Soundness of `normalize'`, `isEquiv'` and `geq'` is proved in `Verify/Level.lean`. What is +*not* proved, and so is what these check, is canonicity of `normalize'` and completeness of +`isEquiv'`/`geq'`. +-/ + +private def u : Level := .param `u +private def v : Level := .param `v +private def w : Level := .param `w +private def x : Level := .param `x + +-- The reconstruction must depend only on the sublevels, not on which `imax` chains appeared +-- in the input. These two have the same sublevels but different scaffolding keys; picking the +-- chain by parent pointers into the key set reified them to different levels. Four parameters +-- and size 10, so exhaustive fuzzing up to size 7 does not reach it. +#guard (Level.max v (.max w (.imax (.imax (.imax u v) w) x))).isEquiv' + (Level.max v (.max w (.imax (.imax (.imax u w) v) x))) + +-- `NormLevel.le` compares sublevels, not nodes: the node `{v} => {const := 2, var := [v+0]}` +-- of `imax 2 v` has its constant dominated at the empty key of `max 2 v` and its variable at +-- `{v}`, and no single entry dominates both. Reachable from the constructor universe check, +-- where it made lean4lean reject an inductive that Lean accepts. +#guard (Level.max (.ofNat 2) v).geq' (.imax (.ofNat 2) v) +#guard (Level.max (u.addOffset 2) v).geq' (.imax (u.addOffset 2) v) + +-- Subsumption drains this node, and the key has to be erased rather than left empty, or +-- `BEq` on the normal form sees scaffolding that carries no information. +#guard (Level.imax u (.max u v)).isEquiv' (.max u v) + +-- Equivalences the core `isEquiv` misses. +#guard (Level.max v u).isEquiv' (.max (.imax u v) u) +#guard !(Level.max v u).isEquiv (.max (.imax u v) u) + +/-! ### Canonical forms -/ + +local elab "normalize " l:level : command => do + Elab.Command.runTermElabM fun _ => do + logInfo m!"{Level.normalize' (← Elab.Term.elabLevel l)}" + +universe u v w + +/-- info: max 1 u -/ +#guard_msgs in normalize max u 1 +/-- info: u -/ +#guard_msgs in normalize imax 1 u +/-- info: max 1 (imax (u + 1) u) -/ +#guard_msgs in normalize u+1 +/-- info: imax 2 u -/ +#guard_msgs in normalize imax 2 u +/-- info: max v (imax (imax u v) w) -/ +#guard_msgs in normalize max w (imax (imax u w) v) +/-- info: max v (imax (imax u v) w) -/ +#guard_msgs in normalize max (imax (imax u v) w) (imax (imax u w) v) +/-- info: u -/ +#guard_msgs in normalize imax u u +/-- info: max 1 (imax (u + 1) u) -/ +#guard_msgs in normalize imax u (u+1) +/-- info: max 1 (imax (max (v + 1) (imax (u + 1) u)) v) -/ +#guard_msgs in normalize imax u v + 1 + +/-! ### Bounded exhaustive canonicity and completeness + +Every equivalent pair of levels must reify to the *same* level, and `isEquiv'` must accept it. +Levels are bucketed by their values on a grid of valuations, which for levels this small +decides equivalence. +-/ + +private def evalL (σ : Name → Nat) : Level → Nat + | .zero => 0 + | .succ l => evalL σ l + 1 + | .max l₁ l₂ => Nat.max (evalL σ l₁) (evalL σ l₂) + | .imax l₁ l₂ => + match evalL σ l₂ with + | 0 => 0 + | n+1 => Nat.max (evalL σ l₁) (n+1) + | .param n => σ n + | .mvar _ => 0 + +private def levelsUpTo (n : Nat) : Array (Array Level) := Id.run do + let mut tbl : Array (Array Level) := #[#[]] + for k in [1:n+1] do + if k = 1 then + tbl := tbl.push #[.zero, .param `u, .param `v, .param `w] + else + let mut out := tbl[k-1]!.map .succ + for i in [1:k-1] do + for a in tbl[i]! do + for b in tbl[k-1-i]! do + out := out.push (.max a b) + out := out.push (.imax a b) + tbl := tbl.push out + return tbl + +private def valsOver (hi : Nat) : Array (Name → Nat) := Id.run do + let mut out := #[] + for i in [0:hi+1] do + for j in [0:hi+1] do + for k in [0:hi+1] do + out := out.push fun n => if n == `u then i else if n == `v then j else k + return out + +/-- Levels of size at most `sz`, grouped by value vector; every group must be a single +`normalize'` image accepted by `isEquiv'`. -/ +private def canonical (sz : Nat) : Bool := Id.run do + let vals := valsOver (sz + 2) + let mut buckets : Std.HashMap (Array Nat) (Level × Level) := {} + for ls in levelsUpTo sz do + for l in ls do + let key := vals.map (evalL · l) + let l' := l.normalize' + match buckets[key]? with + | none => buckets := buckets.insert key (l, l') + | some (r, r') => if l' != r' || !l.isEquiv' r then return false + return true + +-- 852 levels in 123 equivalence classes, so 729 equivalent pairs are checked +#guard canonical 5 diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index 8aafe8eb..4b3ac72c 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -266,7 +266,8 @@ theorem NormLevel.addNode_contains_self : (addNode v k path acc).contains path : simp [addNode]; split <;> simp theorem NormLevel.addConst_contains (H : acc.contains x) : (addConst k path acc).contains x := by - simp [addConst] at *; split <;> simp [H, Std.TreeMap.mem_modify] + simp [addConst] at *; split <;> simp [H, Std.TreeMap.mem_alter] + split <;> simp [H] theorem normalizeAux_contains (H : acc.contains x) : (normalizeAux u path k acc).contains x := by unfold normalizeAux; split @@ -325,8 +326,7 @@ theorem ext_le {n m : Nat} (H : ∀ x, n ≤ x ↔ m ≤ x) : n = m := theorem le_ext_le {n m : Nat} (H : ∀ x, n ≤ x → m ≤ x) : m ≤ n := H _ (Nat.le_refl _) -theorem NormLevel.addConst_eval - (H : acc.contains path) (le : EvalPaths ls ρ path (acc.eval ls ρ)) : +theorem NormLevel.addConst_eval (le : EvalPaths ls ρ path (acc.eval ls ρ)) : (addConst k path acc).eval ls ρ = max' (acc.eval ls ρ) (evalPath ls ρ path k) := by simp [addConst]; split <;> rename_i h · obtain rfl | ⟨rfl, _⟩ := h @@ -336,17 +336,28 @@ theorem NormLevel.addConst_eval rw [this, Nat.max_eq_left]; simp [evalPath]; split <;> [rename_i h; simp] let ⟨h1, h2⟩ := allNZ_cons.1 h; exact Nat.le_trans h1 (evalPath_le.1 le h2) · refine ext_le fun x => ?_ - rw [← Std.TreeMap.isSome_getElem?_eq_contains, Option.isSome_iff_exists] at H; let ⟨v, H⟩ := H - simp [eval_le, Nat.max_le, Std.TreeMap.getElem?_modify, evalPath_le, Node.eval_le, H] - refine ⟨fun h1 => ?_, fun ⟨h1, h2⟩ a b => ?_⟩ - · have := h1 path; simp [Nat.max_le] at this - refine ⟨fun a b h3 h4 => ?_, fun h => (this h).1.1⟩ - specialize h1 a; split at h1 - · subst a; cases H.symm.trans h3; exact ⟨(this h4).1.2, (this h4).2⟩ - · exact h1 _ h3 h4 - · split - · subst a; rintro ⟨⟩ nz; simp [Nat.max_le, nz, h2]; exact h1 _ _ H nz - · exact h1 _ _ + simp [eval_le, Nat.max_le, Std.TreeMap.getElem?_alter, evalPath_le, Node.eval_le] + refine ⟨fun H => ⟨fun a b h nz => ?_, fun nz => ?_⟩, fun ⟨H1, H2⟩ a b h nz => ?_⟩ + · -- the bound at every key transfers back, since `alter` only raises the constant + have := H a; split at this + · subst a; rw [h] at this + obtain ⟨hc, hv⟩ := this _ rfl nz + exact ⟨Nat.le_trans (Nat.le_max_right ..) hc, hv⟩ + · exact this _ h nz + · -- and it bounds `k`, whether or not `path` was already present + have := H path; rw [if_pos rfl] at this; split at this <;> + refine Nat.le_trans ?_ ((this _ rfl nz).1) <;> + first + | exact Nat.le_refl _ + | exact Nat.le_max_left .. + · -- conversely the bound at `path` is the max of the old one and `k` + split at h + · subst a; split at h <;> cases h + · exact ⟨H2 nz, by simp⟩ + · rename_i n hn + obtain ⟨hc, hv⟩ := H1 _ _ hn nz + exact ⟨Nat.max_le.2 ⟨H2 nz, hc⟩, hv⟩ + · exact H1 _ _ h nz theorem VarNode.addVar_le : (∀ vn ∈ VarNode.addVar v k l, vn.eval ls ρ ≤ x) ↔ evalParam ls ρ v + k ≤ x ∧ (∀ vn ∈ l, vn.eval ls ρ ≤ x) := by @@ -386,35 +397,39 @@ theorem NormLevel.addVar_eval (H : acc.contains path) : (addVar v k path acc).ev · subst a; cases h; simp_all [VarNode.addVar_le]; grind · grind +/-- The invariant threaded through `normalizeAux`: the current path is either the root, which +`addConst` creates on demand, or already a key of the map, created by an earlier `addNode`. +`addVar` is only reached in the second case, since it runs only when `path` already contains +the variable being added. -/ theorem normalizeAux_eval (hu : VLevel.ofLevel ls u = some u') - (H : acc.contains path) (le : EvalPaths ls ρ path (acc.eval ls ρ)) : + (H : path = [] ∨ acc.contains path) (le : EvalPaths ls ρ path (acc.eval ls ρ)) : (normalizeAux u path k acc).eval ls ρ = max' (acc.eval ls ρ) (evalPath ls ρ path (u'.eval ρ + k)) := by unfold normalizeAux; split - · cases hu; simp [NormLevel.addConst_eval H le, VLevel.eval] + · cases hu; simp [NormLevel.addConst_eval le, VLevel.eval] · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, rfl⟩ := hu - simp [VLevel.eval, Lean.Nat.imax, NormLevel.addConst_eval H le] + simp [VLevel.eval, Lean.Nat.imax, NormLevel.addConst_eval le] · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, rfl⟩ := hu rw [normalizeAux_eval hu H le, Nat.add_succ, ← Nat.succ_add]; rfl · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, hv, rfl⟩ := hu - rw [normalizeAux_eval hv (normalizeAux_contains H)] <;> rw [normalizeAux_eval hu H le] + rw [normalizeAux_eval hv (H.imp id normalizeAux_contains)] <;> rw [normalizeAux_eval hu H le] · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; rfl · exact le.max · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, rfl⟩, rfl⟩ := hu - rw [normalizeAux_eval hv (normalizeAux_contains H)] <;> rw [normalizeAux_eval hu H le] + rw [normalizeAux_eval hv (H.imp id normalizeAux_contains)] <;> rw [normalizeAux_eval hu H le] · rw [Nat.max_assoc, Nat.add_succ, ← Nat.succ_add, ← evalPath_max, Nat.add_max_add_right]; rfl · exact le.max · rename_i u v w simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, _, hw, rfl⟩, rfl⟩ := hu rw [normalizeAux_eval - (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) (normalizeAux_contains H)] <;> + (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) (H.imp id normalizeAux_contains)] <;> rw [normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hv, rfl⟩) H le] · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; simp [VLevel.eval, imax_max] · exact le.max · rename_i u v w simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, _, hw, rfl⟩, rfl⟩ := hu rw [normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hv, _, hw, rfl⟩) - (normalizeAux_contains H)] <;> + (H.imp id normalizeAux_contains)] <;> rw [normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) H le] · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; simp [VLevel.eval, imax_imax] · exact le.max @@ -422,15 +437,16 @@ theorem normalizeAux_eval (hu : VLevel.ofLevel ls u = some u') simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨hv, rfl⟩, rfl⟩ := hu have := @evalPath_orderedInsert ls ρ v path split <;> rename_i h <;> simp [h] at this - · rw [normalizeAux_eval hu NormLevel.addNode_contains_self] <;> - rw [NormLevel.addNode_eval, NormLevel.addConst_eval H le, Nat.max_assoc] + · rw [normalizeAux_eval hu (.inr NormLevel.addNode_contains_self)] <;> + rw [NormLevel.addNode_eval, NormLevel.addConst_eval le, Nat.max_assoc] · rw [Nat.max_assoc, ← evalPath_max, this, evalPath_cons, ← evalPath_max, Nat.add_max_add_right]; congr 2 simp [VLevel.eval, ← evalParam_eq hv, Lean.Nat.imax] cases evalParam .. <;> simp [Nat.max_eq_max, Nat.max_comm] · refine .insert h (Nat.le_trans ?_ (Nat.le_max_right ..)) le.max rw [this, evalPath_cons, ← evalPath_max]; apply evalPath_mono; grind - · dsimp; split + · have hne : path ≠ [] := by rintro rfl; simp [orderedInsert] at h + dsimp; split · rw [normalizeAux_eval hu H le] simp [evalPath]; split <;> [rename_i nz; simp] have hm := (h ▸ mem_orderedInsert).2 (.inl rfl) @@ -441,7 +457,8 @@ theorem normalizeAux_eval (hu : VLevel.ofLevel ls u = some u') revert this nz; cases evalParam .. <;> simp rw [Nat.max_eq_max, Nat.max_comm (a := VLevel.eval ..), ← Nat.add_max_add_right, ← Nat.max_assoc] intro h; rw [Nat.max_eq_left (b := _+1+k)]; omega - · rw [normalizeAux_eval hu (NormLevel.addVar_contains H)] <;> rw [NormLevel.addVar_eval H] + · rw [normalizeAux_eval hu (H.imp id NormLevel.addVar_contains)] <;> + rw [NormLevel.addVar_eval (H.resolve_left hne)] · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right, this, evalPath_cons, evalPath_cons]; congr 2; split <;> simp [VLevel.eval, Lean.Nat.imax] rename_i h; revert h; simp [← evalParam_eq hv] @@ -452,10 +469,11 @@ theorem normalizeAux_eval (hu : VLevel.ofLevel ls u = some u') · rename_i v; simp [VLevel.ofLevel] at hu; obtain ⟨hv, rfl⟩ := hu have := @evalPath_orderedInsert ls ρ v path split <;> rename_i h <;> simp [h] at this - · rw [NormLevel.addNode_eval, NormLevel.addConst_eval H le, Nat.max_assoc, + · rw [NormLevel.addNode_eval, NormLevel.addConst_eval le, Nat.max_assoc, this, evalPath_cons, ← evalPath_max] simp [VLevel.eval, ← evalParam_eq hv]; congr 2; split <;> simp; omega - · split + · have hne : path ≠ [] := by rintro rfl; simp [orderedInsert] at h + split · simp [evalPath]; split <;> [rename_i nz; simp] have hm := (h ▸ mem_orderedInsert).2 (.inl rfl) have ⟨p1, p2, a1, a2, a3, a4⟩ := le.of_mem hm @@ -463,7 +481,7 @@ theorem normalizeAux_eval (hu : VLevel.ofLevel ls u = some u') simp [allNZ] at nz; specialize nz _ hm simp [VLevel.eval, ← evalParam_eq hv] revert this nz; cases evalParam .. <;> simp; omega - · rw [NormLevel.addVar_eval H, this, evalPath_cons, evalPath_cons] + · rw [NormLevel.addVar_eval (H.resolve_left hne), this, evalPath_cons, evalPath_cons] congr 2; split <;> simp [VLevel.eval, ← evalParam_eq hv] theorem NormLevel.subsumption_eval {s : NormLevel} : @@ -473,7 +491,7 @@ theorem NormLevel.subsumption_eval {s : NormLevel} : theorem normalize_eval (hu : VLevel.ofLevel ls u = some u') : (normalize u).eval ls ρ = u'.eval ρ := by simp [normalize, NormLevel.subsumption_eval] - exact normalizeAux_eval hu (by simp) .nil + exact normalizeAux_eval hu (.inl rfl) .nil theorem Node.eval_congr {a b : Node} (H : a == b) : a.eval ls ρ = b.eval ls ρ := by simp +instances [instBEqNode] at H; simp [H, eval] From 1af6514837a1ef3b2e01357a8d61aafde9b4314a Mon Sep 17 00:00:00 2001 From: Mario Carneiro Date: Tue, 11 Aug 2026 03:17:59 +0200 Subject: [PATCH 32/51] verify: prove soundness of level normalization up to reification normalize_eval, that a level and its normal form evaluate the same under every valuation, is now proved, and with it isEquiv'_wf; neither depends on sorryAx. The reification step normalize' = toTree.reify is still unverified, so this covers everything except turning the normal form back into a Level. The invariant carrying the proof is NormLevel.WF: every variable recorded at a key is an element of that key, and every nonempty key extends another key by a single variable recorded at it. The second half is what makes addConst sound in dropping C(p, 1) for a nonempty p, since along a path whose variables are all nonzero that recorded variable is at least 1; it is also the expressibility property the reconstruction relies on. Since normalize starts from the empty map, a key's parent may be the root while the root is not yet present, so the invariant threaded through normalizeAux is `path = [] or acc.contains path` and WF's parent clause is likewise `p' = [] or s.contains p'`; addVar, the one step needing the key to exist, only runs when path already contains the variable and so is never at the root. subsumption_eval is proved from a fold invariant tracking, for each sublevel of the node being minimized, either a dominating sublevel still present in the node or one at another key of the map. Erasing a drained key is handled together with insertion by a single characterization of the step's lookup, since an absent key and an empty node have the same eval. Node.subsume is characterized through Node.subsumeBy, matching the split the algorithm makes, so the same lemmas serve both minimization and NormLevel.le. Co-Authored-By: Claude Fable 5 --- Lean4Lean/Verify/Level.lean | 742 ++++++++++++++++++++++++++++++------ 1 file changed, 622 insertions(+), 120 deletions(-) diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index 4b3ac72c..0c62773e 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -168,6 +168,8 @@ namespace Normalize attribute [local instance] Lean.Level.Normalize.instOrdName_lean4Lean local instance : Std.TransCmp (α := Name) compare := inferInstanceAs (Std.TransCmp Name.cmp) +local instance : Std.LawfulBEqCmp (α := Name) compare := + inferInstanceAs (Std.LawfulBEqCmp Name.cmp) local instance : Std.LawfulBEqCmp (α := List Name) compare := inferInstanceAs (Std.LawfulBEqCmp (List.compareLex Name.cmp)) @@ -181,6 +183,52 @@ instance : LawfulBEq VarNode where @[reducible] local instance : GetElem? NormLevel (List Name) Node (fun m a => a ∈ m) := inferInstanceAs (GetElem? (Std.TreeMap _ _ compare) ..) +inductive Extend1 : List α → α → List α → Prop + | mk : Extend1 (l₁ ++ l₂) v (l₁ ++ v :: l₂) + +theorem Extend1.base : Extend1 l v (v::l) := .mk (l₁ := []) +theorem Extend1.cons (H : Extend1 l v l') : Extend1 (a::l) v (a::l') := + let .mk := H; .mk (l₁ := _::_) + +theorem Extend1.mem (H : Extend1 p a p') : b ∈ p' ↔ b = a ∨ b ∈ p := by cases H; simp [or_left_comm] + +theorem Extend1.length (H : Extend1 p a p') : p'.length = p.length + 1 := by + cases H; simp [Nat.add_assoc] + +theorem Extend1.of_mem (h : a ∈ p') : ∃ p, Extend1 p a p' := by + obtain ⟨_, _, rfl, _⟩ := List.eq_append_cons_of_mem h; exact ⟨_, .mk⟩ + +theorem Extend1.orderedInsert (H : orderedInsert cmp v p = some p') : Extend1 p v p' := by + induction p generalizing p' with simp [Normalize.orderedInsert] at H + | nil => exact H ▸ .base + | cons _ _ ih => + split at H <;> [(cases H; exact .base); cases H; skip] + simp at H; obtain ⟨_, H, rfl⟩ := H; exact (ih H).cons + +inductive Extend? : List α → α → List α → Prop + | mk1 : Extend1 l v l' → Extend? l v l' + | mk0 : v ∈ l → Extend? l v l + +theorem Extend?.cons (H : Extend? l v l') : Extend? (a::l) v (a::l') := by + cases H with + | mk1 H => exact .mk1 H.cons + | mk0 H => exact .mk0 (.tail _ H) + +theorem Extend?.mem (H : Extend? p a p') : b ∈ p' ↔ b = a ∨ b ∈ p := by + cases H with + | mk1 H => exact H.mem + | mk0 H => simp; rintro rfl; exact H + +theorem Extend?.orderedInsert [BEq α] [LawfulBEq α] [Std.LawfulBEqCmp (α := α) cmp] : + Extend? p v ((orderedInsert cmp v p).getD p) := by + induction p with simp [Normalize.orderedInsert] + | nil => exact .mk1 .base + | cons _ _ ih => + split + · exact .mk1 .base + · simp_all; exact .mk0 (.head _) + · revert ih; cases Normalize.orderedInsert .. <;> exact .cons + section variable (ls : List Name) (ρ : List Nat) in def evalParam (x : Name) : Nat := @@ -230,19 +278,6 @@ theorem evalPath_mono (h : n ≤ m) : theorem evalPath_le : evalPath ls ρ path n ≤ m ↔ (allNZ ls ρ path → n ≤ m) := by simp [evalPath]; split <;> simp [*] -variable (ls : List Name) (ρ : List Nat) in -inductive EvalPaths : List Name → Nat → Prop - | nil : EvalPaths [] n - | insert : orderedInsert Name.cmp a path = some path' → - evalPath ls ρ path (evalParam ls ρ a) ≤ n → EvalPaths path n → EvalPaths path' n - -theorem EvalPaths.mono (h : n ≤ n') : EvalPaths ls ρ path n → EvalPaths ls ρ path n' - | .nil => .nil - | .insert h1 h2 h3 => .insert h1 (Nat.le_trans h2 h) (h3.mono h) - -theorem EvalPaths.max : EvalPaths ls ρ path n → EvalPaths ls ρ path (max' n m) := - .mono (Nat.le_max_left ..) - variable (ls : List Name) (ρ : List Nat) in def NormLevel.eval (l : NormLevel) : Nat := l.foldl (init := 0) fun n a b => max' n (evalPath ls ρ a (b.eval ls ρ)) @@ -266,8 +301,11 @@ theorem NormLevel.addNode_contains_self : (addNode v k path acc).contains path : simp [addNode]; split <;> simp theorem NormLevel.addConst_contains (H : acc.contains x) : (addConst k path acc).contains x := by - simp [addConst] at *; split <;> simp [H, Std.TreeMap.mem_alter] - split <;> simp [H] + simp [addConst] at *; split <;> simp [H, Std.TreeMap.mem_alter]; split <;> simp + +theorem NormLevel.addConst_contains_self (h : k ≠ 0) (h2 : ¬(k = 1 ∧ path ≠ [])) : + (addConst k path acc).contains path := by + simp [addConst, h, h2]; split <;> simp theorem normalizeAux_contains (H : acc.contains x) : (normalizeAux u path k acc).contains x := by unfold normalizeAux; split @@ -298,65 +336,155 @@ theorem imax_imax : Lean.Nat.imax a (Lean.Nat.imax b c) = simp [Lean.Nat.imax]; by_cases h : c = 0 <;> simp [*, Nat.max_eq_max] rw [Nat.max_left_comm c, Nat.max_self] -theorem mem_orderedInsert [BEq α] [LawfulBEq α] [Std.LawfulBEqCmp (α := α) cmp] : - b ∈ (orderedInsert cmp a ls).getD ls ↔ b = a ∨ b ∈ ls := by - induction ls <;> simp [orderedInsert]; split <;> simp_all [or_left_comm] - -theorem allNZ_orderedInsert : - allNZ ls ρ ((orderedInsert Name.cmp a path).getD path) = allNZ ls ρ (a :: path) := by - rw [Bool.eq_iff_iff]; simp [allNZ, mem_orderedInsert] - -theorem evalPath_orderedInsert : - evalPath ls ρ ((orderedInsert Name.cmp a path).getD path) = evalPath ls ρ (a :: path) := by - ext n; simp [evalPath, allNZ_orderedInsert] - -theorem EvalPaths.of_mem (hm : v ∈ path) (H : EvalPaths ls ρ path n) : - ∃ path₁ path₂, (∀ x ∈ path₁, x ∈ path) ∧ - orderedInsert Name.cmp v path₁ = some path₂ ∧ - evalPath ls ρ path₁ (evalParam ls ρ v) ≤ n ∧ - EvalPaths ls ρ path₁ n := by - induction H with | nil => cases hm | insert h1 h2 h3 ih - obtain rfl | hm := (h1 ▸ mem_orderedInsert).1 hm - · exact ⟨_, _, fun _ h => (h1 ▸ mem_orderedInsert).2 (.inr h), h1, h2, h3⟩ - · let ⟨_, _, a1, a2, a3, a4⟩ := ih hm - exact ⟨_, _, fun _ h => (h1 ▸ mem_orderedInsert).2 (.inr (a1 _ h)), a2, a3, a4⟩ +protected theorem Extend?.allNZ (H : Extend? p a p') : allNZ ls ρ p' = allNZ ls ρ (a :: p) := by + rw [Bool.eq_iff_iff]; simp [allNZ, H.mem] + +protected theorem Extend?.evalPath (H : Extend? p a p') : + evalPath ls ρ p' = evalPath ls ρ (a :: p) := by ext n; simp [evalPath, H.allNZ] theorem ext_le {n m : Nat} (H : ∀ x, n ≤ x ↔ m ≤ x) : n = m := Nat.le_antisymm ((H _).2 (Nat.le_refl _)) ((H _).1 (Nat.le_refl _)) theorem le_ext_le {n m : Nat} (H : ∀ x, n ≤ x → m ≤ x) : m ≤ n := H _ (Nat.le_refl _) -theorem NormLevel.addConst_eval (le : EvalPaths ls ρ path (acc.eval ls ρ)) : +/-- The well-formedness invariant of the `NormLevel` maps produced by `normalizeAux`: +every variable recorded at a key is an element of that key, and every nonempty key `p` +extends another key of the map by a single variable that is recorded at `p`. +The latter is what makes the sublevels expressible by `imax` chains (see the reconstruction +comment in `Lean4Lean.Level`), and it lets `addConst` drop `C(p, 1)` for `p ≠ []`. -/ +def NormLevel.WF (s : NormLevel) : Prop := + ∀ p n, s.get? p = some n → + (p ≠ [] → ∃ v p', Extend1 p' v p ∧ (p' = [] ∨ s.contains p') ∧ ∃ x ∈ n.var, x.var = v) ∧ + (∀ v ∈ n.var, v.var ∈ p) + +theorem NormLevel.WF.of_mem (hm : v ∈ path) (H : WF s) (hp : s.contains path) : + ∃ path₁ path₂ n, (∀ x ∈ path₁, x ∈ path) ∧ + Extend1 path₁ v path₂ ∧ (path₁ = [] ∨ s.contains path₁) ∧ s.get? path₂ = some n ∧ + ∃ x ∈ n.var, x.var = v := by + generalize eq : path.length = n + induction n generalizing path with | zero => simp at eq; subst path; cases hm | succ n ih + have ⟨_, hp'⟩ := Option.isSome_iff_exists.1 (Std.TreeMap.isSome_getElem?_eq_contains.trans hp) + have ⟨_, _, a1, a2, a3⟩ := (H _ _ hp').1 (by rintro rfl; cases hm) + obtain rfl | hm := a1.mem.1 hm + · exact ⟨_, _, _, fun _ h => a1.mem.2 (.inr h), a1, a2, hp', a3⟩ + · -- the parent is in the map, since `v` occurs in it and so it is not the root + have ⟨_, _, _, b1, b2⟩ := ih hm (a2.resolve_left (by rintro rfl; cases hm)) + (by cases a1; simp at eq ⊢; exact Nat.succ_inj.1 eq) + exact ⟨_, _, _, fun _ h => a1.mem.2 (.inr (b1 _ h)), b2⟩ + +theorem VarNode.mem_addVar : + (∃ x ∈ VarNode.addVar v k l, x.var = u) ↔ v = u ∨ (∃ x ∈ l, x.var = u) := by + induction l with simp [addVar] | cons x l ih; split <;> simp_all [or_left_comm] + +theorem NormLevel.addVar_wf (hv : v ∈ path) (wf : acc.WF) : + (addVar v k path acc).WF := by + simp [addVar, WF, Std.TreeMap.getElem?_modify, Std.TreeMap.mem_modify] at wf ⊢ + intro p n; split <;> [simp; apply wf] + subst p; rintro _ h rfl; have ⟨a1, a2⟩ := wf _ _ h; refine ⟨fun h => ?_, fun _ h => ?_⟩ + · have ⟨_, _, b1, b2, b3⟩ := a1 h; exact ⟨_, _, b1, b2, VarNode.mem_addVar.2 (.inr b3)⟩ + · obtain eq | ⟨_, h, eq⟩ := VarNode.mem_addVar.1 ⟨_, h, rfl⟩ + · exact eq ▸ hv + · exact eq ▸ a2 _ h + +theorem NormLevel.addNode_wf (H : Extend1 path v path') + (hacc : path = [] ∨ acc.contains path) (wf : acc.WF) : (addNode v k path' acc).WF := by + simp [addNode, WF, Std.TreeMap.getElem?_alter, Std.TreeMap.mem_alter] at * + intro p n; split + · subst p; split <;> rintro ⟨⟩ <;> simp + · exact ⟨fun _ => ⟨_, _, H, hacc.imp id fun h _ => h, rfl⟩, H.mem.2 (.inl rfl)⟩ + · obtain ⟨a1, a2⟩ := wf _ _ ‹_›; refine ⟨fun h => ?_, fun _ h => ?_⟩ + · have ⟨_, _, b1, b2, b3⟩ := a1 h + exact ⟨_, _, b1, b2.imp id fun h _ => h, VarNode.mem_addVar.2 (.inr b3)⟩ + · obtain eq | ⟨_, h, eq⟩ := VarNode.mem_addVar.1 ⟨_, h, rfl⟩ + · exact H.mem.2 (.inl eq.symm) + · exact eq ▸ a2 _ h + · intro h; have ⟨a1, a2⟩ := wf _ _ h; refine ⟨fun h => ?_, a2⟩ + have ⟨_, _, b1, b2, b3⟩ := a1 h; refine ⟨_, _, b1, ?_, b3⟩ + split <;> [split <;> simp; exact b2] + +/-- `WF` survives an update that only adds keys and preserves each node's variables, provided +any key it adds is the root, where the parent condition is vacuous. -/ +theorem NormLevel.WF.update {s s' : NormLevel} (wf : s.WF) + (hk : ∀ q, s.contains q → s'.contains q) + (hv : ∀ p n, s'.get? p = some n → + (∃ n₀, s.get? p = some n₀ ∧ n.var = n₀.var) ∨ (p = [] ∧ n.var = [])) : s'.WF := by + intro p n hn + rcases hv p n hn with ⟨n₀, h₀, hvar⟩ | ⟨rfl, hvar⟩ + · obtain ⟨a1, a2⟩ := wf _ _ h₀ + refine ⟨fun h => ?_, fun v hv => a2 v (hvar ▸ hv)⟩ + obtain ⟨v, p', b1, b2, b3⟩ := a1 h + exact ⟨v, p', b1, b2.imp id (hk _), hvar ▸ b3⟩ + · exact ⟨absurd rfl, by simp [hvar]⟩ + +theorem NormLevel.addConst_wf (hp : path = [] ∨ acc.contains path) (H : acc.WF) : + (addConst k path acc).WF := by + simp only [addConst]; split <;> [exact H; skip] + refine H.update (fun q hq => ?_) fun p n hn => ?_ + · rw [Std.TreeMap.contains_alter]; split <;> [split <;> simp; simp [hq]] + · rw [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_alter] at hn + split at hn <;> [rename_i hpe; exact .inl ⟨n, hn, rfl⟩] + cases eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 hpe) + -- `alter` creates a node only at the root, since otherwise `path` is already a key + match hpath : acc[path]?, hp with + | some n', _ => rw [hpath] at hn; cases hn; exact .inl ⟨n', hpath, rfl⟩ + | none, .inl hr => rw [hpath] at hn; cases hn; exact .inr ⟨hr, rfl⟩ + | none, .inr h => simp [Std.TreeMap.mem_iff_isSome_getElem?, hpath] at h + +theorem normalizeAux_wf (H : path = [] ∨ acc.contains path) (wf : acc.WF) : + (normalizeAux u path k acc).WF := by + unfold normalizeAux; split + · exact NormLevel.addConst_wf H wf + · exact NormLevel.addConst_wf H wf + · exact normalizeAux_wf H wf + · exact normalizeAux_wf (H.imp id normalizeAux_contains) (normalizeAux_wf H wf) + · exact normalizeAux_wf (H.imp id normalizeAux_contains) (normalizeAux_wf H wf) + · exact normalizeAux_wf (H.imp id normalizeAux_contains) (normalizeAux_wf H wf) + · exact normalizeAux_wf (H.imp id normalizeAux_contains) (normalizeAux_wf H wf) + · split <;> rename_i eq <;> [skip; (dsimp; split)] + · exact normalizeAux_wf (.inr NormLevel.addNode_contains_self) + (NormLevel.addNode_wf (.orderedInsert eq) + (H.imp id NormLevel.addConst_contains) (NormLevel.addConst_wf H wf)) + · exact normalizeAux_wf H wf + · refine normalizeAux_wf (H.imp id NormLevel.addVar_contains) (NormLevel.addVar_wf ?_ wf) + exact (eq ▸ Extend?.orderedInsert).mem.2 (.inl rfl) + · exact wf + · exact wf + · split <;> rename_i eq <;> [skip; split] + · exact NormLevel.addNode_wf (.orderedInsert eq) + (H.imp id NormLevel.addConst_contains) (NormLevel.addConst_wf H wf) + · exact wf + · exact NormLevel.addVar_wf ((eq ▸ Extend?.orderedInsert).mem.2 (.inl rfl)) wf + +theorem NormLevel.addConst_eval (H : path = [] ∨ acc.contains path) (wf : acc.WF) : (addConst k path acc).eval ls ρ = max' (acc.eval ls ρ) (evalPath ls ρ path k) := by simp [addConst]; split <;> rename_i h - · obtain rfl | ⟨rfl, _⟩ := h + · obtain rfl | ⟨rfl, hne⟩ := h · simp [evalPath] - · let a::path := path; let .insert h1 le h3 := le - have := h1 ▸ evalPath_orderedInsert (ls := ls) (ρ := ρ); simp at this - rw [this, Nat.max_eq_left]; simp [evalPath]; split <;> [rename_i h; simp] - let ⟨h1, h2⟩ := allNZ_cons.1 h; exact Nat.le_trans h1 (evalPath_le.1 le h2) + · -- `C(p, 1)` for `p ≠ []` is already dominated: `WF` puts a variable of `p` at `p`, + -- and along a nonzero path that variable is at least 1 + rw [Nat.max_eq_left]; refine evalPath_le.2 fun nz => le_ext_le fun n le => ?_ + have H := H.resolve_left hne + rw [← Std.TreeMap.isSome_getElem?_eq_contains, Option.isSome_iff_exists] at H + let ⟨v, H⟩ := H; have ⟨_, _, a1, a2, _, a3, rfl⟩ := (wf _ _ H).1 ‹_› + have := (Node.eval_le.1 (evalPath_le.1 (eval_le.1 le _ _ H) nz)).2 _ a3 + simp [allNZ] at nz + exact Nat.le_trans (nz _ (a1.mem.2 (.inl rfl))) (Nat.le_of_add_right_le this) · refine ext_le fun x => ?_ simp [eval_le, Nat.max_le, Std.TreeMap.getElem?_alter, evalPath_le, Node.eval_le] refine ⟨fun H => ⟨fun a b h nz => ?_, fun nz => ?_⟩, fun ⟨H1, H2⟩ a b h nz => ?_⟩ - · -- the bound at every key transfers back, since `alter` only raises the constant - have := H a; split at this + · have := H a; split at this · subst a; rw [h] at this obtain ⟨hc, hv⟩ := this _ rfl nz exact ⟨Nat.le_trans (Nat.le_max_right ..) hc, hv⟩ · exact this _ h nz - · -- and it bounds `k`, whether or not `path` was already present - have := H path; rw [if_pos rfl] at this; split at this <;> - refine Nat.le_trans ?_ ((this _ rfl nz).1) <;> - first - | exact Nat.le_refl _ - | exact Nat.le_max_left .. - · -- conversely the bound at `path` is the max of the old one and `k` - split at h - · subst a; split at h <;> cases h - · exact ⟨H2 nz, by simp⟩ - · rename_i n hn - obtain ⟨hc, hv⟩ := H1 _ _ hn nz - exact ⟨Nat.max_le.2 ⟨H2 nz, hc⟩, hv⟩ + · have := H path; rw [if_pos rfl] at this; split at this <;> + refine Nat.le_trans ?_ ((this _ rfl nz).1) + · exact Nat.le_refl _ + · exact Nat.le_max_left .. + · split at h + · subst a; split at h <;> cases h <;> [exact ⟨H2 nz, by simp⟩; rename_i n hn] + obtain ⟨hc, hv⟩ := H1 _ _ hn nz + exact ⟨Nat.max_le.2 ⟨H2 nz, hc⟩, hv⟩ · exact H1 _ _ h nz theorem VarNode.addVar_le : (∀ vn ∈ VarNode.addVar v k l, vn.eval ls ρ ≤ x) ↔ @@ -402,96 +530,461 @@ theorem NormLevel.addVar_eval (H : acc.contains path) : (addVar v k path acc).ev `addVar` is only reached in the second case, since it runs only when `path` already contains the variable being added. -/ theorem normalizeAux_eval (hu : VLevel.ofLevel ls u = some u') - (H : path = [] ∨ acc.contains path) (le : EvalPaths ls ρ path (acc.eval ls ρ)) : + (H : path = [] ∨ acc.contains path) (wf : acc.WF) : (normalizeAux u path k acc).eval ls ρ = max' (acc.eval ls ρ) (evalPath ls ρ path (u'.eval ρ + k)) := by unfold normalizeAux; split - · cases hu; simp [NormLevel.addConst_eval le, VLevel.eval] + · cases hu; simp [NormLevel.addConst_eval H wf, VLevel.eval] · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, rfl⟩ := hu - simp [VLevel.eval, Lean.Nat.imax, NormLevel.addConst_eval le] + simp [VLevel.eval, Lean.Nat.imax, NormLevel.addConst_eval H wf] · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, rfl⟩ := hu - rw [normalizeAux_eval hu H le, Nat.add_succ, ← Nat.succ_add]; rfl + rw [normalizeAux_eval hu H wf, Nat.add_succ, ← Nat.succ_add]; rfl · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, hv, rfl⟩ := hu - rw [normalizeAux_eval hv (H.imp id normalizeAux_contains)] <;> rw [normalizeAux_eval hu H le] - · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; rfl - · exact le.max + rw [normalizeAux_eval hv (H.imp id normalizeAux_contains) (normalizeAux_wf H wf), + normalizeAux_eval hu H wf, Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; rfl · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, rfl⟩, rfl⟩ := hu - rw [normalizeAux_eval hv (H.imp id normalizeAux_contains)] <;> rw [normalizeAux_eval hu H le] - · rw [Nat.max_assoc, Nat.add_succ, ← Nat.succ_add, ← evalPath_max, Nat.add_max_add_right]; rfl - · exact le.max + rw [normalizeAux_eval hv (H.imp id normalizeAux_contains) (normalizeAux_wf H wf), + normalizeAux_eval hu H wf, Nat.max_assoc, Nat.add_succ, ← Nat.succ_add, + ← evalPath_max, Nat.add_max_add_right]; rfl · rename_i u v w simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, _, hw, rfl⟩, rfl⟩ := hu - rw [normalizeAux_eval - (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) (H.imp id normalizeAux_contains)] <;> - rw [normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hv, rfl⟩) H le] - · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; simp [VLevel.eval, imax_max] - · exact le.max + rw [normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) + (H.imp id normalizeAux_contains) (normalizeAux_wf H wf), + normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hv, rfl⟩) H wf, + Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; simp [VLevel.eval, imax_max] · rename_i u v w simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, _, hw, rfl⟩, rfl⟩ := hu rw [normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hv, _, hw, rfl⟩) - (H.imp id normalizeAux_contains)] <;> - rw [normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) H le] - · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; simp [VLevel.eval, imax_imax] - · exact le.max + (H.imp id normalizeAux_contains) (normalizeAux_wf H wf), + normalizeAux_eval (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) H wf, + Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right]; simp [VLevel.eval, imax_imax] · rename_i u v simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨hv, rfl⟩, rfl⟩ := hu - have := @evalPath_orderedInsert ls ρ v path + have := Extend?.orderedInsert (cmp := Name.cmp) (p := path) (v := v) split <;> rename_i h <;> simp [h] at this - · rw [normalizeAux_eval hu (.inr NormLevel.addNode_contains_self)] <;> - rw [NormLevel.addNode_eval, NormLevel.addConst_eval le, Nat.max_assoc] - · rw [Nat.max_assoc, ← evalPath_max, this, evalPath_cons, ← evalPath_max, + · rw [normalizeAux_eval hu (.inr NormLevel.addNode_contains_self) + (NormLevel.addNode_wf (.orderedInsert h) + (H.imp id NormLevel.addConst_contains) (NormLevel.addConst_wf H wf)), + NormLevel.addNode_eval, NormLevel.addConst_eval H wf, Nat.max_assoc, + Nat.max_assoc, ← evalPath_max, this.evalPath, evalPath_cons, ← evalPath_max, Nat.add_max_add_right]; congr 2 - simp [VLevel.eval, ← evalParam_eq hv, Lean.Nat.imax] - cases evalParam .. <;> simp [Nat.max_eq_max, Nat.max_comm] - · refine .insert h (Nat.le_trans ?_ (Nat.le_max_right ..)) le.max - rw [this, evalPath_cons, ← evalPath_max]; apply evalPath_mono; grind + simp [VLevel.eval, ← evalParam_eq hv, Lean.Nat.imax] + cases evalParam .. <;> simp [Nat.max_eq_max, Nat.max_comm] · have hne : path ≠ [] := by rintro rfl; simp [orderedInsert] at h dsimp; split - · rw [normalizeAux_eval hu H le] + · rw [normalizeAux_eval hu H wf] simp [evalPath]; split <;> [rename_i nz; simp] - have hm := (h ▸ mem_orderedInsert).2 (.inl rfl) - have ⟨p1, p2, a1, a2, a3, a4⟩ := le.of_mem hm - have := evalPath_le.1 a3 (allNZ_mono a1 nz) + have hm := this.mem.2 (.inl rfl) + obtain ⟨p1, p2, w1, a1, a2, a3, a4, z, a5, rfl⟩ := wf.of_mem hm (H.resolve_left hne) + refine ext_le fun n => ?_; simp [Nat.max_le, NormLevel.eval_le]; intro he + have := Node.eval_le.1 (evalPath_le.1 (he _ _ a4) + (allNZ_mono (fun _ h => (a2.mem.1 h).elim (· ▸ hm) (a1 _)) nz)) |>.2 _ a5 simp [allNZ] at nz; specialize nz _ hm - simp [VLevel.eval, Lean.Nat.imax]; simp [← evalParam_eq hv] - revert this nz; cases evalParam .. <;> simp - rw [Nat.max_eq_max, Nat.max_comm (a := VLevel.eval ..), ← Nat.add_max_add_right, ← Nat.max_assoc] - intro h; rw [Nat.max_eq_left (b := _+1+k)]; omega - · rw [normalizeAux_eval hu (H.imp id NormLevel.addVar_contains)] <;> - rw [NormLevel.addVar_eval (H.resolve_left hne)] - · rw [Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right, this, - evalPath_cons, evalPath_cons]; congr 2; split <;> simp [VLevel.eval, Lean.Nat.imax] - rename_i h; revert h; simp [← evalParam_eq hv] - cases evalParam .. <;> simp [Nat.max_eq_max, Nat.max_comm] - · exact le.max + simp [VLevel.eval, Lean.Nat.imax]; simp [← evalParam_eq hv, VarNode.eval] at this ⊢ + revert this nz; cases evalParam .. <;> simp [Nat.max_eq_max]; omega + · rw [normalizeAux_eval hu (H.imp id NormLevel.addVar_contains) + (NormLevel.addVar_wf (this.mem.2 (.inl rfl)) wf), + NormLevel.addVar_eval (H.resolve_left hne), Nat.max_assoc, ← evalPath_max, Nat.add_max_add_right, + this.evalPath, evalPath_cons, evalPath_cons]; congr 2 + split <;> simp [VLevel.eval, Lean.Nat.imax] + rename_i h; revert h; simp [← evalParam_eq hv] + cases evalParam .. <;> simp [Nat.max_eq_max, Nat.max_comm] · cases hu · simp [VLevel.ofLevel] at hu · rename_i v; simp [VLevel.ofLevel] at hu; obtain ⟨hv, rfl⟩ := hu - have := @evalPath_orderedInsert ls ρ v path + have := Extend?.orderedInsert (cmp := Name.cmp) (p := path) (v := v) split <;> rename_i h <;> simp [h] at this - · rw [NormLevel.addNode_eval, NormLevel.addConst_eval le, Nat.max_assoc, - this, evalPath_cons, ← evalPath_max] + · rw [NormLevel.addNode_eval, NormLevel.addConst_eval H wf, Nat.max_assoc, + this.evalPath, evalPath_cons, ← evalPath_max] simp [VLevel.eval, ← evalParam_eq hv]; congr 2; split <;> simp; omega - · have hne : path ≠ [] := by rintro rfl; simp [orderedInsert] at h - split - · simp [evalPath]; split <;> [rename_i nz; simp] - have hm := (h ▸ mem_orderedInsert).2 (.inl rfl) - have ⟨p1, p2, a1, a2, a3, a4⟩ := le.of_mem hm - have := evalPath_le.1 a3 (allNZ_mono a1 nz) - simp [allNZ] at nz; specialize nz _ hm - simp [VLevel.eval, ← evalParam_eq hv] - revert this nz; cases evalParam .. <;> simp; omega - · rw [NormLevel.addVar_eval (H.resolve_left hne), this, evalPath_cons, evalPath_cons] - congr 2; split <;> simp [VLevel.eval, ← evalParam_eq hv] - -theorem NormLevel.subsumption_eval {s : NormLevel} : - s.subsumption.eval ls ρ = s.eval ls ρ := by - sorry + have hne : path ≠ [] := by rintro rfl; simp [orderedInsert] at h + split + · simp [evalPath]; split <;> [rename_i nz; simp] + have hm := this.mem.2 (.inl rfl) + obtain ⟨p1, p2, w1, a1, a2, a3, a4, z, a5, rfl⟩ := wf.of_mem hm (H.resolve_left hne) + refine ext_le fun n => ?_; simp [Nat.max_le, NormLevel.eval_le]; intro he + have := Node.eval_le.1 (evalPath_le.1 (he _ _ a4) + (allNZ_mono (fun _ h => (a2.mem.1 h).elim (· ▸ hm) (a1 _)) nz)) |>.2 _ a5 + simp [allNZ] at nz; specialize nz _ hm + simp [VLevel.eval]; simp [← evalParam_eq hv, VarNode.eval] at this ⊢ + revert this nz; cases evalParam .. <;> simp; omega + · rw [NormLevel.addVar_eval (H.resolve_left hne), this.evalPath, evalPath_cons, + evalPath_cons] + congr 2; split <;> simp [VLevel.eval, ← evalParam_eq hv] + +theorem subset_length (H : subset cmp l₁ l₂) : l₁.length ≤ l₂.length := by + induction l₂ generalizing l₁ with | nil => cases l₁ <;> simp_all [subset] | cons y l₂ ih + cases l₁ with | nil => simp | cons x l₁ + simp only [subset] at H; split at H + · cases H + · have := ih H; simp only [List.length_cons]; omega + · have := ih H; simp only [List.length_cons] at this ⊢; omega + +theorem subset_mem [BEq α] [LawfulBEq α] [Std.LawfulBEqCmp (α := α) cmp] + (H : subset cmp l₁ l₂) (h : a ∈ l₁) : a ∈ l₂ := by + induction l₂ generalizing l₁ with | nil => cases l₁ <;> simp_all [subset] | cons y l₂ ih + cases l₁ with| nil => cases h | cons x l₁ + simp only [subset] at H; split at H + · cases H + · rename_i h'; rw [Std.LawfulBEqCmp.compare_eq_iff_beq] at h' + cases eq_of_beq h' + rcases List.mem_cons.1 h with rfl | h + · exact .head _ + · exact .tail _ (ih H h) + · exact .tail _ (ih H h) + +theorem subset_eq [BEq α] [LawfulBEq α] [Std.LawfulBEqCmp (α := α) cmp] + (H : subset cmp l₁ l₂) (hl : l₁.length = l₂.length) : l₁ = l₂ := by + induction l₂ generalizing l₁ with | nil => cases l₁ <;> simp_all [subset] | cons y l₂ ih + cases l₁ with | nil => cases hl | cons x l₁ + simp only [subset] at H; simp only [List.length_cons] at hl + split at H + · cases H + · rename_i h'; rw [Std.LawfulBEqCmp.compare_eq_iff_beq] at h' + cases eq_of_beq h'; rw [ih H (by omega)] + · exact absurd (subset_length H) (by simp only [List.length_cons]; omega) + +theorem subsumeVars_subset (h : x ∈ subsumeVars vs₁ vs₂) : x ∈ vs₁ := by + induction vs₁ generalizing vs₂ with | nil => simp_all [subsumeVars] | cons a vs₁ ih + induction vs₂ with | nil => simp_all [subsumeVars] | cons b vs₂ ih₂ + simp only [subsumeVars] at h; split at h + · obtain rfl | h := List.mem_cons.1 h + · exact .head _ + · exact .tail _ (ih h) + · split at h <;> [exact .tail _ (ih h); skip] + obtain rfl | h := List.mem_cons.1 h + · exact .head _ + · exact .tail _ (ih h) + · exact ih₂ h + +theorem subsumeVars_dominated (h₁ : x ∈ vs₁) (h₂ : x ∉ subsumeVars vs₁ vs₂) : + ∃ y ∈ vs₂, y.var = x.var ∧ x.offset ≤ y.offset := by + induction vs₁ generalizing vs₂ with | nil => cases h₁ | cons a vs₁ ih + induction vs₂ with | nil => exact absurd h₁ (by simpa [subsumeVars] using h₂) | cons b vs₂ ih₂ + simp only [subsumeVars] at h₂; split at h₂ + · obtain rfl | h₁ := List.mem_cons.1 h₁ + · cases h₂ (.head _) + · have ⟨y, hy, e, le⟩ := ih h₁ fun h => h₂ (.tail _ h) + exact ⟨y, hy, e, le⟩ + · rename_i heq; split at h₂ + · obtain rfl | h₁ := List.mem_cons.1 h₁ + · rw [Std.LawfulBEqCmp.compare_eq_iff_beq] at heq + exact ⟨b, .head _, (eq_of_beq heq).symm, ‹_›⟩ + · have ⟨y, hy, e, le⟩ := ih h₁ h₂ + exact ⟨y, .tail _ hy, e, le⟩ + · obtain rfl | h₁ := List.mem_cons.1 h₁ + · cases h₂ (.head _) + · have ⟨y, hy, e, le⟩ := ih h₁ fun h => h₂ (.tail _ h) + exact ⟨y, .tail _ hy, e, le⟩ + · have ⟨y, hy, e, le⟩ := ih₂ h₂ + exact ⟨y, .tail _ hy, e, le⟩ + +theorem le_foldl_max {vs : List VarNode} + (h : c ≤ vs.foldl (·.max ·.offset) n + 1) : c ≤ n + 1 ∨ ∃ y ∈ vs, c ≤ y.offset + 1 := by + induction vs generalizing n with | nil => exact .inl h | cons x vs ih + obtain h | ⟨y, hy, h⟩ := ih h + · refine (Nat.le_total x.offset n).imp (fun h' => ?_) (fun h' => ⟨x, .head _, ?_⟩) + · simp [Nat.max_eq_left h'] at h; omega + · simp [Nat.max_eq_right h'] at h; omega + · exact .inr ⟨y, .tail _ hy, h⟩ + +theorem Node.const_le_eval {l : Node} : l.const ≤ Node.eval ls ρ l := + (Node.eval_le.1 (Nat.le_refl _)).1 + +theorem Node.var_le_eval {l : Node} (h : x ∈ l.var) : + VarNode.eval ls ρ x ≤ Node.eval ls ρ l := + (Node.eval_le.1 (Nat.le_refl _)).2 _ h + +theorem Node.eval_empty {l : Node} (H : l.isEmpty) : Node.eval ls ρ l = 0 := by + simp [Node.isEmpty] at H; simp [eval, H.1, H.2] + +theorem NormLevel.eval_filter {m : NormLevel} : + NormLevel.eval ls ρ (m.filter fun _ n => !n.isEmpty) = m.eval ls ρ := by + refine ext_le fun x => ?_ + simp only [eval_le, Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_filter] + refine ⟨fun H a b h => ?_, fun H a b h => ?_⟩ + · by_cases he : b.isEmpty + · simp [evalPath_le, Node.eval_empty he] + · exact H a b (by simp [h, he]) + · exact H _ _ (Option.eq_some_of_pfilter_eq_some h) + +theorem subsumeVars_eval (H : ∀ v ∈ vs₂, VarNode.eval ls ρ v ≤ n) : + (∀ v ∈ subsumeVars vs₁ vs₂, VarNode.eval ls ρ v ≤ n) ↔ + ∀ v ∈ vs₁, VarNode.eval ls ρ v ≤ n := by + refine ⟨fun h v hv => ?_, fun h v hv => h _ (subsumeVars_subset hv)⟩ + by_cases hs : v ∈ subsumeVars vs₁ vs₂ <;> [exact h _ hs; skip] + have ⟨y, hy, e, le⟩ := subsumeVars_dominated hv hs + exact Nat.le_trans (by simp [VarNode.eval, e]; omega) (H _ hy) + +theorem Node.subsumeBy_const_eq {same : Bool} {n₁ n₂ : Node} : + (n₁.subsumeBy same n₂).const = + if n₁.const = 0 || + (same || n₁.const > n₂.const) && + (n₂.var.isEmpty || n₁.const > n₂.var.foldl (·.max ·.offset) 0 + 1) + then n₁.const else 0 := by + simp only [Node.subsumeBy]; split <;> split <;> rfl + +theorem Node.subsumeBy_var_eq {same : Bool} {n₁ n₂ : Node} : + (n₁.subsumeBy same n₂).var = + if same || n₂.var.isEmpty then n₁.var else subsumeVars n₁.var n₂.var := by + simp only [Node.subsumeBy]; split <;> split <;> simp + +theorem Node.subsume_const_eq : (Node.subsume p₁ n₁ p₂ n₂).const = + if !subset compare p₂ p₁ || + (n₁.const = 0 || + (p₁.length == p₂.length || n₁.const > n₂.const) && + (n₂.var.isEmpty || n₁.const > n₂.var.foldl (·.max ·.offset) 0 + 1)) + then n₁.const else 0 := by + simp only [Node.subsume] + cases hs : subset compare p₂ p₁ <;> + simp only [reduceIte, Bool.not_true, Bool.not_false, Bool.false_or, Bool.true_or] + · rfl + · exact subsumeBy_const_eq + +theorem Node.subsume_var_eq : (Node.subsume p₁ n₁ p₂ n₂).var = + if !subset compare p₂ p₁ || (p₁.length == p₂.length || n₂.var.isEmpty) + then n₁.var else subsumeVars n₁.var n₂.var := by + simp only [Node.subsume] + cases hs : subset compare p₂ p₁ <;> + simp only [reduceIte, Bool.not_true, Bool.not_false, Bool.false_or, Bool.true_or] + · rfl + · exact subsumeBy_var_eq + +theorem Node.subsume_var_subset (h : x ∈ (Node.subsume p₁ n₁ p₂ n₂).var) : x ∈ n₁.var := by + rw [Node.subsume_var_eq] at h; split at h <;> [exact h; exact subsumeVars_subset h] + +theorem Node.subsume_const_cases (p₁ n₁ p₂ n₂) : + (Node.subsume p₁ n₁ p₂ n₂).const = n₁.const ∨ (Node.subsume p₁ n₁ p₂ n₂).const = 0 := by + rw [Node.subsume_const_eq]; split <;> [exact .inl rfl; exact .inr rfl] + +theorem Node.subsume_eval_le : + Node.eval ls ρ (Node.subsume p₁ n₁ p₂ n₂) ≤ Node.eval ls ρ n₁ := by + refine Node.eval_le.2 ⟨?_, fun v h => Node.var_le_eval (Node.subsume_var_subset h)⟩ + obtain h | h := Node.subsume_const_cases p₁ n₁ p₂ n₂ + · exact h ▸ Node.const_le_eval + · simp [h] + +/-- If `subsume` dropped the constant, the drop was justified: the constant is dominated +by the constant of `n₂` at a strictly smaller key, or by a variable of `n₂`. -/ +theorem Node.subsume_const_drop (h : (Node.subsume p₁ n₁ p₂ n₂).const ≠ n₁.const) : + subset compare p₂ p₁ ∧ + (p₁.length ≠ p₂.length ∧ n₁.const ≤ n₂.const ∨ ∃ y ∈ n₂.var, n₁.const ≤ y.offset + 1) := by + rw [Node.subsume_const_eq] at h + split at h <;> [cases h rfl; rename_i hc] + rw [Bool.or_eq_true, Bool.or_eq_true, not_or, not_or] at hc + obtain ⟨hs, hc0, hc⟩ := hc + have hsub : subset compare p₂ p₁ := by revert hs; cases subset compare p₂ p₁ <;> simp + refine ⟨hsub, ?_⟩ + rw [Bool.and_eq_true, Decidable.not_and_iff_not_or_not] at hc + obtain hc | hc := hc <;> rw [Bool.or_eq_true, not_or] at hc <;> obtain ⟨h1, h2⟩ := hc + · refine .inl ⟨fun e => h1 (by simp [e]), by simpa [Nat.not_lt] using h2⟩ + · have hne : n₂.var ≠ [] := fun e => h1 (by simp [e]) + have h2 : n₁.const ≤ n₂.var.foldl (·.max ·.offset) 0 + 1 := by + simpa [Nat.not_lt] using h2 + obtain h | h := le_foldl_max (c := n₁.const) (n := 0) h2 + · obtain ⟨y, hy⟩ := List.exists_mem_of_ne_nil _ hne + exact .inr ⟨y, hy, by omega⟩ + · exact .inr h + +/-- If `subsume` changed the variable list, the change was `subsumeVars` against the +variables of `n₂` at a strictly smaller key. -/ +theorem Node.subsume_var_cases (p₁ n₁ p₂ n₂) : + (Node.subsume p₁ n₁ p₂ n₂).var = n₁.var ∨ + (subset compare p₂ p₁ ∧ p₁.length ≠ p₂.length ∧ + (Node.subsume p₁ n₁ p₂ n₂).var = subsumeVars n₁.var n₂.var) := by + rw [Node.subsume_var_eq]; split + · exact .inl rfl + · rename_i hc + rw [Bool.or_eq_true, Bool.or_eq_true, not_or, not_or] at hc + obtain ⟨hs, hlen, -⟩ := hc + have hsub : subset compare p₂ p₁ := by revert hs; cases subset compare p₂ p₁ <;> simp + exact .inr ⟨hsub, fun e => hlen (by simp [e]), rfl⟩ + +theorem NormLevel.minimize_var_subset {acc : NormLevel} + (h : x ∈ (acc.minimize p₁ n₁).var) : x ∈ n₁.var := by + rw [minimize, Std.TreeMap.foldl_eq_foldl_toList] at h + generalize acc.toList = l at h + induction l generalizing n₁ with | nil => exact h | cons a l ih + exact Node.subsume_var_subset (ih h) + +theorem NormLevel.minimize_eval_le {acc : NormLevel} : + Node.eval ls ρ (acc.minimize p₁ n₁) ≤ n₁.eval ls ρ := by + rw [minimize, Std.TreeMap.foldl_eq_foldl_toList] + generalize acc.toList = l + induction l generalizing n₁ with | nil => exact Nat.le_refl _ | cons a l ih + exact Nat.le_trans (ih (n₁ := Node.subsume p₁ n₁ a.1 a.2)) Node.subsume_eval_le + +/-- Minimizing a node against the rest of the map preserves its contribution to the total, +assuming every other entry's contribution is already bounded by `m`. -/ +theorem NormLevel.minimize_eval_iff {acc : NormLevel} {p₁ : List Name} {n₁ : Node} {m : Nat} + (wfa : ∀ p n, acc.get? p = some n → ∀ v ∈ n.var, v.var ∈ p) + (h₁ : acc.get? p₁ = some n₁) + (hacc : ∀ p n, p ≠ p₁ → acc.get? p = some n → evalPath ls ρ p (Node.eval ls ρ n) ≤ m) + (nz : allNZ ls ρ p₁) : + Node.eval ls ρ (acc.minimize p₁ n₁) ≤ m ↔ Node.eval ls ρ n₁ ≤ m := by + have wf₁ := wfa _ _ h₁ + have evalq p₂ n₂ (hne : p₂ ≠ p₁) (h₂ : acc.get? p₂ = some n₂) (hsub : subset compare p₂ p₁) : + Node.eval ls ρ n₂ ≤ m := by + have := hacc _ _ hne h₂ + rw [evalPath_le] at this + exact this (allNZ_mono (fun _ h => subset_mem hsub h) nz) + -- a variable dominated at a different key of the map is bounded by `m` + have domle (x : VarNode) : (∃ p₂ n₂ y, p₂ ≠ p₁ ∧ acc.get? p₂ = some n₂ ∧ + subset compare p₂ p₁ ∧ y ∈ n₂.var ∧ y.var = x.var ∧ x.offset ≤ y.offset) → + VarNode.eval ls ρ x ≤ m := fun ⟨p₂, n₂, y, hne, h₂, hsub, hy, e, le⟩ => by + refine Nat.le_trans ?_ (Nat.le_trans (Node.var_le_eval hy) (evalq _ _ hne h₂ hsub)) + simp only [VarNode.eval, ← e]; omega + refine ⟨fun hf => ?_, fun h => Nat.le_trans minimize_eval_le h⟩ + rw [minimize, Std.TreeMap.foldl_eq_foldl_toList] at hf + have hmem pn (h : pn ∈ acc.toList) : acc.get? pn.1 = some pn.2 := + Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h + generalize acc.toList = l at hf hmem + -- fold invariant: vars of the current node come from `n₁`; the constant is intact or + -- justifiably dropped; every original variable is dominated by a current one or elsewhere + suffices ∀ n1, (∀ x ∈ n1.var, x ∈ n₁.var) → + (n1.const = n₁.const ∨ (n1.const = 0 ∧ + ((∃ y ∈ n₁.var, n₁.const ≤ y.offset + 1) ∨ + ∃ p₂ n₂, p₂ ≠ p₁ ∧ acc.get? p₂ = some n₂ ∧ subset compare p₂ p₁ ∧ + n₁.const ≤ Node.eval ls ρ n₂))) → + (∀ x ∈ n₁.var, (∃ y ∈ n1.var, y.var = x.var ∧ x.offset ≤ y.offset) ∨ + ∃ p₂ n₂ y, p₂ ≠ p₁ ∧ acc.get? p₂ = some n₂ ∧ subset compare p₂ p₁ ∧ + y ∈ n₂.var ∧ y.var = x.var ∧ x.offset ≤ y.offset) → + Node.eval ls ρ (List.foldl (fun n1 pn => Node.subsume p₁ n1 pn.1 pn.2) n1 l) ≤ m → + Node.eval ls ρ n₁ ≤ m from + this n₁ (fun _ => id) (.inl rfl) (fun x h => .inl ⟨x, h, rfl, Nat.le_refl _⟩) hf + clear hf + induction l with intro n1 hL hK hJ hf + | nil => + refine Node.eval_le.2 ⟨?_, fun x hx => ?_⟩ + · obtain hK | ⟨-, hK | ⟨p₂, n₂, hne, h₂, hsub, hc⟩⟩ := hK + · exact Nat.le_trans (hK ▸ Node.const_le_eval) hf + · obtain ⟨y, hy, hc⟩ := hK + obtain ⟨y', hy', e, le⟩ | hd := hJ _ hy + · refine Nat.le_trans ?_ (Nat.le_trans (Node.var_le_eval hy') hf) + have : 0 < evalParam ls ρ y'.var := by + simp [allNZ] at nz; exact nz _ (wf₁ _ (hL _ hy')) + simp only [VarNode.eval]; omega + · refine Nat.le_trans ?_ (domle _ hd) + obtain ⟨p₂, n₂, y', hne, h₂, hsub, hy', e, le⟩ := hd + have : 0 < evalParam ls ρ y'.var := by + simp [allNZ] at nz; exact nz _ (subset_mem hsub (wfa _ _ h₂ _ hy')) + simp only [VarNode.eval, ← e]; omega + · exact Nat.le_trans hc (evalq _ _ hne h₂ hsub) + · obtain ⟨y, hy, e, le⟩ | hd := hJ _ hx + · refine Nat.le_trans ?_ (Nat.le_trans (Node.var_le_eval hy) hf) + simp only [VarNode.eval, ← e]; omega + · exact domle _ hd + | cons pn l ih => + simp only [List.mem_cons, forall_eq_or_imp] at hmem + obtain ⟨h₂, hmem'⟩ := hmem + refine ih hmem' _ (fun x h => hL _ (Node.subsume_var_subset h)) ?_ (fun x hx => ?_) hf + · by_cases hc : (Node.subsume p₁ n1 pn.1 pn.2).const = n1.const + · rw [hc]; exact hK + obtain ⟨hsub, hd⟩ := Node.subsume_const_drop hc + obtain heq | hzero := Node.subsume_const_cases p₁ n1 pn.1 pn.2 + · cases hc heq + have hc1 : n1.const = n₁.const := by + rcases hK with h | ⟨h, -⟩ + · exact h + · cases hc (hzero.trans h.symm) + refine .inr ⟨hzero, ?_⟩ + by_cases hpe : pn.1 = p₁ + · subst hpe + have : pn.2 = n₁ := by cases h₁.symm.trans h₂; rfl + subst this + obtain ⟨hne', -⟩ | ⟨y, hy, hle⟩ := hd + · exact absurd rfl hne' + · exact .inl ⟨y, hy, hc1 ▸ hle⟩ + · refine .inr ⟨pn.1, pn.2, hpe, h₂, hsub, ?_⟩ + obtain ⟨-, hle⟩ | ⟨y, hy, hle⟩ := hd + · exact hc1 ▸ Nat.le_trans hle Node.const_le_eval + · refine hc1 ▸ Nat.le_trans hle ?_ + have : 0 < evalParam ls ρ y.var := by + simp [allNZ] at nz + exact nz _ (subset_mem hsub (wfa _ _ h₂ _ hy)) + refine Nat.le_trans ?_ (Node.var_le_eval hy) + simp only [VarNode.eval]; omega + · obtain ⟨y, hy, e, le⟩ | hd := hJ _ hx <;> [skip; exact .inr hd] + obtain hv | ⟨hsub, hlen, hv⟩ := Node.subsume_var_cases p₁ n1 pn.1 pn.2 + · exact .inl ⟨y, hv ▸ hy, e, le⟩ + by_cases hy' : y ∈ (Node.subsume p₁ n1 pn.1 pn.2).var + · exact .inl ⟨y, hy', e, le⟩ + obtain ⟨z, hz, ez, lez⟩ := subsumeVars_dominated hy (hv ▸ hy') + have hpe : pn.1 ≠ p₁ := fun h => hlen (h ▸ rfl) + exact .inr ⟨pn.1, pn.2, z, hpe, h₂, hsub, hz, ez.trans e, Nat.le_trans le lez⟩ + +theorem NormLevel.subsumption_eval {s : NormLevel} (wf : s.WF) : + (s.subsumption).eval ls ρ = s.eval ls ρ := by + rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList] + have hmem pn (h : pn ∈ s.toList) : s.get? pn.1 = some pn.2 := + Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h + have nd : (s.toList.map Prod.fst).Nodup := by simpa using Std.TreeMap.nodup_keys (t := s) + generalize s.toList = l at hmem nd + suffices ∀ (l : List (List Name × Node)) (acc : NormLevel), + (l.map Prod.fst).Nodup → + (∀ p n, (p, n) ∈ l → acc.get? p = some n) → + (∀ p n, acc.get? p = some n → ∀ v ∈ n.var, v.var ∈ p) → + eval ls ρ acc = eval ls ρ s → + eval ls ρ (List.foldl (fun acc pn => + let n := acc.minimize pn.1 pn.2 + if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l) = eval ls ρ s from + this _ _ nd (fun _ _ => hmem _) (fun _ _ h => (wf _ _ h).2) rfl + clear hmem nd; intro l + induction l with | nil => exact fun acc _ _ _ eq => eq | cons pn l ih + have ⟨p₁, n₁⟩ := pn; intro acc nd hl wfa eq + simp only [List.map_cons, List.nodup_cons] at nd + have h₁ := hl _ _ (.head _) + -- a drained key is erased rather than kept, which is the same for `eval` + have hins p : + (if (acc.minimize p₁ n₁).isEmpty then acc.erase p₁ + else acc.insert p₁ (acc.minimize p₁ n₁)).get? p = + if p₁ = p then if (acc.minimize p₁ n₁).isEmpty then none else some (acc.minimize p₁ n₁) + else acc.get? p := by + split <;> + simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_erase, + Std.TreeMap.getElem?_insert] <;> + split <;> split <;> simp_all + have hmin_le m + (H : ∀ a b, (if (acc.minimize p₁ n₁).isEmpty then acc.erase p₁ + else acc.insert p₁ (acc.minimize p₁ n₁)).get? a = some b → + evalPath ls ρ a (Node.eval ls ρ b) ≤ m) + (nz : allNZ ls ρ p₁) : Node.eval ls ρ (acc.minimize p₁ n₁) ≤ m := by + by_cases he : (acc.minimize p₁ n₁).isEmpty + · simp [Node.isEmpty, List.isEmpty_iff] at he; simp [Node.eval, he.1, he.2] + · have hget : (if (acc.minimize p₁ n₁).isEmpty then acc.erase p₁ + else acc.insert p₁ (acc.minimize p₁ n₁)).get? p₁ = some (acc.minimize p₁ n₁) := by + rw [hins p₁, if_pos rfl, if_neg he] + have := H _ _ hget + rw [evalPath_le] at this; exact this nz + refine ih _ nd.2 (fun p n h => ?_) (fun p n h v hv => ?_) ((ext_le fun m => ?_).trans eq) + · have hne : p₁ ≠ p := fun e => nd.1 (by rw [e]; exact List.mem_map_of_mem h) + exact (hins p).trans (if_neg hne) ▸ hl _ _ (.tail _ h) + · rw [hins p] at h; split at h + · split at h <;> [cases h; skip] + cases h; rename_i hp _; subst hp + exact wfa _ _ h₁ _ (minimize_var_subset hv) + · exact wfa _ _ h _ hv + · simp only [eval_le]; constructor <;> intro H p n h + · by_cases hp : p = p₁ + · subst hp; cases h₁.symm.trans h + refine evalPath_le.2 fun nz => ?_ + refine (minimize_eval_iff wfa h₁ (fun q nq hne hq => ?_) nz).1 (hmin_le _ H nz) + exact H _ _ ((hins q).trans (if_neg hne.symm) ▸ hq) + · exact H p n ((hins p).trans (if_neg (Ne.symm hp)) ▸ h) + · rw [hins p] at h; split at h <;> [skip; exact H _ _ h] + split at h <;> [cases h; skip] + cases h; rename_i hp _; subst hp + refine evalPath_le.2 fun nz => ?_ + have := H _ _ h₁; rw [evalPath_le] at this + exact Nat.le_trans minimize_eval_le (this nz) theorem normalize_eval (hu : VLevel.ofLevel ls u = some u') : (normalize u).eval ls ρ = u'.eval ρ := by - simp [normalize, NormLevel.subsumption_eval] - exact normalizeAux_eval hu (.inl rfl) .nil + simp [normalize] + refine have h1 := ?_; by + rw [NormLevel.subsumption_eval (normalizeAux_wf (by simp) h1)] + exact normalizeAux_eval hu (by simp) h1 + simp [NormLevel.WF] theorem Node.eval_congr {a b : Node} (H : a == b) : a.eval ls ρ = b.eval ls ρ := by simp +instances [instBEqNode] at H; simp [H, eval] @@ -519,6 +1012,15 @@ theorem NormLevel.eval_congr {a b : NormLevel} (H : a == b) : a.eval ls ρ = b.e end Normalize +theorem isEquiv'_wf (h : isEquiv' u v) + (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') : u' ≈ v' := by + simp only [isEquiv', Bool.or_eq_true, beq_iff_eq] at h + obtain rfl | h := h + · cases hu.symm.trans hv; rfl + · refine VLevel.equiv_def.2 fun ρ => ?_ + rw [← Normalize.normalize_eval (ρ := ρ) hu, ← Normalize.normalize_eval (ρ := ρ) hv] + exact Normalize.NormLevel.eval_congr h + theorem isEquivList_wf (H : Level.isEquivList us vs) : List.mapM (VLevel.ofLevel Us) us = some us' → List.mapM (VLevel.ofLevel Us) vs = some vs' → us'.Forall₂ (· ≈ ·) vs' := by From 2e04d2f5b6800c7743902664caf02e7846501b52 Mon Sep 17 00:00:00 2001 From: Mario Carneiro Date: Tue, 11 Aug 2026 03:56:19 +0200 Subject: [PATCH 33/51] verify: prove soundness of geq' geq'_wf: if geq' u v reports true then v' <= u' in every valuation, so the constructor universe check in Inductive/Add.lean only accepts levels that really are below the declared one. Completeness is not proved (and is only fuzz-tested); it is not needed for soundness of the checker. The work is in NormLevel.le_eval, which is Theorem 39 of the paper read in the direction the algorithm computes it. For each entry of l1 the algorithm folds over l2 carrying the sublevels that are still outstanding, and reports domination when the fold bails out with none. The proof runs that fold backwards: the bail-out point has an empty node, whose eval is 0, and each step is undone by subsumeBy_eval_iff, which says that discharging against n2 preserves a bound m as long as n2 itself evaluates to at most m. That hypothesis holds because the fold only discharges against keys that are subsets of the key being checked, so on a valuation making the checked key live those entries are live too and bounded by the total of l2. Domination of a constant by a variable (C(E,L) <= V(F,x,K) needs only L <= K+1) is where the condition set has to be all-nonzero: x is an element of F by the WF invariant, so it evaluates to at least 1 there. Since geq' compares normal forms, that half of WF has to survive subsumption; subsumption_vars proves it does, minimization only shrinking variable lists at unchanged keys. The domination step lemmas are stated for subsumeBy rather than subsume, so subsume_const_drop, subsume_eval_le and friends now derive from them instead of repeating the case analysis. Co-Authored-By: Claude Fable 5 --- Lean4Lean/Verify/Level.lean | 184 ++++++++++++++++++++++++++++++------ 1 file changed, 153 insertions(+), 31 deletions(-) diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index 0c62773e..0113c23d 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -729,6 +729,64 @@ theorem Node.subsumeBy_var_eq {same : Bool} {n₁ n₂ : Node} : if same || n₂.var.isEmpty then n₁.var else subsumeVars n₁.var n₂.var := by simp only [Node.subsumeBy]; split <;> split <;> simp +theorem Node.subsumeBy_var_subset {same : Bool} + (h : x ∈ (Node.subsumeBy same n₁ n₂).var) : x ∈ n₁.var := by + rw [Node.subsumeBy_var_eq] at h; split at h <;> [exact h; exact subsumeVars_subset h] + +theorem Node.subsumeBy_const_cases {same : Bool} (n₁ n₂ : Node) : + (n₁.subsumeBy same n₂).const = n₁.const ∨ (n₁.subsumeBy same n₂).const = 0 := by + rw [Node.subsumeBy_const_eq]; split <;> [exact .inl rfl; exact .inr rfl] + +theorem Node.subsumeBy_eval_le {same : Bool} : + Node.eval ls ρ (n₁.subsumeBy same n₂) ≤ Node.eval ls ρ n₁ := by + refine Node.eval_le.2 ⟨?_, fun v h => Node.var_le_eval (Node.subsumeBy_var_subset h)⟩ + obtain h | h := Node.subsumeBy_const_cases (same := same) n₁ n₂ + · exact h ▸ Node.const_le_eval + · simp [h] + +/-- If `subsumeBy` dropped the constant, the drop was justified: the constant is dominated +by the constant of `n₂` (only possible when the two keys differ), or by a variable of `n₂`. -/ +theorem Node.subsumeBy_const_drop {same : Bool} + (h : (Node.subsumeBy same n₁ n₂).const ≠ n₁.const) : + same = false ∧ n₁.const ≤ n₂.const ∨ ∃ y ∈ n₂.var, n₁.const ≤ y.offset + 1 := by + rw [Node.subsumeBy_const_eq] at h + split at h <;> [cases h rfl; rename_i hc] + rw [Bool.or_eq_true, not_or] at hc + obtain ⟨-, hc⟩ := hc + rw [Bool.and_eq_true, Decidable.not_and_iff_not_or_not] at hc + obtain hc | hc := hc <;> rw [Bool.or_eq_true, not_or] at hc <;> obtain ⟨h1, h2⟩ := hc + · exact .inl ⟨by simpa using h1, by simpa [Nat.not_lt] using h2⟩ + · have hne : n₂.var ≠ [] := fun e => h1 (by simp [e]) + have h2 : n₁.const ≤ n₂.var.foldl (·.max ·.offset) 0 + 1 := by + simpa [Nat.not_lt] using h2 + obtain h | h := le_foldl_max (c := n₁.const) (n := 0) h2 + · obtain ⟨y, hy⟩ := List.exists_mem_of_ne_nil _ hne + exact .inr ⟨y, hy, by omega⟩ + · exact .inr h + +/-- The domination step is exact against a node bounded by `m`: everything `subsumeBy` +drops from `n₁` is dominated by a sublevel of `n₂`, and `n₂` evaluates to at most `m`. +Domination of the constant by a variable needs that variable to evaluate to at least its +offset plus one, which is why the condition set must be all-nonzero (`hnz`). -/ +theorem Node.subsumeBy_eval_iff {same : Bool} {n₁ n₂ : Node} {m : Nat} + (hnz : ∀ v ∈ n₂.var, 0 < evalParam ls ρ v.var) (h₂ : Node.eval ls ρ n₂ ≤ m) : + Node.eval ls ρ (n₁.subsumeBy same n₂) ≤ m ↔ Node.eval ls ρ n₁ ≤ m := by + have hvar₂ v (hv : v ∈ n₂.var) : VarNode.eval ls ρ v ≤ m := + Nat.le_trans (Node.var_le_eval hv) h₂ + refine ⟨fun h => ?_, fun h => Nat.le_trans Node.subsumeBy_eval_le h⟩ + rw [Node.eval_le] at h ⊢ + refine ⟨?_, fun x hx => ?_⟩ + · by_cases hc : (n₁.subsumeBy same n₂).const = n₁.const + · exact hc ▸ h.1 + obtain ⟨-, hle⟩ | ⟨y, hy, hle⟩ := Node.subsumeBy_const_drop hc + · exact Nat.le_trans hle (Nat.le_trans Node.const_le_eval h₂) + · refine Nat.le_trans ?_ (hvar₂ _ hy) + have := hnz _ hy; simp only [VarNode.eval]; omega + · rw [Node.subsumeBy_var_eq] at h + split at h + · exact h.2 _ hx + · exact (subsumeVars_eval hvar₂).1 h.2 _ hx + theorem Node.subsume_const_eq : (Node.subsume p₁ n₁ p₂ n₂).const = if !subset compare p₂ p₁ || (n₁.const = 0 || @@ -751,40 +809,25 @@ theorem Node.subsume_var_eq : (Node.subsume p₁ n₁ p₂ n₂).var = · exact subsumeBy_var_eq theorem Node.subsume_var_subset (h : x ∈ (Node.subsume p₁ n₁ p₂ n₂).var) : x ∈ n₁.var := by - rw [Node.subsume_var_eq] at h; split at h <;> [exact h; exact subsumeVars_subset h] + rw [Node.subsume] at h; split at h <;> [exact subsumeBy_var_subset h; exact h] theorem Node.subsume_const_cases (p₁ n₁ p₂ n₂) : (Node.subsume p₁ n₁ p₂ n₂).const = n₁.const ∨ (Node.subsume p₁ n₁ p₂ n₂).const = 0 := by - rw [Node.subsume_const_eq]; split <;> [exact .inl rfl; exact .inr rfl] + rw [Node.subsume]; split <;> [exact subsumeBy_const_cases ..; exact .inl rfl] theorem Node.subsume_eval_le : Node.eval ls ρ (Node.subsume p₁ n₁ p₂ n₂) ≤ Node.eval ls ρ n₁ := by - refine Node.eval_le.2 ⟨?_, fun v h => Node.var_le_eval (Node.subsume_var_subset h)⟩ - obtain h | h := Node.subsume_const_cases p₁ n₁ p₂ n₂ - · exact h ▸ Node.const_le_eval - · simp [h] + rw [Node.subsume]; split <;> [exact subsumeBy_eval_le; exact Nat.le_refl _] /-- If `subsume` dropped the constant, the drop was justified: the constant is dominated by the constant of `n₂` at a strictly smaller key, or by a variable of `n₂`. -/ theorem Node.subsume_const_drop (h : (Node.subsume p₁ n₁ p₂ n₂).const ≠ n₁.const) : subset compare p₂ p₁ ∧ (p₁.length ≠ p₂.length ∧ n₁.const ≤ n₂.const ∨ ∃ y ∈ n₂.var, n₁.const ≤ y.offset + 1) := by - rw [Node.subsume_const_eq] at h - split at h <;> [cases h rfl; rename_i hc] - rw [Bool.or_eq_true, Bool.or_eq_true, not_or, not_or] at hc - obtain ⟨hs, hc0, hc⟩ := hc - have hsub : subset compare p₂ p₁ := by revert hs; cases subset compare p₂ p₁ <;> simp - refine ⟨hsub, ?_⟩ - rw [Bool.and_eq_true, Decidable.not_and_iff_not_or_not] at hc - obtain hc | hc := hc <;> rw [Bool.or_eq_true, not_or] at hc <;> obtain ⟨h1, h2⟩ := hc - · refine .inl ⟨fun e => h1 (by simp [e]), by simpa [Nat.not_lt] using h2⟩ - · have hne : n₂.var ≠ [] := fun e => h1 (by simp [e]) - have h2 : n₁.const ≤ n₂.var.foldl (·.max ·.offset) 0 + 1 := by - simpa [Nat.not_lt] using h2 - obtain h | h := le_foldl_max (c := n₁.const) (n := 0) h2 - · obtain ⟨y, hy⟩ := List.exists_mem_of_ne_nil _ hne - exact .inr ⟨y, hy, by omega⟩ - · exact .inr h + rw [Node.subsume] at h + split at h <;> [skip; cases h rfl] + refine ⟨‹_›, (subsumeBy_const_drop h).imp_left fun ⟨he, hc⟩ => ⟨fun e => ?_, hc⟩⟩ + simp [e] at he /-- If `subsume` changed the variable list, the change was `subsumeVars` against the variables of `n₂` at a strictly smaller key. -/ @@ -913,6 +956,45 @@ theorem NormLevel.minimize_eval_iff {acc : NormLevel} {p₁ : List Name} {n₁ : have hpe : pn.1 ≠ p₁ := fun h => hlen (h ▸ rfl) exact .inr ⟨pn.1, pn.2, z, hpe, h₂, hsub, hz, ez.trans e, Nat.le_trans le lez⟩ +/-- One step of `subsumption`: the key being minimized is updated, or erased if it drained, +and no other key changes. -/ +theorem NormLevel.subsumption_step_get? (acc : NormLevel) (n₁ : Node) (p₁ p : List Name) : + (if (acc.minimize p₁ n₁).isEmpty then acc.erase p₁ + else acc.insert p₁ (acc.minimize p₁ n₁)).get? p = + if p₁ = p then (if (acc.minimize p₁ n₁).isEmpty then none else some (acc.minimize p₁ n₁)) + else acc.get? p := by + split <;> + simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_erase, + Std.TreeMap.getElem?_insert] <;> + split <;> split <;> simp_all + +/-- `subsumption` only shrinks the variable lists, at unchanged keys, so it preserves the +half of `WF` saying that every variable recorded at a key is an element of it. -/ +theorem NormLevel.subsumption_vars {s : NormLevel} + (wf : ∀ p n, s.get? p = some n → ∀ v ∈ n.var, v.var ∈ p) : + ∀ p n, s.subsumption.get? p = some n → ∀ v ∈ n.var, v.var ∈ p := by + rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList] + have hmem pn (h : pn ∈ s.toList) : s.get? pn.1 = some pn.2 := + Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h + generalize s.toList = l at hmem + suffices ∀ (l : List (List Name × Node)) (acc : NormLevel), + (∀ pn ∈ l, s.get? pn.1 = some pn.2) → + (∀ p n, acc.get? p = some n → ∀ v ∈ n.var, v.var ∈ p) → + ∀ p n, (List.foldl (fun acc pn => + let n := acc.minimize pn.1 pn.2 + if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).get? p = some n → + ∀ v ∈ n.var, v.var ∈ p from this _ _ hmem wf + clear hmem; intro l + induction l with | nil => exact fun _ _ => id | cons pn l ih + intro acc hl hacc + refine ih _ (fun _ h => hl _ (.tail _ h)) fun p n h v hv => ?_ + rw [subsumption_step_get?] at h + split at h + · split at h <;> [cases h; skip] + cases h; rename_i hp _; subst hp + exact wf _ _ (hl _ (.head _)) _ (minimize_var_subset hv) + · exact hacc _ _ h _ hv + theorem NormLevel.subsumption_eval {s : NormLevel} (wf : s.WF) : (s.subsumption).eval ls ρ = s.eval ls ρ := by rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList] @@ -935,15 +1017,7 @@ theorem NormLevel.subsumption_eval {s : NormLevel} (wf : s.WF) : simp only [List.map_cons, List.nodup_cons] at nd have h₁ := hl _ _ (.head _) -- a drained key is erased rather than kept, which is the same for `eval` - have hins p : - (if (acc.minimize p₁ n₁).isEmpty then acc.erase p₁ - else acc.insert p₁ (acc.minimize p₁ n₁)).get? p = - if p₁ = p then if (acc.minimize p₁ n₁).isEmpty then none else some (acc.minimize p₁ n₁) - else acc.get? p := by - split <;> - simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_erase, - Std.TreeMap.getElem?_insert] <;> - split <;> split <;> simp_all + have hins := subsumption_step_get? acc n₁ p₁ have hmin_le m (H : ∀ a b, (if (acc.minimize p₁ n₁).isEmpty then acc.erase p₁ else acc.insert p₁ (acc.minimize p₁ n₁)).get? a = some b → @@ -986,6 +1060,48 @@ theorem normalize_eval (hu : VLevel.ofLevel ls u = some u') : exact normalizeAux_eval hu (by simp) h1 simp [NormLevel.WF] +theorem normalize_vars : ∀ p n, (normalize u).get? p = some n → ∀ v ∈ n.var, v.var ∈ p := + NormLevel.subsumption_vars fun _ _ h => + (normalizeAux_wf (by simp) (by simp [NormLevel.WF]) _ _ h).2 + +/-- Soundness of `NormLevel.le`, Theorem 39 of the paper: it reports `true` only when every +sublevel of `l₁` is dominated. Each entry of `l₁` is compared against a fold over `l₂`, +where every entry discharges from the node what it can, and the fold stops (returning +`none`) once nothing is left to discharge; so the fold ends in `none` only if the node is +bounded by the total of `l₂`. -/ +theorem NormLevel.le_eval {l₁ l₂ : NormLevel} + (wf₂ : ∀ p n, l₂.get? p = some n → ∀ v ∈ n.var, v.var ∈ p) + (h : l₁.le l₂) : l₁.eval ls ρ ≤ l₂.eval ls ρ := by + refine NormLevel.eval_le.2 fun p₁ n₁ h₁ => evalPath_le.2 fun nz => ?_ + -- an entry of `l₂` at a key below `p₁` is bounded by the total, on a live condition set + have hbd p₂ n₂ (h₂ : l₂.get? p₂ = some n₂) (hsub : subset compare p₂ p₁) : + (∀ v ∈ n₂.var, 0 < evalParam ls ρ v.var) ∧ Node.eval ls ρ n₂ ≤ l₂.eval ls ρ := by + have hnz : allNZ ls ρ p₂ := allNZ_mono (fun _ h => subset_mem hsub h) nz + refine ⟨fun v hv => ?_, ?_⟩ + · simp only [allNZ, List.all_eq_true, decide_eq_true_eq] at hnz + exact hnz _ (wf₂ _ _ h₂ _ hv) + · have := evalPath_le.1 (NormLevel.eval_le.1 (Nat.le_refl (l₂.eval ls ρ)) _ _ h₂) + exact this hnz + rw [NormLevel.le, Std.TreeMap.all_eq_all_toList, List.all_eq_true] at h + have hf := h (p₁, n₁) (Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 (by simpa using h₁)) + simp only [Std.TreeMap.foldlM_eq_foldlM_toList, Option.isNone_iff_eq_none] at hf + have hmem pn (h : pn ∈ l₂.toList) : l₂.get? pn.1 = some pn.2 := + Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h + clear h₁ h + generalize l₂.toList = l at hf hmem + induction l generalizing n₁ with + | nil => simp at hf + | cons pn l ih => + simp only [List.foldlM_cons] at hf + simp only [List.mem_cons, forall_eq_or_imp] at hmem + by_cases hs : subset compare pn.1 p₁ + · refine (Node.subsumeBy_eval_iff (same := false) (n₂ := pn.2) + (hbd _ _ hmem.1 hs).1 (hbd _ _ hmem.1 hs).2).1 ?_ + by_cases he : (n₁.subsumeBy false pn.2).isEmpty + · simp [Node.eval_empty he] + · exact ih _ (by simpa [hs, he] using hf) hmem.2 + · exact ih _ (by simpa [hs] using hf) hmem.2 + theorem Node.eval_congr {a b : Node} (H : a == b) : a.eval ls ρ = b.eval ls ρ := by simp +instances [instBEqNode] at H; simp [H, eval] @@ -1021,6 +1137,12 @@ theorem isEquiv'_wf (h : isEquiv' u v) rw [← Normalize.normalize_eval (ρ := ρ) hu, ← Normalize.normalize_eval (ρ := ρ) hv] exact Normalize.NormLevel.eval_congr h +theorem geq'_wf (h : geq' u v) + (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') : v' ≤ u' := by + intro ρ + rw [← Normalize.normalize_eval (ρ := ρ) hv, ← Normalize.normalize_eval (ρ := ρ) hu] + exact Normalize.NormLevel.le_eval Normalize.normalize_vars h + theorem isEquivList_wf (H : Level.isEquivList us vs) : List.mapM (VLevel.ofLevel Us) us = some us' → List.mapM (VLevel.ofLevel Us) vs = some vs' → us'.Forall₂ (· ≈ ·) vs' := by From ce18bd0d8d6c7d70fea4d7f0604cfe5bbd6edd63 Mon Sep 17 00:00:00 2001 From: Mario Carneiro Date: Tue, 11 Aug 2026 06:40:44 +0200 Subject: [PATCH 34/51] verify: prove soundness of normalize' normalize' reifies a normal form by building a Tree and turning it into a Level; normalize'_eval says the result evaluates like the input under every valuation, which was the last unverified step of normalization. Tree.eval gives a Tree the value its reification has: the node's own sublevels, plus every child under the imax guard of the variable labelling the edge into it. Tree.reify_eval proves that is the value of the level, the only interesting case being reify's shortcut for a child reifying to zero, where imax 0 a and a agree. Tree.eval_le_iff then characterizes that value: a tree is bounded by m exactly when the sublevels recorded at its nodes are, and so is the V(p, a, 0) that the edge into each node contributes on its own. The edge half is the reason a tree shape is not free: an imax chain built to carry a sublevel adds sublevels of its own. So a chain is only usable if each of its edges is dominated (Dom), and a key is only expressible if its elements can be ordered so that all of them are (Feas). lexChain searches for such an order greedily, which is complete because Dom is monotone in the conditions accumulated so far (the exchange argument), and its feasibility lookahead is exact (feasible_sound, feasible_complete); lexChain_spec concludes that it returns an admissible chain whenever one exists, so its fallback branch is unreachable for normal forms. normalize_feas supplies the hypothesis: WF.feas builds a chain for the map normalizeAux produces, out of the WF parent clause, and Feas transfers to the subsumed map along Covers, since minimization drops a variable only in favour of one with the same name at a strictly smaller key. Covers is what is left of WF after subsumption, which does not preserve WF itself: for `max (imax d b) (imax (imax c b) a)` the key [a, b] drains and is erased, leaving [a, b, c] with no parent key. WF wants the witness at the key; Dom accepts one at a subset of it. The reconstruction itself is characterized rather than bounded. Tree.At relates a path to the subtree at its end, and toTree_spec makes a single pass over the map establishing that every entry is recorded at the end of its chain (WrittenAt) and that everything in the tree comes from an entry (Accounted). A write puts its own entry there and leaves the others alone, either because it lands on a different path, distinct keys having distinct chains since lexChain only permutes a sorted key, or because it lands on the same key and writes the same data. No duplicate-freedom assumption on the child lists is needed: modifyAt_eq decomposes a modify as one entry replaced or one inserted, so an entry either survives it or is the one modified, whichever entry it matched first. toTree_le_iff reads both halves off as one biconditional, and toTree_eval is ext_le over that and NormLevel.eval_le, so the equality comes from dividing the bound over the maxes on both sides. What is left is per-entry: the node the tree records is part of the entry, the sublevel it omits is the edge into it, and an edge is dominated because the chain is admissible. Co-Authored-By: Claude Opus 5 --- Lean4Lean/Verify/Axioms.lean | 4 + Lean4Lean/Verify/Level.lean | 1125 +++++++++++++++++++++++++++++++++- 2 files changed, 1104 insertions(+), 25 deletions(-) diff --git a/Lean4Lean/Verify/Axioms.lean b/Lean4Lean/Verify/Axioms.lean index 8429d294..f620c116 100644 --- a/Lean4Lean/Verify/Axioms.lean +++ b/Lean4Lean/Verify/Axioms.lean @@ -10,6 +10,10 @@ variable {α : Type u} {β : Type v} {cmp : α → α → Ordering} {t : TreeMap axiom all_eq_all_toList {p : α → β → Bool} : t.all p = t.toList.all fun a => p a.1 a.2 +/-- https://github.com/leanprover/lean4/issues/12798 -/ +axiom any_eq_any_toList {p : α → β → Bool} : + t.any p = t.toList.any fun a => p a.1 a.2 + end Std.TreeMap open scoped _root_.List diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index 0113c23d..5f081e37 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -232,7 +232,7 @@ theorem Extend?.orderedInsert [BEq α] [LawfulBEq α] [Std.LawfulBEqCmp (α := section variable (ls : List Name) (ρ : List Nat) in def evalParam (x : Name) : Nat := -let i := ls.idxOf x; if i < ls.length then ρ[i]?.getD 0 else 0 + let i := ls.idxOf x; if i < ls.length then ρ[i]?.getD 0 else 0 theorem evalParam_eq (hv : ls.idxOf x < ls.length) : evalParam ls ρ x = ρ[List.idxOf x ls]?.getD 0 := if_pos hv @@ -347,6 +347,41 @@ theorem ext_le {n m : Nat} (H : ∀ x, n ≤ x ↔ m ≤ x) : n = m := theorem le_ext_le {n m : Nat} (H : ∀ x, n ≤ x → m ≤ x) : m ≤ n := H _ (Nat.le_refl _) +/-- Condition sets are strictly sorted, which is what makes `subset` a decision procedure +for inclusion: it is built up by `orderedInsert` from the empty set. -/ +def Sorted (l : List Name) : Prop := l.Pairwise (compare · · = .lt) + +nonrec theorem Sorted.nil : Sorted [] := .nil + +theorem Sorted.of_cons (h : Sorted (a :: l)) : Sorted l := (List.pairwise_cons.1 h).2 + +theorem Sorted.head (h : Sorted (a :: l)) : ∀ b ∈ l, compare a b = .lt := + (List.pairwise_cons.1 h).1 + +theorem Sorted.erase (h : Sorted l) : Sorted (l.erase a) := h.sublist (List.erase_sublist ..) + +theorem Sorted.nodup (h : Sorted l) : l.Nodup := + h.imp <| by rintro _ _ hab rfl; rw [Std.ReflOrd.compare_self] at hab; cases hab + +theorem Sorted.orderedInsert (h : Sorted l) (he : orderedInsert Name.cmp a l = some l') : + Sorted l' := by + induction l generalizing l' with | nil => cases he; exact .cons (by simp) .nil | cons b l ih + simp only [Normalize.orderedInsert] at he + split at he <;> rename_i hab + · cases he + refine .cons (fun c hc => ?_) h + obtain rfl | hc := List.mem_cons.1 hc + · exact hab + · exact Std.TransCmp.lt_trans hab (h.head _ hc) + · cases he + · simp only [Option.map_eq_some_iff] at he + obtain ⟨l'', he, rfl⟩ := he + refine .cons (fun c hc => ?_) (ih h.of_cons he) + -- `c` is either `a`, which is above `b`, or an element of `l` + obtain rfl | hc := (Extend1.orderedInsert he).mem.1 hc + · exact Std.OrientedCmp.lt_of_gt hab + · exact h.head _ hc + /-- The well-formedness invariant of the `NormLevel` maps produced by `normalizeAux`: every variable recorded at a key is an element of that key, and every nonempty key `p` extends another key of the map by a single variable that is recorded at `p`. @@ -355,7 +390,7 @@ comment in `Lean4Lean.Level`), and it lets `addConst` drop `C(p, 1)` for `p ≠ def NormLevel.WF (s : NormLevel) : Prop := ∀ p n, s.get? p = some n → (p ≠ [] → ∃ v p', Extend1 p' v p ∧ (p' = [] ∨ s.contains p') ∧ ∃ x ∈ n.var, x.var = v) ∧ - (∀ v ∈ n.var, v.var ∈ p) + (∀ v ∈ n.var, v.var ∈ p) ∧ Sorted p theorem NormLevel.WF.of_mem (hm : v ∈ path) (H : WF s) (hp : s.contains path) : ∃ path₁ path₂ n, (∀ x ∈ path₁, x ∈ path) ∧ @@ -372,6 +407,13 @@ theorem NormLevel.WF.of_mem (hm : v ∈ path) (H : WF s) (hp : s.contains path) (by cases a1; simp at eq ⊢; exact Nat.succ_inj.1 eq) exact ⟨_, _, _, fun _ h => a1.mem.2 (.inr (b1 _ h)), b2⟩ +theorem NormLevel.WF.sortedOf {s : NormLevel} (wf : s.WF) (H : path = [] ∨ s.contains path) : + Sorted path := by + obtain rfl | h := H + · exact Sorted.nil + · obtain ⟨n, hn⟩ := Option.isSome_iff_exists.1 (Std.TreeMap.isSome_getElem?_eq_contains.trans h) + exact (wf _ _ hn).2.2 + theorem VarNode.mem_addVar : (∃ x ∈ VarNode.addVar v k l, x.var = u) ↔ v = u ∨ (∃ x ∈ l, x.var = u) := by induction l with simp [addVar] | cons x l ih; split <;> simp_all [or_left_comm] @@ -380,25 +422,26 @@ theorem NormLevel.addVar_wf (hv : v ∈ path) (wf : acc.WF) : (addVar v k path acc).WF := by simp [addVar, WF, Std.TreeMap.getElem?_modify, Std.TreeMap.mem_modify] at wf ⊢ intro p n; split <;> [simp; apply wf] - subst p; rintro _ h rfl; have ⟨a1, a2⟩ := wf _ _ h; refine ⟨fun h => ?_, fun _ h => ?_⟩ + subst p; rintro _ h rfl; have ⟨a1, a2, a3⟩ := wf _ _ h + refine ⟨fun h => ?_, fun _ h => ?_, a3⟩ · have ⟨_, _, b1, b2, b3⟩ := a1 h; exact ⟨_, _, b1, b2, VarNode.mem_addVar.2 (.inr b3)⟩ · obtain eq | ⟨_, h, eq⟩ := VarNode.mem_addVar.1 ⟨_, h, rfl⟩ · exact eq ▸ hv · exact eq ▸ a2 _ h -theorem NormLevel.addNode_wf (H : Extend1 path v path') +theorem NormLevel.addNode_wf (H : Extend1 path v path') (hs : Sorted path') (hacc : path = [] ∨ acc.contains path) (wf : acc.WF) : (addNode v k path' acc).WF := by simp [addNode, WF, Std.TreeMap.getElem?_alter, Std.TreeMap.mem_alter] at * intro p n; split · subst p; split <;> rintro ⟨⟩ <;> simp - · exact ⟨fun _ => ⟨_, _, H, hacc.imp id fun h _ => h, rfl⟩, H.mem.2 (.inl rfl)⟩ - · obtain ⟨a1, a2⟩ := wf _ _ ‹_›; refine ⟨fun h => ?_, fun _ h => ?_⟩ + · exact ⟨fun _ => ⟨_, _, H, hacc.imp id fun h _ => h, rfl⟩, H.mem.2 (.inl rfl), hs⟩ + · obtain ⟨a1, a2, a3⟩ := wf _ _ ‹_›; refine ⟨fun h => ?_, fun _ h => ?_, a3⟩ · have ⟨_, _, b1, b2, b3⟩ := a1 h exact ⟨_, _, b1, b2.imp id fun h _ => h, VarNode.mem_addVar.2 (.inr b3)⟩ · obtain eq | ⟨_, h, eq⟩ := VarNode.mem_addVar.1 ⟨_, h, rfl⟩ · exact H.mem.2 (.inl eq.symm) · exact eq ▸ a2 _ h - · intro h; have ⟨a1, a2⟩ := wf _ _ h; refine ⟨fun h => ?_, a2⟩ + · intro h; have ⟨a1, a2, a3⟩ := wf _ _ h; refine ⟨fun h => ?_, a2, a3⟩ have ⟨_, _, b1, b2, b3⟩ := a1 h; refine ⟨_, _, b1, ?_, b3⟩ split <;> [split <;> simp; exact b2] @@ -410,11 +453,11 @@ theorem NormLevel.WF.update {s s' : NormLevel} (wf : s.WF) (∃ n₀, s.get? p = some n₀ ∧ n.var = n₀.var) ∨ (p = [] ∧ n.var = [])) : s'.WF := by intro p n hn rcases hv p n hn with ⟨n₀, h₀, hvar⟩ | ⟨rfl, hvar⟩ - · obtain ⟨a1, a2⟩ := wf _ _ h₀ - refine ⟨fun h => ?_, fun v hv => a2 v (hvar ▸ hv)⟩ + · obtain ⟨a1, a2, a3⟩ := wf _ _ h₀ + refine ⟨fun h => ?_, fun v hv => a2 v (hvar ▸ hv), a3⟩ obtain ⟨v, p', b1, b2, b3⟩ := a1 h exact ⟨v, p', b1, b2.imp id (hk _), hvar ▸ b3⟩ - · exact ⟨absurd rfl, by simp [hvar]⟩ + · exact ⟨absurd rfl, by simp [hvar], Sorted.nil⟩ theorem NormLevel.addConst_wf (hp : path = [] ∨ acc.contains path) (H : acc.WF) : (addConst k path acc).WF := by @@ -442,7 +485,7 @@ theorem normalizeAux_wf (H : path = [] ∨ acc.contains path) (wf : acc.WF) : · exact normalizeAux_wf (H.imp id normalizeAux_contains) (normalizeAux_wf H wf) · split <;> rename_i eq <;> [skip; (dsimp; split)] · exact normalizeAux_wf (.inr NormLevel.addNode_contains_self) - (NormLevel.addNode_wf (.orderedInsert eq) + (NormLevel.addNode_wf (.orderedInsert eq) ((wf.sortedOf H).orderedInsert eq) (H.imp id NormLevel.addConst_contains) (NormLevel.addConst_wf H wf)) · exact normalizeAux_wf H wf · refine normalizeAux_wf (H.imp id NormLevel.addVar_contains) (NormLevel.addVar_wf ?_ wf) @@ -450,7 +493,7 @@ theorem normalizeAux_wf (H : path = [] ∨ acc.contains path) (wf : acc.WF) : · exact wf · exact wf · split <;> rename_i eq <;> [skip; split] - · exact NormLevel.addNode_wf (.orderedInsert eq) + · exact NormLevel.addNode_wf (.orderedInsert eq) ((wf.sortedOf H).orderedInsert eq) (H.imp id NormLevel.addConst_contains) (NormLevel.addConst_wf H wf) · exact wf · exact NormLevel.addVar_wf ((eq ▸ Extend?.orderedInsert).mem.2 (.inl rfl)) wf @@ -563,7 +606,7 @@ theorem normalizeAux_eval (hu : VLevel.ofLevel ls u = some u') have := Extend?.orderedInsert (cmp := Name.cmp) (p := path) (v := v) split <;> rename_i h <;> simp [h] at this · rw [normalizeAux_eval hu (.inr NormLevel.addNode_contains_self) - (NormLevel.addNode_wf (.orderedInsert h) + (NormLevel.addNode_wf (.orderedInsert h) ((wf.sortedOf H).orderedInsert h) (H.imp id NormLevel.addConst_contains) (NormLevel.addConst_wf H wf)), NormLevel.addNode_eval, NormLevel.addConst_eval H wf, Nat.max_assoc, Nat.max_assoc, ← evalPath_max, this.evalPath, evalPath_cons, ← evalPath_max, @@ -644,6 +687,34 @@ theorem subset_eq [BEq α] [LawfulBEq α] [Std.LawfulBEqCmp (α := α) cmp] cases eq_of_beq h'; rw [ih H (by omega)] · exact absurd (subset_length H) (by simp only [List.length_cons]; omega) +/-- On sorted lists, `subset` decides inclusion. -/ +theorem subset_of_sorted (h₁ : Sorted l₁) (h₂ : Sorted l₂) (h : ∀ x ∈ l₁, x ∈ l₂) : + subset compare l₁ l₂ := by + induction l₂ generalizing l₁ with + | nil => cases l₁ with | nil => rfl | cons x l₁ => cases h x (.head _) + | cons y l₂ ih + cases l₁ with | nil => rfl | cons x l₁ + simp only [subset] + have hxy := h x (.head _) + split <;> rename_i hc + · -- `x < y` is impossible: `x` is in `y :: l₂`, whose elements are all `≥ y` + obtain rfl | hx := List.mem_cons.1 hxy + · rw [Std.ReflOrd.compare_self] at hc; cases hc + · exact absurd (h₂.head _ hx) (by rw [Std.OrientedCmp.gt_of_lt hc]; simp) + · rw [Std.LawfulBEqCmp.compare_eq_iff_beq] at hc + cases eq_of_beq hc + refine ih h₁.of_cons h₂.of_cons fun z hz => ?_ + obtain rfl | hz' := List.mem_cons.1 (h z (.tail _ hz)) + · exact absurd (h₁.head _ hz) (by rw [Std.ReflOrd.compare_self]; simp) + · exact hz' + · refine ih h₁ h₂.of_cons fun z hz => ?_ + obtain rfl | hz' := List.mem_cons.1 (h z hz) + · obtain rfl | hz := List.mem_cons.1 hz + · exact absurd hc (by rw [Std.ReflOrd.compare_self]; simp) + · exact absurd (h₁.head _ hz) (by + rw [Std.OrientedCmp.gt_of_lt (Std.OrientedCmp.lt_of_gt hc)]; simp) + · exact hz' + theorem subsumeVars_subset (h : x ∈ subsumeVars vs₁ vs₂) : x ∈ vs₁ := by induction vs₁ generalizing vs₂ with | nil => simp_all [subsumeVars] | cons a vs₁ ih induction vs₂ with | nil => simp_all [subsumeVars] | cons b vs₂ ih₂ @@ -970,33 +1041,121 @@ theorem NormLevel.subsumption_step_get? (acc : NormLevel) (n₁ : Node) (p₁ p /-- `subsumption` only shrinks the variable lists, at unchanged keys, so it preserves the half of `WF` saying that every variable recorded at a key is an element of it. -/ -theorem NormLevel.subsumption_vars {s : NormLevel} - (wf : ∀ p n, s.get? p = some n → ∀ v ∈ n.var, v.var ∈ p) : - ∀ p n, s.subsumption.get? p = some n → ∀ v ∈ n.var, v.var ∈ p := by +theorem NormLevel.subsumption_vars {s : NormLevel} (wf : s.WF) : + ∀ p n, s.subsumption.get? p = some n → (∀ v ∈ n.var, v.var ∈ p) ∧ Sorted p := by rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList] have hmem pn (h : pn ∈ s.toList) : s.get? pn.1 = some pn.2 := Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h generalize s.toList = l at hmem suffices ∀ (l : List (List Name × Node)) (acc : NormLevel), (∀ pn ∈ l, s.get? pn.1 = some pn.2) → - (∀ p n, acc.get? p = some n → ∀ v ∈ n.var, v.var ∈ p) → + (∀ p n, acc.get? p = some n → (∀ v ∈ n.var, v.var ∈ p) ∧ Sorted p) → ∀ p n, (List.foldl (fun acc pn => let n := acc.minimize pn.1 pn.2 if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).get? p = some n → - ∀ v ∈ n.var, v.var ∈ p from this _ _ hmem wf + (∀ v ∈ n.var, v.var ∈ p) ∧ Sorted p from this _ _ hmem fun p n h => (wf p n h).2 clear hmem; intro l induction l with | nil => exact fun _ _ => id | cons pn l ih intro acc hl hacc - refine ih _ (fun _ h => hl _ (.tail _ h)) fun p n h v hv => ?_ + refine ih _ (fun _ h => hl _ (.tail _ h)) fun p n h => ?_ rw [subsumption_step_get?] at h split at h · split at h <;> [cases h; skip] cases h; rename_i hp _; subst hp - exact wf _ _ (hl _ (.head _)) _ (minimize_var_subset hv) - · exact hacc _ _ h _ hv + have := (wf _ _ (hl _ (.head _))).2 + exact ⟨fun v hv => this.1 _ (minimize_var_subset hv), this.2⟩ + · exact hacc _ _ h + +/-- A variable that minimization drops is dropped in favour of one with the same name at a +strictly smaller key. -/ +theorem NormLevel.minimize_var_dominated {acc : NormLevel} {p₁ n₁ x} + (hx : x ∈ n₁.var) (h : x ∉ (acc.minimize p₁ n₁).var) : + ∃ p₂ n₂ y, acc.get? p₂ = some n₂ ∧ y ∈ n₂.var ∧ y.var = x.var ∧ + p₂ ≠ p₁ ∧ ∀ z ∈ p₂, z ∈ p₁ := by + rw [minimize, Std.TreeMap.foldl_eq_foldl_toList] at h + have hmem pn (h : pn ∈ acc.toList) : acc.get? pn.1 = some pn.2 := + Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h + generalize acc.toList = l at h hmem + suffices ∀ (l : List (List Name × Node)) (n : Node), + (∀ pn ∈ l, acc.get? pn.1 = some pn.2) → x ∈ n.var → + x ∉ (List.foldl (fun n pn => Node.subsume p₁ n pn.1 pn.2) n l).var → + ∃ p₂ n₂ y, acc.get? p₂ = some n₂ ∧ y ∈ n₂.var ∧ y.var = x.var ∧ + p₂ ≠ p₁ ∧ ∀ z ∈ p₂, z ∈ p₁ from this _ _ hmem hx h + clear hx h hmem; intro l + induction l with + | nil => exact fun n _ hx h => absurd hx h + | cons pn l ih => + intro n hl hx h + by_cases hx' : x ∈ (Node.subsume p₁ n pn.1 pn.2).var + · exact ih _ (fun _ h => hl _ (.tail _ h)) hx' h + · obtain heq | ⟨hsub, hlen, heq⟩ := Node.subsume_var_cases p₁ n pn.1 pn.2 + · rw [heq] at hx'; exact absurd hx hx' + · rw [heq] at hx' + obtain ⟨y, hy, e, -⟩ := subsumeVars_dominated hx hx' + exact ⟨pn.1, pn.2, y, hl _ (.head _), hy, e, + fun he => hlen (by rw [he]), fun _ hz => subset_mem hsub hz⟩ + +/-- `s'` covers `s`: every variable recorded in `s` is still recorded in `s'`, at a subset of +its key. This is all of a map that `Dom`, hence `Feas`, looks at. -/ +def NormLevel.Covers (s' s : NormLevel) : Prop := + ∀ p n x, s.get? p = some n → x ∈ n.var → + ∃ q m y, s'.get? q = some m ∧ y ∈ m.var ∧ y.var = x.var ∧ ∀ z ∈ q, z ∈ p + +/-- `subsumption` only removes variables from a node, and never the last witness for a name: +a removed one is still recorded at a strictly smaller key, possibly after further removals +there. So the subsumed map covers the original, and its entries are entries of it. -/ +theorem NormLevel.subsumption_covers {s : NormLevel} : + (∀ p n, s.subsumption.get? p = some n → + ∃ n₀, s.get? p = some n₀ ∧ ∀ x ∈ n.var, x ∈ n₀.var) ∧ s.subsumption.Covers s := by + rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList] + have hmem pn (h : pn ∈ s.toList) : s.get? pn.1 = some pn.2 := + Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h + generalize s.toList = l at hmem + suffices ∀ (l : List (List Name × Node)) (acc : NormLevel), + (∀ pn ∈ l, s.get? pn.1 = some pn.2) → + (∀ p n, acc.get? p = some n → ∃ n₀, s.get? p = some n₀ ∧ ∀ x ∈ n.var, x ∈ n₀.var) → + acc.Covers s → + (∀ p n, (List.foldl (fun acc pn => + let n := acc.minimize pn.1 pn.2 + if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).get? p = some n → + ∃ n₀, s.get? p = some n₀ ∧ ∀ x ∈ n.var, x ∈ n₀.var) ∧ + (List.foldl (fun acc pn => + let n := acc.minimize pn.1 pn.2 + if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).Covers s from + this _ _ hmem (fun p n h => ⟨n, h, fun _ => id⟩) + (fun p n x h hx => ⟨p, n, x, h, hx, rfl, fun _ => id⟩) + clear hmem; intro l + induction l with | nil => exact fun _ _ h1 h2 => ⟨h1, h2⟩ | cons pn l ih + obtain ⟨p₁, n₁⟩ := pn + intro acc hl hsub hcov + have h₁ : s.get? p₁ = some n₁ := hl _ (.head _) + refine ih _ (fun _ h => hl _ (.tail _ h)) (fun p n h => ?_) (fun p n x hp hx => ?_) + · rw [subsumption_step_get?] at h + split at h + · split at h <;> [cases h; skip] + cases h; rename_i hp _; subst hp + exact ⟨n₁, h₁, fun x hx => minimize_var_subset hx⟩ + · exact hsub _ _ h + · obtain ⟨q, m, y, hq, hy, e, hqp⟩ := hcov _ _ _ hp hx + by_cases hqp₁ : q = p₁ + · subst hqp₁ + -- the write lands on the key covering `x`: either the variable survives it, or it is + -- dominated at a smaller key, which this step leaves alone + obtain ⟨n₀, h₀, hy₀⟩ := hsub _ _ hq + cases h₀.symm.trans h₁ + by_cases hmin : y ∈ (acc.minimize q n₁).var + · refine ⟨q, _, y, ?_, hmin, e, hqp⟩ + rw [subsumption_step_get?, if_pos rfl, if_neg] + simp only [Node.isEmpty, Bool.and_eq_true, List.isEmpty_iff, not_and] + rintro - he; simp [he] at hmin + · obtain ⟨p₂, n₂, z, h₂, hz, e₂, hne, hp₂⟩ := minimize_var_dominated (hy₀ _ hy) hmin + exact ⟨p₂, n₂, z, by rw [subsumption_step_get?, if_neg (Ne.symm hne)]; exact h₂, + hz, e₂.trans e, fun w hw => hqp _ (hp₂ _ hw)⟩ + · exact ⟨q, m, y, by rw [subsumption_step_get?, if_neg (Ne.symm hqp₁)]; exact hq, + hy, e, hqp⟩ theorem NormLevel.subsumption_eval {s : NormLevel} (wf : s.WF) : - (s.subsumption).eval ls ρ = s.eval ls ρ := by + s.subsumption.eval ls ρ = s.eval ls ρ := by rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList] have hmem pn (h : pn ∈ s.toList) : s.get? pn.1 = some pn.2 := Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h @@ -1010,7 +1169,7 @@ theorem NormLevel.subsumption_eval {s : NormLevel} (wf : s.WF) : eval ls ρ (List.foldl (fun acc pn => let n := acc.minimize pn.1 pn.2 if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l) = eval ls ρ s from - this _ _ nd (fun _ _ => hmem _) (fun _ _ h => (wf _ _ h).2) rfl + this _ _ nd (fun _ _ => hmem _) (fun _ _ h => (wf _ _ h).2.1) rfl clear hmem nd; intro l induction l with | nil => exact fun acc _ _ _ eq => eq | cons pn l ih have ⟨p₁, n₁⟩ := pn; intro acc nd hl wfa eq @@ -1060,9 +1219,15 @@ theorem normalize_eval (hu : VLevel.ofLevel ls u = some u') : exact normalizeAux_eval hu (by simp) h1 simp [NormLevel.WF] +theorem normalize_vars_sorted : ∀ p n, (normalize u).get? p = some n → + (∀ v ∈ n.var, v.var ∈ p) ∧ Sorted p := + NormLevel.subsumption_vars (normalizeAux_wf (by simp) (by simp [NormLevel.WF])) + theorem normalize_vars : ∀ p n, (normalize u).get? p = some n → ∀ v ∈ n.var, v.var ∈ p := - NormLevel.subsumption_vars fun _ _ h => - (normalizeAux_wf (by simp) (by simp [NormLevel.WF]) _ _ h).2 + fun _ _ h => (normalize_vars_sorted _ _ h).1 + +theorem normalize_sorted : ∀ p n, (normalize u).get? p = some n → Sorted p := + fun _ _ h => (normalize_vars_sorted _ _ h).2 /-- Soundness of `NormLevel.le`, Theorem 39 of the paper: it reports `true` only when every sublevel of `l₁` is dominated. Each entry of `l₁` is compared against a fold over `l₂`, @@ -1126,6 +1291,905 @@ theorem NormLevel.eval_congr {a b : NormLevel} (H : a == b) : a.eval ls ρ = b.e · exact Node.eval_congr h2 ▸ Nat.le_max_right .. · exact Nat.le_trans (ih H) (Nat.le_max_left ..) +/-! +### Reconstruction + +The value of a `Tree` is the value of the level it reifies to: a tree node contributes its +own sublevels, and every child contributes under the `imax` guard of the variable labelling +the edge into it. That edge guard is what makes the tree shape meaningful — a node at path +`[a₁, …, aₙ]` (innermost first) is guarded by all of `a₁, …, aₙ` — and it is also what makes +the tree carry sublevels of its own, since `imax x a` is at least `a` when `a ≠ 0`. +-/ + +mutual + +def Tree.eval (ls : List Name) (ρ : List Nat) : Tree → Nat + | ⟨const, var, child⟩ => max' (Node.eval ls ρ ⟨const, var⟩) (Tree.evalChild ls ρ child) + +def Tree.evalChild (ls : List Name) (ρ : List Nat) : List (Name × Tree) → Nat + | [] => 0 + | (a, t) :: l => + max' (Lean.Nat.imax (Tree.eval ls ρ t) (evalParam ls ρ a)) (Tree.evalChild ls ρ l) + +end + +/-- The value of the optional level accumulated by `reify`. -/ +def evalOpt (ρ : Name → Nat) (μ : LMVarId → Nat) : Option Level → Nat + | none => 0 + | some l => Level.eval ρ μ l + +@[simp] theorem evalOpt_none : evalOpt ρ μ none = 0 := rfl +@[simp] theorem evalOpt_some : evalOpt ρ μ (some l) = Level.eval ρ μ l := rfl + +theorem imax_eq_ite : Lean.Nat.imax a b = if b = 0 then 0 else max' a b := rfl + +theorem imax_zero_left : Lean.Nat.imax 0 a = a := by rw [imax_eq_ite]; split <;> omega + +theorem Node.eval_const {var : List VarNode} : + Node.eval ls ρ ⟨c, var⟩ = max' c (Node.eval ls ρ ⟨0, var⟩) := + ext_le fun x => by simp [Node.eval_le, Nat.max_le] + +theorem Node.eval_cons {var : List VarNode} : + Node.eval ls ρ ⟨c, a :: var⟩ = max' (VarNode.eval ls ρ a) (Node.eval ls ρ ⟨c, var⟩) := + ext_le fun x => by simp [Node.eval_le, Nat.max_le, and_left_comm] + +theorem eval_mkMax : + Level.eval ρ μ (Tree.reify.mkMax l o) = max' (Level.eval ρ μ l) (evalOpt ρ μ o) := by + cases o <;> simp [Tree.reify.mkMax, evalOpt, Level.eval] + +theorem eval_addOffset : Level.eval ρ μ (l.addOffset k) = Level.eval ρ μ l + k := by + simp only [Level.addOffset] + induction k generalizing l with + | zero => rfl + | succ k ih => rw [Level.addOffsetAux, ih]; simp [Level.eval]; omega + +theorem eval_ofNat : Level.eval ρ μ (Level.ofNat k) = k := by + induction k with + | zero => rfl + | succ k ih => simp [Level.ofNat, Level.eval, ih] + +theorem eval_varFold (var : List VarNode) (o : Option Level) : + evalOpt (evalParam ls ρ) μ (var.foldr (init := o) fun n r => + some (Tree.reify.mkMax (Level.addOffset (.param n.var) n.offset) r)) = + max' (Node.eval ls ρ ⟨0, var⟩) (evalOpt (evalParam ls ρ) μ o) := by + induction var with | nil => simp [Node.eval] | cons a var ih + simp only [List.foldr_cons, evalOpt_some, eval_mkMax, eval_addOffset, Level.eval, ih, + Node.eval_cons, VarNode.eval]; omega + +mutual + +theorem Tree.reify_eval (t : Tree) : t.reify.eval (evalParam ls ρ) μ = t.eval ls ρ := by + obtain ⟨const, var, child⟩ := t + rw [eval] + simp only [reify] + have h1 := eval_varFold (ls := ls) (ρ := ρ) (μ := μ) var (child.foldr reify.mkChild none) + rw [reifyChild_eval] at h1 + rw [Node.eval_const (c := const)] + split <;> [rename_i heq; rename_i l heq] + · rw [heq, evalOpt_none] at h1 + rw [eval_ofNat]; omega + · rw [heq, evalOpt_some] at h1 + split + · subst const; omega + · simp only [Level.eval, eval_ofNat, h1]; exact (Nat.max_assoc ..).symm + +theorem Tree.reifyChild_eval (child : List (Name × Tree)) : + evalOpt (evalParam ls ρ) μ (child.foldr reify.mkChild none) = evalChild ls ρ child := by + match child with + | [] => rfl + | (n, t) :: child => + rw [List.foldr_cons, evalChild, reify.mkChild] + have ht := reify_eval (ls := ls) (ρ := ρ) (μ := μ) t + have ih := reifyChild_eval (ls := ls) (ρ := ρ) (μ := μ) child + split <;> rename_i h + · rw [h] at ht + simp only [evalOpt_some, eval_mkMax, Level.eval, ih, ← ht, imax_zero_left] + · simp only [evalOpt_some, eval_mkMax, Level.eval, ih, ht] + +end + +/-- `Tree.At t p t'` says `t'` is the subtree of `t` at path `p`, listed innermost first, +the way `Tree.modify` takes it. -/ +inductive Tree.At : Tree → List Name → Tree → Prop + | nil : At t [] t + | cons (h : At t p t') (hm : (a, t'') ∈ t'.child) : At t (a :: p) t'' + +theorem Tree.eval_eq (t : Tree) : + eval ls ρ t = max' (Node.eval ls ρ ⟨t.const, t.var⟩) (evalChild ls ρ t.child) := by + cases t; rw [eval] + +theorem Tree.At.append (h : At t' q t'') (hm : (a, t') ∈ t.child) : + At t (q ++ [a]) t'' := by + induction h with + | nil => exact .cons .nil hm + | cons _ hm' ih => exact .cons ih hm' + +/-- A path passes through all of its tails. -/ +theorem Tree.At.suffix {t : Tree} : ∀ {path t' q}, At t path t' → q <:+ path → ∃ t'', At t q t'' := by + intro path + induction path with + | nil => intro t' q _ hq; cases List.suffix_nil.1 hq; exact ⟨t, .nil⟩ + | cons a p ih => + intro t' q h hq + obtain rfl | hq := List.suffix_cons_iff.1 hq + · exact ⟨t', h⟩ + · cases h; rename_i t₁ h _; exact ih h hq + +theorem Tree.At.nil_inv (h : At t [] t') : t' = t := by cases h; rfl + +/-- Inverting `At.append`: a nonempty path is a child of the root followed by the rest. -/ +theorem Tree.At.append_inv : ∀ {q t t''}, At t (q ++ [a]) t'' → + ∃ t₁, (a, t₁) ∈ t.child ∧ At t₁ q t'' := by + intro q + induction q with + | nil => + intro t t'' h + cases h; rename_i t₁ h hm + cases h.nil_inv + exact ⟨t'', hm, .nil⟩ + | cons b q ih => + intro t t'' h + simp only [List.cons_append] at h + cases h; rename_i t₁ h hm + obtain ⟨t₂, hm₂, h₂⟩ := ih h + exact ⟨t₂, hm₂, .cons h₂ hm⟩ + +/-- Paths only look at the children, so replacing the root's own data leaves them all in +place; only the empty path sees the difference. -/ +theorem Tree.At.of_child_eq {t u : Tree} (hc : u.child = t.child) : + ∀ {p t'}, At t p t' → At u p t' ∨ (p = [] ∧ t' = t) := by + intro p + induction p with + | nil => intro t' h; exact .inr ⟨rfl, h.nil_inv⟩ + | cons a q ih => + intro t'' h + cases h; rename_i t₁ h hm + obtain h' | ⟨rfl, rfl⟩ := ih h + · exact .inl (.cons h' hm) + · exact .inl (.cons .nil (by rw [hc]; exact hm)) + +theorem Tree.mem_le {l : List (Name × Tree)} (hm : (a, t) ∈ l) : + Lean.Nat.imax (eval ls ρ t) (evalParam ls ρ a) ≤ evalChild ls ρ l := by + induction l with + | nil => cases hm + | cons b l ih => + obtain ⟨b, t'⟩ := b + rw [evalChild] + obtain h | hm := List.mem_cons.1 hm + · cases h; exact Nat.le_max_left .. + · exact Nat.le_trans (ih hm) (Nat.le_max_right ..) + +theorem evalPath_cons_imax : + evalPath ls ρ (a :: p) c ≤ evalPath ls ρ p (Lean.Nat.imax c (evalParam ls ρ a)) := by + rw [evalPath_cons] + exact evalPath_mono <| by + by_cases h : evalParam ls ρ a = 0 <;> + simp [imax_eq_ite, h, Nat.pos_of_ne_zero, Nat.le_max_left] + +theorem evalPath_cons_edge : + evalPath ls ρ (a :: p) (evalParam ls ρ a) ≤ + evalPath ls ρ p (Lean.Nat.imax c (evalParam ls ρ a)) := by + rw [evalPath_cons] + exact evalPath_mono <| by + by_cases h : evalParam ls ρ a = 0 <;> + simp [imax_eq_ite, h, Nat.pos_of_ne_zero, Nat.le_max_right] + +theorem evalPath_append_single (ha : evalParam ls ρ a ≠ 0) : + evalPath ls ρ (p ++ [a]) c = evalPath ls ρ p c := by + simp [evalPath, allNZ, List.all_append, Nat.pos_of_ne_zero ha] + +theorem Tree.At.le (h : At t p t') : + evalPath ls ρ p (eval ls ρ t') ≤ eval ls ρ t := by + induction h with + | nil => simp [evalPath, allNZ] + | cons _ hm ih => + refine Nat.le_trans evalPath_cons_imax (Nat.le_trans (evalPath_mono ?_) ih) + exact Nat.le_trans (mem_le hm) (eval_eq _ ▸ Nat.le_max_right ..) + +theorem Tree.At.edge_le (h : At t (a :: p) t') : + evalPath ls ρ (a :: p) (evalParam ls ρ a) ≤ eval ls ρ t := by + cases h with | @cons _ t'' _ _ h' hm => ?_ + refine Nat.le_trans (evalPath_cons_edge (c := eval ls ρ t')) + (Nat.le_trans (evalPath_mono ?_) h'.le) + exact Nat.le_trans (mem_le hm) (eval_eq t'' ▸ Nat.le_max_right ..) + +mutual + +/-- A tree is bounded by `m` as soon as all the sublevels it reifies to are: the ones +recorded at its nodes, and the `V(p, a, 0)` contributed by the edge into each node. -/ +theorem Tree.eval_le_of (t : Tree) + (h1 : ∀ p t', At t p t' → evalPath ls ρ p (Node.eval ls ρ ⟨t'.const, t'.var⟩) ≤ m) + (h2 : ∀ a p t', At t (a :: p) t' → evalPath ls ρ (a :: p) (evalParam ls ρ a) ≤ m) : + eval ls ρ t ≤ m := by + obtain ⟨const, var, child⟩ := t + rw [eval] + refine Nat.max_le.2 ⟨h1 [] _ .nil, evalChild_le_of child ?_ ?_ ?_⟩ + · exact fun a t' hm p t'' hat => h1 _ _ (hat.append hm) + · exact fun a t' hm b p t'' hat => h2 _ _ _ (hat.append hm) + · exact fun a t' hm => h2 a [] t' (.cons .nil hm) + +theorem Tree.evalChild_le_of : ∀ (l : List (Name × Tree)), + (∀ a t', (a, t') ∈ l → ∀ p t'', At t' p t'' → + evalPath ls ρ (p ++ [a]) (Node.eval ls ρ ⟨t''.const, t''.var⟩) ≤ m) → + (∀ a t', (a, t') ∈ l → ∀ b p t'', At t' (b :: p) t'' → + evalPath ls ρ ((b :: p) ++ [a]) (evalParam ls ρ b) ≤ m) → + (∀ a t', (a, t') ∈ l → evalPath ls ρ [a] (evalParam ls ρ a) ≤ m) → + evalChild ls ρ l ≤ m + | [], _, _, _ => by rw [evalChild]; exact Nat.zero_le _ + | (a, t) :: l, h1, h2, h3 => by + rw [evalChild] + refine Nat.max_le.2 ⟨?_, evalChild_le_of l + (fun a t' hm => h1 a t' (.tail _ hm)) (fun a t' hm => h2 a t' (.tail _ hm)) + (fun a t' hm => h3 a t' (.tail _ hm))⟩ + by_cases ha : evalParam ls ρ a = 0 + · simp [imax_eq_ite, ha] + · have hle : evalParam ls ρ a ≤ m := by + have := h3 a t (.head _) + simpa [evalPath, allNZ, Nat.pos_of_ne_zero ha] using this + have ht : eval ls ρ t ≤ m := + eval_le_of t + (fun p t'' hat => evalPath_append_single ha ▸ h1 a t (.head _) p t'' hat) + (fun b p t'' hat => evalPath_append_single ha ▸ h2 a t (.head _) b p t'' hat) + rw [imax_eq_ite]; split <;> omega + +end + +/-- A tree is bounded by `m` exactly when all the sublevels it reifies to are: the ones +recorded at its nodes, and the one each edge contributes. -/ +theorem Tree.eval_le_iff {t : Tree} {m : Nat} : + eval ls ρ t ≤ m ↔ + (∀ p t', At t p t' → evalPath ls ρ p (Node.eval ls ρ ⟨t'.const, t'.var⟩) ≤ m) ∧ + (∀ a p t', At t (a :: p) t' → evalPath ls ρ (a :: p) (evalParam ls ρ a) ≤ m) := by + refine ⟨fun h => ?_, fun ⟨h1, h2⟩ => eval_le_of t h1 h2⟩ + refine ⟨fun _ t' hp => ?_, fun _ _ _ hp => Nat.le_trans hp.edge_le h⟩ + exact Nat.le_trans (Nat.le_trans (evalPath_mono (eval_eq t' ▸ Nat.le_max_left ..)) hp.le) h + +/-! +### Admissible chains + +Reifying the sublevels at a key `p` means nesting them under an `imax` chain whose variables +are the elements of `p`; the chain contributes the sublevel `V(q, a, 0)` for every one of its +edges, where `q` is the set of conditions from the outside up to and including that edge. The +level is therefore equivalent to the normal form only if every such edge is *dominated* +(`Dom`), and a key is expressible only if its elements can be ordered so that all of them are +(`Feas`). `lexChain` searches for such an order greedily; `feasible` is its lookahead. +-/ + +/-- The edge adding `a` to the conditions `acc` contributes `V(acc ∪ {a}, a, 0)`, which the +normal form dominates when it has some `V(T, a+k)` with `T ⊆ acc ∪ {a}`. -/ +def NormLevel.Dom (s : NormLevel) (a : Name) (acc : List Name) : Prop := + ∃ p n, s.get? p = some n ∧ (∃ x ∈ n.var, x.var = a) ∧ ∀ y ∈ p, y = a ∨ y ∈ acc + +theorem NormLevel.Dom.mono {s : NormLevel} + (h : s.Dom a acc) (hs : ∀ x ∈ acc, x ∈ acc') : s.Dom a acc' := + let ⟨p, n, h1, h2, h3⟩ := h + ⟨p, n, h1, h2, fun y hy => (h3 y hy).imp id (hs _)⟩ + +/-- A dominated edge contributes nothing beyond the normal form. -/ +theorem NormLevel.Dom.le {s : NormLevel} (h : s.Dom a acc) : + evalPath ls ρ (a :: acc) (evalParam ls ρ a) ≤ s.eval ls ρ := by + refine evalPath_le.2 fun nz => ?_ + rw [allNZ_cons] at nz + obtain ⟨p, n, h1, ⟨x, hx, hxa⟩, h3⟩ := h + have hnz : allNZ ls ρ p := by + simp only [allNZ, List.all_eq_true, decide_eq_true_eq] + refine fun y hy => (h3 y hy).elim (fun e => e ▸ nz.1) fun hy => ?_ + simp only [allNZ, List.all_eq_true, decide_eq_true_eq] at nz + exact nz.2 _ hy + refine Nat.le_trans ?_ (Nat.le_trans (Node.var_le_eval hx) + (evalPath_le.1 (NormLevel.eval_le.1 (Nat.le_refl _) _ _ h1) hnz)) + simp only [VarNode.eval, ← hxa]; omega + +theorem NormLevel.addable_sound {s : NormLevel} (h : s.addable a acc) : s.Dom a acc := by + simp only [addable, Std.TreeMap.any_eq_any_toList, List.any_eq_true, Bool.and_eq_true, + beq_iff_eq] at h + obtain ⟨⟨p, n⟩, hm, ⟨x, hx, hxa⟩, hsub⟩ := h + refine ⟨p, n, Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hm, + ⟨x, hx, hxa⟩, fun y hy => ?_⟩ + by_cases hya : y = a + · exact .inl hya + · exact .inr (subset_mem hsub ((List.mem_erase_of_ne hya).2 hy)) + +theorem NormLevel.addable_complete {s : NormLevel} (hs : ∀ p n, s.get? p = some n → Sorted p) + (hacc : Sorted acc) (h : s.Dom a acc) : s.addable a acc := by + obtain ⟨p, n, h1, ⟨x, hx, hxa⟩, h3⟩ := h + simp only [addable, Std.TreeMap.any_eq_any_toList, List.any_eq_true, Bool.and_eq_true, + beq_iff_eq] + refine ⟨(p, n), Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 (by simpa using h1), + ⟨x, hx, hxa⟩, subset_of_sorted (hs _ _ h1).erase hacc fun y hy => ?_⟩ + refine (h3 y (List.mem_of_mem_erase hy)).resolve_left fun e => ?_ + exact absurd (e ▸ hy) ((hs _ _ h1).nodup.not_mem_erase) + +/-- The conditions `rem` can be added to `acc` one at a time, each addition dominated. -/ +inductive NormLevel.Feas (s : NormLevel) : List Name → List Name → Prop + | nil {acc} : Feas s acc [] + | cons {acc a rem} : a ∈ rem → s.Dom a acc → Feas s (a :: acc) (rem.erase a) → Feas s acc rem + +theorem NormLevel.Feas.mono {s : NormLevel} (hs : ∀ x ∈ acc, x ∈ acc') + (h : Feas s acc rem) : Feas s acc' rem := by + induction h generalizing acc' with | nil => exact .nil | cons hm hd _ ih + refine .cons hm (hd.mono hs) <| ih fun x hx => ?_ + obtain rfl | hx := List.mem_cons.1 hx + · exact .head _ + · exact .tail _ (hs _ hx) + +/-- Greedy exchange: a dominated element can always be taken first. -/ +theorem NormLevel.Feas.exchange {s : NormLevel} (h : Feas s acc rem) : + ∀ {a}, a ∈ rem → s.Dom a acc → Feas s (a :: acc) (rem.erase a) := by + induction h with | nil => nofun | @cons acc b rem hmb hdb H ih + intro a hm hd + by_cases hab : a = b <;> [(subst hab; exact H); skip] + refine .cons ((List.mem_erase_of_ne (Ne.symm hab)).2 hmb) (hdb.mono fun x hx => .tail _ hx) ?_ + rw [List.erase_comm] + refine ih ((List.mem_erase_of_ne hab).2 hm) (hd.mono fun x hx => .tail _ hx) + |>.mono fun x hx => ?_ + obtain rfl | hx := List.mem_cons.1 hx + · exact .tail _ (.head _) + · obtain rfl | hx := List.mem_cons.1 hx + · exact .head _ + · exact .tail _ (.tail _ hx) + +/-- Peel off the element added last: it is dominated by all the others. -/ +theorem NormLevel.Feas.peel {s : NormLevel} (h : Feas s acc rem) (nd : rem.Nodup) (hne : rem ≠ []) : + ∃ a ∈ rem, s.Dom a (acc ++ rem.erase a) ∧ Feas s acc (rem.erase a) := by + induction h with + | nil => exact absurd rfl hne + | @cons acc b rem hmb hdb H ih => + by_cases he : rem.erase b = [] + · exact ⟨b, hmb, hdb.mono fun x hx => List.mem_append_left _ hx, he ▸ .nil⟩ + obtain ⟨a, hma, hda, hfa⟩ := ih (nd.erase _) he + have hab : a ≠ b := by rintro rfl; exact absurd hma nd.not_mem_erase + have hmb' : b ∈ rem.erase a := (List.mem_erase_of_ne (Ne.symm hab)).2 hmb + refine ⟨a, List.mem_of_mem_erase hma, hda.mono fun x hx => ?_, ?_⟩ + · simp only [List.cons_append, List.mem_cons, List.mem_append] at hx ⊢ + obtain rfl | hx | hx := hx + · exact .inr hmb' + · exact .inl hx + · rw [List.erase_comm] at hx; exact .inr (List.mem_of_mem_erase hx) + · exact .cons hmb' hdb <| by rw [List.erase_comm]; exact hfa + +theorem NormLevel.feasible_go_sound {s : NormLevel} : + ∀ {fuel acc rem}, NormLevel.feasible.go s fuel acc rem → s.Feas acc rem + | 0, _, rem, h => by simp [feasible.go, List.isEmpty_iff] at h; exact h ▸ .nil + | fuel+1, acc, rem, h => by + rw [feasible.go] at h + split at h <;> [(let [] := rem; exact .nil); rename_i a ha] + have hm := List.mem_of_find?_eq_some ha + have hd := addable_sound (List.find?_eq_some_iff_getElem.1 ha).1 + refine .cons hm hd ((feasible_go_sound h).mono fun x hx => ?_) + exact List.mem_cons.2 ((Extend?.orderedInsert (cmp := Name.cmp) (v := a) (p := acc)).mem.1 hx) + +theorem NormLevel.feasible_sound {s : NormLevel} (h : s.feasible acc rem) : s.Feas acc rem := + feasible_go_sound h + +theorem NormLevel.feasible_go_complete {s : NormLevel} (hs : ∀ p n, s.get? p = some n → Sorted p) : + ∀ {fuel acc rem}, rem.length ≤ fuel → Sorted acc → s.Feas acc rem → feasible.go s fuel acc rem + | 0, _, rem, hf, _, _ => by + rw [feasible.go]; cases rem with | nil => rfl | cons => cases hf + | fuel+1, acc, rem, hf, hacc, h => by + rw [feasible.go] + split <;> [rename_i ha; rename_i a ha] + · -- the first element of the chain is addable, so `find?` cannot fail + cases h with | nil => rfl | @cons b _ _ hm hd + exact absurd (addable_complete hs hacc hd) (by simpa using List.find?_eq_none.1 ha _ hm) + · have hm := List.mem_of_find?_eq_some ha + have hd := addable_sound (List.find?_eq_some_iff_getElem.1 ha).1 + have hext := Extend?.orderedInsert (cmp := Name.cmp) (v := a) (p := acc) + refine feasible_go_complete hs ?_ ?_ ((h.exchange hm hd).mono fun x hx => hext.mem.2 ?_) + · rw [List.length_erase_of_mem hm]; omega + · match he : Normalize.orderedInsert Name.cmp a acc with + | none => exact hacc + | some acc' => exact hacc.orderedInsert he + · exact List.mem_cons.1 hx + +theorem NormLevel.feasible_complete {s : NormLevel} (hs : ∀ p n, s.get? p = some n → Sorted p) + (hacc : Sorted acc) (h : s.Feas acc rem) : s.feasible acc rem := + feasible_go_complete hs (Nat.le_refl _) hacc h + +theorem NormLevel.Feas.perm {s : NormLevel} (h : Feas s acc rem) (hp : rem.Perm rem') : + Feas s acc rem' := by + induction h generalizing rem' with + | nil => cases hp.nil_eq; exact .nil + | cons hm hd _ ih => exact .cons (hp.mem_iff.1 hm) hd (ih (hp.erase _)) + +/-- Extend a chain on the inside: the new element's conditions are all the others. -/ +theorem NormLevel.Feas.cons_last {s : NormLevel} (h : Feas s acc rem) (hnm : a ∉ rem) + (hd : s.Dom a (acc ++ rem)) : Feas s acc (a :: rem) := by + induction h with + | nil => exact .cons (.head _) (by simpa using hd) (by simpa using Feas.nil) + | @cons acc b rem hmb hdb _ ih => + have hab : b ≠ a := fun e => hnm (e ▸ hmb) + refine .cons (.tail _ hmb) hdb ?_ + rw [List.erase_cons_tail (by simpa using Ne.symm hab)] + refine ih (fun h => hnm (List.mem_of_mem_erase h)) (hd.mono fun x hx => ?_) + -- everything outside `a` is still there: `b` moved into the accumulator + simp only [List.cons_append, List.mem_cons, List.mem_append] at hx ⊢ + obtain hx | hx := hx + · exact .inr (.inl hx) + · by_cases hxb : x = b + · exact .inl hxb + · exact .inr (.inr ((List.mem_erase_of_ne hxb).2 hx)) + +/-- Every key of a well-formed normal form admits a chain: its `WF` parent is a key with one +condition fewer, and the variable relating them dominates the edge between them. -/ +theorem NormLevel.WF.feas {s : NormLevel} (wf : s.WF) : ∀ {p}, s.contains p → s.Feas [] p := by + intro p + generalize eq : p.length = len + induction len generalizing p with + | zero => cases List.eq_nil_of_length_eq_zero eq; exact fun _ => .nil + | succ len ih => + intro hp + have hne : p ≠ [] := by rintro rfl; cases eq + obtain ⟨n, hn⟩ := Option.isSome_iff_exists.1 (Std.TreeMap.isSome_getElem?_eq_contains.trans hp) + obtain ⟨v, p', h1, h2, x, hx, hxv⟩ := (wf _ _ hn).1 hne + have hperm : p.Perm (v :: p') := by cases h1; exact List.perm_middle + have hnm : v ∉ p' := by + have := (wf.sortedOf (.inr hp)).nodup + rw [hperm.nodup_iff] at this + exact (List.nodup_cons.1 this).1 + refine Feas.perm ?_ hperm.symm + refine Feas.cons_last (h2.elim (fun e => by subst e; exact .nil) (fun h => ih (by + have := h1.length; omega) h)) hnm ⟨p, n, hn, ⟨x, hx, hxv⟩, fun y hy => ?_⟩ + simpa using (h1.mem.1 hy).imp id id + +/-- Domination only reads off variable names and their keys, so a map that covers another +dominates whatever it does. -/ +theorem NormLevel.Dom.mono_map {s s' : NormLevel} (h : s'.Covers s) (hd : s.Dom a acc) : + s'.Dom a acc := by + obtain ⟨p, n, hp, ⟨x, hx, hxa⟩, hcond⟩ := hd + obtain ⟨q, m, y, hq, hy, e, hsub⟩ := h _ _ _ hp hx + exact ⟨q, m, hq, ⟨y, hy, e.trans hxa⟩, fun z hz => hcond _ (hsub _ hz)⟩ + +theorem NormLevel.Feas.mono_map {s s' : NormLevel} (h : s'.Covers s) : + ∀ {acc rem}, s.Feas acc rem → s'.Feas acc rem + | _, _, .nil => .nil + | _, _, .cons hm hd H => .cons hm (hd.mono_map h) (Feas.mono_map h H) + +/-- Every key of the normal form admits a chain. `WF.feas` gives this for the map `normalizeAux` +builds; subsumption keeps it because it covers that map, dropping a variable only in favour of +one with the same name at a smaller key. -/ +theorem normalize_feas : ∀ p, (normalize u).contains p → (normalize u).Feas [] p := by + intro p hp + have wf : (normalizeAux u [] 0 {}).WF := normalizeAux_wf (by simp) (by simp [NormLevel.WF]) + refine NormLevel.Feas.mono_map NormLevel.subsumption_covers.2 (wf.feas ?_) + obtain ⟨n, hn⟩ := Option.isSome_iff_exists.1 (Std.TreeMap.isSome_getElem?_eq_contains.trans hp) + obtain ⟨n₀, h₀, -⟩ := NormLevel.subsumption_covers.1 p n + (by rw [Std.TreeMap.get?_eq_getElem?]; exact hn) + exact Std.TreeMap.isSome_getElem?_eq_contains.symm.trans + (by simp [Std.TreeMap.get?_eq_getElem?] at h₀; simp [h₀]) + +/-- An admissible chain, innermost first: each element is dominated relative to the +conditions outside it. -/ +def NormLevel.Adm (s : NormLevel) : List Name → Prop + | [] => True + | a :: l => s.Dom a l ∧ s.Adm l + +/-- `lexChain` always reorders its input, even in the fallback branch. -/ +theorem NormLevel.lexChain_perm {s : NormLevel} : ∀ {fuel p}, (s.lexChain fuel p).Perm p + | 0, p => by rw [lexChain] + | fuel+1, p => by + rw [lexChain] + split + · rename_i a ha + exact .trans (.cons _ lexChain_perm) + (List.perm_cons_erase (List.mem_of_find?_eq_some ha)).symm + · exact .refl _ + +/-- Whenever a key admits some chain, `lexChain` returns one: it reorders the key, and +every edge of the resulting `imax` chain is dominated. -/ +theorem NormLevel.lexChain_spec {s : NormLevel} (hs : ∀ p n, s.get? p = some n → Sorted p) : + ∀ {fuel p}, p.length ≤ fuel → Sorted p → s.Feas [] p → + (s.lexChain fuel p).Perm p ∧ s.Adm (s.lexChain fuel p) + | 0, p, hf, _, _ => by + rw [lexChain]; cases p with | nil => exact ⟨.refl _, trivial⟩ | cons => cases hf + | fuel+1, p, hf, hp, h => by + rw [lexChain] + split + · rename_i a ha + have hm := List.mem_of_find?_eq_some ha + have hpred := List.find?_eq_some_iff_getElem.1 ha |>.1 + simp only [Bool.and_eq_true] at hpred + have hlen : (p.erase a).length ≤ fuel := by + rw [List.length_erase_of_mem hm]; omega + obtain ⟨hperm, hadm⟩ := + lexChain_spec hs hlen hp.erase (feasible_sound hpred.2) + refine ⟨.trans (.cons _ hperm) (List.perm_cons_erase hm).symm, ?_, hadm⟩ + exact (addable_sound hpred.1).mono fun x hx => hperm.mem_iff.2 hx + · rename_i hnone + -- the chain that exists ends somewhere, and `find?` would have found that element + refine ⟨.refl _, ?_⟩ + match p, h with + | [], _ => exact trivial + | b :: p, h => + obtain ⟨a, hm, hd, hfa⟩ := h.peel hp.nodup (by simp) + have h1 : s.addable a ((b :: p).erase a) := + addable_complete hs hp.erase (by simpa using hd) + have h2 : s.feasible [] ((b :: p).erase a) := feasible_complete hs Sorted.nil hfa + have hnot := List.find?_eq_none.1 hnone _ hm + simp [h1, h2] at hnot + +theorem NormLevel.Adm.suffix {s : NormLevel} : ∀ {l}, s.Adm l → a :: q <:+ l → s.Dom a q + | [], _, h => by simp at h + | b :: l, ⟨h1, h2⟩, h => by + obtain ⟨l', he⟩ := h + match l' with + | [] => cases he; exact h1 + | c :: l' => exact Adm.suffix h2 ⟨l', by cases he; rfl⟩ + +/-! ### Building the tree -/ + +theorem evalPath_le_self : evalPath ls ρ path c ≤ c := by rw [evalPath]; split <;> simp + +theorem evalPath_perm (h : p.Perm p') : evalPath ls ρ p c = evalPath ls ρ p' c := by + simp only [evalPath, show allNZ ls ρ p = allNZ ls ρ p' from Bool.eq_iff_iff.2 + ⟨allNZ_mono fun _ hx => h.symm.mem_iff.1 hx, allNZ_mono fun _ hx => h.mem_iff.1 hx⟩] + +theorem evalPath_singleton : + evalPath ls ρ [a] c = if 0 < evalParam ls ρ a then c else 0 := by simp [evalPath, allNZ] + +theorem evalPath_single : evalPath ls ρ p (evalPath ls ρ [a] c) = evalPath ls ρ (a :: p) c := by + rw [evalPath_singleton, ← evalPath_cons] + +theorem imax_eq_evalPath : Lean.Nat.imax c (evalParam ls ρ a) = + max' (evalPath ls ρ [a] c) (evalPath ls ρ [a] (evalParam ls ρ a)) := by + by_cases h : evalParam ls ρ a = 0 <;> + simp [imax_eq_ite, evalPath_singleton, h, Nat.pos_of_ne_zero] + +/-- `modify` read from the outside in, matching the way `Tree.At` extends a path: the +shallowest element of the path selects a child, and the rest is modified inside it. -/ +theorem Tree.modify_append (path : List Name) (g : Tree → Tree) (b : Name) (t : Tree) : + Tree.modify (path ++ [b]) g t = + { t with child := modifyAt (Tree.modify path g) b t.child } := by + induction path generalizing t g with + | nil => rfl + | cons a p ih => rw [List.cons_append, Tree.modify, ih]; rfl + +/-- All that matters about `modifyAt`: it replaces one entry with key `a` by `f` of it, or +inserts `(a, f default)` somewhere if there is none, and leaves the rest of the list alone. -/ +theorem modifyAt_eq (f : Tree → Tree) (a : Name) (l : List (Name × Tree)) : + ∃ l₁ l₂ y, modifyAt f a l = l₁ ++ (a, f y) :: l₂ ∧ + (l = l₁ ++ l₂ ∧ y = default ∨ l = l₁ ++ (a, y) :: l₂) := by + induction l with + | nil => exact ⟨[], [], default, rfl, .inl ⟨rfl, rfl⟩⟩ + | cons b l ih => + obtain ⟨b, t⟩ := b + match he : Name.cmp a b with + | .lt => exact ⟨[], (b, t) :: l, default, by simp [modifyAt, he], .inl ⟨rfl, rfl⟩⟩ + | .eq => + rw [Std.LawfulBEqCmp.compare_eq_iff_beq (cmp := Name.cmp)] at he + cases eq_of_beq he + exact ⟨[], l, t, by + simp [modifyAt, Std.ReflCmp.compare_self (cmp := Name.cmp)], .inr rfl⟩ + | .gt => + obtain ⟨l₁, l₂, y, h1, h2⟩ := ih + exact ⟨(b, t) :: l₁, l₂, y, by simp [modifyAt, he, h1], + h2.imp (fun ⟨h, hy⟩ => ⟨by simp [h], hy⟩) fun h => by simp [h]⟩ + +theorem mem_modifyAt_self (f : Tree → Tree) (a : Name) (l : List (Name × Tree)) : + ∃ y, (a, f y) ∈ modifyAt f a l := by + obtain ⟨l₁, l₂, y, h, -⟩ := modifyAt_eq f a l + exact ⟨y, by rw [h]; simp⟩ + +/-- The node `modify` writes is there to be found, and its data does not depend on what was +at the path before: the payload of a key is what sits at the end of its chain. -/ +theorem Tree.At_modify_self (path : List Name) (g : Tree → Tree) (t : Tree) : + ∃ t₀, Tree.At (t.modify path g) path (g t₀) := by + suffices ∀ (r : List Name) (g : Tree → Tree) (t : Tree), + ∃ t₀, Tree.At (Tree.modify r.reverse g t) r.reverse (g t₀) by + simpa using this path.reverse g t + clear path g t; intro r + induction r with + | nil => exact fun g t => ⟨t, .nil⟩ + | cons b r ih => + intro g t + rw [List.reverse_cons, Tree.modify_append] + obtain ⟨x, hx⟩ := mem_modifyAt_self (f := Tree.modify r.reverse g) b t.child + obtain ⟨t₀, ht₀⟩ := ih g x + exact ⟨t₀, ht₀.append hx⟩ + +/-- Nothing is lost: an entry either survives `modifyAt` untouched, or is the one it modifies. +(The second case does not need the entry to be the *first* one with its key, so no +duplicate-freedom assumption is needed here or below.) -/ +theorem mem_modifyAt {f : Tree → Tree} {l : List (Name × Tree)} (hm : (c, x) ∈ l) : + (c, x) ∈ modifyAt f a l ∨ (c = a ∧ (c, f x) ∈ modifyAt f a l) := by + obtain ⟨l₁, l₂, y, h, h'⟩ := modifyAt_eq f a l + rw [h] + obtain ⟨rfl, -⟩ | rfl := h' + · obtain hm | hm := List.mem_append.1 hm + · exact .inl (List.mem_append.2 (.inl hm)) + · exact .inl (List.mem_append.2 (.inr (.tail _ hm))) + · obtain hm | hm := List.mem_append.1 hm + · exact .inl (List.mem_append.2 (.inl hm)) + obtain heq | hm := List.mem_cons.1 hm + · simp only [Prod.mk.injEq] at heq; obtain ⟨rfl, rfl⟩ := heq + exact .inr ⟨rfl, List.mem_append.2 (.inr (.head _))⟩ + · exact .inl (List.mem_append.2 (.inr (.tail _ hm))) + +/-- A node written at one path survives a later write at a different path: the write only +replaces the data of the node it lands on, and every other node keeps its own. -/ +theorem Tree.At_modify_of_ne_aux {g : Tree → Tree} (hg : ∀ t, (g t).child = t.child) : + ∀ (r : List Name) {path t t'}, path ≠ r.reverse → At t path t' → + ∃ t'', At (Tree.modify r.reverse g t) path t'' ∧ + t''.const = t'.const ∧ t''.var = t'.var := by + intro r + induction r with + | nil => + intro path t t' hne h + rw [List.reverse_nil, Tree.modify] + obtain h' | ⟨rfl, rfl⟩ := h.of_child_eq (hg t) + · exact ⟨t', h', rfl, rfl⟩ + · exact absurd rfl hne + | cons b r ih => + intro path t t' hne h + rw [List.reverse_cons, Tree.modify_append] + obtain rfl | ⟨q, a, rfl⟩ := List.eq_nil_or_concat path + · cases h.nil_inv; exact ⟨_, .nil, rfl, rfl⟩ + simp only [List.concat_eq_append, List.reverse_cons] at h hne ⊢ + obtain ⟨t₁, hm, h₁⟩ := h.append_inv + obtain hm' | ⟨rfl, hm'⟩ := mem_modifyAt (f := Tree.modify r.reverse g) (a := b) hm + · exact ⟨t', h₁.append hm', rfl, rfl⟩ + · have : q ≠ r.reverse := by rintro rfl; exact hne rfl + obtain ⟨t'', h'', hc, hv⟩ := ih this h₁ + exact ⟨t'', h''.append hm', hc, hv⟩ + +theorem Tree.At_modify_of_ne {g : Tree → Tree} (hg : ∀ t, (g t).child = t.child) + (hne : path ≠ path') (h : At t path t') : + ∃ t'', At (Tree.modify path' g t) path t'' ∧ t''.const = t'.const ∧ t''.var = t'.var := by + have := At_modify_of_ne_aux hg path'.reverse (path := path) (by rwa [List.reverse_reverse]) h + rwa [List.reverse_reverse] at this + +/-- Conversely, nothing appears from nowhere: an entry of `modifyAt` is an entry of the list, +or the modified one, which was an entry or is fresh. -/ +theorem mem_modifyAt_inv {f : Tree → Tree} {l : List (Name × Tree)} + (h : (c, x) ∈ modifyAt f a l) : + (c, x) ∈ l ∨ (c = a ∧ ∃ y, x = f y ∧ (y = default ∨ (a, y) ∈ l)) := by + induction l with + | nil => + simp only [modifyAt, List.mem_singleton, Prod.mk.injEq] at h + obtain ⟨rfl, rfl⟩ := h + exact .inr ⟨rfl, default, rfl, .inl rfl⟩ + | cons b l ih => + obtain ⟨b, t⟩ := b + match he : Name.cmp a b with + | .lt => + simp only [modifyAt, he] at h + obtain h | h := List.mem_cons.1 h + · cases h; exact .inr ⟨rfl, default, rfl, .inl rfl⟩ + · exact .inl h + | .eq => + rw [Std.LawfulBEqCmp.compare_eq_iff_beq (cmp := Name.cmp)] at he + cases eq_of_beq he + simp only [modifyAt, Std.ReflCmp.compare_self (cmp := Name.cmp)] at h + obtain h | h := List.mem_cons.1 h + · cases h; exact .inr ⟨rfl, t, rfl, .inr (.head _)⟩ + · exact .inl (.tail _ h) + | .gt => + simp only [modifyAt, he] at h + obtain h | h := List.mem_cons.1 h + · cases h; exact .inl (.head _) + · exact (ih h).imp (.tail _) fun ⟨rfl, y, hy, h⟩ => ⟨rfl, y, hy, h.imp id (.tail _)⟩ + +theorem Tree.At.of_child_nil (hc : t.child = []) (h : At t p t') : p = [] ∧ t' = t := by + obtain rfl | ⟨q, a, rfl⟩ := List.eq_nil_or_concat p + · exact ⟨rfl, h.nil_inv⟩ + · rw [List.concat_eq_append] at h + obtain ⟨t₁, hm, -⟩ := h.append_inv + rw [hc] at hm; cases hm + +theorem suffix_concat {α} {l₁ l₂ : List α} (h : l₁ <:+ l₂) (a : α) : + l₁ ++ [a] <:+ l₂ ++ [a] := by + obtain ⟨u, rfl⟩ := h; exact ⟨u, by rw [List.append_assoc]⟩ + +/-- Inverting a write: a path of the modified tree either ends at the node just written, or +is a tail of the written path whose node was created empty on the way, or was already there +carrying the same data. -/ +theorem Tree.At_modify_inv_aux {g : Tree → Tree} (hg : ∀ t, (g t).child = t.child) : + ∀ (r : List Name) {path t t'}, At (Tree.modify r.reverse g t) path t' → + (path = r.reverse ∧ ∃ t₀, t' = g t₀) ∨ + (path <:+ r.reverse ∧ t'.const = 0 ∧ t'.var = []) ∨ + (∃ t'', At t path t'' ∧ t'.const = t''.const ∧ t'.var = t''.var) := by + intro r + induction r with + | nil => + intro path t t' h + rw [List.reverse_nil, Tree.modify] at h + obtain h' | ⟨rfl, rfl⟩ := h.of_child_eq (hg t).symm + · exact .inr (.inr ⟨t', h', rfl, rfl⟩) + · exact .inl ⟨rfl, t, rfl⟩ + | cons b r ih => + intro path t t' h + rw [List.reverse_cons, Tree.modify_append] at h + obtain rfl | ⟨q, a, rfl⟩ := List.eq_nil_or_concat path + · cases h.nil_inv; exact .inr (.inr ⟨t, .nil, rfl, rfl⟩) + rw [List.concat_eq_append] at h ⊢ + obtain ⟨t₁, hm, h₁⟩ := h.append_inv + obtain hm | ⟨rfl, y, rfl, hy⟩ := mem_modifyAt_inv hm + · exact .inr (.inr ⟨t', h₁.append hm, rfl, rfl⟩) + · obtain ⟨rfl, t₀, rfl⟩ | ⟨hs, hc, hv⟩ | ⟨t'', h'', hc, hv⟩ := ih h₁ + · exact .inl ⟨by rw [List.reverse_cons], t₀, rfl⟩ + · exact .inr (.inl ⟨by rw [List.reverse_cons]; exact suffix_concat hs _, hc, hv⟩) + · obtain rfl | hy := hy + · obtain ⟨rfl, rfl⟩ := h''.of_child_nil rfl + exact .inr (.inl ⟨by rw [List.reverse_cons]; exact ⟨r.reverse, by simp⟩, hc, hv⟩) + · exact .inr (.inr ⟨t'', h''.append hy, hc, hv⟩) + +theorem Tree.At_modify_inv {g : Tree → Tree} (hg : ∀ t, (g t).child = t.child) + (h : At (Tree.modify path' g t) path t') : + (path = path' ∧ ∃ t₀, t' = g t₀) ∨ + (path <:+ path' ∧ t'.const = 0 ∧ t'.var = []) ∨ + (∃ t'', At t path t'' ∧ t'.const = t''.const ∧ t'.var = t''.var) := by + have := At_modify_inv_aux hg path'.reverse (path := path) + (by rwa [List.reverse_reverse]) (t' := t') + rwa [List.reverse_reverse] at this + +/-- Sorted lists with the same elements are equal, so distinct keys reify to distinct paths: +`lexChain` only permutes a key. -/ +theorem Sorted.perm_eq (h₁ : Sorted l₁) (h₂ : Sorted l₂) (h : l₁.Perm l₂) : l₁ = l₂ := by + induction l₁ generalizing l₂ with + | nil => exact h.nil_eq + | cons a l₁ ih => + match l₂, h₂, h with + | [], _, h => simp at h + | b :: l₂, h₂, h => + have hab : a = b := by + -- each head is at most every element of the other list + obtain rfl | ha := List.mem_cons.1 (h.mem_iff.1 (.head _)) + · rfl + obtain rfl | hb := List.mem_cons.1 (h.symm.mem_iff.1 (.head _)) + · rfl + exact absurd (h₂.head _ ha) (by + rw [Std.OrientedCmp.gt_of_lt (h₁.head _ hb)]; simp) + subst hab + rw [ih h₁.of_cons h₂.of_cons ((List.perm_cons _).1 h)] + +/-- The variables the reconstruction records for the entry `(p, n)`: those of `n`, except the +one the edge into the node already contributes. -/ +def NormLevel.treeVar (s : NormLevel) (p : List Name) (n : Node) : List VarNode := + if let v :: _ := s.lexChain p.length p then subsumeVars n.var [⟨v, 0⟩] else n.var + +/-- The entry `(p, n)` is recorded in `t`: at the end of `p`'s chain sits a node carrying +`n`'s constant and `treeVar p n`. -/ +def NormLevel.WrittenAt (s : NormLevel) (t : Tree) (p : List Name) (n : Node) : Prop := + ∃ t', Tree.At t (s.lexChain p.length p) t' ∧ t'.const = n.const ∧ t'.var = s.treeVar p n + +theorem NormLevel.WrittenAt.write {s : NormLevel} (t : Tree) (p : List Name) (n : Node) : + s.WrittenAt (t.modify (s.lexChain p.length p) + fun t => { t with const := n.const, var := s.treeVar p n }) p n := + let ⟨_, h⟩ := Tree.At_modify_self _ _ t + ⟨_, h, rfl, rfl⟩ + +/-- Distinct keys get distinct chains, since `lexChain` only permutes a sorted key. -/ +theorem NormLevel.lexChain_inj {s : NormLevel} (h₁ : Sorted p) (h₂ : Sorted p') + (h : s.lexChain p.length p = s.lexChain p'.length p') : p = p' := by + refine Sorted.perm_eq h₁ h₂ ((lexChain_perm (s := s) (fuel := p.length) (p := p)).symm.trans ?_) + rw [h]; exact lexChain_perm + +/-- Conversely, everything the tree contains comes from an entry: every nonempty path is a +tail of some key's chain, and the node at the end of a path is either empty scaffolding or +the entry whose chain leads there. -/ +def NormLevel.Accounted (s : NormLevel) (t : Tree) : Prop := + ∀ path t', Tree.At t path t' → + (path ≠ [] → ∃ p n, s.get? p = some n ∧ path <:+ s.lexChain p.length p) ∧ + (t'.const = 0 ∧ t'.var = [] ∨ ∃ p n, s.get? p = some n ∧ + path = s.lexChain p.length p ∧ t'.const = n.const ∧ t'.var = s.treeVar p n) + +/-- The single pass over the map that both directions of soundness read off: after the fold +every entry is recorded at the end of its chain, and everything in the tree is accounted for +by an entry. A write puts its own entry there (`At_modify_self`) and leaves the others alone, +either because it lands on a different path — distinct keys have distinct chains — or because +it lands on the same key, and then writes the same data. -/ +theorem NormLevel.toTree_spec {s : NormLevel} (hsort : ∀ p n, s.get? p = some n → Sorted p) : + s.Accounted (toTree s) ∧ ∀ p n, s.get? p = some n → s.WrittenAt (toTree s) p n := by + rw [toTree, Std.TreeMap.foldl_eq_foldl_toList] + have hmem : ∀ pn : List Name × Node, pn ∈ s.toList ↔ s.get? pn.1 = some pn.2 := fun _ => + Std.TreeMap.mem_toList_iff_getElem?_eq_some.trans (by rw [Std.TreeMap.get?_eq_getElem?]) + have hinit : s.Accounted ⟨0, [], []⟩ := fun path t' h => by + obtain ⟨rfl, rfl⟩ := h.of_child_nil rfl + exact ⟨fun h => absurd rfl h, .inl ⟨rfl, rfl⟩⟩ + suffices ∀ (l : List (List Name × Node)) (t : Tree), + (∀ pn ∈ l, s.get? pn.1 = some pn.2) → s.Accounted t → + s.Accounted (List.foldl (fun t pn => + let path := s.lexChain pn.1.length pn.1 + let var := if let v :: _ := path then subsumeVars pn.2.var [⟨v, 0⟩] else pn.2.var + t.modify path fun t => { t with const := pn.2.const, var }) t l) ∧ + ∀ p n, s.get? p = some n → (s.WrittenAt t p n ∨ (p, n) ∈ l) → + s.WrittenAt (List.foldl (fun t pn => + let path := s.lexChain pn.1.length pn.1 + let var := if let v :: _ := path then subsumeVars pn.2.var [⟨v, 0⟩] else pn.2.var + t.modify path fun t => { t with const := pn.2.const, var }) t l) p n by + have := this _ _ (fun pn h => (hmem pn).1 h) hinit + exact ⟨this.1, fun p n hp => this.2 p n hp (.inr ((hmem (p, n)).2 hp))⟩ + clear hmem hinit; intro l + induction l with + | nil => exact fun _ _ h => ⟨h, fun _ _ _ h => h.resolve_right (by simp)⟩ + | cons pn l ih => + obtain ⟨p', n'⟩ := pn + intro t hl hacc + have hp' : s.get? p' = some n' := hl _ (.head _) + refine (ih _ (fun _ h => hl _ (.tail _ h)) ?_).imp id fun H p n hp h => H p n hp ?_ + · -- nothing unaccounted for appears: the write adds its own node and empty scaffolding + intro path t' h + obtain ⟨rfl, t₀, rfl⟩ | ⟨hs, hc, hv⟩ | ⟨t'', h'', hc, hv⟩ := + Tree.At_modify_inv (g := fun t => + { t with const := n'.const, var := s.treeVar p' n' }) (fun _ => rfl) h + · exact ⟨fun _ => ⟨p', n', hp', List.suffix_refl _⟩, .inr ⟨p', n', hp', rfl, rfl, rfl⟩⟩ + · exact ⟨fun _ => ⟨p', n', hp', hs⟩, .inl ⟨hc, hv⟩⟩ + · exact ⟨(hacc _ _ h'').1, by rw [hc, hv]; exact (hacc _ _ h'').2⟩ + · -- and nothing already written is lost + obtain ⟨t', hat, hc, hv⟩ | h := h + · refine .inl ?_ + by_cases hpp : p = p' + · subst hpp; cases hp.symm.trans hp'; exact .write .. + · obtain ⟨t'', hat', hc', hv'⟩ := Tree.At_modify_of_ne (g := fun t => + { t with const := n'.const, var := s.treeVar p' n' }) (fun _ => rfl) + (fun he => hpp (lexChain_inj (hsort _ _ hp) (hsort _ _ hp') he)) hat + exact ⟨t'', hat', hc' ▸ hc, hv' ▸ hv⟩ + · obtain h | h := List.mem_cons.1 h + · simp only [Prod.mk.injEq] at h + obtain ⟨rfl, rfl⟩ := h + exact .inl (.write ..) + · exact .inr h + +/-- What the reconstruction contributes, as a biconditional: the tree is bounded by `m` +exactly when for every entry the node the tree records for it is, and so is every edge of its +chain. Nothing here is about domination, so no hypothesis on the chains is needed. -/ +theorem NormLevel.toTree_le_iff {s : NormLevel} (hsort : ∀ p n, s.get? p = some n → Sorted p) + {m : Nat} : Tree.eval ls ρ (toTree s) ≤ m ↔ + ∀ p n, s.get? p = some n → + evalPath ls ρ (s.lexChain p.length p) (Node.eval ls ρ ⟨n.const, s.treeVar p n⟩) ≤ m ∧ + ∀ a q, a :: q <:+ s.lexChain p.length p → + evalPath ls ρ (a :: q) (evalParam ls ρ a) ≤ m := by + obtain ⟨hacc, hwr⟩ := toTree_spec hsort + rw [Tree.eval_le_iff] + refine ⟨fun ⟨h1, h2⟩ p n hp => ?_, fun H => ⟨fun path t' hat => ?_, fun a q t' hat => ?_⟩⟩ + · obtain ⟨t', hat, hc, hv⟩ := hwr p n hp + refine ⟨by rw [← hc, ← hv]; exact h1 _ _ hat, fun a q hq => ?_⟩ + obtain ⟨t'', hat''⟩ := hat.suffix hq + exact h2 _ _ _ hat'' + · obtain ⟨-, ⟨hc, hv⟩ | ⟨p, n, hp, rfl, hc, hv⟩⟩ := hacc _ _ hat + · rw [show Node.eval ls ρ ⟨t'.const, t'.var⟩ = 0 from by simp [Node.eval, hc, hv]] + simp [evalPath] + · rw [hc, hv]; exact (H p n hp).1 + · obtain ⟨p, n, hp, hsuf⟩ := (hacc _ _ hat).1 (by simp) + exact (H p n hp).2 _ _ hsuf + +/-- Soundness of the reconstruction: the tree built from a normal form, hence the level it +reifies to, evaluates like the normal form. Below, because the node recorded for an entry +carries a subset of its sublevels and every edge is dominated, `lexChain` emitting only +admissible chains; above, because the one sublevel the node omits, `V(p, v, 0)` for the +innermost element of the chain, is what the edge into it contributes. -/ +theorem NormLevel.toTree_eval {s : NormLevel} (hsort : ∀ p n, s.get? p = some n → Sorted p) + (hfeas : ∀ p, s.contains p → s.Feas [] p) : + Tree.eval ls ρ (toTree s) = s.eval ls ρ := by + refine ext_le fun m => (toTree_le_iff hsort).trans (Iff.trans ?_ NormLevel.eval_le.symm) + refine ⟨fun H p n hp => ?_, fun H p n hp => ⟨?_, fun a q hq => ?_⟩⟩ + · -- the entry is the node the tree records for it, plus the edge into that node + rw [← evalPath_perm (lexChain_perm (s := s) (fuel := p.length) (p := p))] + refine evalPath_le.2 fun nz => ?_ + have h1 := evalPath_le.1 (H p n hp).1 nz + rw [Node.eval_le] at h1 ⊢ + refine ⟨h1.1, ?_⟩ + rw [NormLevel.treeVar] at h1 + split at h1 + · rename_i v q hch + refine (subsumeVars_eval ?_).1 h1.2 + simp only [List.mem_singleton, VarNode.eval] + rintro _ rfl + exact evalPath_le.1 ((H p n hp).2 v q (by rw [hch]; exact List.suffix_refl _)) (hch ▸ nz) + · exact h1.2 + · -- the recorded node is part of the entry + rw [evalPath_perm (lexChain_perm (s := s) (fuel := p.length) (p := p))] + refine Nat.le_trans (evalPath_mono ?_) (H p n hp) + refine Node.eval_le.2 ⟨Node.const_le_eval (l := n), fun v hv => Node.var_le_eval ?_⟩ + revert hv; rw [NormLevel.treeVar]; split + · exact subsumeVars_subset + · exact id + · -- and every edge of the chain is dominated by an entry + have hcon : s.contains p := Std.TreeMap.isSome_getElem?_eq_contains.symm.trans + (by simp [Std.TreeMap.get?_eq_getElem?] at hp; simp [hp]) + obtain ⟨-, hadm⟩ := lexChain_spec hsort (Nat.le_refl _) (hsort _ _ hp) (hfeas _ hcon) + exact Nat.le_trans (hadm.suffix hq).le (NormLevel.eval_le.2 H) + end Normalize theorem isEquiv'_wf (h : isEquiv' u v) @@ -1137,6 +2201,17 @@ theorem isEquiv'_wf (h : isEquiv' u v) rw [← Normalize.normalize_eval (ρ := ρ) hu, ← Normalize.normalize_eval (ρ := ρ) hv] exact Normalize.NormLevel.eval_congr h +/-- Soundness of reification: the level `normalize'` reconstructs evaluates like the input +everywhere. Reification is `toTree` followed by `reify`, and both preserve the value: the +tree's `imax` chains contribute nothing the normal form does not already have, since every +key admits a chain (`normalize_feas`) and `lexChain` then picks an admissible one, and +nothing is lost, since every entry is recorded at the end of its chain. -/ +theorem normalize'_eval (hu : VLevel.ofLevel ls u = some u') : + Level.eval (Normalize.evalParam ls ρ) μ (normalize' u) = u'.eval ρ := by + rw [normalize', Normalize.Tree.reify_eval, + Normalize.NormLevel.toTree_eval Normalize.normalize_sorted Normalize.normalize_feas] + exact Normalize.normalize_eval hu + theorem geq'_wf (h : geq' u v) (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') : v' ≤ u' := by intro ρ From 8b51c9c091bceaa77553817377946206da39b8f0 Mon Sep 17 00:00:00 2001 From: Mario Carneiro Date: Tue, 11 Aug 2026 07:51:50 +0200 Subject: [PATCH 35/51] verify: prove completeness of isEquiv' and geq' Semantically equal levels have equal normal forms, and NormLevel.le accepts every valid semantic inequality. The key is a converse to Theorem 39 (separation): evaluating at a valuation tailored to a single sublevel forces a syntactic dominator among the sublevels of the bounding form. Completeness of le then follows from exactness of the subsumeBy fold, and canonicity from the fact that subsumption leaves no sublevel dominated by another slot (Reduced), so mutual domination pins the two maps to be equal. Co-Authored-By: Claude Fable 5 --- Lean4Lean/Verify/Level.lean | 1054 +++++++++++++++++++++++++++++++++++ 1 file changed, 1054 insertions(+) diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index 5f081e37..9ddfe536 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -2190,6 +2190,1022 @@ theorem NormLevel.toTree_eval {s : NormLevel} (hsort : ∀ p n, s.get? p = some obtain ⟨-, hadm⟩ := lexChain_spec hsort (Nat.le_refl _) (hsort _ _ hp) (hfeas _ hcon) exact Nat.le_trans (hadm.suffix hq).le (NormLevel.eval_le.2 H) +/-! +### Completeness + +`geq'` and `isEquiv'` are not only sound but complete: `NormLevel.le` detects every semantic +inequality between normal forms, and semantically equal levels have equal normal forms. The +key is a converse to Theorem 39 (`NormLevel.le_eval`): evaluating at a valuation tailored to +a single sublevel shows that a semantic bound forces a syntactic dominator among the +sublevels of the bounding form (`separation`). Completeness of `le` then follows because the +`subsumeBy` fold removes exactly the dominated sublevels, and canonicity because +`subsumption` leaves no sublevel dominated by another slot (`Reduced`), so mutual domination +forces the two maps to be equal. +-/ + +/-- The variable lists of nodes are strictly sorted by variable name. -/ +def VarsSorted (l : List VarNode) : Prop := l.Pairwise (compare ·.var ·.var = .lt) + +theorem VarsSorted.of_cons (h : VarsSorted (v :: l)) : VarsSorted l := (List.pairwise_cons.1 h).2 + +theorem VarsSorted.head (h : VarsSorted (v :: l)) : ∀ x ∈ l, compare v.var x.var = .lt := + (List.pairwise_cons.1 h).1 + +/-- In a sorted variable list, the name determines the entry. -/ +theorem VarsSorted.eq_of_var_eq (h : VarsSorted l) (h₁ : x ∈ l) (h₂ : y ∈ l) + (e : x.var = y.var) : x = y := by + induction l with | nil => cases h₁ | cons v l ih + obtain rfl | h₁' := List.mem_cons.1 h₁ + · obtain rfl | h₂' := List.mem_cons.1 h₂ + · rfl + · have := h.head _ h₂'; rw [e, Std.ReflOrd.compare_self] at this; cases this + · obtain rfl | h₂' := List.mem_cons.1 h₂ + · have := h.head _ h₁'; rw [← e, Std.ReflOrd.compare_self] at this; cases this + · exact ih h.of_cons h₁' h₂' + +theorem VarNode.mem_addVar' (h : x ∈ VarNode.addVar v k l) : x.var = v ∨ x ∈ l := by + induction l with + | nil => simp [addVar] at h; simp [h] + | cons y l ih => + simp only [addVar] at h + split at h + · rcases List.mem_cons.1 h with rfl | h <;> simp [h] + · rcases List.mem_cons.1 h with rfl | h <;> simp [h] + · rcases List.mem_cons.1 h with rfl | h + · simp + · exact (ih h).imp_right (.tail _) + +theorem VarNode.addVar_sorted (h : VarsSorted l) : VarsSorted (VarNode.addVar v k l) := by + induction l with | nil => exact .cons (by simp) .nil | cons x l ih + simp only [addVar] + split <;> rename_i hc + · refine .cons (fun y hy => ?_) h + obtain rfl | hy := List.mem_cons.1 hy + · exact hc + · exact Std.TransCmp.lt_trans hc (h.head _ hy) + · rw [Std.LawfulBEqCmp.compare_eq_iff_beq] at hc + have e := eq_of_beq hc + exact .cons (fun y hy => by rw [e]; exact h.head _ hy) h.of_cons + · refine .cons (fun y hy => ?_) (ih h.of_cons) + obtain e | hy := VarNode.mem_addVar' hy + · rw [e]; exact Std.OrientedCmp.lt_of_gt hc + · exact h.head _ hy + +/-- Every node of the map has its variable list sorted by name. -/ +def NormLevel.SortedVars (s : NormLevel) : Prop := + ∀ p n, s.get? p = some n → VarsSorted n.var + +theorem NormLevel.addVar_sortedVars (h : acc.SortedVars) : + (addVar v k path acc).SortedVars := by + intro p n hn + simp only [addVar, Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_modify] at hn + split at hn + · obtain ⟨n', hn', rfl⟩ := Option.map_eq_some_iff.1 hn + exact VarNode.addVar_sorted (h path n' (Std.TreeMap.get?_eq_getElem? .. ▸ hn')) + · exact h _ _ (Std.TreeMap.get?_eq_getElem? .. ▸ hn) + +theorem NormLevel.addNode_sortedVars (h : acc.SortedVars) : + (addNode v k path acc).SortedVars := by + intro p n hn + simp only [addNode, Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_alter] at hn + split at hn + · match e : acc[path]?, hn with + | some n', hn => + cases hn; exact VarNode.addVar_sorted (h path n' (Std.TreeMap.get?_eq_getElem? .. ▸ e)) + | none, hn => cases hn; exact .cons (by simp) .nil + · exact h _ _ (Std.TreeMap.get?_eq_getElem? .. ▸ hn) + +theorem NormLevel.addConst_sortedVars (h : acc.SortedVars) : + (addConst k path acc).SortedVars := by + intro p n hn + simp only [addConst] at hn; split at hn <;> [exact h _ _ hn; skip] + simp only [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_alter] at hn + split at hn + · match e : acc[path]?, hn with + | some n', hn => cases hn; exact h path n' (Std.TreeMap.get?_eq_getElem? .. ▸ e) + | none, hn => cases hn; exact .nil + · exact h _ _ (Std.TreeMap.get?_eq_getElem? .. ▸ hn) + +theorem normalizeAux_sortedVars (h : acc.SortedVars) : + (normalizeAux u path k acc).SortedVars := by + unfold normalizeAux; split + · exact NormLevel.addConst_sortedVars h + · exact NormLevel.addConst_sortedVars h + · exact normalizeAux_sortedVars h + · exact normalizeAux_sortedVars (normalizeAux_sortedVars h) + · exact normalizeAux_sortedVars (normalizeAux_sortedVars h) + · exact normalizeAux_sortedVars (normalizeAux_sortedVars h) + · exact normalizeAux_sortedVars (normalizeAux_sortedVars h) + · split <;> [skip; (dsimp; split)] + · exact normalizeAux_sortedVars + (NormLevel.addNode_sortedVars (NormLevel.addConst_sortedVars h)) + · exact normalizeAux_sortedVars h + · exact normalizeAux_sortedVars (NormLevel.addVar_sortedVars h) + · exact h + · exact h + · split <;> [skip; split] + · exact NormLevel.addNode_sortedVars (NormLevel.addConst_sortedVars h) + · exact h + · exact NormLevel.addVar_sortedVars h + +theorem subsumeVars_sublist : ∀ vs₁ vs₂ : List VarNode, List.Sublist (subsumeVars vs₁ vs₂) vs₁ + | [], _ => by simp [subsumeVars] + | _ :: _, [] => by simp [subsumeVars] + | x :: xs, y :: ys => by + simp only [subsumeVars]; split + · exact (subsumeVars_sublist xs (y :: ys)).cons_cons x + · split + · exact (subsumeVars_sublist xs ys).cons x + · exact (subsumeVars_sublist xs ys).cons_cons x + · exact subsumeVars_sublist (x :: xs) ys + +theorem Node.subsume_var_sublist : List.Sublist (Node.subsume p₁ n₁ p₂ n₂).var n₁.var := by + obtain h | ⟨-, -, h⟩ := Node.subsume_var_cases p₁ n₁ p₂ n₂ <;> rw [h] + · exact List.Sublist.refl _ + · exact subsumeVars_sublist .. + +theorem NormLevel.minimize_var_sublist {acc : NormLevel} : + List.Sublist (acc.minimize p₁ n₁).var n₁.var := by + rw [minimize, Std.TreeMap.foldl_eq_foldl_toList] + generalize acc.toList = l + induction l generalizing n₁ with | nil => exact List.Sublist.refl _ | cons a l ih + exact (ih (n₁ := Node.subsume p₁ n₁ a.1 a.2)).trans Node.subsume_var_sublist + +theorem NormLevel.subsumption_sortedVars {s : NormLevel} (hs : s.SortedVars) : + s.subsumption.SortedVars := by + rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList] + have hmem pn (h : pn ∈ s.toList) : s.get? pn.1 = some pn.2 := + Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h + generalize s.toList = l at hmem + suffices ∀ (l : List (List Name × Node)) (acc : NormLevel), + (∀ pn ∈ l, s.get? pn.1 = some pn.2) → acc.SortedVars → + ∀ p n, (List.foldl (fun acc pn => + let n := acc.minimize pn.1 pn.2 + if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).get? p = some n → + VarsSorted n.var from this _ _ hmem hs + clear hmem; intro l + induction l with | nil => exact fun _ _ => id | cons pn l ih + intro acc hl hacc + refine ih _ (fun _ h => hl _ (.tail _ h)) fun p n h => ?_ + rw [subsumption_step_get?] at h + split at h + · split at h <;> [cases h; skip] + cases h; rename_i hp _; subst hp + exact (hs _ _ (hl _ (.head _))).sublist minimize_var_sublist + · exact hacc _ _ h + +theorem normalize_sortedVars : (normalize u).SortedVars := + NormLevel.subsumption_sortedVars (normalizeAux_sortedVars fun p n h => by simp at h) + +/-- `subsumption` erases a key rather than leaving an empty node behind. -/ +theorem NormLevel.subsumption_nonempty {s : NormLevel} : + ∀ p n, s.subsumption.get? p = some n → n.isEmpty = false := by + rw [subsumption, Std.TreeMap.foldl_eq_foldl_toList] + suffices ∀ (l : List (List Name × Node)) (acc : NormLevel), + (∀ p n, acc.get? p = some n → n.isEmpty = false ∨ (p, n) ∈ l) → + ∀ p n, (List.foldl (fun acc pn => + let n := acc.minimize pn.1 pn.2 + if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).get? p = some n → + n.isEmpty = false from + this _ _ fun p n h => .inr (Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 + (Std.TreeMap.get?_eq_getElem? .. ▸ h)) + intro l + induction l with + | nil => exact fun acc h p n hn => (h p n hn).resolve_right (by simp) + | cons pn l ih => + intro acc hacc + refine ih _ fun p n h => ?_ + rw [subsumption_step_get?] at h + split at h <;> rename_i hp + · split at h <;> [cases h; skip] + cases h; rename_i he; exact .inl (by simpa using he) + · refine (hacc _ _ h).imp_right fun hm => ?_ + obtain h' | h' := List.mem_cons.1 hm + · exact absurd (congrArg Prod.fst h'.symm) hp + · exact h' + +theorem normalize_nonempty : ∀ p n, (normalize u).get? p = some n → n.isEmpty = false := + NormLevel.subsumption_nonempty + +theorem NormLevel.addVar_keys (h : (addVar v k path acc).contains p) : acc.contains p := by + simpa [addVar, Std.TreeMap.mem_modify] using h + +theorem NormLevel.addNode_keys (h : (addNode v k path acc).contains p) : + p = path ∨ acc.contains p := by + rw [addNode, Std.TreeMap.contains_alter] at h + split at h + · rename_i hc + exact .inl (eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 hc)).symm + · exact .inr h + +theorem NormLevel.addConst_keys (h : (addConst k path acc).contains p) : + p = path ∨ acc.contains p := by + rw [addConst] at h; split at h <;> [exact .inr h; skip] + rw [Std.TreeMap.contains_alter] at h + split at h + · rename_i hc + exact .inl (eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 hc)).symm + · exact .inr h + +/-- All keys of the map built by `normalizeAux` consist of level parameters, which are +in `ls` whenever `ofLevel` succeeds. -/ +theorem normalizeAux_keys (hu : VLevel.ofLevel ls u = some u') + (hpath : ∀ x ∈ path, x ∈ ls) (hacc : ∀ p, acc.contains p → ∀ x ∈ p, x ∈ ls) : + ∀ p, (normalizeAux u path k acc).contains p → ∀ x ∈ p, x ∈ ls := by + unfold normalizeAux; split + · exact fun p h => (NormLevel.addConst_keys h).elim + (fun e x hx => hpath x (e ▸ hx)) (hacc p) + · exact fun p h => (NormLevel.addConst_keys h).elim + (fun e x hx => hpath x (e ▸ hx)) (hacc p) + · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, rfl⟩ := hu + exact normalizeAux_keys hu hpath hacc + · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, hv, rfl⟩ := hu + exact normalizeAux_keys hv hpath (normalizeAux_keys hu hpath hacc) + · simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, rfl⟩, rfl⟩ := hu + exact normalizeAux_keys hv hpath (normalizeAux_keys hu hpath hacc) + · rename_i u v w + simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, _, hw, rfl⟩, rfl⟩ := hu + exact normalizeAux_keys (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) hpath + (normalizeAux_keys (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hv, rfl⟩) hpath hacc) + · rename_i u v w + simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨_, hv, _, hw, rfl⟩, rfl⟩ := hu + exact normalizeAux_keys (by simpa [VLevel.ofLevel] using ⟨_, hv, _, hw, rfl⟩) hpath + (normalizeAux_keys (by simpa [VLevel.ofLevel] using ⟨_, hu, _, hw, rfl⟩) hpath hacc) + · rename_i u v + simp [VLevel.ofLevel] at hu; obtain ⟨_, hu, _, ⟨hv, rfl⟩, rfl⟩ := hu + have hvls : v ∈ ls := List.idxOf_lt_length_iff.1 hv + split <;> rename_i h + · refine normalizeAux_keys hu (fun x hx => ?_) fun q hq => ?_ + · exact ((Extend1.orderedInsert h).mem.1 hx).elim (fun e => e.symm ▸ hvls) (hpath x) + · obtain e | hq' := NormLevel.addNode_keys hq + · exact fun x hx => by + rcases (Extend1.orderedInsert h).mem.1 (e ▸ hx) with rfl | hx' + · exact hvls + · exact hpath x hx' + · exact (NormLevel.addConst_keys hq').elim + (fun e x hx => hpath x (e ▸ hx)) (hacc q) + · dsimp; split + · exact normalizeAux_keys hu hpath hacc + · exact normalizeAux_keys hu hpath fun q hq => hacc q (NormLevel.addVar_keys hq) + · exact hacc + · exact hacc + · rename_i v + simp [VLevel.ofLevel] at hu; obtain ⟨hv, rfl⟩ := hu + have hvls : v ∈ ls := List.idxOf_lt_length_iff.1 hv + split <;> rename_i h + · intro q hq + obtain e | hq' := NormLevel.addNode_keys hq + · exact fun x hx => by + rcases (Extend1.orderedInsert h).mem.1 (e ▸ hx) with rfl | hx' + · exact hvls + · exact hpath x hx' + · exact (NormLevel.addConst_keys hq').elim + (fun e x hx => hpath x (e ▸ hx)) (hacc q) + · split + · exact hacc + · exact fun q hq => hacc q (NormLevel.addVar_keys hq) + +theorem normalize_keys (hu : VLevel.ofLevel ls u = some u') : + ∀ p n, (normalize u).get? p = some n → ∀ x ∈ p, x ∈ ls := by + intro p n h + obtain ⟨n₀, h₀, -⟩ := NormLevel.subsumption_covers.1 p n h + have hc : (normalizeAux u [] 0 {}).contains p := + Std.TreeMap.isSome_getElem?_eq_contains.symm.trans + (by simp [Std.TreeMap.get?_eq_getElem?] at h₀; simp [h₀]) + exact normalizeAux_keys hu (by simp) (fun q hq => by simp at hq) p hc + +/-- A single sublevel of the canonical form: `Sub.const p k` is `C(p, k)` and +`Sub.var p x k` is `V(p, x, k)`. -/ +inductive Sub where + | const (p : List Name) (k : Nat) + | var (p : List Name) (x : Name) (k : Nat) + +def Sub.path : Sub → List Name + | .const p _ => p + | .var p _ _ => p + +/-- Domination of sublevels, following Theorem 39: `s.le t` when `t`'s value bounds `s`'s +value under every valuation. The dominator's condition set is a *subset*, so that it fires +whenever the dominated sublevel does; a constant is dominated by `V(F, x, K)` up to `K + 1` +since that sublevel is at least `K + 1` whenever its conditions hold; and a variable +sublevel is only dominated by the same variable at a larger offset. -/ +protected def Sub.le : Sub → Sub → Prop + | .const p k, .const q l => (∀ z ∈ q, z ∈ p) ∧ k ≤ l + | .const p k, .var q _ l => (∀ z ∈ q, z ∈ p) ∧ k ≤ l + 1 + | .var _ _ _, .const _ _ => False + | .var p x k, .var q y l => (∀ z ∈ q, z ∈ p) ∧ x = y ∧ k ≤ l + +protected theorem Sub.le.trans : ∀ {a b c : Sub}, a.le b → b.le c → a.le c + | .const _ _, .const _ _, .const _ _, ⟨s₁, h₁⟩, ⟨s₂, h₂⟩ => + ⟨fun z hz => s₁ _ (s₂ _ hz), Nat.le_trans h₁ h₂⟩ + | .const _ _, .const _ _, .var _ _ _, ⟨s₁, h₁⟩, ⟨s₂, h₂⟩ => + ⟨fun z hz => s₁ _ (s₂ _ hz), by omega⟩ + | .const _ _, .var _ _ _, .const _ _, _, h₂ => h₂.elim + | .const _ _, .var _ _ _, .var _ _ _, ⟨s₁, h₁⟩, ⟨s₂, _, h₂⟩ => + ⟨fun z hz => s₁ _ (s₂ _ hz), by omega⟩ + | .var _ _ _, .const _ _, _, h₁, _ => h₁.elim + | .var _ _ _, .var _ _ _, .const _ _, _, h₂ => h₂.elim + | .var _ _ _, .var _ _ _, .var _ _ _, ⟨s₁, e₁, h₁⟩, ⟨s₂, e₂, h₂⟩ => + ⟨fun z hz => s₁ _ (s₂ _ hz), e₁.trans e₂, Nat.le_trans h₁ h₂⟩ + +theorem subset_antisymm (h₁ : Sorted l₁) (h₂ : Sorted l₂) + (h : ∀ z ∈ l₁, z ∈ l₂) (h' : ∀ z ∈ l₂, z ∈ l₁) : l₁ = l₂ := + subset_eq (subset_of_sorted h₁ h₂ h) <| + Nat.le_antisymm (subset_length (subset_of_sorted h₁ h₂ h)) + (subset_length (subset_of_sorted h₂ h₁ h')) + +protected theorem Sub.le.antisymm : ∀ {a b : Sub}, Sorted a.path → Sorted b.path → + a.le b → b.le a → a = b + | .const p _, .const q _, ha, hb, ⟨s₁, h₁⟩, ⟨s₂, h₂⟩ => by + rw [subset_antisymm (l₁ := p) (l₂ := q) ha hb s₂ s₁, Nat.le_antisymm h₁ h₂] + | .const _ _, .var _ _ _, _, _, _, h₂ => h₂.elim + | .var _ _ _, .const _ _, _, _, h₁, _ => h₁.elim + | .var p _ _, .var q _ _, ha, hb, ⟨s₁, e₁, h₁⟩, ⟨s₂, e₂, h₂⟩ => by + rw [subset_antisymm (l₁ := p) (l₂ := q) ha hb s₂ s₁, e₁, Nat.le_antisymm h₁ h₂] + +/-- The sublevels recorded in a `NormLevel`: `C(p, n.const)` for nonzero constants and +`V(p, x, k)` for each recorded variable. -/ +def NormLevel.HasSub (s : NormLevel) : Sub → Prop + | .const p k => ∃ n, s.get? p = some n ∧ n.const = k ∧ k ≠ 0 + | .var p x k => ∃ n, s.get? p = some n ∧ ⟨x, k⟩ ∈ n.var + +variable (ls : List Name) (ρ : List Nat) in +def Sub.eval : Sub → Nat + | .const p k => evalPath ls ρ p k + | .var p x k => evalPath ls ρ p (evalParam ls ρ x + k) + +theorem NormLevel.HasSub.le_eval {s : NormLevel} : ∀ {t}, s.HasSub t → + t.eval ls ρ ≤ s.eval ls ρ + | .const _ _, ⟨_, hn, hk, _⟩ => + Nat.le_trans (evalPath_mono (hk ▸ Node.const_le_eval)) + (NormLevel.eval_le.1 (Nat.le_refl _) _ _ hn) + | .var _ _ _, ⟨_, hn, hx⟩ => + Nat.le_trans (evalPath_mono (Node.var_le_eval hx)) + (NormLevel.eval_le.1 (Nat.le_refl _) _ _ hn) + +theorem NormLevel.lt_eval {s : NormLevel} : + m < eval ls ρ s ↔ ∃ p n, s.get? p = some n ∧ m < evalPath ls ρ p (Node.eval ls ρ n) := by + refine ⟨fun h => ?_, fun ⟨p, n, hn, hlt⟩ => + Nat.lt_of_lt_of_le hlt (NormLevel.eval_le.1 (Nat.le_refl _) _ _ hn)⟩ + refine Classical.byContradiction fun hc => ?_ + exact absurd (eval_le.2 fun p n hn => Nat.not_lt.1 fun hlt => hc ⟨p, n, hn, hlt⟩) + (Nat.not_le.2 h) + +theorem Node.lt_eval {n : Node} : + m < Node.eval ls ρ n ↔ m < n.const ∨ ∃ v ∈ n.var, m < VarNode.eval ls ρ v := by + refine ⟨fun h => ?_, fun h => ?_⟩ + · refine Classical.byContradiction fun hc => ?_ + rw [not_or] at hc; obtain ⟨h₁, h₂⟩ := hc + refine absurd (Node.eval_le.2 ⟨Nat.not_lt.1 h₁, fun v hv => Nat.not_lt.1 fun hlt => ?_⟩) + (Nat.not_le.2 h) + exact h₂ ⟨v, hv, hlt⟩ + · obtain h | ⟨v, hv, h⟩ := h + · exact Nat.lt_of_lt_of_le h Node.const_le_eval + · exact Nat.lt_of_lt_of_le h (Node.var_le_eval hv) + +theorem lt_evalPath (h : m < evalPath ls ρ p n) : allNZ ls ρ p ∧ m < n := by + rw [evalPath] at h; split at h + · exact ⟨‹_›, h⟩ + · exact absurd h (Nat.not_lt_zero m) + +theorem evalParam_map {f : Name → Nat} (hx : x ∈ ls) : evalParam ls (ls.map f) x = f x := by + have hv : ls.idxOf x < ls.length := List.idxOf_lt_length_iff.2 hx + rw [evalParam_eq hv, List.getElem?_map, List.getElem?_eq_getElem hv] + simp [List.getElem_idxOf] + +theorem evalParam_not_mem (hx : x ∉ ls) : evalParam ls ρ x = 0 := by + simp only [evalParam] + rw [if_neg fun h => hx (List.idxOf_lt_length_iff.1 h)] + +theorem evalParam_map_pos {f : Name → Nat} (h : 0 < evalParam ls (ls.map f) z) : + z ∈ ls ∧ 0 < f z := by + by_cases hz : z ∈ ls + · refine ⟨hz, ?_⟩; rwa [evalParam_map hz] at h + · rw [evalParam_not_mem hz] at h; exact absurd h (Nat.lt_irrefl 0) + +theorem evalParam_map_le {f : Name → Nat} (hb : f z ≤ c) : + evalParam ls (ls.map f) z ≤ c := by + by_cases hz : z ∈ ls + · rw [evalParam_map hz]; exact hb + · rw [evalParam_not_mem hz]; exact Nat.zero_le _ + +theorem foldl_max_le {f : α → Nat} {m : Nat} : ∀ {l : List α} {i : Nat}, + l.foldl (fun r a => max' r (f a)) i ≤ m ↔ i ≤ m ∧ ∀ a ∈ l, f a ≤ m + | [], _ => by simp + | a :: l, i => by simp [foldl_max_le (l := l), Nat.max_le, and_assoc] + +/-- A bound on all the constants and offsets appearing in the map. -/ +def Node.bound (n : Node) : Nat := n.var.foldl (fun r v => max' r v.offset) n.const + +def NormLevel.bound (s : NormLevel) : Nat := s.foldl (fun r _ n => max' r n.bound) 0 + +theorem NormLevel.bound_spec {s : NormLevel} (h : s.get? p = some n) : + n.const ≤ s.bound ∧ ∀ v ∈ n.var, v.offset ≤ s.bound := by + have hmem := Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 (Std.TreeMap.get?_eq_getElem? .. ▸ h) + have hb : n.bound ≤ s.bound := by + rw [bound, Std.TreeMap.foldl_eq_foldl_toList] + exact ((foldl_max_le (f := fun pn : List Name × Node => pn.2.bound)).1 + (Nat.le_refl _)).2 _ hmem + exact (foldl_max_le (f := fun v : VarNode => v.offset)).1 hb + +/-- The separation theorem, a converse to Theorem 39: if the value of `l₁` is bounded by the +value of `l₂` under every valuation, then every sublevel of `l₁` has a syntactic dominator +among the sublevels of `l₂`. The valuation exhibiting the dominator sets every variable of +the sublevel's condition set to `1`, the sublevel's own variable (if any) to a value `N` +larger than every constant and offset of `l₂`, and everything else to `0`: only entries of +`l₂` at condition sets below the sublevel's can contribute, and only a sublevel with the +same variable can reach `N`. -/ +theorem NormLevel.separation {l₁ l₂ : NormLevel} + (hls : ∀ p n, l₁.get? p = some n → ∀ x ∈ p, x ∈ ls) + (wf₁ : ∀ p n, l₁.get? p = some n → ∀ v ∈ n.var, v.var ∈ p) + (h : ∀ ρ, l₁.eval ls ρ ≤ l₂.eval ls ρ) : + ∀ t, l₁.HasSub t → ∃ t', l₂.HasSub t' ∧ t.le t' := by + intro t ht + match t, ht with + | .const p k, ⟨n, hn, hk, hk0⟩ => + have hnz : allNZ ls (ls.map fun z => if z ∈ p then 1 else 0) p := by + simp only [allNZ, List.all_eq_true, decide_eq_true_eq] + intro z hz + rw [evalParam_map (hls _ _ hn _ hz)]; simp [hz] + have h₁ : k ≤ l₁.eval ls (ls.map fun z => if z ∈ p then 1 else 0) := + Nat.le_trans (by simp [Sub.eval, evalPath, hnz]) + (HasSub.le_eval (t := .const p k) ⟨n, hn, hk, hk0⟩) + have h₂ := NormLevel.lt_eval.1 (Nat.lt_of_lt_of_le (by omega : k - 1 < k) + (Nat.le_trans h₁ (h _))) + obtain ⟨q, m, hq, hlt⟩ := h₂ + obtain ⟨hnzq, hlt⟩ := lt_evalPath hlt + have hsub : ∀ z ∈ q, z ∈ p := by + intro z hz + simp only [allNZ, List.all_eq_true, decide_eq_true_eq] at hnzq + have := (evalParam_map_pos (hnzq z hz)).2 + split at this + · assumption + · exact absurd this (Nat.lt_irrefl 0) + obtain hc | ⟨v, hv, hvlt⟩ := Node.lt_eval.1 hlt + · exact ⟨.const q m.const, ⟨m, hq, rfl, by omega⟩, hsub, by omega⟩ + · refine ⟨.var q v.var v.offset, ⟨m, hq, hv⟩, hsub, ?_⟩ + have hev : evalParam ls (ls.map fun z => if z ∈ p then 1 else 0) v.var ≤ 1 := + evalParam_map_le (by split <;> omega) + simp only [VarNode.eval] at hvlt + omega + | .var p x k, ⟨n, hn, hx⟩ => + have hxp : x ∈ p := wf₁ _ _ hn _ hx + have hxls : x ∈ ls := hls _ _ hn _ hxp + have hnz : allNZ ls (ls.map fun z => + if z = x then l₂.bound + k + 2 else if z ∈ p then 1 else 0) p := by + simp only [allNZ, List.all_eq_true, decide_eq_true_eq] + intro z hz + simp only [evalParam_map (hls _ _ hn _ hz)] + split + · omega + · omega + have h₁ : l₂.bound + k + 2 + k ≤ l₁.eval ls (ls.map fun z => + if z = x then l₂.bound + k + 2 else if z ∈ p then 1 else 0) := by + refine Nat.le_trans ?_ (HasSub.le_eval (t := .var p x k) ⟨n, hn, hx⟩) + simp [Sub.eval, evalPath, hnz, evalParam_map hxls] + obtain ⟨q, m, hq, hlt⟩ := NormLevel.lt_eval.1 + (Nat.lt_of_lt_of_le (by omega : l₂.bound + k + 2 + k - 1 < l₂.bound + k + 2 + k) + (Nat.le_trans h₁ (h _))) + obtain ⟨hnzq, hlt⟩ := lt_evalPath hlt + have hsub : ∀ z ∈ q, z ∈ p := by + intro z hz + simp only [allNZ, List.all_eq_true, decide_eq_true_eq] at hnzq + have := (evalParam_map_pos (hnzq z hz)).2 + split at this + · rename_i hz'; subst hz'; exact hxp + · split at this + · assumption + · exact absurd this (Nat.lt_irrefl 0) + obtain hc | ⟨v, hv, hvlt⟩ := Node.lt_eval.1 hlt + · exact absurd hc (by have := (bound_spec hq).1; omega) + · by_cases hvx : v.var = x + · refine ⟨.var q x v.offset, ⟨m, hq, by rw [← hvx]; exact hv⟩, hsub, rfl, ?_⟩ + simp [VarNode.eval, hvx, evalParam_map hxls] at hvlt + omega + · have hoff := (bound_spec hq).2 _ hv + have hev : evalParam ls (ls.map fun z => + if z = x then l₂.bound + k + 2 else if z ∈ p then 1 else 0) v.var ≤ 1 := + evalParam_map_le (by rw [if_neg hvx]; split <;> omega) + simp only [VarNode.eval] at hvlt + exact absurd hvlt (by omega) + +private theorem name_lt_ne {a b : Name} (h : compare a b = .lt) : a ≠ b := by + rintro rfl; rw [Std.ReflOrd.compare_self] at h; cases h + +/-- Exactness of `subsumeVars` on sorted lists: a surviving variable has no dominator +in the subtracted list. -/ +theorem subsumeVars_complete {x y : VarNode} : ∀ {vs₁ vs₂ : List VarNode}, + VarsSorted vs₁ → VarsSorted vs₂ → x ∈ subsumeVars vs₁ vs₂ → y ∈ vs₂ → + y.var = x.var → x.offset ≤ y.offset → False + | [], _, _, _, hx, _ => by simp [subsumeVars] at hx + | _ :: _, [], _, _, _, hy => nomatch hy + | a :: vs₁, b :: vs₂, h₁, h₂, hx, hy => by + intro e hle + simp only [subsumeVars] at hx + split at hx <;> rename_i hab + · rcases List.mem_cons.1 hx with rfl | hx' + · rcases List.mem_cons.1 hy with rfl | hy' + · exact name_lt_ne hab e.symm + · exact name_lt_ne (Std.TransCmp.lt_trans hab (h₂.head _ hy')) e.symm + · exact subsumeVars_complete h₁.of_cons h₂ hx' hy e hle + · have eab : a.var = b.var := eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 hab) + split at hx <;> rename_i hoff + · rcases List.mem_cons.1 hy with rfl | hy' + · exact name_lt_ne (h₁.head _ (subsumeVars_subset hx)) (eab.trans e) + · exact subsumeVars_complete h₁.of_cons h₂.of_cons hx hy' e hle + · rcases List.mem_cons.1 hx with rfl | hx' + · rcases List.mem_cons.1 hy with rfl | hy' + · exact hoff hle + · exact name_lt_ne (h₂.head _ hy') (e.trans eab).symm + · rcases List.mem_cons.1 hy with rfl | hy' + · exact name_lt_ne (h₁.head _ (subsumeVars_subset hx')) (eab.trans e) + · exact subsumeVars_complete h₁.of_cons h₂.of_cons hx' hy' e hle + · rcases List.mem_cons.1 hy with rfl | hy' + · have hbx : compare y.var x.var = .lt := by + have hba := Std.OrientedCmp.lt_of_gt hab + rcases List.mem_cons.1 (subsumeVars_subset hx) with rfl | hxv + · exact hba + · exact Std.TransCmp.lt_trans hba (h₁.head _ hxv) + exact name_lt_ne hbx e + · exact subsumeVars_complete h₁ h₂.of_cons hx hy' e hle + +theorem le_foldl_max_self {vs : List VarNode} : ∀ {n : Nat}, n ≤ vs.foldl (·.max ·.offset) n := by + induction vs with | nil => exact Nat.le_refl _ | cons a vs ih + exact fun {n} => Nat.le_trans (Nat.le_max_left _ _) ih + +theorem foldl_max_ge {vs : List VarNode} (hy : y ∈ vs) : + ∀ {n : Nat}, y.offset ≤ vs.foldl (·.max ·.offset) n := by + induction vs with | nil => cases hy | cons a vs ih + rcases List.mem_cons.1 hy with rfl | hy' + · exact fun {n} => Nat.le_trans (Nat.le_max_right _ _) le_foldl_max_self + · exact fun {n} => ih hy' + +/-- Exactness of the constant part of `subsumeBy`: a dominated constant is dropped. -/ +theorem Node.subsumeBy_const_complete {same : Bool} {n₁ n₂ : Node} + (h : (same = false ∧ n₁.const ≤ n₂.const) ∨ ∃ y ∈ n₂.var, n₁.const ≤ y.offset + 1) : + (n₁.subsumeBy same n₂).const = 0 := by + rw [Node.subsumeBy_const_eq] + split <;> [rename_i hc; rfl] + simp only [Bool.or_eq_true, Bool.and_eq_true, decide_eq_true_eq, List.isEmpty_iff] at hc + obtain hc | ⟨hc1, hc2⟩ := hc + · exact hc + obtain ⟨rfl, hle⟩ | ⟨y, hy, hle⟩ := h + · rcases hc1 with hc1 | hc1 + · cases hc1 + · omega + · rcases hc2 with hc2 | hc2 + · rw [hc2] at hy; cases hy + · have := foldl_max_ge hy (n := 0); omega + +theorem Node.subsumeBy_var_sublist {same : Bool} {n₁ n₂ : Node} : + List.Sublist (n₁.subsumeBy same n₂).var n₁.var := by + rw [Node.subsumeBy_var_eq]; split + · exact List.Sublist.refl _ + · exact subsumeVars_sublist .. + +/-- Exactness of the variable part of `subsumeBy` at a different key: a dominated variable +is dropped. -/ +theorem Node.subsumeBy_var_complete {n₁ n₂ : Node} (h₁ : VarsSorted n₁.var) + (h₂ : VarsSorted n₂.var) (hx : x ∈ (n₁.subsumeBy false n₂).var) (hy : y ∈ n₂.var) + (e : y.var = x.var) (hle : x.offset ≤ y.offset) : False := by + rw [Node.subsumeBy_var_eq] at hx + split at hx <;> rename_i hc + · simp only [Bool.false_or, List.isEmpty_iff] at hc + rw [hc] at hy; cases hy + · exact subsumeVars_complete h₁ h₂ hx hy e hle + +/-- Completeness of the discharging fold in `NormLevel.le`: if every sublevel of `n₁` has a +dominator among the entries of `l` at a subkey of `p₁`, the fold discharges everything and +returns `none`. -/ +theorem NormLevel.le_fold_complete {p₁ : List Name} : + ∀ (l : List (List Name × Node)) (n₁ : Node), VarsSorted n₁.var → + (∀ pn ∈ l, VarsSorted pn.2.var) → n₁.isEmpty = false → + (n₁.const ≠ 0 → ∃ pn ∈ l, subset compare pn.1 p₁ ∧ + (n₁.const ≤ pn.2.const ∨ ∃ y ∈ pn.2.var, n₁.const ≤ y.offset + 1)) → + (∀ x ∈ n₁.var, ∃ pn ∈ l, subset compare pn.1 p₁ ∧ + ∃ y ∈ pn.2.var, y.var = x.var ∧ x.offset ≤ y.offset) → + List.foldlM (m := Option) (fun n pn => + if subset compare pn.1 p₁ then + if (n.subsumeBy false pn.2).isEmpty then none else some (n.subsumeBy false pn.2) + else some n) n₁ l = none + | [], n₁, _, _, hne, hconst, hvar => by + rw [Node.isEmpty, Bool.and_eq_false_iff] at hne + obtain h0 | hv := hne + · obtain ⟨_, h, -⟩ := hconst (by simpa using h0) + cases h + · obtain ⟨x, hx⟩ := List.exists_mem_of_ne_nil _ (by simpa using hv) + obtain ⟨_, h, -⟩ := hvar x hx + cases h + | pn :: l, n₁, hvs₁, hvsl, hne, hconst, hvar => by + simp only [List.foldlM_cons] + by_cases hs : subset compare pn.1 p₁ + · rw [if_pos hs] + by_cases he : (n₁.subsumeBy false pn.2).isEmpty + · rw [if_pos he]; rfl + · rw [if_neg he] + show List.foldlM _ _ l = none + refine le_fold_complete l _ (hvs₁.sublist Node.subsumeBy_var_sublist) + (fun pn h => hvsl _ (.tail _ h)) (by simpa using he) ?_ ?_ + · intro h0 + have hc : (n₁.subsumeBy false pn.2).const = n₁.const := + (Node.subsumeBy_const_cases ..).resolve_right h0 + obtain ⟨pn', hpn', hsub', hdom'⟩ := hconst (hc ▸ h0) + rcases List.mem_cons.1 hpn' with rfl | hpn' + · exact absurd (Node.subsumeBy_const_complete + (hdom'.imp (fun h => ⟨rfl, h⟩) id)) h0 + · exact ⟨pn', hpn', hsub', hc ▸ hdom'⟩ + · intro x hx + obtain ⟨pn', hpn', hsub', y, hy, e, hle⟩ := hvar x (Node.subsumeBy_var_subset hx) + rcases List.mem_cons.1 hpn' with rfl | hpn' + · exact (Node.subsumeBy_var_complete hvs₁ (hvsl _ (.head _)) hx hy e hle).elim + · exact ⟨pn', hpn', hsub', y, hy, e, hle⟩ + · rw [if_neg hs] + show List.foldlM _ _ l = none + refine le_fold_complete l n₁ hvs₁ (fun pn h => hvsl _ (.tail _ h)) hne ?_ ?_ + · intro h0 + obtain ⟨pn', hpn', hsub', hdom'⟩ := hconst h0 + rcases List.mem_cons.1 hpn' with rfl | hpn' + · exact absurd hsub' hs + · exact ⟨pn', hpn', hsub', hdom'⟩ + · intro x hx + obtain ⟨pn', hpn', hsub', hy⟩ := hvar x hx + rcases List.mem_cons.1 hpn' with rfl | hpn' + · exact absurd hsub' hs + · exact ⟨pn', hpn', hsub', hy⟩ + +/-- Completeness of `NormLevel.le`: per-sublevel domination implies acceptance. -/ +theorem NormLevel.le_complete {l₁ l₂ : NormLevel} + (hvs₁ : l₁.SortedVars) (hvs₂ : l₂.SortedVars) + (hne : ∀ p n, l₁.get? p = some n → n.isEmpty = false) + (hsort₁ : ∀ p n, l₁.get? p = some n → Sorted p) + (hsort₂ : ∀ p n, l₂.get? p = some n → Sorted p) + (hdom : ∀ t, l₁.HasSub t → ∃ t', l₂.HasSub t' ∧ t.le t') : + l₁.le l₂ := by + rw [NormLevel.le, Std.TreeMap.all_eq_all_toList, List.all_eq_true] + rintro ⟨p₁, n₁⟩ hmem + have h₁ := Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hmem + simp only [Std.TreeMap.foldlM_eq_foldlM_toList, Option.isNone_iff_eq_none] + have hmem₂ : ∀ q m, l₂.get? q = some m → (q, m) ∈ l₂.toList := fun q m h => + Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 (Std.TreeMap.get?_eq_getElem? .. ▸ h) + refine le_fold_complete l₂.toList n₁ (hvs₁ _ _ h₁) + (fun pn h => hvs₂ _ _ <| Std.TreeMap.get?_eq_getElem? .. ▸ + Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h) (hne _ _ h₁) (fun h0 => ?_) (fun x hx => ?_) + · obtain ⟨t', ht', hle⟩ := hdom (.const p₁ n₁.const) ⟨n₁, h₁, rfl, h0⟩ + match t', ht', hle with + | .const q _, ⟨m, hq, hc, _⟩, ⟨hsub, hle⟩ => + exact ⟨(q, m), hmem₂ _ _ hq, + subset_of_sorted (hsort₂ _ _ hq) (hsort₁ _ _ h₁) hsub, .inl (hc ▸ hle)⟩ + | .var q yv yk, ⟨m, hq, hyk⟩, ⟨hsub, hle⟩ => + exact ⟨(q, m), hmem₂ _ _ hq, + subset_of_sorted (hsort₂ _ _ hq) (hsort₁ _ _ h₁) hsub, .inr ⟨⟨yv, yk⟩, hyk, hle⟩⟩ + · obtain ⟨t', ht', hle⟩ := hdom (.var p₁ x.var x.offset) ⟨n₁, h₁, hx⟩ + match t', ht', hle with + | .const _ _, _, hle => exact hle.elim + | .var q yv yk, ⟨m, hq, hyk⟩, ⟨hsub, hev, hle⟩ => + exact ⟨(q, m), hmem₂ _ _ hq, + subset_of_sorted (hsort₂ _ _ hq) (hsort₁ _ _ h₁) hsub, ⟨yv, yk⟩, hyk, hev.symm, hle⟩ + +/-- The sublevels of a single node keyed at `p`. -/ +def Node.HasSub (p : List Name) (n : Node) : Sub → Prop + | .const q k => p = q ∧ n.const = k ∧ k ≠ 0 + | .var q x k => p = q ∧ ⟨x, k⟩ ∈ n.var + +theorem NormLevel.hasSub_iff {s : NormLevel} {t} : + s.HasSub t ↔ ∃ p n, s.get? p = some n ∧ Node.HasSub p n t := by + match t with + | .const p k => + constructor + · rintro ⟨n, hn, hk, hk0⟩; exact ⟨p, n, hn, rfl, hk, hk0⟩ + · rintro ⟨q, n, hn, rfl, hk, hk0⟩; exact ⟨n, hn, hk, hk0⟩ + | .var p x k => + constructor + · rintro ⟨n, hn, hx⟩; exact ⟨p, n, hn, rfl, hx⟩ + · rintro ⟨q, n, hn, rfl, hx⟩; exact ⟨n, hn, hx⟩ + +theorem Node.subsume_hasSub : ∀ {t}, Node.HasSub p₁ (Node.subsume p₁ n p₂ n₂) t → + Node.HasSub p₁ n t + | .const _ k, ⟨rfl, hck, hk0⟩ => by + refine ⟨rfl, ?_, hk0⟩ + obtain h | h := Node.subsume_const_cases p₁ n p₂ n₂ + · rw [← h]; exact hck + · rw [h] at hck; exact absurd hck.symm hk0 + | .var _ _ _, ⟨rfl, hxk⟩ => ⟨rfl, Node.subsume_var_subset hxk⟩ + +theorem NormLevel.minimize_hasSub {acc : NormLevel} {t} + (h : Node.HasSub p₁ (acc.minimize p₁ n₁) t) : Node.HasSub p₁ n₁ t := by + rw [minimize, Std.TreeMap.foldl_eq_foldl_toList] at h + generalize acc.toList = l at h + induction l generalizing n₁ with + | nil => exact h + | cons a l ih => exact Node.subsume_hasSub (ih h) + +/-- A `subsumption` step only removes sublevels. -/ +theorem NormLevel.subsumption_step_hasSub {acc : NormLevel} {p₁ : List Name} {n₁ : Node} + (h₁ : acc.get? p₁ = some n₁) {t} + (h : NormLevel.HasSub (if (acc.minimize p₁ n₁).isEmpty then acc.erase p₁ + else acc.insert p₁ (acc.minimize p₁ n₁)) t) : acc.HasSub t := by + rw [hasSub_iff] at h ⊢ + obtain ⟨p, n, hp, hn⟩ := h + rw [subsumption_step_get?] at hp + split at hp <;> rename_i hpe + · split at hp <;> [cases hp; skip] + cases hp; subst hpe + exact ⟨p₁, n₁, h₁, minimize_hasSub hn⟩ + · exact ⟨p, n, hp, hn⟩ + +/-- Exactness of minimization, fold form: a sublevel surviving the subtraction of every entry +in `l` is not (strictly) dominated by any of their sublevels — domination forces equality. -/ +theorem NormLevel.minimize_exact_aux {acc : NormLevel} {p₁ : List Name} {n₁ : Node} + (hsort : ∀ p n, acc.get? p = some n → Sorted p) (hvsa : acc.SortedVars) + (h₁ : acc.get? p₁ = some n₁) (hs₁ : Sorted p₁) (hvs₁ : VarsSorted n₁.var) : + ∀ (l : List (List Name × Node)) (n : Node), + (∀ pn ∈ l, acc.get? pn.1 = some pn.2) → + (∀ x ∈ n.var, x ∈ n₁.var) → (n.const ≠ 0 → n.const = n₁.const) → VarsSorted n.var → + ∀ t, Node.HasSub p₁ (l.foldl (fun n pn => Node.subsume p₁ n pn.1 pn.2) n) t → + Node.HasSub p₁ n t ∧ + ∀ pn ∈ l, ∀ t', Node.HasSub pn.1 pn.2 t' → t.le t' → t = t' + | [], _, _, _, _, _, _, ht => ⟨ht, fun _ h => nomatch h⟩ + | (p₂, n₂) :: l, n, hl, hnvar, hnconst, hvs, t, ht => by + simp only [List.foldl_cons] at ht + have h₂ : acc.get? p₂ = some n₂ := hl _ (.head _) + have hvs₂ : VarsSorted n₂.var := hvsa _ _ h₂ + have hs₂ : Sorted p₂ := hsort _ _ h₂ + obtain ⟨ht', hrest⟩ := minimize_exact_aux hsort hvsa h₁ hs₁ hvs₁ l + (Node.subsume p₁ n p₂ n₂) (fun pn h => hl _ (.tail _ h)) + (fun x hx => hnvar _ (Node.subsume_var_subset hx)) + (fun h0 => by + obtain hc | hc := Node.subsume_const_cases p₁ n p₂ n₂ + · rw [hc]; exact hnconst (hc ▸ h0) + · exact absurd hc h0) + (hvs.sublist Node.subsume_var_sublist) t ht + refine ⟨Node.subsume_hasSub ht', ?_⟩ + rintro pn hpn t' ht'' hle + rcases List.mem_cons.1 hpn with rfl | hpn + · obtain ⟨q, k⟩ | ⟨q, x, k⟩ := t <;> obtain ⟨q', k'⟩ | ⟨q', y, k'⟩ := t' + · -- const dominated by const + obtain ⟨rfl, hck, hk0⟩ := ht' + obtain ⟨rfl, hck', hk0'⟩ := ht'' + obtain ⟨hsub, hlek⟩ := hle + have hgate : subset compare p₂ p₁ := subset_of_sorted hs₂ hs₁ hsub + have hsu : Node.subsume p₁ n p₂ n₂ = n.subsumeBy (p₁.length == p₂.length) n₂ := by + rw [Node.subsume, if_pos hgate] + by_cases hlen : p₁.length = p₂.length + · have hqq : p₂ = p₁ := subset_eq hgate hlen.symm + have hn₂ : n₂ = n₁ := by + rw [hqq] at h₂; cases h₂.symm.trans h₁; rfl + have hkc : n.const = k := by + obtain hc | hc := Node.subsume_const_cases p₁ n p₂ n₂ + · rw [← hc]; exact hck + · rw [hc] at hck; exact absurd hck.symm hk0 + have hne0 : n.const ≠ 0 := fun h0 => hk0 (hkc.symm.trans h0) + rw [hqq, show k = k' from by rw [← hck', hn₂, ← hnconst hne0, hkc]] + · have hbeq : (p₁.length == p₂.length) = false := by simpa using hlen + rw [hsu, hbeq] at hck + have hkc : n.const = k := by + obtain hc | hc := Node.subsumeBy_const_cases (same := false) n n₂ + · rw [← hc]; exact hck + · rw [hc] at hck; exact absurd hck.symm hk0 + refine absurd hck ?_ + rw [Node.subsumeBy_const_complete (n₁ := n) (n₂ := n₂) + (.inl ⟨rfl, by rw [hkc, hck']; exact hlek⟩)] + exact fun h => hk0 h.symm + · -- const dominated by a variable + obtain ⟨rfl, hck, hk0⟩ := ht' + obtain ⟨rfl, hyk⟩ := ht'' + obtain ⟨hsub, hlek⟩ := hle + have hgate : subset compare p₂ p₁ := subset_of_sorted hs₂ hs₁ hsub + have hsu : Node.subsume p₁ n p₂ n₂ = n.subsumeBy (p₁.length == p₂.length) n₂ := by + rw [Node.subsume, if_pos hgate] + rw [hsu] at hck + have hkc : n.const = k := by + obtain hc | hc := Node.subsumeBy_const_cases (same := p₁.length == p₂.length) n n₂ + · rw [← hc]; exact hck + · rw [hc] at hck; exact absurd hck.symm hk0 + refine absurd hck ?_ + rw [Node.subsumeBy_const_complete (n₁ := n) (n₂ := n₂) + (.inr ⟨⟨y, k'⟩, hyk, by rw [hkc]; exact hlek⟩)] + exact fun h => hk0 h.symm + · exact hle.elim + · -- variable dominated by a variable + obtain ⟨rfl, hxk⟩ := ht' + obtain ⟨rfl, hyk⟩ := ht'' + obtain ⟨hsub, rfl, hlek⟩ := hle + have hgate : subset compare p₂ p₁ := subset_of_sorted hs₂ hs₁ hsub + have hsu : Node.subsume p₁ n p₂ n₂ = n.subsumeBy (p₁.length == p₂.length) n₂ := by + rw [Node.subsume, if_pos hgate] + by_cases hlen : p₁.length = p₂.length + · have hqq : p₂ = p₁ := subset_eq hgate hlen.symm + have hn₂ : n₂ = n₁ := by + rw [hqq] at h₂; cases h₂.symm.trans h₁; rfl + have hk : (⟨x, k⟩ : VarNode) = ⟨x, k'⟩ := + hvs₁.eq_of_var_eq (hnvar _ (Node.subsume_var_subset hxk)) (hn₂ ▸ hyk) rfl + rw [hqq, show k = k' from congrArg VarNode.offset hk] + · have hbeq : (p₁.length == p₂.length) = false := by simpa using hlen + rw [hsu, hbeq] at hxk + exact (Node.subsumeBy_var_complete hvs hvs₂ hxk hyk rfl hlek).elim + · exact hrest _ hpn _ ht'' hle + +theorem NormLevel.minimize_exact {acc : NormLevel} {p₁ : List Name} {n₁ : Node} + (hsort : ∀ p n, acc.get? p = some n → Sorted p) (hvsa : acc.SortedVars) + (h₁ : acc.get? p₁ = some n₁) : + ∀ t t', Node.HasSub p₁ (acc.minimize p₁ n₁) t → acc.HasSub t' → t.le t' → t = t' := by + intro t t' ht ht' hle + rw [minimize, Std.TreeMap.foldl_eq_foldl_toList] at ht + have hmem pn (h : pn ∈ acc.toList) : acc.get? pn.1 = some pn.2 := + Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h + obtain ⟨-, hexact⟩ := minimize_exact_aux hsort hvsa h₁ (hsort _ _ h₁) (hvsa _ _ h₁) + acc.toList n₁ hmem (fun _ => id) (fun _ => rfl) (hvsa _ _ h₁) t ht + obtain ⟨p₂, n₂, hp₂, hn₂⟩ := hasSub_iff.1 ht' + exact hexact (p₂, n₂) (Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 + (Std.TreeMap.get?_eq_getElem? .. ▸ hp₂)) _ hn₂ hle + +/-- A normal form is reduced when no sublevel is dominated by another: domination between +recorded sublevels forces them to be the same sublevel. -/ +def NormLevel.Reduced (s : NormLevel) : Prop := + ∀ t t', s.HasSub t → s.HasSub t' → t.le t' → t = t' + +/-- `subsumption` produces a reduced map: every entry is minimized against the (current) +whole map, minimization removes exactly the dominated sublevels, and later steps only +shrink the map, which cannot introduce new domination. -/ +theorem NormLevel.subsumption_reduced {s : NormLevel} + (hsort : ∀ p n, s.get? p = some n → Sorted p) (hvsa : s.SortedVars) : + s.subsumption.Reduced := by + have hmem pn (h : pn ∈ s.toList) : s.get? pn.1 = some pn.2 := + Std.TreeMap.get?_eq_getElem? .. ▸ Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 h + have nd : (s.toList.map Prod.fst).Nodup := by simpa using Std.TreeMap.nodup_keys (t := s) + rw [Reduced, subsumption, Std.TreeMap.foldl_eq_foldl_toList] + suffices ∀ (l : List (List Name × Node)) (acc : NormLevel), + (l.map Prod.fst).Nodup → + (∀ pn ∈ l, acc.get? pn.1 = some pn.2) → + (∀ p n, acc.get? p = some n → Sorted p) → acc.SortedVars → + (∀ p n, acc.get? p = some n → p ∉ l.map Prod.fst → + ∀ t t', Node.HasSub p n t → acc.HasSub t' → t.le t' → t = t') → + ∀ t t', (List.foldl (fun acc pn => + let n := acc.minimize pn.1 pn.2 + if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).HasSub t → + (List.foldl (fun acc pn => + let n := acc.minimize pn.1 pn.2 + if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).HasSub t' → + t.le t' → t = t' from + this _ _ nd hmem hsort hvsa fun p n hp hnp => absurd + (List.mem_map_of_mem (f := Prod.fst) (Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 + (Std.TreeMap.get?_eq_getElem? .. ▸ hp))) hnp + clear hmem nd hsort hvsa; intro l + induction l with + | nil => + intro acc _ _ _ _ hred t t' ht ht' hle + obtain ⟨p, n, hp, hnt⟩ := hasSub_iff.1 ht + exact hred p n hp (by simp) t t' hnt ht' hle + | cons pn l ih => + obtain ⟨p₂, n₂⟩ := pn + intro acc nd hl hsorta hvsacc hred + simp only [List.map_cons, List.nodup_cons] at nd + have h₂ : acc.get? p₂ = some n₂ := hl _ (.head _) + simp only [List.foldl_cons] + have hstep := subsumption_step_get? acc n₂ p₂ + refine ih _ nd.2 (fun pn' h => ?_) (fun p n h => ?_) (fun p n h => ?_) + (fun p n hp hnp t t' hnt ht' hle => ?_) + · have hne : p₂ ≠ pn'.1 := fun e => nd.1 (e ▸ List.mem_map_of_mem (f := Prod.fst) h) + rw [hstep, if_neg hne] + exact hl _ (.tail _ h) + · rw [hstep] at h; split at h <;> rename_i hpe + · split at h <;> [cases h; skip] + cases h; exact hpe ▸ hsorta _ _ h₂ + · exact hsorta _ _ h + · rw [hstep] at h; split at h <;> rename_i hpe + · split at h <;> [cases h; skip] + cases h + exact (hvsacc _ _ h₂).sublist minimize_var_sublist + · exact hvsacc _ _ h + · rw [hstep] at hp; split at hp <;> rename_i hpe + · split at hp <;> [cases hp; skip] + cases hp; subst hpe + exact minimize_exact hsorta hvsacc h₂ t t' hnt (subsumption_step_hasSub h₂ ht') hle + · refine hred p n hp ?_ t t' hnt (subsumption_step_hasSub h₂ ht') hle + simp only [List.map_cons, List.mem_cons, not_or] + exact ⟨fun e => hpe e.symm, hnp⟩ + +theorem normalize_reduced : (normalize u).Reduced := by + refine NormLevel.subsumption_reduced ?_ (normalizeAux_sortedVars fun _ _ => by simp) + exact fun p n h => (normalizeAux_wf (by simp) (by simp [NormLevel.WF]) p n h).2.2 + +/-! Canonicity: two reduced normal forms with the same semantics have the same sublevels, +and hence are equal maps. -/ + +instance : LawfulBEq Node where + rfl {a} := by cases a <;> simp! +instances [instBEqNode] + eq_of_beq {a b} h := by + cases a; cases b + simp! +instances [instBEqNode] at h + simp [h.1, h.2] + +theorem VarsSorted.eq_of_mem_iff : ∀ {l₁ l₂ : List VarNode}, VarsSorted l₁ → VarsSorted l₂ → + (∀ x, x ∈ l₁ ↔ x ∈ l₂) → l₁ = l₂ + | [], [], _, _, _ => rfl + | [], _ :: _, _, _, h => nomatch (h _).2 (.head _) + | _ :: _, [], _, _, h => nomatch (h _).1 (.head _) + | a :: l₁, b :: l₂, h₁, h₂, h => by + cases show a = b by + rcases List.mem_cons.1 ((h a).1 (.head _)) with rfl | ha <;> [rfl; skip] + rcases List.mem_cons.1 ((h b).2 (.head _)) with rfl | hb <;> [rfl; skip] + exact absurd (h₂.head _ ha) (by rw [Std.OrientedCmp.gt_of_lt (h₁.head _ hb)]; simp) + refine congrArg (a :: ·) (VarsSorted.eq_of_mem_iff h₁.of_cons h₂.of_cons + fun x => ⟨fun hx => ?_, fun hx => ?_⟩) + · rcases List.mem_cons.1 ((h x).1 (.tail _ hx)) with rfl | hx' + · exact absurd (h₁.head _ hx) (by rw [Std.ReflOrd.compare_self]; simp) + · exact hx' + · rcases List.mem_cons.1 ((h x).2 (.tail _ hx)) with rfl | hx' + · exact absurd (h₂.head _ hx) (by rw [Std.ReflOrd.compare_self]; simp) + · exact hx' + +theorem NormLevel.HasSub.path_sorted {s : NormLevel} + (hsort : ∀ p n, s.get? p = some n → Sorted p) : ∀ {t}, s.HasSub t → Sorted t.path + | .const _ _, ⟨_, hn, _⟩ => hsort _ _ hn + | .var _ _ _, ⟨_, hn, _⟩ => hsort _ _ hn + +/-- In reduced maps, mutual per-sublevel domination pins the sublevels to be equal: the +dominator of a sublevel is itself dominated by a sublevel of the first map, which by +reducedness is the sublevel we started from, and antisymmetry finishes. -/ +theorem NormLevel.Reduced.hasSub_iff_hasSub {A B : NormLevel} + (rA : A.Reduced) (rB : B.Reduced) + (sortA : ∀ p n, A.get? p = some n → Sorted p) + (sortB : ∀ p n, B.get? p = some n → Sorted p) + (hAB : ∀ t, A.HasSub t → ∃ t', B.HasSub t' ∧ t.le t') + (hBA : ∀ t, B.HasSub t → ∃ t', A.HasSub t' ∧ t.le t') : + ∀ t, A.HasSub t ↔ B.HasSub t := by + suffices ∀ {A B : NormLevel}, A.Reduced → + (∀ p n, A.get? p = some n → Sorted p) → (∀ p n, B.get? p = some n → Sorted p) → + (∀ t, A.HasSub t → ∃ t', B.HasSub t' ∧ t.le t') → + (∀ t, B.HasSub t → ∃ t', A.HasSub t' ∧ t.le t') → + ∀ t, A.HasSub t → B.HasSub t from + fun t => ⟨this rA sortA sortB hAB hBA t, this rB sortB sortA hBA hAB t⟩ + clear rA rB sortA sortB hAB hBA + intro A B rA sortA sortB hAB hBA t ht + obtain ⟨t', ht', hle⟩ := hAB t ht + obtain ⟨t'', ht'', hle'⟩ := hBA t' ht' + cases rA t t'' ht ht'' (hle.trans hle') + exact (hle.antisymm (HasSub.path_sorted sortA ht) (HasSub.path_sorted sortB ht') hle').symm ▸ + ht' + +/-- Two reduced normal forms with the same sublevels are equal as `NormLevel`s. -/ +theorem NormLevel.eq_of_hasSub_iff {A B : NormLevel} + (hvsA : A.SortedVars) (hvsB : B.SortedVars) + (hneA : ∀ p n, A.get? p = some n → n.isEmpty = false) + (hneB : ∀ p n, B.get? p = some n → n.isEmpty = false) + (h : ∀ t, A.HasSub t ↔ B.HasSub t) : A == B := by + suffices ∀ {A B : NormLevel}, A.SortedVars → B.SortedVars → + (∀ p n, A.get? p = some n → n.isEmpty = false) → + (∀ t, A.HasSub t ↔ B.HasSub t) → + ∀ p n, A.get? p = some n → B.get? p = some n by + have h1 := @this A B hvsA hvsB hneA h + have h2 := @this B A hvsB hvsA hneB fun t => (h t).symm + simp +instances only [instBEqNormLevel, Std.TreeMap.all_eq_all_toList, + Bool.and_eq_true, List.all_eq_true] + constructor <;> rintro ⟨p, n⟩ hpn + · have := h1 p n (Std.TreeMap.get?_eq_getElem? .. ▸ + Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hpn) + rw [Std.TreeMap.get?_eq_getElem?] at this + simp [this] + · have := h2 p n (Std.TreeMap.get?_eq_getElem? .. ▸ + Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hpn) + rw [Std.TreeMap.get?_eq_getElem?] at this + simp [this] + clear hvsA hvsB hneA hneB h + intro A B hvsA hvsB hneA h p n hp + have hne := hneA _ _ hp + rw [Node.isEmpty, Bool.and_eq_false_iff] at hne + have hBp : ∃ m, B.get? p = some m := by + obtain h0 | hv := hne + · obtain ⟨m, hm, -⟩ := (h (.const p n.const)).1 ⟨n, hp, rfl, by simpa using h0⟩ + exact ⟨m, hm⟩ + · obtain ⟨x, hx⟩ := List.exists_mem_of_ne_nil _ (by simpa using hv) + obtain ⟨m, hm, -⟩ := (h (.var p x.var x.offset)).1 ⟨n, hp, hx⟩ + exact ⟨m, hm⟩ + obtain ⟨m, hm⟩ := hBp + have hconst : n.const = m.const := by + by_cases h0 : n.const = 0 + · by_cases h0' : m.const = 0 + · rw [h0, h0'] + · obtain ⟨n', hn', hc, -⟩ := (h (.const p m.const)).2 ⟨m, hm, rfl, h0'⟩ + cases hn'.symm.trans hp + exact absurd (h0 ▸ hc).symm h0' + · obtain ⟨m', hm', hc, -⟩ := (h (.const p n.const)).1 ⟨n, hp, rfl, h0⟩ + cases hm'.symm.trans hm + exact hc.symm + have hvar : n.var = m.var := by + refine VarsSorted.eq_of_mem_iff (hvsA _ _ hp) (hvsB _ _ hm) + fun x => ⟨fun hx => ?_, fun hx => ?_⟩ + · obtain ⟨m', hm', hx'⟩ := (h (.var p x.var x.offset)).1 ⟨n, hp, hx⟩ + cases hm'.symm.trans hm + exact hx' + · obtain ⟨n', hn', hx'⟩ := (h (.var p x.var x.offset)).2 ⟨m, hm, hx⟩ + cases hn'.symm.trans hp + exact hx' + obtain ⟨nc, nv⟩ := n + obtain ⟨mc, mv⟩ := m + cases hconst; cases hvar + exact hm + end Normalize theorem isEquiv'_wf (h : isEquiv' u v) @@ -2225,3 +3241,41 @@ theorem isEquivList_wf (H : Level.isEquivList us vs) : induction us generalizing vs with cases vs <;> simp [List.all2] at H <;> simp | cons u us ih rename_i v vs; rintro _ _ u' hu us' hus rfl v' hv vs' hvs rfl exact .cons (isEquiv_wf H.1 hu hv) (ih H.2 hus hvs) + +/-- Completeness of `geq'`: every valid semantic inequality is accepted. Every sublevel of +`normalize v` is semantically bounded by `normalize u`, hence syntactically dominated by one +of its sublevels (`separation`), which is exactly what the discharging fold in +`NormLevel.le` checks for. -/ +theorem geq'_complete (hu : VLevel.ofLevel ls u = some u') + (hv : VLevel.ofLevel ls v = some v') (h : v' ≤ u') : geq' u v := by + show (Normalize.normalize v).le (Normalize.normalize u) + refine Normalize.NormLevel.le_complete Normalize.normalize_sortedVars + Normalize.normalize_sortedVars Normalize.normalize_nonempty + Normalize.normalize_sorted Normalize.normalize_sorted ?_ + refine Normalize.NormLevel.separation (Normalize.normalize_keys hv) + Normalize.normalize_vars fun ρ => ?_ + rw [Normalize.normalize_eval hv, Normalize.normalize_eval hu] + exact h ρ + +/-- Completeness of `isEquiv'`: semantically equal levels have equal normal forms. Both +normal forms are reduced (`subsumption_reduced`), mutually dominate each other's sublevels +(`separation`), and reduced forms with the same sublevels are the same map. -/ +theorem isEquiv'_complete (hu : VLevel.ofLevel ls u = some u') + (hv : VLevel.ofLevel ls v = some v') (h : u' ≈ v') : isEquiv' u v := by + have equiv := VLevel.equiv_def.1 h + have h₁ : ∀ ρ, (Normalize.normalize u).eval ls ρ ≤ (Normalize.normalize v).eval ls ρ := + fun ρ => by rw [Normalize.normalize_eval hu, Normalize.normalize_eval hv, equiv ρ] + exact Nat.le_refl _ + have h₂ : ∀ ρ, (Normalize.normalize v).eval ls ρ ≤ (Normalize.normalize u).eval ls ρ := + fun ρ => by rw [Normalize.normalize_eval hu, Normalize.normalize_eval hv, equiv ρ] + exact Nat.le_refl _ + simp only [isEquiv', Bool.or_eq_true] + refine .inr ?_ + exact Normalize.NormLevel.eq_of_hasSub_iff Normalize.normalize_sortedVars + Normalize.normalize_sortedVars Normalize.normalize_nonempty Normalize.normalize_nonempty + (Normalize.NormLevel.Reduced.hasSub_iff_hasSub Normalize.normalize_reduced + Normalize.normalize_reduced Normalize.normalize_sorted Normalize.normalize_sorted + (Normalize.NormLevel.separation (Normalize.normalize_keys hu) + Normalize.normalize_vars h₁) + (Normalize.NormLevel.separation (Normalize.normalize_keys hv) + Normalize.normalize_vars h₂)) From 4ff2346712b17a8513b683ccfeaeff76d000bd47 Mon Sep 17 00:00:00 2001 From: Mario Carneiro Date: Tue, 11 Aug 2026 08:02:53 +0200 Subject: [PATCH 36/51] verify: prove completeness of normalize' Semantically equal levels reconstruct to syntactically equal levels: the normal forms are BEq-equal, BEq-equal maps have equal toLists (TreeMap equality itself does not follow, since the tree shape depends on insertion order), and the reconstruction depends on the map only through its entry list (addable/feasible/lexChain/toTree congruence). Co-Authored-By: Claude Fable 5 --- Lean4Lean/Verify/Level.lean | 169 ++++++++++++++++++++++++++++-------- 1 file changed, 131 insertions(+), 38 deletions(-) diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index 9ddfe536..124ca04b 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -3144,8 +3144,7 @@ theorem NormLevel.Reduced.hasSub_iff_hasSub {A B : NormLevel} obtain ⟨t', ht', hle⟩ := hAB t ht obtain ⟨t'', ht'', hle'⟩ := hBA t' ht' cases rA t t'' ht ht'' (hle.trans hle') - exact (hle.antisymm (HasSub.path_sorted sortA ht) (HasSub.path_sorted sortB ht') hle').symm ▸ - ht' + exact (hle.antisymm (HasSub.path_sorted sortA ht) (HasSub.path_sorted sortB ht') hle').symm ▸ ht' /-- Two reduced normal forms with the same sublevels are equal as `NormLevel`s. -/ theorem NormLevel.eq_of_hasSub_iff {A B : NormLevel} @@ -3206,6 +3205,103 @@ theorem NormLevel.eq_of_hasSub_iff {A B : NormLevel} cases hconst; cases hvar exact hm +/-- Semantically equal levels have `BEq`-equal normal forms. -/ +theorem normalize_complete (hu : VLevel.ofLevel ls u = some u') + (hv : VLevel.ofLevel ls v = some v') : normalize u == normalize v ↔ u' ≈ v' := by + refine .trans ⟨fun h ls => ?_, fun h => ?_⟩ VLevel.equiv_def.symm + · rw [← normalize_eval hu, NormLevel.eval_congr h, normalize_eval hv] + have h₁ : ∀ ρ, (normalize u).eval ls ρ ≤ (normalize v).eval ls ρ := fun ρ => by + rw [normalize_eval hu, normalize_eval hv, h ρ]; exact Nat.le_refl _ + have h₂ : ∀ ρ, (normalize v).eval ls ρ ≤ (normalize u).eval ls ρ := fun ρ => by + rw [normalize_eval hu, normalize_eval hv, h ρ]; exact Nat.le_refl _ + exact NormLevel.eq_of_hasSub_iff normalize_sortedVars normalize_sortedVars + normalize_nonempty normalize_nonempty + (NormLevel.Reduced.hasSub_iff_hasSub normalize_reduced normalize_reduced + normalize_sorted normalize_sorted + (NormLevel.separation (normalize_keys hu) normalize_vars h₁) + (NormLevel.separation (normalize_keys hv) normalize_vars h₂)) + +/-! `BEq`-equal maps have equal `toList`s, and the reconstruction depends on the map only +through `toList`, so equal normal forms reify to syntactically equal levels. (`TreeMap` +equality itself does not follow from `==`: the internal tree shape depends on insertion +order.) -/ + +private theorem listName_compare_self {p : List Name} : compare p p = .eq := + Std.LawfulBEqCmp.compare_eq_iff_beq.2 (by simp) + +theorem sorted_pairs_eq : ∀ {l₁ l₂ : List (List Name × Node)}, + l₁.Pairwise (compare ·.1 ·.1 = .lt) → l₂.Pairwise (compare ·.1 ·.1 = .lt) → + (∀ x, x ∈ l₁ ↔ x ∈ l₂) → l₁ = l₂ + | [], [], _, _, _ => rfl + | [], _ :: _, _, _, h => nomatch (h _).2 (.head _) + | _ :: _, [], _, _, h => nomatch (h _).1 (.head _) + | a :: l₁, b :: l₂, h₁, h₂, h => by + have head₁ := (List.pairwise_cons.1 h₁).1 + have head₂ := (List.pairwise_cons.1 h₂).1 + cases show a = b by + rcases List.mem_cons.1 ((h a).1 (.head _)) with rfl | ha <;> [rfl; skip] + rcases List.mem_cons.1 ((h b).2 (.head _)) with rfl | hb <;> [rfl; skip] + cases Std.OrientedCmp.not_lt_of_lt (head₁ _ hb) (head₂ _ ha) + refine congrArg (a :: ·) (sorted_pairs_eq (List.pairwise_cons.1 h₁).2 + (List.pairwise_cons.1 h₂).2 fun x => ⟨fun hx => ?_, fun hx => ?_⟩) + · rcases List.mem_cons.1 ((h x).1 (.tail _ hx)) with rfl | hx' + · have := head₁ _ hx; rw [listName_compare_self] at this; cases this + · exact hx' + · rcases List.mem_cons.1 ((h x).2 (.tail _ hx)) with rfl | hx' + · have := head₂ _ hx; rw [listName_compare_self] at this; cases this + · exact hx' + +theorem NormLevel.toList_eq {A B : NormLevel} (h : A == B) : A.toList = B.toList := by + simp +instances only [instBEqNormLevel, Std.TreeMap.all_eq_all_toList, + Bool.and_eq_true, List.all_eq_true] at h + refine sorted_pairs_eq Std.TreeMap.ordered_keys_toList Std.TreeMap.ordered_keys_toList + fun x => ⟨fun hx => ?_, fun hx => ?_⟩ + · have := h.1 x hx + rw [beq_iff_eq, Std.TreeMap.get?_eq_getElem?] at this + exact Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 this + · have := h.2 x hx + rw [beq_iff_eq, Std.TreeMap.get?_eq_getElem?] at this + exact Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 this + +theorem NormLevel.addable_congr {A B : NormLevel} (h : A.toList = B.toList) : + A.addable a acc = B.addable a acc := by + rw [addable, addable, Std.TreeMap.any_eq_any_toList, Std.TreeMap.any_eq_any_toList, h] + +theorem NormLevel.feasible_go_congr {A B : NormLevel} (h : A.toList = B.toList) : + ∀ fuel acc rem, NormLevel.feasible.go A fuel acc rem = NormLevel.feasible.go B fuel acc rem + | 0, _, _ => rfl + | fuel+1, acc, rem => by + simp only [feasible.go] + rw [show (fun a => A.addable a acc) = fun a => B.addable a acc from + funext fun a => addable_congr h] + cases rem.find? fun a => B.addable a acc with + | none => rfl + | some a => exact feasible_go_congr h fuel _ _ + +theorem NormLevel.feasible_congr {A B : NormLevel} (h : A.toList = B.toList) : + A.feasible acc rem = B.feasible acc rem := by + simp only [feasible]; exact feasible_go_congr h .. + +theorem NormLevel.lexChain_congr {A B : NormLevel} (h : A.toList = B.toList) : + ∀ fuel p, A.lexChain fuel p = B.lexChain fuel p + | 0, _ => rfl + | fuel+1, p => by + simp only [lexChain] + rw [show (fun a => A.addable a (p.erase a) && A.feasible [] (p.erase a)) + = fun a => B.addable a (p.erase a) && B.feasible [] (p.erase a) from + funext fun a => by rw [addable_congr h, feasible_congr h]] + cases p.find? fun a => B.addable a (p.erase a) && B.feasible [] (p.erase a) with + | none => rfl + | some a => exact congrArg (a :: ·) (lexChain_congr h fuel _) + +/-- The reconstruction depends only on the entry list of the map. -/ +theorem NormLevel.toTree_congr {A B : NormLevel} (h : A.toList = B.toList) : + A.toTree = B.toTree := by + rw [toTree, toTree, Std.TreeMap.foldl_eq_foldl_toList, Std.TreeMap.foldl_eq_foldl_toList, h] + congr 1 + funext t pn + rw [lexChain_congr h] + end Normalize theorem isEquiv'_wf (h : isEquiv' u v) @@ -3224,12 +3320,12 @@ key admits a chain (`normalize_feas`) and `lexChain` then picks an admissible on nothing is lost, since every entry is recorded at the end of its chain. -/ theorem normalize'_eval (hu : VLevel.ofLevel ls u = some u') : Level.eval (Normalize.evalParam ls ρ) μ (normalize' u) = u'.eval ρ := by - rw [normalize', Normalize.Tree.reify_eval, - Normalize.NormLevel.toTree_eval Normalize.normalize_sorted Normalize.normalize_feas] - exact Normalize.normalize_eval hu + open Normalize in + rw [normalize', Tree.reify_eval, NormLevel.toTree_eval normalize_sorted normalize_feas] + exact normalize_eval hu -theorem geq'_wf (h : geq' u v) - (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') : v' ≤ u' := by +theorem geq'_wf (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') + (h : geq' u v) : v' ≤ u' := by intro ρ rw [← Normalize.normalize_eval (ρ := ρ) hv, ← Normalize.normalize_eval (ρ := ρ) hu] exact Normalize.NormLevel.le_eval Normalize.normalize_vars h @@ -3242,40 +3338,37 @@ theorem isEquivList_wf (H : Level.isEquivList us vs) : rename_i v vs; rintro _ _ u' hu us' hus rfl v' hv vs' hvs rfl exact .cons (isEquiv_wf H.1 hu hv) (ih H.2 hus hvs) +/-- Canonicity of `normalize'`: semantically equal levels reconstruct to syntactically equal +levels. The normal forms are `BEq`-equal, hence have the same entry list, and the +reconstruction (`lexChain` and the tree fold) depends on the map only through its entry +list. -/ +theorem normalize'_complete (hu : VLevel.ofLevel ls u = some u') + (hv : VLevel.ofLevel ls v = some v') : normalize' u = normalize' v ↔ u' ≈ v' := by + refine ⟨fun h => ?_, fun h => ?_⟩ + · refine VLevel.equiv_def.2 fun ρ => ?_ + rw [← normalize'_eval (μ := fun _ => 0) hu, ← normalize'_eval hv, h] + · simp only [normalize'] + rw [← Normalize.normalize_complete hu hv] at h + rw [Normalize.NormLevel.toTree_congr (Normalize.NormLevel.toList_eq h)] + +/-- Completeness of `isEquiv'`: semantically equal levels have equal normal forms. Both +normal forms are reduced (`subsumption_reduced`), mutually dominate each other's sublevels +(`separation`), and reduced forms with the same sublevels are the same map. -/ +theorem isEquiv'_complete (hu : VLevel.ofLevel ls u = some u') + (hv : VLevel.ofLevel ls v = some v') : isEquiv' u v ↔ u' ≈ v' := by + simp [isEquiv', Normalize.normalize_complete hu hv] + rintro rfl; cases hu.symm.trans hv; exact rfl + /-- Completeness of `geq'`: every valid semantic inequality is accepted. Every sublevel of `normalize v` is semantically bounded by `normalize u`, hence syntactically dominated by one of its sublevels (`separation`), which is exactly what the discharging fold in `NormLevel.le` checks for. -/ theorem geq'_complete (hu : VLevel.ofLevel ls u = some u') - (hv : VLevel.ofLevel ls v = some v') (h : v' ≤ u') : geq' u v := by - show (Normalize.normalize v).le (Normalize.normalize u) - refine Normalize.NormLevel.le_complete Normalize.normalize_sortedVars - Normalize.normalize_sortedVars Normalize.normalize_nonempty - Normalize.normalize_sorted Normalize.normalize_sorted ?_ - refine Normalize.NormLevel.separation (Normalize.normalize_keys hv) - Normalize.normalize_vars fun ρ => ?_ - rw [Normalize.normalize_eval hv, Normalize.normalize_eval hu] + (hv : VLevel.ofLevel ls v = some v') : geq' u v ↔ v' ≤ u' := by + open Normalize in + refine ⟨geq'_wf hu hv, fun h => ?_⟩ + refine NormLevel.le_complete normalize_sortedVars normalize_sortedVars normalize_nonempty + normalize_sorted normalize_sorted ?_ + refine NormLevel.separation (normalize_keys hv) normalize_vars fun ρ => ?_ + rw [normalize_eval hv, normalize_eval hu] exact h ρ - -/-- Completeness of `isEquiv'`: semantically equal levels have equal normal forms. Both -normal forms are reduced (`subsumption_reduced`), mutually dominate each other's sublevels -(`separation`), and reduced forms with the same sublevels are the same map. -/ -theorem isEquiv'_complete (hu : VLevel.ofLevel ls u = some u') - (hv : VLevel.ofLevel ls v = some v') (h : u' ≈ v') : isEquiv' u v := by - have equiv := VLevel.equiv_def.1 h - have h₁ : ∀ ρ, (Normalize.normalize u).eval ls ρ ≤ (Normalize.normalize v).eval ls ρ := - fun ρ => by rw [Normalize.normalize_eval hu, Normalize.normalize_eval hv, equiv ρ] - exact Nat.le_refl _ - have h₂ : ∀ ρ, (Normalize.normalize v).eval ls ρ ≤ (Normalize.normalize u).eval ls ρ := - fun ρ => by rw [Normalize.normalize_eval hu, Normalize.normalize_eval hv, equiv ρ] - exact Nat.le_refl _ - simp only [isEquiv', Bool.or_eq_true] - refine .inr ?_ - exact Normalize.NormLevel.eq_of_hasSub_iff Normalize.normalize_sortedVars - Normalize.normalize_sortedVars Normalize.normalize_nonempty Normalize.normalize_nonempty - (Normalize.NormLevel.Reduced.hasSub_iff_hasSub Normalize.normalize_reduced - Normalize.normalize_reduced Normalize.normalize_sorted Normalize.normalize_sorted - (Normalize.NormLevel.separation (Normalize.normalize_keys hu) - Normalize.normalize_vars h₁) - (Normalize.NormLevel.separation (Normalize.normalize_keys hv) - Normalize.normalize_vars h₂)) From c4fce070e78bb3d3ca2f0c0e00e07d9d0a21b86d Mon Sep 17 00:00:00 2001 From: Mario Carneiro Date: Tue, 11 Aug 2026 09:45:24 +0200 Subject: [PATCH 37/51] fix: absorb the node constant into plain children when reifying An edge labelled `a` whose subtree holds nothing but `V(_, a, k)` contributes `imax (a+k) a`, which differs from the plain `a+k` only at `a = 0`, where the plain form gives `k` instead of `0`. So the guard can be dropped whenever the node's constant is at least `k`, and the constant itself dropped when some child's offset reaches it. Both stay functions of the normal form, so canonicity is unaffected (normalize'_complete is unchanged); only reify_eval needs the new argument, via plainOffset?_eval and reifyChild_ge. Without this, every offset in the input doubled the size of its normal form: u+1 reified to max 1 (imax (u+1) u). Measured over the 522k level occurrences reaching lean4lean's comparison sites while checking Lean+Std+Batteries, the share of levels already in normal form rises from 51% to 67%, the share whose normal form is larger than the input falls from 37% to 17%, and the mean normalized size falls from 5.69 to 3.07 against a mean input size of 2.97. Co-Authored-By: Claude Fable 5 --- Lean4Lean/Level.lean | 30 +++++++++++--- Lean4Lean/Tests/Level.lean | 20 ++++++++-- Lean4Lean/Verify/Level.lean | 80 +++++++++++++++++++++++++++++++------ 3 files changed, 109 insertions(+), 21 deletions(-) diff --git a/Lean4Lean/Level.lean b/Lean4Lean/Level.lean index eeb6bcb3..3bf9e8a4 100644 --- a/Lean4Lean/Level.lean +++ b/Lean4Lean/Level.lean @@ -261,23 +261,41 @@ def NormLevel.toTree (acc : NormLevel) : Tree := let var := if let v :: _ := path then subsumeVars n.var [⟨v, 0⟩] else n.var t.modify path fun t => { t with const := n.const, var } +/-- If the subtree behind an edge labelled `a` holds nothing but the sublevel `V(_, a, k)`, +return `k`. + +Such an edge contributes `imax (a+k) a`, which differs from the plain `a+k` only at `a = 0`, +where the plain form gives `k` instead of `0`. So the guard may be dropped, and the child +written as just `a+k`, whenever the node's constant is at least `k` — and if the constant is +*exactly* `k`, it may then be dropped itself, since `a+k ≥ k`. Without this, `u+1` would reify +to `max 1 (imax (u+1) u)` rather than to itself, and the canonical form would be roughly twice +the size of the input on typical levels. -/ +def Tree.plainOffset? (a : Name) : Tree → Option Nat + | ⟨0, [], []⟩ => some 0 + | ⟨0, [v], []⟩ => if v.var == a then some v.offset else none + | _ => none + def Tree.reify : Tree → Level | { const, var, child } => - let l := child.foldr mkChild none + let l := child.foldr (mkChild const) none let l := var.foldr (init := l) fun n r => some (mkMax (addOffset (.param n.var) n.offset) r) match l with | none => ofNat const - | some l => if const = 0 then l else max (ofNat const) l + | some l => + if const == 0 || child.any fun c => plainOffset? c.1 c.2 == some const then l + else max (ofNat const) l where mkMax (l : Level) : Option Level → Level | none => l | some u => max l u - mkChild + mkChild (const : Nat) | (n, t), r => - match reify t with - | .zero => mkMax (.param n) r - | t => mkMax (imax t (.param n)) r + match plainOffset? n t with + | some k => + if k ≤ const then mkMax (addOffset (.param n) k) r + else mkMax (imax (reify t) (.param n)) r + | none => mkMax (imax (reify t) (.param n)) r end Normalize diff --git a/Lean4Lean/Tests/Level.lean b/Lean4Lean/Tests/Level.lean index e231a323..8fc831de 100644 --- a/Lean4Lean/Tests/Level.lean +++ b/Lean4Lean/Tests/Level.lean @@ -49,17 +49,31 @@ universe u v w #guard_msgs in normalize max u 1 /-- info: u -/ #guard_msgs in normalize imax 1 u -/-- info: max 1 (imax (u + 1) u) -/ -#guard_msgs in normalize u+1 /-- info: imax 2 u -/ #guard_msgs in normalize imax 2 u + +-- Constant absorption (`Tree.plainOffset?`): the sublevel `V({u}, u, 1)` is reified as the +-- plain `u+1` rather than the guarded `imax (u+1) u`, because the node's constant `1` covers +-- what the plain form contributes at `u = 0`; the constant is then redundant and dropped. +-- Without this every offset in the input doubles the size of its normal form. +/-- info: u + 1 -/ +#guard_msgs in normalize u+1 +/-- info: max u (v + 1) -/ +#guard_msgs in normalize max u (v+1) +-- the constant survives when no variable's offset reaches it +/-- info: max 2 (u + 1) -/ +#guard_msgs in normalize max 2 (u+1) +-- and the guard survives when the constant (here 0) does not cover the offset, as it must: +-- `u+2` is 2 at `u = 0`, where the level is 0 +/-- info: imax (u + 2) u -/ +#guard_msgs in normalize imax (u+2) u /-- info: max v (imax (imax u v) w) -/ #guard_msgs in normalize max w (imax (imax u w) v) /-- info: max v (imax (imax u v) w) -/ #guard_msgs in normalize max (imax (imax u v) w) (imax (imax u w) v) /-- info: u -/ #guard_msgs in normalize imax u u -/-- info: max 1 (imax (u + 1) u) -/ +/-- info: u + 1 -/ #guard_msgs in normalize imax u (u+1) /-- info: max 1 (imax (max (v + 1) (imax (u + 1) u)) v) -/ #guard_msgs in normalize imax u v + 1 diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index 124ca04b..898968a1 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -1356,35 +1356,91 @@ theorem eval_varFold (var : List VarNode) (o : Option Level) : simp only [List.foldr_cons, evalOpt_some, eval_mkMax, eval_addOffset, Level.eval, ih, Node.eval_cons, VarNode.eval]; omega +/-- The two shapes `plainOffset?` accepts. -/ +theorem Tree.plainOffset?_eq {a : Name} {t : Tree} {k : Nat} (h : plainOffset? a t = some k) : + t = ⟨0, [], []⟩ ∧ k = 0 ∨ t = ⟨0, [⟨a, k⟩], []⟩ := by + unfold plainOffset? at h + split at h + · exact .inl ⟨rfl, by simpa using h.symm⟩ + · rename_i v _ + split at h <;> [skip; cases h] + cases h; rename_i hv + exact .inr (by rw [← eq_of_beq hv]) + · cases h + +/-- Dropping the `imax` guard of a plain child is exact modulo the node's constant: the two +differ only when the edge variable is zero, where the plain form contributes `k ≤ const`. -/ +theorem Tree.plainOffset?_eval {a : Name} {t : Tree} {k const : Nat} + (h : plainOffset? a t = some k) (hk : k ≤ const) : + max' const (Lean.Nat.imax (eval ls ρ t) (evalParam ls ρ a)) = + max' const (evalParam ls ρ a + k) := by + obtain ⟨rfl, rfl⟩ | rfl := plainOffset?_eq h + · rw [show eval ls ρ ⟨0, [], []⟩ = 0 from by simp [eval, evalChild, Node.eval], + imax_zero_left] + omega + · rw [show eval ls ρ ⟨0, [⟨a, k⟩], []⟩ = evalParam ls ρ a + k from by + simp [eval, evalChild, Node.eval, VarNode.eval], imax_eq_ite] + split <;> omega + +/-- A child emitted plainly at exactly the node's constant makes that constant redundant. -/ +theorem Tree.reifyChild_ge {const : Nat} : ∀ child : List (Name × Tree), + (child.any fun c => plainOffset? c.1 c.2 == some const) → + const ≤ evalOpt (evalParam ls ρ) μ (child.foldr (reify.mkChild const) none) + | (n, t) :: child, h => by + rw [List.foldr_cons, reify.mkChild] + simp only [List.any_cons, Bool.or_eq_true, beq_iff_eq] at h + -- either this child is the witness, in which case it is emitted as `n + const`, or the + -- witness is further down and the fold maxes its value in + obtain h | h := h + · rw [h]; dsimp only; rw [if_pos (Nat.le_refl const)] + simp only [evalOpt_some, eval_mkMax, eval_addOffset, Level.eval] + omega + · have ih := reifyChild_ge (ls := ls) (ρ := ρ) (μ := μ) child h + split <;> [split; skip] <;> + simp only [evalOpt_some, eval_mkMax] <;> omega + mutual theorem Tree.reify_eval (t : Tree) : t.reify.eval (evalParam ls ρ) μ = t.eval ls ρ := by obtain ⟨const, var, child⟩ := t rw [eval] simp only [reify] - have h1 := eval_varFold (ls := ls) (ρ := ρ) (μ := μ) var (child.foldr reify.mkChild none) - rw [reifyChild_eval] at h1 + have h1 := eval_varFold (ls := ls) (ρ := ρ) (μ := μ) var + (child.foldr (reify.mkChild const) none) + have hc := reifyChild_eval (ls := ls) (ρ := ρ) (μ := μ) const child rw [Node.eval_const (c := const)] split <;> [rename_i heq; rename_i l heq] · rw [heq, evalOpt_none] at h1 rw [eval_ofNat]; omega · rw [heq, evalOpt_some] at h1 - split - · subst const; omega - · simp only [Level.eval, eval_ofNat, h1]; exact (Nat.max_assoc ..).symm + split <;> rename_i hd + · -- the constant is dropped: either it is zero, or some child already covers it + simp only [Bool.or_eq_true, beq_iff_eq] at hd + rw [h1] + obtain rfl | hd := hd + · omega + · have := Tree.reifyChild_ge (ls := ls) (ρ := ρ) (μ := μ) (const := const) child hd + omega + · simp only [Level.eval, eval_ofNat, h1, Nat.max_eq_max]; omega -theorem Tree.reifyChild_eval (child : List (Name × Tree)) : - evalOpt (evalParam ls ρ) μ (child.foldr reify.mkChild none) = evalChild ls ρ child := by +theorem Tree.reifyChild_eval (const : Nat) (child : List (Name × Tree)) : + max' const (evalOpt (evalParam ls ρ) μ (child.foldr (reify.mkChild const) none)) = + max' const (evalChild ls ρ child) := by match child with | [] => rfl | (n, t) :: child => rw [List.foldr_cons, evalChild, reify.mkChild] have ht := reify_eval (ls := ls) (ρ := ρ) (μ := μ) t - have ih := reifyChild_eval (ls := ls) (ρ := ρ) (μ := μ) child - split <;> rename_i h - · rw [h] at ht - simp only [evalOpt_some, eval_mkMax, Level.eval, ih, ← ht, imax_zero_left] - · simp only [evalOpt_some, eval_mkMax, Level.eval, ih, ht] + have ih := reifyChild_eval (ls := ls) (ρ := ρ) (μ := μ) const child + split <;> rename_i k h + · split <;> rename_i hk + · have hp := Tree.plainOffset?_eval (ls := ls) (ρ := ρ) h hk + simp only [evalOpt_some, eval_mkMax, eval_addOffset, Level.eval] at * + omega + · simp only [evalOpt_some, eval_mkMax, Level.eval, ht] at * + omega + · simp only [evalOpt_some, eval_mkMax, Level.eval, ht] at * + omega end From 5aa2addb7a5289d51ce63840cdace56c6c2e2f35 Mon Sep 17 00:00:00 2001 From: Mario Carneiro Date: Tue, 11 Aug 2026 10:23:27 +0200 Subject: [PATCH 38/51] perf: use core's isEquiv/geq as the fast path for isEquiv'/geq' Core's versions are sound but incomplete, which is exactly what a fast path needs: when they accept, the levels really are equivalent (isEquiv_wf/geq_wf), and when they reject we fall back to the complete check, so completeness is still supplied entirely by normalize_complete/le_complete and the fast path contributes nothing to it. Replaying the 261k level comparisons performed while checking Lean+Std+ Batteries, core's filter decided every one of the 260894 real equivalences and left only the 340 genuinely inequivalent calls to the fallback. isEquiv' drops from 2941ms to 192ms and geq' from 3728ms to 198ms over that workload, within 2x of core's own routines net of harness overhead. Note this makes isEquiv'/geq' depend on the patch axioms for core's normalize, which the checker already relied on: isEquivList is List.all2 isEquiv, so isEquivList_wf went through isEquiv_wf regardless. Co-Authored-By: Claude Fable 5 --- Lean4Lean/Level.lean | 12 ++++++++++-- Lean4Lean/Verify/Level.lean | 19 ++++++++++++------- 2 files changed, 22 insertions(+), 9 deletions(-) diff --git a/Lean4Lean/Level.lean b/Lean4Lean/Level.lean index 3bf9e8a4..38705c13 100644 --- a/Lean4Lean/Level.lean +++ b/Lean4Lean/Level.lean @@ -301,11 +301,19 @@ end Normalize def normalize' (l : Level) : Level := (Normalize.normalize l).toTree.reify -def isEquiv' (u v : Level) : Bool := u == v || Normalize.normalize u == Normalize.normalize v +/-- Core's `isEquiv` is sound but incomplete, so it can be used as a fast path: when it +accepts, the levels really are equivalent, and when it rejects we fall back to the complete +check. Over the 261k level comparisons performed while checking Lean+Std+Batteries this +filter decided every single real equivalence, leaving only the genuinely inequivalent 0.1% +to the fallback — and it is roughly 20× cheaper than normalizing. -/ +def isEquiv' (u v : Level) : Bool := + isEquiv u v || Normalize.normalize u == Normalize.normalize v def isEquivList : List Level → List Level → Bool := List.all2 isEquiv -def geq' (u v : Level) : Bool := (Normalize.normalize v).le (Normalize.normalize u) +/-- Core's `geq` as a fast path, on the same grounds as `isEquiv'`. -/ +def geq' (u v : Level) : Bool := + geq u v || (Normalize.normalize v).le (Normalize.normalize u) -- local elab "normalize " l:level : command => do -- Elab.Command.runTermElabM fun _ => do diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index 898968a1..e347f52f 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -3363,8 +3363,8 @@ end Normalize theorem isEquiv'_wf (h : isEquiv' u v) (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') : u' ≈ v' := by simp only [isEquiv', Bool.or_eq_true, beq_iff_eq] at h - obtain rfl | h := h - · cases hu.symm.trans hv; rfl + obtain h | h := h + · exact isEquiv_wf h hu hv · refine VLevel.equiv_def.2 fun ρ => ?_ rw [← Normalize.normalize_eval (ρ := ρ) hu, ← Normalize.normalize_eval (ρ := ρ) hv] exact Normalize.NormLevel.eval_congr h @@ -3382,9 +3382,12 @@ theorem normalize'_eval (hu : VLevel.ofLevel ls u = some u') : theorem geq'_wf (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') (h : geq' u v) : v' ≤ u' := by - intro ρ - rw [← Normalize.normalize_eval (ρ := ρ) hv, ← Normalize.normalize_eval (ρ := ρ) hu] - exact Normalize.NormLevel.le_eval Normalize.normalize_vars h + simp only [geq', Bool.or_eq_true] at h + obtain h | h := h + · exact geq_wf h hu hv + · intro ρ + rw [← Normalize.normalize_eval (ρ := ρ) hv, ← Normalize.normalize_eval (ρ := ρ) hu] + exact Normalize.NormLevel.le_eval Normalize.normalize_vars h theorem isEquivList_wf (H : Level.isEquivList us vs) : List.mapM (VLevel.ofLevel Us) us = some us' → @@ -3412,8 +3415,8 @@ normal forms are reduced (`subsumption_reduced`), mutually dominate each other's (`separation`), and reduced forms with the same sublevels are the same map. -/ theorem isEquiv'_complete (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') : isEquiv' u v ↔ u' ≈ v' := by - simp [isEquiv', Normalize.normalize_complete hu hv] - rintro rfl; cases hu.symm.trans hv; exact rfl + simp only [isEquiv', Bool.or_eq_true, Normalize.normalize_complete hu hv] + exact ⟨fun h => h.elim (fun h => isEquiv_wf h hu hv) id, .inr⟩ /-- Completeness of `geq'`: every valid semantic inequality is accepted. Every sublevel of `normalize v` is semantically bounded by `normalize u`, hence syntactically dominated by one @@ -3423,6 +3426,8 @@ theorem geq'_complete (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') : geq' u v ↔ v' ≤ u' := by open Normalize in refine ⟨geq'_wf hu hv, fun h => ?_⟩ + simp only [geq', Bool.or_eq_true] + refine .inr ?_ refine NormLevel.le_complete normalize_sortedVars normalize_sortedVars normalize_nonempty normalize_sorted normalize_sorted ?_ refine NormLevel.separation (normalize_keys hv) normalize_vars fun ρ => ?_ From b2bf43e7ff6f154e5b28390cb94719e8f209e2d6 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Mon, 10 Aug 2026 21:17:27 -0400 Subject: [PATCH 39/51] 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 9a19b44d..6827637a 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 40/51] 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 75c3d5a7..f3c99065 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 7ed24cd0..44bfd3fb 100644 --- a/Lean4Lean/Environment/Basic.lean +++ b/Lean4Lean/Environment/Basic.lean @@ -51,6 +51,62 @@ def isNonRecStructure (env : Environment) (constName : Name) : Bool := | some (.inductInfo { isRec := false, ctors := [_], numIndices := 0, .. }) => true | _ => false +/-- A one-constructor, unindexed structure whose constructor and generated +recursor have both reached the host environment. Family metadata is staged +before either artifact is inserted; projection verification may only demand a +registered Theory view at this later boundary. + +Unlike `isNonRecStructure`, projection readiness deliberately does not inspect +`InductiveVal.isRec`: Lean emits primitive projections for recursive structures +too (including nested-recursive structures in the Lean prelude). -/ +def isProjectionReadyStructure (env : Environment) (constName : Name) : Bool := + match env.constants.find?' constName with + | some (.inductInfo { ctors := [ctor], numIndices := 0, .. }) => + match env.constants.find?' ctor, + env.constants.find?' (mkRecName constName) with + | some (.ctorInfo _), some (.recInfo _) => true + | _, _ => false + | _ => false + +theorem isProjectionReadyStructure_false_of_no_ctorInfo + {env : Environment} {name : Name} {info : InductiveVal} + (hfind : env.constants.find?' name = some (.inductInfo info)) + (hnoCtor : ∀ ctor ctorInfo, + env.constants.find?' ctor ≠ some (.ctorInfo ctorInfo)) : + env.isProjectionReadyStructure name = false := by + cases info + rename_i constant numParams numIndices all ctors numNested isRec isUnsafe isReflexive + cases constant + unfold isProjectionReadyStructure + rw [hfind] + cases numIndices with + | succ _ => rfl + | zero => + cases ctors with + | nil => rfl + | cons ctor rest => + cases rest with + | cons _ _ => rfl + | nil => + cases hctor : env.constants.find?' ctor with + | none => simp [hctor] + | some info => + cases info <;> simp_all + +theorem isProjectionReadyStructure_false_of_numIndices_ne + {env : Environment} {name : Name} {info : InductiveVal} + (hfind : env.constants.find?' name = some (.inductInfo info)) + (hindices : info.numIndices ≠ 0) : + env.isProjectionReadyStructure name = false := by + cases info + simp_all [isProjectionReadyStructure] + +theorem isProjectionReadyStructure_false_of_not_found + {env : Environment} {name : Name} + (hfind : env.constants.find?' name = none) : + env.isProjectionReadyStructure name = false := by + simp [isProjectionReadyStructure, hfind] + def checkName (env : Environment) (n : Name) (allowPrimitive := false) : Except Exception Unit := do if env.contains n then diff --git a/Lean4Lean/Theory/Projection.lean b/Lean4Lean/Theory/Projection.lean index 501dd383..199c3f65 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 c71b1d61..cf9a2b00 100644 --- a/Lean4Lean/TypeChecker.lean +++ b/Lean4Lean/TypeChecker.lean @@ -200,32 +200,46 @@ def getSortLevel (e : Expr) : RecM Level := do def isProp (e : Expr) : RecM Bool := return (← getSortLevel e).isAlwaysZero +def invalidProj (e : Expr) : RecM α := do + throw <| .invalidProj (← getEnv) (← getLCtx) e + +def inferProjParams (proj : Expr) : List Expr → Expr → RecM Expr + | [], r => pure r + | arg :: args, r => do + let .forallE _ _ body _ ← whnf r | invalidProj proj + inferProjParams proj args (body.instantiate1 arg) + +def inferProjFields (proj : Expr) (typeName : Name) + (struct : Expr) (maybePropType : Bool) : + Nat → Nat → Expr → RecM Expr + | _, 0, r => pure r + | fieldIdx, count + 1, r => do + let .forallE _ dom body _ ← whnf r | invalidProj proj + if body.hasLooseBVars && maybePropType then + if !(← isProp dom) then invalidProj proj + inferProjFields proj typeName struct maybePropType (fieldIdx + 1) count + (body.instantiate1 (.proj typeName fieldIdx struct)) + def inferProj (typeName : Name) (idx : Nat) (struct structType : Expr) : RecM Expr := do let e := Expr.proj typeName idx struct let type ← whnf structType type.withApp fun I args => do let env ← getEnv - let fail {_} := do throw <| .invalidProj env (← getLCtx) e - let .const I_name I_levels := I | fail - if typeName != I_name then fail - let .inductInfo I_val ← env.get I_name | fail - let [c] := I_val.ctors | fail - if args.size != I_val.numParams + I_val.numIndices then fail + let .const I_name I_levels := I | invalidProj e + if typeName != I_name then invalidProj e + let .inductInfo I_val ← env.get I_name | invalidProj e + let [c] := I_val.ctors | invalidProj e + unless env.isProjectionReadyStructure I_name do invalidProj e + if args.size != I_val.numParams + I_val.numIndices then invalidProj e let c_info ← env.get c - let mut r := c_info.instantiateTypeLevelParams I_levels - for i in [:I_val.numParams] do - let .forallE _ _ b _ ← whnf r | fail - r := b.instantiate1 args[i]! + let .ctorInfo ctorInfo := c_info | invalidProj e + unless idx < ctorInfo.numFields do invalidProj e + let r ← inferProjParams e (args.toList.take I_val.numParams) + (c_info.instantiateTypeLevelParams I_levels) let maybePropType := !(← getSortLevel type).isNeverZero - for i in [:idx] do - let .forallE _ dom b _ ← whnf r | fail - if b.hasLooseBVars then - if maybePropType then if !(← isProp dom) then fail - r := b.instantiate1 (.proj I_name i struct) - else - r := b - let .forallE _ dom _ _ ← whnf r | fail - if maybePropType then if !(← isProp dom) then fail + let r ← inferProjFields e I_name struct maybePropType 0 idx r + let .forallE _ dom _ _ ← whnf r | invalidProj e + if maybePropType then if !(← isProp dom) then invalidProj e return dom def inferType' (e : Expr) (inferOnly : Bool) : RecM Expr := do diff --git a/Lean4Lean/Verify/Environment/ConstructorValidation.lean b/Lean4Lean/Verify/Environment/ConstructorValidation.lean index 45df0455..3a466725 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 322c5b5a..58606b72 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean @@ -79,6 +79,13 @@ theorem cvmEmptyVEnvsWF : hasPrimitives := l4l05EmptyHasPrimitives safePrimitives := cvmEmptySafePrimitives mono := fun _ => .rfl + projectionReady := by + intro _ name _ _ h + simp only [constructorValidityMatrixContext, + Kernel.Environment.isProjectionReadyStructure, + Kernel.Environment.ofConstants] at h + simp only [SMap.WF.find?'_eq_find? SMap.WF.empty] at h + simp [SMap.find?] at h theorem prbEmptySafePrimitives : propRecursiveBoundaryContext.env.find? name = some info → @@ -98,6 +105,13 @@ theorem prbEmptyVEnvsWF : hasPrimitives := l4l05EmptyHasPrimitives safePrimitives := prbEmptySafePrimitives mono := fun _ => .rfl + projectionReady := by + intro _ name _ _ h + simp only [propRecursiveBoundaryContext, + Kernel.Environment.isProjectionReadyStructure, + Kernel.Environment.ofConstants] at h + simp only [SMap.WF.find?'_eq_find? SMap.WF.empty] at h + simp [SMap.find?] at h def cvmExecutionResult := AddInductive.buildNormalizationCandidateExecution 2 @@ -544,6 +558,24 @@ def cvmDeclaredInfo : ConstantInfo := 0 false cvmCandidate.families.singleton.familyType.type.trace.terminalContext +theorem cvmDeclaredInfo_isRec : + (AddInductive.singletonDeclaredInfo + cvmFamilyValidationRun.stats 2 0 constructorValidityMatrixKernelType + 0 false + cvmCandidate.families.singleton.familyType.type.trace.terminalContext).isRec = + true := by + simp only [AddInductive.singletonDeclaredInfo] + rw [cvmFamilyValidationRun.stats_eq] + simp [cvmFamilyValidationRun, + AddInductive.CandidateExprTrace.singletonCandidateInductiveStats, + AddInductive.isRec, AddInductive.isRec.loop, + AddInductive.hasIndOcc, + constructorValidityMatrixKernelType, + constructorValidityMatrixKernelCtor, + constructorValidityMatrixInfo, constructorValidityMatrixMkInfo, + ConstantInfo.name, ConstantInfo.type, ConstantInfo.toConstantVal, + Expr.constName!] + theorem cvmFamilyNames_eq : constructorValidityMatrixKernelType.name = constructorValidityMatrixType.name := by @@ -563,6 +595,43 @@ theorem cvmFamilyMap_add : cvmCandidate.families.singleton.familyType.type.trace.terminalContext cvmExecution.familyEnv cvmStatsNindices_eq h +theorem cvmConstructorContext_noProjectionReady (name : Name) : + cvmConstructorContext.env.isProjectionReadyStructure name = false := by + have hConstants : + cvmConstructorContext.env.constants = + ({} : ConstMap).insert constructorValidityMatrixType.name + cvmDeclaredInfo := by + simp only [cvmConstructorContext] + rw [cvmFamilyMap_add, cvmTerminalEnv_eq] + rfl + have hMap : + (({} : ConstMap).insert constructorValidityMatrixType.name + cvmDeclaredInfo).WF := + SMap.WF.empty.insert _ _ (by simp [SMap.find?]) + by_cases hName : constructorValidityMatrixType.name = name + · subst name + apply Kernel.Environment.isProjectionReadyStructure_false_of_no_ctorInfo + (info := AddInductive.singletonDeclaredInfo + cvmFamilyValidationRun.stats 2 0 constructorValidityMatrixKernelType + 0 false + cvmCandidate.families.singleton.familyType.type.trace.terminalContext) + · rw [hConstants, hMap.find?'_eq_find?, + SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + simp [cvmDeclaredInfo] + · intro ctor ctorInfo hctor + rw [hConstants, hMap.find?'_eq_find?, + SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] at hctor + split at hctor + · cases hctor + · simp [SMap.find?] at hctor + · apply Kernel.Environment.isProjectionReadyStructure_false_of_not_found + rw [hConstants, hMap.find?'_eq_find?, + SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + simp [hName, SMap.find?] + def cvmTypeEnv : VEnv := (VEnv.empty.addConst constructorValidityMatrixType.name constructorValidityMatrixType.toVConstant).get! @@ -626,6 +695,10 @@ def cvmFamilyStage : validation := cvmFamilyValidationRun typeEnv := cvmTypeEnv addInduct := cvmAddType + projectionReady := by + intro name _ _ h + rw [cvmConstructorContext_noProjectionReady] at h + contradiction family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := by @@ -1789,6 +1862,37 @@ theorem prbTerminalEnv_eq : congrArg AddInductive.Context.env prbFamilyCandidateContext_eq _ = propRecursiveBoundaryContext.env := rfl +theorem prbConstructorContext_noProjectionReady (name : Name) : + prbConstructorContext.env.isProjectionReadyStructure name = false := by + have hConstants : + prbConstructorContext.env.constants = + ({} : ConstMap).insert propRecursiveBoundaryType.name + prbDeclaredInfo := by + simp only [prbConstructorContext] + rw [prbFamilyMap_add, prbTerminalEnv_eq] + rfl + have hMap : + (({} : ConstMap).insert propRecursiveBoundaryType.name + prbDeclaredInfo).WF := + SMap.WF.empty.insert _ _ (by simp [SMap.find?]) + by_cases hName : propRecursiveBoundaryType.name = name + · subst name + apply Kernel.Environment.isProjectionReadyStructure_false_of_numIndices_ne + (info := AddInductive.singletonDeclaredInfo + prbFamilyValidationRun.stats 1 1 propRecursiveBoundaryKernelType + 0 false + prbCandidate.families.singleton.familyType.type.trace.terminalContext) + · rw [hConstants, hMap.find?'_eq_find?, + SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + simp [prbDeclaredInfo] + · simp [AddInductive.singletonDeclaredInfo] + · apply Kernel.Environment.isProjectionReadyStructure_false_of_not_found + rw [hConstants, hMap.find?'_eq_find?, + SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + simp [hName, SMap.find?] + theorem prbDeclaredInfo_tr : TrConstVal .safe VEnv.empty prbDeclaredInfo propRecursiveBoundaryType.toVConstVal := by @@ -1842,6 +1946,10 @@ def prbFamilyStage : validation := prbFamilyValidationRun typeEnv := prbTypeEnv addInduct := prbAddType + projectionReady := by + intro name _ _ h + rw [prbConstructorContext_noProjectionReady] at h + contradiction family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := by diff --git a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean index 81c5e561..48c90694 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean @@ -103,6 +103,60 @@ theorem indexedVecSemanticNatSafePrimitives : exact ⟨rfl, rfl⟩ · simp [SMap.find?] at hfind +theorem indexedVecKernelEnv_noProjectionReady (name : Name) : + indexedVecKernelEnv.isProjectionReadyStructure name = false := by + simp only [indexedVecKernelEnv, + Kernel.Environment.isProjectionReadyStructure, + Kernel.Environment.ofConstants] + simp only [natMap_wf.find?'_eq_find?] + simp only [natMap, natCtorMap_wf.find?_insert] + simp only [natCtorMap, natZeroMap_wf.find?_insert] + simp only [natZeroMap, natTypeMap_wf.find?_insert] + simp only [natTypeMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + by_cases hRec : ``Nat.rec = name + · subst name + simp [SMap.find?, natRecInfo] + · by_cases hSucc : ``Nat.succ = name + · subst name + simp [hRec, SMap.find?, natSuccInfo] + · by_cases hZero : ``Nat.zero = name + · subst name + simp [hRec, hSucc, SMap.find?, natZeroInfo] + · by_cases hNat : ``Nat = name + · subst name + simp [hRec, hSucc, hZero, SMap.find?, natInfo] + · simp [hRec, hSucc, hZero, hNat, SMap.find?] + +theorem indexedVecTypeEnv_noProjectionReady (name : Name) : + ctorContext.env.isProjectionReadyStructure name = false := by + simp only [ctorContext, ctorEnv, + Kernel.Environment.isProjectionReadyStructure, + Kernel.Environment.ofConstants] + simp only [indexedVecTypeMap_wf.find?'_eq_find?] + simp only [indexedVecTypeMap, natMap_wf.find?_insert] + simp only [natMap, natCtorMap_wf.find?_insert] + simp only [natCtorMap, natZeroMap_wf.find?_insert] + simp only [natZeroMap, natTypeMap_wf.find?_insert] + simp only [natTypeMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + by_cases hVec : ``IndexedVec = name + · subst name + simp [SMap.find?, indexedVecInfo] + · by_cases hRec : ``Nat.rec = name + · subst name + simp [hVec, SMap.find?, natRecInfo] + · by_cases hSucc : ``Nat.succ = name + · subst name + simp [hVec, hRec, SMap.find?, natSuccInfo] + · by_cases hZero : ``Nat.zero = name + · subst name + simp [hVec, hRec, hSucc, SMap.find?, natZeroInfo] + · by_cases hNat : ``Nat = name + · subst name + simp [hVec, hRec, hSucc, hZero, SMap.find?, natInfo] + · simp [hVec, hRec, hSucc, hZero, hNat, SMap.find?] + def indexedVecSemanticNatVEnvs : VEnvs where venv _ := natFinalEnv @@ -114,6 +168,10 @@ theorem indexedVecSemanticNatVEnvsWF : indexedVecSemanticNatVEnvs.WF indexedVecK hasPrimitives := indexedVecSemanticNatHasPrimitives safePrimitives := indexedVecSemanticNatSafePrimitives mono := fun _ => .rfl + projectionReady := by + intro _ name _ _ h + rw [indexedVecKernelEnv_noProjectionReady] at h + contradiction def indexedVecSemanticAddType : AddInductConstant .induct natMap natFinalEnv @@ -172,6 +230,10 @@ def indexedVecFamilyStage : validation := indexedVecFamilyValidationRun typeEnv := indexedVecTypeEnv addInduct := indexedVecSemanticAddType + projectionReady := by + intro name _ _ h + rw [indexedVecTypeEnv_noProjectionReady] at h + contradiction family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := rfl diff --git a/Lean4Lean/Verify/Environment/InductiveFixtures.lean b/Lean4Lean/Verify/Environment/InductiveFixtures.lean index 27cdeb7d..2fc2d0e9 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 77d2462c..b3a5f5bd 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 858cb755..4a4d98ae 100644 --- a/Lean4Lean/Verify/TypeChecker.lean +++ b/Lean4Lean/Verify/TypeChecker.lean @@ -16,6 +16,7 @@ structure VEnvs.WF (env : Environment) (ves : VEnvs) where safePrimitives : env.find? n = some ci → Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = [] mono : safety ≤ safety' → ves.venv safety' ≤ ves.venv safety + projectionReady : ProjectionReady env (ves.venv safety) namespace TypeChecker @@ -45,6 +46,7 @@ def VContext.mk' {env : Environment} {ves : VEnvs} (wf : ves.WF env) hasPrimitives := wf.hasPrimitives safePrimitives := wf.safePrimitives trenv := wf.tr + projectionReady := wf.projectionReady mlctx := .nil mlctx_wf := trivial lctx_eq := rfl diff --git a/Lean4Lean/Verify/TypeChecker/Basic.lean b/Lean4Lean/Verify/TypeChecker/Basic.lean index 6252d896..629d8b8f 100644 --- a/Lean4Lean/Verify/TypeChecker/Basic.lean +++ b/Lean4Lean/Verify/TypeChecker/Basic.lean @@ -101,6 +101,37 @@ theorem WF.weak' (wf : WF env Us Δ m) : WF env Us Δ' m where end EquivManager +/-- Exact alignment between one host structure record and the registered +Theory artifact used to interpret primitive projections. The positional +metadata is retained explicitly because ordinary constant translation checks +types but does not identify the kernel's parameter/constructor roles. -/ +structure ProjectionArtifact (env : Environment) (name : Name) + (info : InductiveVal) (venv : VEnv) where + view : VStructureView + name_eq : view.name = name + viewWF : view.WF venv + constructorInfo : ConstructorVal + constructor_find : env.find? view.constructorName = + some (.ctorInfo constructorInfo) + constructor_numParams_eq : constructorInfo.numParams = view.nparams + constructor_numFields_eq : constructorInfo.numFields = view.fields.length + levelParams_length : info.levelParams.length = view.uvars + numParams_eq : info.numParams = view.nparams + numIndices_eq : info.numIndices = 0 + ctors_eq : info.ctors = [view.constructorName] + rawResult_sort : ∃ resultLevel, + view.generation.block.rawResult = .sort resultLevel + programsWF : view.ProgramsWF venv + +/-- Every complete host structure accepted by projection inference is backed +by one coherent registered Theory artifact. This is deliberately separate +from constant translation: individually translated family, constructor, and +recursor constants do not by themselves identify one generation artifact. -/ +def ProjectionReady (env : Environment) (venv : VEnv) : Prop := + ∀ name info, env.find? name = some (.inductInfo info) → + env.isProjectionReadyStructure name = true → + Nonempty (ProjectionArtifact env name info venv) + namespace TypeChecker inductive MLCtx where @@ -193,6 +224,7 @@ structure VContext extends Context where safePrimitives : env.find? n = some ci → Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = [] trenv : TrEnv safety env venv + projectionReady : ProjectionReady env venv mlctx : MLCtx mlctx_wf : mlctx.WF venv lparams lctx_eq : mlctx.lctx = lctx @@ -954,3 +986,19 @@ theorem ensureSortCore.WF {c : VContext} {s : VState} (he : c.TrExprS e e') : · let .sort _ := e exact .pure ⟨⟨_, rfl⟩, he, hb⟩ exact .getEnv <| .getLCtx .throw + +theorem getSortLevel.WF + (he : c.TrExprS e e') : (getSortLevel e).WF c s fun l _ => + ∃ u', VLevel.ofLevel c.lparams l = some u' ∧ c.HasType e' (.sort u') := by + refine (inferType.WF he).bind fun ty _ le ⟨ty', _, _, h1, h2⟩ => ?_ + refine (ensureSortCore.WF h1).bind fun ty _ le h => ?_ + obtain ⟨⟨u, rfl⟩, ⟨ty₂, h3, h4⟩, _⟩ := h + let .sort hu := h3 + exact .pure ⟨_, hu, h2.defeqU_r c.Ewf c.Δwf h4.symm⟩ + +theorem isProp.WF + (he : c.TrExprS e e') : (isProp e).WF c s fun b _ => + b → c.HasType e' (.sort .zero) := by + refine (getSortLevel.WF he).bind fun l _ le ⟨u', hu, h⟩ => .pure fun H => ?_ + exact h.defeqU_r c.Ewf c.Δwf + ⟨_, .sortDF (.of_ofLevel hu) trivial (ofLevel_isAlwaysZero hu H)⟩ diff --git a/Lean4Lean/Verify/TypeChecker/InferType.lean b/Lean4Lean/Verify/TypeChecker/InferType.lean index da5b6f01..075338e8 100644 --- a/Lean4Lean/Verify/TypeChecker/InferType.lean +++ b/Lean4Lean/Verify/TypeChecker/InferType.lean @@ -385,10 +385,571 @@ theorem inferLet.WF refine (c.withMLC_self ▸ inferLet.loop.WF (Nat.zero_le _) [] rfl rfl rfl rfl rfl ?_ hr) hinf exact fun P hP he => ⟨(AllAbove.wf wf.trctx.wf.fvwf).2 hP, he.mono fun _ h _ => h, fun _ => id⟩ +theorem AppStack.toSpineWF {c : VContext} + (H : AppStack c.venv c.lparams c.vlctx f f' args) + (hf : c.HasType f' (VExpr.forallN As C)) + (hlen : args.length = As.length) : + ∃ args', args.Forall₂ (c.TrExprS · ·) args' ∧ + c.venv.SpineWF c.lparams.length c.vlctx.toCtx + (VExpr.forallN As C) args' (VExpr.instRev C args') ∧ + c.TrExprS (f.mkAppList args) (VExpr.appN f' args') := by + induction args generalizing f f' As C with + | nil => + cases As with + | nil => + let .head hfull := H + exact ⟨[], .nil, rfl, by simpa⟩ + | cons _ _ => simp at hlen + | cons arg args ih => + cases As with + | nil => simp at hlen + | cons A As => + let .app hfun harg hf' harg' Hrest := H + have htypes := hf.uniqU c.Ewf c.Δwf hfun + have ⟨⟨_, hA⟩, _⟩ := htypes.forallE_inv c.Ewf c.Δwf + have hargA := harg.defeqU_r c.Ewf c.Δwf ⟨_, hA.symm⟩ + have hlen' : args.length = As.length := by simpa using hlen + have htailType : c.HasType (.app f' _) ((VExpr.forallN As C).inst _) := + hf.app hargA + rw [VExpr.instN_forallN] at htailType + obtain ⟨args', hargs', hspine, hfull⟩ := + ih Hrest htailType (by simpa [VExpr.instTelN_length] using hlen') + refine ⟨_ :: args', .cons harg' hargs', ⟨A, VExpr.forallN As C, + rfl, hargA, ?_⟩, ?_⟩ + have hlenArgsAs : args'.length = As.length := + hargs'.length_eq.symm.trans hlen' + rw [VExpr.instN_forallN] + simpa [VExpr.instRev, hlenArgsAs] using hspine + simpa [Expr.mkAppList, VExpr.appN] using hfull + +theorem invalidProj.WF {c : VContext} {s : VState} : + (invalidProj e : RecM α).WF c s Q := by + unfold invalidProj + exact .getEnv <| .getLCtx .throw + +theorem inferProjParams.WF {c : VContext} {s : VState} + (hargs : args.Forall₂ (c.TrExprS · ·) args') + (hrBelow : c.FVarsBelow proj r) + (hargsBelow : ∀ arg ∈ args, c.FVarsBelow proj arg) + (hr : c.TrExpr r R) + (hspine : c.venv.SpineWF c.lparams.length c.vlctx.toCtx + R args' T) : + (inferProjParams proj args r).WF c s fun out _ => + c.FVarsBelow proj out ∧ c.TrExpr out T := by + induction hargs generalizing r R s with + | nil => + simp [inferProjParams] at hspine ⊢ + exact hspine ▸ .pure ⟨hrBelow, hr⟩ + | @cons arg arg' args args' harg hargs ih => + simp only [inferProjParams] + have hargBelow := hargsBelow arg (by simp) + have hargsBelow' : ∀ arg ∈ args, c.FVarsBelow proj arg := by + intro arg harg + exact hargsBelow arg (by simp [harg]) + obtain ⟨A, B, rfl, hargType, hrest⟩ := hspine + obtain ⟨r', hrS, hrEq⟩ := hr + refine (whnf.WF hrS).bind fun out s' _ + ⟨houtBelow, ⟨out', hout, houtEq⟩⟩ => ?_ + have houtEq := houtEq.trans c.Ewf c.Δwf hrEq + cases out with + | forallE name dom body bi => + let .forallE hdomTy hbodyTy hdom hbody := hout + have hforallEq := houtEq.forallE_inv c.Ewf c.Δwf + obtain ⟨⟨_, hdomEq⟩, _, hbodyEq⟩ := hforallEq + have hargType' := hargType.defeqU_r c.Ewf c.Δwf + ⟨_, hdomEq.symm⟩ + have hnext : c.TrExpr (body.instantiate1 arg) (B.inst arg') := by + simpa only [Expr.instantiate1_eq] using + (.inst c.Ewf c.Δwf hargType' + ⟨_, hbody, _, hbodyEq⟩ (harg.trExpr c.Ewf c.Δwf)) + have hnextBelow : c.FVarsBelow proj (body.instantiate1 arg) := by + intro P hP hproj + have houtFVars := (hrBelow.trans houtBelow) P hP hproj + simpa only [Expr.instantiate1_eq] using + houtFVars.2.instantiate1 (hargBelow P hP hproj) + exact ih hnextBelow hargsBelow' hnext hrest + | bvar | fvar | mvar | sort | const | app | lam | letE | lit | + mdata | proj => exact invalidProj.WF + +theorem inferProjFields.WF {c : VContext} {s : VState} + {view : VStructureView} {levels : List VLevel} + {params : List VExpr} {major : VExpr} {tailResult cursor : VExpr} + (hstruct : c.TrExprS struct major) + (hview : view.WF c.venv) + (hlevels : ∀ level ∈ levels, level.WF c.lparams.length) + (hlevelsLength : levels.length = view.uvars) + (hparamsLength : params.length = view.nparams) + (hparamsSpine : ∃ resultLevel, + c.venv.SpineWF c.lparams.length c.vlctx.toCtx + (view.familyType.instL levels) params (.sort resultLevel)) + (hprograms : view.ProgramsWF c.venv) + (hname : view.name = typeName) + (hmajor : c.HasType major (view.structureType levels params)) + (hrBelow : c.FVarsBelow proj r) + (hstructBelow : c.FVarsBelow proj struct) + (hbound : fieldIdx + count < + (view.specializedFields levels params).length) + (hr : c.TrExpr r cursor) + (hcursor : VExpr.consumeForalls? + (VExpr.forallN (view.specializedFields levels params) tailResult) + (view.projectionArgs levels params fieldIdx major) = some cursor) : + (inferProjFields proj typeName struct maybePropType fieldIdx count r).WF + c s fun out _ => + ∃ cursor', + VExpr.consumeForalls? + (VExpr.forallN (view.specializedFields levels params) tailResult) + (view.projectionArgs levels params (fieldIdx + count) major) = + some cursor' ∧ + c.FVarsBelow proj out ∧ c.TrExpr out cursor' := by + induction count generalizing s r cursor fieldIdx with + | zero => + simp only [inferProjFields, Nat.add_zero] + exact .pure ⟨cursor, hcursor, hrBelow, hr⟩ + | succ count ih => + simp only [inferProjFields] + have hfieldIdx : fieldIdx < + (view.specializedFields levels params).length := by omega + have hcodeIdx : fieldIdx < + (view.projectionCodes levels params).length := by + simpa using hfieldIdx + let code := (view.projectionCodes levels params)[fieldIdx] + have hcode : + (view.projectionCodes levels params)[fieldIdx]? = some code := + List.getElem?_eq_getElem hcodeIdx + have hargsLength : + (view.projectionArgs levels params fieldIdx major).length = + fieldIdx := + view.projectionArgs_length levels params fieldIdx major + (Nat.le_of_lt hcodeIdx) + obtain ⟨field, semanticBody, hfield, hconsume⟩ := + VExpr.consumeForalls?_forallN_domain + (view.specializedFields levels params) tailResult + (view.projectionArgs levels params fieldIdx major) + (by simpa [hargsLength] using hfieldIdx) + rw [hargsLength] at hfield + have hcursorShape : cursor = + .forallE + (field.instRevAt + (view.projectionArgs levels params fieldIdx major) 0) + semanticBody := + Option.some.inj (hcursor.symm.trans hconsume) + subst cursor + obtain ⟨field', typeBody, hfield', htypeFn, + hprojectorField⟩ := + hprograms.projector_hasType_field c.Ewf c.Δwf hlevels + hlevelsLength hparamsLength hparamsSpine hcode hmajor + have hfieldEq : field' = field := + Option.some.inj (hfield'.symm.trans hfield) + subst field' + have hprojector := hprograms c.Δwf hlevels hlevelsLength + hparamsLength hparamsSpine hcode + have hprojSem : c.venv.TrProj c.lparams.length c.vlctx.toCtx + view levels params fieldIdx major (.app code.projector major) := { + viewWF := hview + levelsWF := hlevels + levels_length := hlevelsLength + params_length := hparamsLength + paramsSpine := hparamsSpine + majorType := hmajor + program := ⟨code, hcode, rfl, hprojector⟩ } + have hprojStrict : c.TrExprS (.proj typeName fieldIdx struct) + (.app code.projector major) := + .proj hstruct ⟨view, levels, params, hname, hprojSem⟩ + obtain ⟨r', hrS, hrEq⟩ := hr + refine (whnf.WF hrS).bind fun out nextState _ + ⟨houtBelow, ⟨out', hout, houtEq⟩⟩ => ?_ + have houtEq := houtEq.trans c.Ewf c.Δwf hrEq + cases out with + | forallE name dom body bi => + let .forallE hdomTy hbodyTy hdom hbody := hout + have hforallEq := houtEq.forallE_inv c.Ewf c.Δwf + obtain ⟨⟨_, hdomEq⟩, _, hbodyEq⟩ := hforallEq + have hprojectorField' := hprojectorField.defeqU_r + c.Ewf c.Δwf ⟨_, hdomEq.symm⟩ + have hnext : c.TrExpr + (body.instantiate1 (.proj typeName fieldIdx struct)) + (semanticBody.inst (.app code.projector major)) := by + simpa only [Expr.instantiate1_eq] using + (.inst c.Ewf c.Δwf hprojectorField' + ⟨_, hbody, _, hbodyEq⟩ + (hprojStrict.trExpr c.Ewf.ordered c.Δwf)) + have hnextBelow : c.FVarsBelow proj + (body.instantiate1 (.proj typeName fieldIdx struct)) := by + intro P hP hproj + have houtFVars := (hrBelow.trans houtBelow) P hP hproj + have hfieldProj : FVarsIn P + (.proj typeName fieldIdx struct) := by + simpa [FVarsIn] using hstructBelow P hP hproj + simpa only [Expr.instantiate1_eq] using + houtFVars.2.instantiate1 hfieldProj + have hconsumeNext : VExpr.consumeForalls? + (VExpr.forallN (view.specializedFields levels params) tailResult) + (view.projectionArgs levels params (fieldIdx + 1) major) = + some (semanticBody.inst (.app code.projector major)) := by + rw [view.projectionArgs_succ levels params fieldIdx major hcode] + rw [VExpr.consumeForalls?_append, hconsume] + rfl + have hbound' : fieldIdx + 1 + count < + (view.specializedFields levels params).length := by omega + have hrec (recState : VState) := + ih (s := recState) hnextBelow hbound' hnext hconsumeNext + simp only + split + · refine (isProp.WF hdom).bind fun _ propState _ _ => ?_ + split + · exact invalidProj.WF + · simpa only [pure_bind, Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using hrec propState + · simpa only [pure_bind, Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using hrec nextState + | bvar | fvar | mvar | sort | const | app | lam | letE | lit | + mdata | proj => exact invalidProj.WF + theorem inferProj.WF - (he : c.TrExprS e e') (hty : c.TrExprS ety ety') (hasty : c.HasType e' ty') : + (heBelow : c.FVarsBelow e ety) + (he : c.TrExprS e e') (hty : c.TrExprS ety ety') + (hasty : c.HasType e' ety') : (inferProj st i e ety).WF c s fun ty _ => - ∃ ty', c.TrTyping (.proj st i e) ty e' ty' := sorry + ∃ proj' ty', c.TrTyping (.proj st i e) ty proj' ty' := by + unfold inferProj + refine (whnf.WF hty).bind fun type _ _ ⟨htypeBelow, htype⟩ => ?_ + have hprojBelowType : c.FVarsBelow (.proj st i e) type := by + intro P hP hproj + exact htypeBelow P hP (heBelow P hP (by simpa [FVarsIn] using hproj)) + obtain ⟨type', htypeS, htypeEq⟩ := htype + rw [Expr.withApp_eq] + have ⟨family', hstack⟩ := AppStack.build + (type.mkAppList_getAppArgsList ▸ htypeS) + simp only + split + · rename_i familyName familyLevels hfamilyShape + refine .getEnv ?_ + split + · exact invalidProj.WF + · simp only [pure_bind] + rename_i hname + refine (M.WF.liftExcept envGet.WF).lift.bind fun ci _ _ hfind => ?_ + split + · rename_i info + split + · rename_i constructor hctors + split + · rename_i hready + split + · exact invalidProj.WF + · rename_i hargs + obtain ⟨artifact⟩ := + c.projectionReady familyName info hfind hready + have hhead := hstack.tr + rw [hfamilyShape] at hhead + let .const (us' := levels') hfamilyConst hlevelsMap + hlevelsLength := hhead + have hviewFamily := artifact.viewWF.family + rw [artifact.name_eq] at hviewFamily + rw [hviewFamily] at hfamilyConst + cases hfamilyConst + have hlevelsWF : ∀ level ∈ levels', + level.WF c.lparams.length := + VLevel.WF.of_mapM_ofLevel hlevelsMap + have hlevelsSourceLength : levels'.length = + artifact.view.generation.block.sourceType.uvars := + (List.mapM_eq_some.1 hlevelsMap).length_eq.symm.trans + hlevelsLength + have hlevelsLength' : levels'.length = artifact.view.uvars := by + exact hlevelsSourceLength.trans + artifact.view.generation.block.sourceType_uvars_eq + have hargsSize : type.getAppArgs.size = + info.numParams + info.numIndices := by + simpa using hargs + have hargsLength : type.getAppArgsList.length = + artifact.view.nparams := by + rw [← Expr.getAppArgs_toList] + simp [hargsSize, + artifact.numParams_eq, artifact.numIndices_eq] + have hfamilyType : c.HasType (.const familyName levels') + (artifact.view.familyType.instL levels') := by + exact VEnv.HasType.const hviewFamily hlevelsWF + hlevelsSourceLength + have hfamilyTypeShape : c.HasType (.const familyName levels') + (VExpr.forallN + (artifact.view.generation.block.rawParams.map + (VExpr.instL levels')) + (artifact.view.generation.block.rawResult.instL + levels')) := by + simpa [VStructureView.familyType, + VInductDecl.NormalizedChecked.rawType_eq, + artifact.view.raw_indices_eq, + VExpr.instL_forallN, VExpr.forallN] using hfamilyType + have hargsRawLength : type.getAppArgsList.length = + (artifact.view.generation.block.rawParams.map + (VExpr.instL levels')).length := by + simpa [artifact.view.generation.shape.1] using hargsLength + obtain ⟨params', hparamsTr, hparamsSpineRaw, htypeFull⟩ := + AppStack.toSpineWF hstack hfamilyTypeShape hargsRawLength + rw [type.mkAppList_getAppArgsList] at htypeFull + have htypeAppliedEq := htypeFull.uniq c.Ewf + (.refl c.Ewf c.Δwf) htypeS + have hmajorType : c.HasType e' + (artifact.view.structureType levels' params') := by + apply hasty.defeqU_r c.Ewf c.Δwf + have := (htypeAppliedEq.trans c.Ewf c.Δwf htypeEq).symm + simpa [VStructureView.structureType, + artifact.name_eq] using this + have hparamsLength : params'.length = + artifact.view.nparams := + hparamsTr.length_eq.symm.trans hargsLength + have hparamsRawLength : params'.length = + (artifact.view.generation.block.rawParams.map + (VExpr.instL levels')).length := + hparamsTr.length_eq.symm.trans hargsRawLength + have hparamsSpine : ∃ resultLevel, + c.venv.SpineWF c.lparams.length c.vlctx.toCtx + (artifact.view.familyType.instL levels') params' + (.sort resultLevel) := by + obtain ⟨resultLevel, hresultLevel⟩ := artifact.rawResult_sort + refine ⟨resultLevel.inst levels', ?_⟩ + rw [hresultLevel] at hparamsSpineRaw + rw [VExpr.instRev_closedN params' (by trivial)] at hparamsSpineRaw + simpa [VStructureView.familyType, + VInductDecl.NormalizedChecked.rawType_eq, + artifact.view.raw_indices_eq, hresultLevel, + VExpr.instL_forallN, VExpr.forallN, + VExpr.instRev, VExpr.instL] using hparamsSpineRaw + have hconstructorName : + constructor = artifact.view.constructorName := by + have := hctors.symm.trans artifact.ctors_eq + simpa using this + refine (M.WF.liftExcept envGet.WF).lift.bind + fun c_info _ _ hctorFind => ?_ + cases c_info with + | ctorInfo ctorInfo => + simp only + split + · rename_i hidxHost + have hctorInfoEq : + ctorInfo = artifact.constructorInfo := by + rw [hconstructorName, artifact.constructor_find] at hctorFind + exact ConstantInfo.ctorInfo.inj + (Option.some.inj hctorFind.symm) + have hiFields : i < + (artifact.view.specializedFields levels' params').length := by + rw [hctorInfoEq, + artifact.constructor_numFields_eq] at hidxHost + simpa [VStructureView.specializedFields, + VStructureView.fields] using hidxHost + have hviewConstructor : c.venv.constants constructor = + some artifact.view.constructor.raw.toVConstant := by + simpa [hconstructorName] using + artifact.viewWF.toRegistered.constructor + obtain ⟨_, hctorTr⟩ := + c.trenv.find?_uniq hctorFind hviewConstructor + have hrawCtorUvars : + artifact.view.constructor.raw.uvars = + artifact.view.uvars := by + exact artifact.view.generation.ctor_uvars_eq + (by simp [artifact.view.constructor_eq]) + have hctorLevelLength : + ctorInfo.levelParams.length = familyLevels.length := + hctorTr.2.1.trans <| hrawCtorUvars.trans <| + hlevelsLength'.symm.trans + (List.mapM_eq_some.1 hlevelsMap).length_eq.symm + have hctorType₀ := hctorTr.2.2.instL c.Ewf + (Us := c.lparams) (ls' := levels') (Δ := []) + trivial hlevelsMap hctorLevelLength + have hctorType := hctorType₀.weakFV c.Ewf + (.from_nil c.mlctx.noBV) c.Δwf + rw [(c.Ewf.ordered.closedC + hviewConstructor).instL.liftN_eq + (Nat.le_refl _)] at hctorType + let ctorTail := VExpr.forallN + (artifact.view.fields.map (VExpr.instL levels')) + ((artifact.view.constructor.rawResult + artifact.view.nparams).instL levels') + rw [artifact.view.constructor.rawType_eq] at hctorType + have hinstantiate : + ((.ctorInfo ctorInfo : ConstantInfo) + |>.instantiateTypeLevelParams familyLevels) = + ctorInfo.type.instantiateLevelParams + ctorInfo.levelParams familyLevels := rfl + have hctorTypeShape : c.TrExpr + ((.ctorInfo ctorInfo : ConstantInfo) + |>.instantiateTypeLevelParams familyLevels) + (VExpr.forallN + (artifact.view.constructorParams.map + (VExpr.instL levels')) ctorTail) := by + simpa [ConstantInfo.instantiateTypeLevelParams, + ConstantVal.instantiateTypeLevelParams, + ConstantInfo.type, ConstantInfo.toConstantVal, ctorTail, + VInductDecl.NormalizedCtor.declaredBinders, + VStructureView.nparams, + VStructureView.constructorParams, + VStructureView.fields, + VExpr.instL_forallN, VExpr.forallN_append, + List.map_append] using hctorType + have hctorTypeBelow : c.FVarsBelow (.proj st i e) + ((.ctorInfo ctorInfo : ConstantInfo) + |>.instantiateTypeLevelParams familyLevels) := by + intro P _ _ + simpa [ConstantInfo.instantiateTypeLevelParams, + ConstantVal.instantiateTypeLevelParams, + ConstantInfo.type, ConstantInfo.toConstantVal] using + hctorType₀.fvarsIn.mono nofun + have hparamArgsEq : + List.take info.numParams type.getAppArgs.toList = + type.getAppArgsList := by + simp [Expr.getAppArgs_toList, artifact.numParams_eq, + ← hargsLength] + have hparamArgsTr : + (List.take info.numParams + type.getAppArgs.toList).Forall₂ + (c.TrExprS · ·) params' := by + simpa [hparamArgsEq] using hparamsTr + have hparamArgsBelow : ∀ arg ∈ + List.take info.numParams type.getAppArgs.toList, + c.FVarsBelow (.proj st i e) arg := by + intro arg harg P hP hproj + apply FVarsIn.getAppArgsList + (hprojBelowType P hP hproj) + simpa [hparamArgsEq] using harg + have hctorParamsSpine := + artifact.viewWF.constructorParamsSpine c.Ewf.ordered + levels' hlevelsWF hlevelsLength' params' hparamsLength + hparamsSpine ctorTail + refine (inferProjParams.WF hparamArgsTr hctorTypeBelow + hparamArgsBelow hctorTypeShape hctorParamsSpine).bind + fun r _ _ hr => ?_ + obtain ⟨hrBelow, hr⟩ := hr + let tailResult := + ((artifact.view.constructor.rawResult + artifact.view.nparams).instL levels').instRevAt + params' artifact.view.fields.length + have hctorTailInst : ctorTail.instRev params' = + VExpr.forallN + (artifact.view.specializedFields levels' params') + tailResult := by + simp [ctorTail, tailResult, + VExpr.instRev_forallN_projection, + VStructureView.specializedFields, + VExpr.instRevAt_map_instL_zipIdx] + rw [hctorTailInst] at hr + refine (getSortLevel.WF htypeS).bind + fun sortLevel nextState _ _ => ?_ + have hstructBelow : c.FVarsBelow (.proj st i e) e := by + intro P _ hproj + simpa [FVarsIn] using hproj + have hcursorZero : VExpr.consumeForalls? + (VExpr.forallN + (artifact.view.specializedFields levels' params') + tailResult) + (artifact.view.projectionArgs levels' params' 0 e') = + some (VExpr.forallN + (artifact.view.specializedFields levels' params') + tailResult) := by + rfl + refine (inferProjFields.WF he artifact.viewWF hlevelsWF + hlevelsLength' hparamsLength hparamsSpine + artifact.programsWF artifact.name_eq hmajorType + hrBelow hstructBelow (by simpa using hiFields) hr + hcursorZero).bind + fun r _ _ hr => ?_ + obtain ⟨cursor, hcursor, hrBelow, hr⟩ := hr + have hcursor' : VExpr.consumeForalls? + (VExpr.forallN + (artifact.view.specializedFields levels' params') + tailResult) + (artifact.view.projectionArgs levels' params' i e') = + some cursor := by + simpa using hcursor + have hcodeIdx : i < + (artifact.view.projectionCodes levels' params').length := by + simpa using hiFields + let code := + (artifact.view.projectionCodes levels' params')[i] + have hcode : + (artifact.view.projectionCodes levels' params')[i]? = + some code := + List.getElem?_eq_getElem hcodeIdx + have hprojectionArgsLength : + (artifact.view.projectionArgs levels' params' i e').length = + i := + artifact.view.projectionArgs_length levels' params' i e' + (Nat.le_of_lt hcodeIdx) + obtain ⟨field, semanticBody, hfield, hconsume⟩ := + VExpr.consumeForalls?_forallN_domain + (artifact.view.specializedFields levels' params') + tailResult + (artifact.view.projectionArgs levels' params' i e') + (by simpa [hprojectionArgsLength] using hiFields) + rw [hprojectionArgsLength] at hfield + have hcursorShape : cursor = + .forallE + (field.instRevAt + (artifact.view.projectionArgs levels' params' i e') 0) + semanticBody := + Option.some.inj (hcursor'.symm.trans hconsume) + subst cursor + have hprograms : artifact.view.ProgramsWF c.venv := + artifact.programsWF + obtain ⟨field', typeBody, hfield', htypeFn, + hprojectorField⟩ := + hprograms.projector_hasType_field + c.Ewf c.Δwf hlevelsWF hlevelsLength' hparamsLength + hparamsSpine hcode hmajorType + have hfieldEq : field' = field := + Option.some.inj (hfield'.symm.trans hfield) + subst field' + have hprojector := hprograms c.Δwf hlevelsWF + hlevelsLength' hparamsLength hparamsSpine hcode + have hprojSem : c.venv.TrProj c.lparams.length + c.vlctx.toCtx artifact.view levels' params' i e' + (.app code.projector e') := { + viewWF := artifact.viewWF + levelsWF := hlevelsWF + levels_length := hlevelsLength' + params_length := hparamsLength + paramsSpine := hparamsSpine + majorType := hmajorType + program := ⟨code, hcode, rfl, hprojector⟩ } + have hst : st = familyName := by + simpa using hname + have hprojStrict : c.TrExprS (.proj st i e) + (.app code.projector e') := + .proj he ⟨artifact.view, levels', params', + artifact.name_eq.trans hst.symm, hprojSem⟩ + obtain ⟨r', hrS, hrEq⟩ := hr + refine (whnf.WF hrS).bind fun out _ _ + ⟨houtBelow, ⟨out', hout, houtEq⟩⟩ => ?_ + have houtEq := houtEq.trans c.Ewf c.Δwf hrEq + cases out with + | forallE name dom body bi => + let .forallE hdomTy hbodyTy hdom hbody := hout + have hforallEq := houtEq.forallE_inv c.Ewf c.Δwf + obtain ⟨⟨_, hdomEq⟩, _, hbodyEq⟩ := hforallEq + have hprojectorField' := hprojectorField.defeqU_r + c.Ewf c.Δwf ⟨_, hdomEq.symm⟩ + have hdomBelow : c.FVarsBelow (.proj st i e) dom := by + intro P hP hproj + exact ((hrBelow.trans houtBelow) P hP hproj).1 + have hresult : ∃ proj' ty', + c.TrTyping (.proj st i e) dom proj' ty' := + ⟨.app code.projector e', _, hdomBelow, hprojStrict, + hdom, hprojectorField'⟩ + simp only + split + · refine (isProp.WF hdom).bind fun _ _ _ _ => ?_ + split + · exact invalidProj.WF + · exact .pure hresult + · exact .pure hresult + | bvar | fvar | mvar | sort | const | app | lam | letE | + lit | mdata | proj => exact invalidProj.WF + · exact invalidProj.WF + | axiomInfo | defnInfo | thmInfo | opaqueInfo | quotInfo | + inductInfo | recInfo => exact invalidProj.WF + · exact invalidProj.WF + · exact invalidProj.WF + · exact invalidProj.WF + · exact invalidProj.WF theorem literal_is_primitive (H : n = ``Nat ∨ n = ``Char.ofNat ∨ n = ``String.ofList) : Environment.primitives.contains n := by @@ -457,7 +1018,7 @@ theorem inferType'.WF exact hF ⟨hb, .mdata h1, h⟩ · refine (inferType'.WF (by exact h1) ?_).bind fun _ _ _ ⟨_, _, hb, h1, h2, h3⟩ => ?_ · exact fun h => let ⟨_, .proj h ..⟩ := hinf h; ⟨_, h⟩ - exact (inferProj.WF h1 h2 h3).bind fun ty _ _ ⟨ty', h⟩ => hF h + exact (inferProj.WF hb h1 h2 h3).bind fun ty _ _ ⟨_, ty', h⟩ => hF h · exact .readThe <| (M.WF.liftExcept inferFVar.WF).lift.bind fun _ _ _ ⟨_, _, h⟩ => hF h · exact .throw · rename_i h _; simp [Expr.hasLooseBVars, Expr.looseBVarRange'] at h @@ -498,3 +1059,23 @@ theorem inferType'.WF subst hP; refine hF ⟨?_, .app hf3 ha3 hf1 ha1, hl4.inst c.Ewf ha3 ha1, .app hf3 ha3⟩ exact fun _ hP he => (hfb.trans hb _ hP he.1).2.instantiate1 he.2 · exact (inferLet.WF h1 hinf).bind fun _ _ _ ⟨_, _, h⟩ => hF h + +/-- +info: 'Lean4Lean.TypeChecker.Inner.inferProj.WF' depends on axioms: [propext, + sorryAx, + Classical.choice, + Quot.sound, + Expr.instantiate1_eq, + Expr.mkAppData_eq, + Expr.mkData_eq, + Expr.replace_eq, + Level.hasMVar_eq, + Level.hasParam_eq, + Level.instLawfulBEqLevel, + PersistentArray.toList'_push, + PersistentHashMap.findAux_isSome, + PersistentHashMap.WF.find?_eq, + PersistentHashMap.WF.toList'_insert] +-/ +#guard_msgs in +#print axioms inferProj.WF diff --git a/Lean4Lean/Verify/TypeChecker/IsDefEq.lean b/Lean4Lean/Verify/TypeChecker/IsDefEq.lean index 7eddbada..992ae6a1 100644 --- a/Lean4Lean/Verify/TypeChecker/IsDefEq.lean +++ b/Lean4Lean/Verify/TypeChecker/IsDefEq.lean @@ -281,21 +281,6 @@ theorem isDefEqApp.WF {c : VContext} {s : VState} simp [Expr.getAppArgs_toList, Expr.mkAppList_getAppArgsList] at h2 exact h2 hb _ he₁ _ he₂ -theorem getSortLevel.WF - (he : c.TrExprS e e') : (getSortLevel e).WF c s fun l _ => - ∃ u', VLevel.ofLevel c.lparams l = some u' ∧ c.HasType e' (.sort u') := by - refine (inferType.WF he).bind fun ty _ le ⟨ty', _, _, h1, h2⟩ => ?_ - refine (ensureSortCore.WF h1).bind fun ty _ le h => ?_ - obtain ⟨⟨u, rfl⟩, ⟨ty₂, h3, h4⟩, _⟩ := h - let .sort hu := h3 - exact .pure ⟨_, hu, h2.defeqU_r c.Ewf c.Δwf h4.symm⟩ - -theorem isProp.WF - (he : c.TrExprS e e') : (isProp e).WF c s fun b _ => b → c.HasType e' (.sort .zero) := by - refine (getSortLevel.WF he).bind fun l _ le ⟨u', hu, h⟩ => .pure fun H => ?_ - exact h.defeqU_r c.Ewf c.Δwf - ⟨_, .sortDF (.of_ofLevel hu) trivial (ofLevel_isAlwaysZero hu H)⟩ - theorem isDefEqProofIrrel.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : RecM.WF c s (isDefEqProofIrrel e₁ e₂) fun b _ => b = .true → c.IsDefEqU e₁' e₂' := by diff --git a/Lean4Lean/Verify/Typing/Lemmas.lean b/Lean4Lean/Verify/Typing/Lemmas.lean index 85d2d84f..f982a9ad 100644 --- a/Lean4Lean/Verify/Typing/Lemmas.lean +++ b/Lean4Lean/Verify/Typing/Lemmas.lean @@ -136,6 +136,17 @@ theorem Closed.getAppArgsList {e} (h : Closed e) {{a}} (ha : a ∈ e.getAppArgsList) : Closed a := h.getAppArgsRevList (by simpa [← Expr.getAppArgsList_reverse]) +theorem FVarsIn.getAppArgsRevList {e} (h : FVarsIn P e) + {{a}} (ha : a ∈ e.getAppArgsRevList) : FVarsIn P a := by + revert a + unfold Expr.getAppArgsRevList + split <;> simp + exact ⟨h.2, FVarsIn.getAppArgsRevList h.1⟩ + +theorem FVarsIn.getAppArgsList {e} (h : FVarsIn P e) + {{a}} (ha : a ∈ e.getAppArgsList) : FVarsIn P a := + h.getAppArgsRevList (by simpa [← Expr.getAppArgsList_reverse]) + theorem Closed.looseBVarRange_le : Closed e k → e.looseBVarRange' ≤ k := by induction e generalizing k <;> simp +contextual [*, Closed, Expr.looseBVarRange', Nat.max_le] From f1ad7c6db5bf1e4afd4a4d09b3a1f1c8e2a233ad Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Tue, 11 Aug 2026 08:36:08 -0400 Subject: [PATCH 41/51] 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 199c3f65..fef14e24 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 ce2f7686..3984fce3 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 42/51] 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 f3c99065..8cc80366 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 fef14e24..8c27a572 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 58606b72..5c2afeb6 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 48c90694..f32d2587 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 2fc2d0e9..04bfe71d 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 629d8b8f..a05c7362 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 075338e8..0ca0e455 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 9815dcdf..5e356666 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 f982a9ad..178a808f 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 43/51] 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 00000000..b9f2ccfd --- /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 66a7bb1b..97337409 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 ae8afeec..e97daaae 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 3984fce3..0efa7a9f 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 90162770..81872ff3 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 3a466725..6a93e3d9 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 5c2afeb6..d068e301 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 6f027e77..9f0c87ed 100644 --- a/Lean4Lean/Verify/Environment/Elimination.lean +++ b/Lean4Lean/Verify/Environment/Elimination.lean @@ -6,11 +6,11 @@ open Lean hiding Environment Exception namespace AddInductive -/-- Theory's presentation of the Boolean returned by the ordinary -large-eliminator checker. -/ -def checkerElimMode : Bool → VInductDecl.ElimMode - | false => .small - | true => .large +/-- Compatibility name for Theory's presentation of the Boolean returned by +the ordinary large-eliminator checker. -/ +@[deprecated VInductDecl.ElimMode.ofBool (since := "2026-08-11")] +abbrev checkerElimMode : Bool → VInductDecl.ElimMode := + VInductDecl.ElimMode.ofBool /-- Lightweight alignment for an exact `getElimLevel` execution when the normalization statistics are already pinned independently. This is useful for @@ -22,7 +22,7 @@ structure CheckerElimLevelRun (execution : ElimLevelExecution stats indTypes context) : Type where sourceUvars_eq : source.uvars = context.lparams.length mode_eq : generation.elimination = - checkerElimMode execution.large.result + VInductDecl.ElimMode.ofBool execution.large.result recUvars_eq : generation.recUvars = (getRecLevelParams execution.level context.lparams).length recLevels_eq : @@ -42,7 +42,7 @@ def build? Option (CheckerElimLevelRun generation execution) := do if huvars : source.uvars = context.lparams.length then if hmode : generation.elimination = - checkerElimMode execution.large.result then + VInductDecl.ElimMode.ofBool execution.large.result then if hrecUvars : generation.recUvars = (getRecLevelParams execution.level context.lparams).length then if hlevels : @@ -67,11 +67,11 @@ theorem large_result_iff cases hresult : execution.large.result with | false => have hmode : generation.elimination = VInductDecl.ElimMode.small := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] | true => have hmode : generation.elimination = VInductDecl.ElimMode.large := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] theorem small_result_iff @@ -81,11 +81,11 @@ theorem small_result_iff cases hresult : execution.large.result with | false => have hmode : generation.elimination = VInductDecl.ElimMode.small := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] | true => have hmode : generation.elimination = VInductDecl.ElimMode.large := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] end CheckerElimLevelRun @@ -143,7 +143,7 @@ structure CheckerEliminationRun sourceUvars_eq : source.uvars = execution.normalization.validationContext.lparams.length mode_eq : generation.elimination = - checkerElimMode execution.elimination.large.result + VInductDecl.ElimMode.ofBool execution.elimination.large.result kTarget_eq : generation.kTarget = execution.kTarget.result recUvars_eq : generation.recUvars = execution.recLevelParams.length recLevels_eq : execution.recLevels.mapM @@ -164,7 +164,7 @@ def build? if huvars : source.uvars = execution.normalization.validationContext.lparams.length then if hmode : generation.elimination = - checkerElimMode execution.elimination.large.result then + VInductDecl.ElimMode.ofBool execution.elimination.large.result then if hkTarget : generation.kTarget = execution.kTarget.result then if hrecUvars : generation.recUvars = execution.recLevelParams.length then @@ -192,11 +192,11 @@ theorem large_result_iff cases hresult : execution.elimination.large.result with | false => have hmode : generation.elimination = VInductDecl.ElimMode.small := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] | true => have hmode : generation.elimination = VInductDecl.ElimMode.large := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] theorem small_result_iff @@ -206,11 +206,11 @@ theorem small_result_iff cases hresult : execution.elimination.large.result with | false => have hmode : generation.elimination = VInductDecl.ElimMode.small := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] | true => have hmode : generation.elimination = VInductDecl.ElimMode.large := by - simpa [checkerElimMode, hresult] using run.mode_eq + simpa [hresult] using run.mode_eq simp [hmode] theorem kTarget_result_true_iff diff --git a/Lean4Lean/Verify/Environment/InductiveFixtures.lean b/Lean4Lean/Verify/Environment/InductiveFixtures.lean index 04bfe71d..bfec8aaf 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 b3a5f5bd..bf679c20 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 178a808f..67576305 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 6827637a..4b871ab4 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 44/51] 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 349b682a..c7204099 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 b9f2ccfd..486050ed 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 8c27a572..b4aac623 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 4b871ab4..60f10be1 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 45/51] 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 00000000..3a46d994 --- /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 b4aac623..d29a4c1a 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 0efa7a9f..d6771ec2 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 519253da..2c0806cc 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 cf9a2b00..bce4d6d1 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 a05c7362..ff1c2584 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 992ae6a1..9e21a8ca 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 60f10be1..c647ede4 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 From b292275cecebb70ae65fabe7ef7c57dc3aafaf4e Mon Sep 17 00:00:00 2001 From: Mario Carneiro Date: Tue, 11 Aug 2026 10:35:02 +0200 Subject: [PATCH 46/51] perf: skip the NormLevel for levels with no essential imax A level built from zero/succ/max/param alone normalizes to a map with the constant at the empty key and one single-variable node per parameter, so it can be collected by a sorted merge and the tree read off directly, without building a TreeMap. normalize' dispatches on flat?, and normalize'_eq shows the dispatch is transparent, so normalize'_eval and normalize'_complete go through unchanged. The proof characterizes the map pointwise (NormLevel.Flat): normalizeAux builds it by addConst/addNode, subsumption is the identity on it (a condition set is empty or a singleton and the constant-carrying node has no variables, so nothing subsumes anything), and each singleton key's lexChain is forced, leaving toTree to add one child per parameter in name order. 3.8x on normalize' over an exhaustive corpus of flat levels. Note the kernel does not call normalize' on its hot path -- level comparison goes through isEquiv'/geq', which 5aa2add handles -- so this speeds up canonical-form production rather than checking. sorted_pairs_eq and its helper move up verbatim (plus a docstring), since the new section needs them. Co-Authored-By: Claude Fable 5 --- Lean4Lean/Level.lean | 49 +++- Lean4Lean/Verify/Level.lean | 555 ++++++++++++++++++++++++++++++++---- 2 files changed, 548 insertions(+), 56 deletions(-) diff --git a/Lean4Lean/Level.lean b/Lean4Lean/Level.lean index 38705c13..49b14d3e 100644 --- a/Lean4Lean/Level.lean +++ b/Lean4Lean/Level.lean @@ -297,9 +297,56 @@ where else mkMax (imax (reify t) (.param n)) r | none => mkMax (imax (reify t) (.param n)) r +/-! +### Fast path for levels without an essential `imax` + +Levels arising in practice are almost always built from `zero`, `succ`, `max` and `param` +alone: `mkLevelIMax'` already discharges `imax _ 0`, `imax _ (_+1)`, `imax a a` and +`imax ≤1 _` where the kernel builds levels, and in a census of the 522k level comparisons +performed while checking Lean+Std+Batteries, 99.8% of the levels reaching them were +`imax`-free. + +Such a level's canonical form is flat: its sublevels are `C(∅, K)` and one `V({x}, x, kₓ)` +per parameter, nothing is ever subsumed (a condition set is `∅` or a singleton, and the `C` +node carries no variables), and each `imax` chain is a single edge. So the whole `NormLevel` +can be replaced by a sorted merge, and the tree read off directly. Note that every parameter +occurrence contributes its offset to the constant as well, so `K` dominates every `kₓ` and +the reified children never need their `imax` guard. +-/ + +/-- The map a run of flat data stands for: the constant at the root (absent when zero) and +`V({x}, x, k)` at each singleton key. Note this inserts the keys in sorted order, whereas +`normalizeAux` inserts them in traversal order, so the two build the same entries in +differently balanced trees — everything downstream compares maps entry by entry. -/ +def toNormLevel (c : Nat) (vs : List VarNode) : NormLevel := + vs.foldl (fun s v => s.insert [v.var] ⟨0, [v]⟩) + (if c = 0 then {} else (∅ : NormLevel).insert [] ⟨c, []⟩) + +/-- Collect the largest constant and the largest offset of each parameter, throwing the +`NormLevel` built from what has been collected so far on reaching an `imax`, so that +`normalizeAux` picks up from there rather than retraversing. -/ +def flatAux : Level → Nat → Nat × List VarNode → Except NormLevel (Nat × List VarNode) + | .zero, k, (c, vs) => .ok (Nat.max c k, vs) + | .succ l, k, acc => flatAux l (k+1) acc + | .max a b, k, acc => + match flatAux a k acc with + | .ok acc => flatAux b k acc + | .error s => .error (normalizeAux b [] k s) + | .param x, k, (c, vs) => .ok (Nat.max c k, VarNode.addVar x k vs) + | .mvar _, _, acc => .ok acc + | l@(.imax ..), k, (c, vs) => .error (normalizeAux l [] k (toNormLevel c vs)) + +/-- The tree `toTree` builds for a flat level: the constant at the root, and one child per +parameter holding `V({x}, x, kₓ)` — dropped when `kₓ = 0`, as the edge already provides it. -/ +def flatTree (c : Nat) (vs : List VarNode) : Tree := + ⟨c, [], vs.map fun v => (v.var, ⟨0, if v.offset == 0 then [] else [v], []⟩)⟩ + end Normalize -def normalize' (l : Level) : Level := (Normalize.normalize l).toTree.reify +def normalize' (l : Level) : Level := + match Normalize.flatAux l 0 (0, []) with + | .ok (c, vs) => (Normalize.flatTree c vs).reify + | .error s => s.subsumption.toTree.reify /-- Core's `isEquiv` is sound but incomplete, so it can be used as a fast path: when it accepts, the levels really are equivalent, and when it rejects we fall back to the complete diff --git a/Lean4Lean/Verify/Level.lean b/Lean4Lean/Verify/Level.lean index e347f52f..79d86c5e 100644 --- a/Lean4Lean/Verify/Level.lean +++ b/Lean4Lean/Verify/Level.lean @@ -2854,37 +2854,30 @@ theorem NormLevel.le_fold_complete {p₁ : List Name} : cases h | pn :: l, n₁, hvs₁, hvsl, hne, hconst, hvar => by simp only [List.foldlM_cons] - by_cases hs : subset compare pn.1 p₁ - · rw [if_pos hs] - by_cases he : (n₁.subsumeBy false pn.2).isEmpty - · rw [if_pos he]; rfl - · rw [if_neg he] - show List.foldlM _ _ l = none - refine le_fold_complete l _ (hvs₁.sublist Node.subsumeBy_var_sublist) - (fun pn h => hvsl _ (.tail _ h)) (by simpa using he) ?_ ?_ - · intro h0 - have hc : (n₁.subsumeBy false pn.2).const = n₁.const := - (Node.subsumeBy_const_cases ..).resolve_right h0 - obtain ⟨pn', hpn', hsub', hdom'⟩ := hconst (hc ▸ h0) - rcases List.mem_cons.1 hpn' with rfl | hpn' - · exact absurd (Node.subsumeBy_const_complete - (hdom'.imp (fun h => ⟨rfl, h⟩) id)) h0 - · exact ⟨pn', hpn', hsub', hc ▸ hdom'⟩ - · intro x hx - obtain ⟨pn', hpn', hsub', y, hy, e, hle⟩ := hvar x (Node.subsumeBy_var_subset hx) - rcases List.mem_cons.1 hpn' with rfl | hpn' - · exact (Node.subsumeBy_var_complete hvs₁ (hvsl _ (.head _)) hx hy e hle).elim - · exact ⟨pn', hpn', hsub', y, hy, e, hle⟩ - · rw [if_neg hs] - show List.foldlM _ _ l = none - refine le_fold_complete l n₁ hvs₁ (fun pn h => hvsl _ (.tail _ h)) hne ?_ ?_ + split <;> rename_i hs + · by_cases he : (n₁.subsumeBy false pn.2).isEmpty <;> simp [he] + refine le_fold_complete l _ (hvs₁.sublist Node.subsumeBy_var_sublist) + (fun pn h => hvsl _ (.tail _ h)) (by simpa using he) ?_ ?_ · intro h0 - obtain ⟨pn', hpn', hsub', hdom'⟩ := hconst h0 + have hc : (n₁.subsumeBy false pn.2).const = n₁.const := + (Node.subsumeBy_const_cases ..).resolve_right h0 + obtain ⟨pn', hpn', hsub', hdom'⟩ := hconst (hc ▸ h0) + rcases List.mem_cons.1 hpn' with rfl | hpn' + · exact absurd (Node.subsumeBy_const_complete + (hdom'.imp (fun h => ⟨rfl, h⟩) id)) h0 + · exact ⟨pn', hpn', hsub', hc ▸ hdom'⟩ + · intro x hx + obtain ⟨pn', hpn', hsub', y, hy, e, hle⟩ := hvar x (Node.subsumeBy_var_subset hx) + rcases List.mem_cons.1 hpn' with rfl | hpn' + · exact (Node.subsumeBy_var_complete hvs₁ (hvsl _ (.head _)) hx hy e hle).elim + · exact ⟨pn', hpn', hsub', y, hy, e, hle⟩ + · refine le_fold_complete l n₁ hvs₁ (fun pn h => hvsl _ (.tail _ h)) hne + (fun h0 => ?_) (fun x hx => ?_) + · obtain ⟨pn', hpn', hsub', hdom'⟩ := hconst h0 rcases List.mem_cons.1 hpn' with rfl | hpn' · exact absurd hsub' hs · exact ⟨pn', hpn', hsub', hdom'⟩ - · intro x hx - obtain ⟨pn', hpn', hsub', hy⟩ := hvar x hx + · obtain ⟨pn', hpn', hsub', hy⟩ := hvar x hx rcases List.mem_cons.1 hpn' with rfl | hpn' · exact absurd hsub' hs · exact ⟨pn', hpn', hsub', hy⟩ @@ -2921,6 +2914,469 @@ theorem NormLevel.le_complete {l₁ l₂ : NormLevel} exact ⟨(q, m), hmem₂ _ _ hq, subset_of_sorted (hsort₂ _ _ hq) (hsort₁ _ _ h₁) hsub, ⟨yv, yk⟩, hyk, hev.symm, hle⟩ +/-- Two key-sorted entry lists with the same entries are equal. -/ +theorem sorted_pairs_eq : ∀ {l₁ l₂ : List (List Name × Node)}, + l₁.Pairwise (compare ·.1 ·.1 = .lt) → l₂.Pairwise (compare ·.1 ·.1 = .lt) → + (∀ x, x ∈ l₁ ↔ x ∈ l₂) → l₁ = l₂ + | [], [], _, _, _ => rfl + | [], _ :: _, _, _, h => nomatch (h _).2 (.head _) + | _ :: _, [], _, _, h => nomatch (h _).1 (.head _) + | a :: l₁, b :: l₂, h₁, h₂, h => by + have head₁ := (List.pairwise_cons.1 h₁).1 + have head₂ := (List.pairwise_cons.1 h₂).1 + cases show a = b by + rcases List.mem_cons.1 ((h a).1 (.head _)) with rfl | ha <;> [rfl; skip] + rcases List.mem_cons.1 ((h b).2 (.head _)) with rfl | hb <;> [rfl; skip] + cases Std.OrientedCmp.not_lt_of_lt (head₁ _ hb) (head₂ _ ha) + refine congrArg (a :: ·) (sorted_pairs_eq (List.pairwise_cons.1 h₁).2 + (List.pairwise_cons.1 h₂).2 fun x => ⟨fun hx => ?_, fun hx => ?_⟩) + · rcases List.mem_cons.1 ((h x).1 (.tail _ hx)) with rfl | hx' + · have := head₁ _ hx; rw [Std.ReflOrd.compare_self] at this; cases this + · exact hx' + · rcases List.mem_cons.1 ((h x).2 (.tail _ hx)) with rfl | hx' + · have := head₂ _ hx; rw [Std.ReflOrd.compare_self] at this; cases this + · exact hx' + +/-! ### The flat fast path + +For a level with no essential `imax`, `normalize` produces a map with the constant at the +root and one single-variable node per parameter (`NormLevel.Flat`), and `toTree` reads that +off directly, so building the `NormLevel` can be skipped entirely. -/ + +/-- The map `normalize` produces for a flat level, pointwise: `C(∅, c)` at the root, and +`V({x}, x, k)` at each singleton key whose parameter is recorded in `vs`. -/ +def flatGet (c : Nat) (vs : List VarNode) : List Name → Option Node + | [] => if c = 0 then none else some ⟨c, []⟩ + | [x] => (vs.find? (·.var == x)).map fun v => ⟨0, [v]⟩ + | _ => none + +def NormLevel.Flat (s : NormLevel) (c : Nat) (vs : List VarNode) : Prop := + ∀ p, s.get? p = flatGet c vs p + +theorem find?_var_eq_some {vs : List VarNode} {x : Name} {v : VarNode} (hvs : VarsSorted vs) : + vs.find? (·.var == x) = some v ↔ v ∈ vs ∧ v.var = x := by + refine ⟨fun h => ⟨List.mem_of_find?_eq_some h, by simpa using List.find?_some h⟩, ?_⟩ + rintro ⟨hv, rfl⟩ + match h : vs.find? (·.var == v.var) with + | none => simp [List.find?_eq_none] at h; exact absurd rfl (h _ hv) + | some w => + have hw := List.mem_of_find?_eq_some h + have hwe : w.var = v.var := by simpa using List.find?_some h + rw [h, hvs.eq_of_var_eq hw hv hwe] + +theorem find?_var_eq_none {vs : List VarNode} {x : Name} : + vs.find? (·.var == x) = none ↔ ∀ v ∈ vs, v.var ≠ x := by + simp [List.find?_eq_none] + +/-- `addVar` raises the offset of the entry for `x`, leaving the rest alone. -/ +theorem VarNode.find?_addVar {vs : List VarNode} {x y : Name} {k : Nat} (hvs : VarsSorted vs) : + (VarNode.addVar x k vs).find? (·.var == y) = + if x = y then some ⟨x, ((vs.find? (·.var == x)).map (·.offset.max k)).getD k⟩ + else vs.find? (·.var == y) := by + induction vs with | nil => split <;> simp [VarNode.addVar, *] | cons w l ih + simp only [VarNode.addVar] + split <;> rename_i hc + · have hnone : (w :: l).find? (·.var == x) = none := by + refine find?_var_eq_none.2 fun v hv => ?_ + obtain rfl | hv := List.mem_cons.1 hv + · exact fun e => name_lt_ne hc e.symm + · exact fun e => name_lt_ne (Std.TransCmp.lt_trans hc (hvs.head _ hv)) e.symm + split <;> rename_i h + · subst h; rw [List.find?_cons_of_pos (by simp), hnone]; rfl + · rw [List.find?_cons_of_neg (by simp [h])] + · have e := eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 hc) + split <;> rename_i h + · subst h; rw [List.find?_cons_of_pos (by simp), List.find?_cons_of_pos (by simp [← e])]; rfl + · rw [List.find?_cons_of_neg (by simp [h]), List.find?_cons_of_neg (by simp [← e, h])] + · have hne := name_lt_ne (Std.OrientedCmp.lt_of_gt hc) + by_cases hy : w.var = y + · rw [if_neg (hy ▸ hne.symm), List.find?_cons_of_pos (by simp [hy]), + List.find?_cons_of_pos (by simp [hy])] + · rw [List.find?_cons_of_neg (by simp [hy]), ih hvs.of_cons, + List.find?_cons_of_neg (by simp [hne]), List.find?_cons_of_neg (by simp [hy])] + +theorem NormLevel.addConst_flat {s : NormLevel} {c k : Nat} {vs : List VarNode} + (h : s.Flat c vs) : (addConst k [] s).Flat (Nat.max c k) vs := by + by_cases hk : k = 0 + · subst hk + rw [show Nat.max c 0 = c from Nat.max_zero c, NormLevel.addConst, if_pos (by simp)] + exact h + · rw [NormLevel.addConst, if_neg (by simp [hk])] + intro p + rw [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_alter] + have hmax : ¬Nat.max c k = 0 := by simp only [Nat.max_eq_zero_iff]; simp [hk] + split <;> rename_i he + · cases eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 he) + rw [← Std.TreeMap.get?_eq_getElem?, h []] + simp only [flatGet] + by_cases hc0 : c = 0 + · subst hc0 + rw [if_pos rfl, if_neg hmax, show Nat.max 0 k = k from Nat.zero_max k] + · rw [if_neg hc0, if_neg hmax, show Nat.max c k = Nat.max k c from Nat.max_comm c k] + · rw [← Std.TreeMap.get?_eq_getElem?, h p] + match p with + | [] => cases he Std.ReflOrd.compare_self + | [_] | _ :: _ :: _ => rfl + +theorem NormLevel.addNode_flat {s : NormLevel} {c k : Nat} {vs : List VarNode} {x : Name} + (hvs : VarsSorted vs) (h : s.Flat c vs) : + (addNode x k [x] s).Flat c (VarNode.addVar x k vs) := by + intro p + rw [NormLevel.addNode, Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_alter] + split <;> rename_i he + · have hp : [x] = p := eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 he) + subst hp + rw [← Std.TreeMap.get?_eq_getElem?, h [x]] + simp only [flatGet] + rw [VarNode.find?_addVar hvs, if_pos rfl] + match hfd : vs.find? (·.var == x) with + | none => rw [hfd]; rfl + | some v => + have hv : v.var = x := by simpa using List.find?_some hfd + rw [hfd] + show some ({ const := 0, var := VarNode.addVar x k [v] } : Node) = _ + rw [show VarNode.addVar x k [v] = [⟨x, v.offset.max k⟩] from by + simp only [VarNode.addVar, hv, Std.ReflCmp.compare_self]]; rfl + · rw [← Std.TreeMap.get?_eq_getElem?, h p] + match p with + | [] => rfl + | [y] => + have hxy : x ≠ y := by rintro rfl; exact he Std.ReflOrd.compare_self + simp only [flatGet] + rw [VarNode.find?_addVar hvs, if_neg hxy] + | _ :: _ :: _ => rfl + +/-- The entries of a flat map: the root carries the constant (and is absent when it is zero), +and every other key is a singleton carrying one variable of `vs`. -/ +private theorem flatGet_eq_some {c : Nat} {vs : List VarNode} {p : List Name} {n : Node} + (h : flatGet c vs p = some n) : + (p = [] ∧ n = ⟨c, []⟩ ∧ c ≠ 0) ∨ ∃ v ∈ vs, p = [v.var] ∧ n = ⟨0, [v]⟩ := by + match p with + | [] => + simp only [flatGet] at h + split at h + · cases h + · exact .inl ⟨rfl, by cases h; rfl, by assumption⟩ + | [x] => + simp only [flatGet, Option.map_eq_some_iff] at h + obtain ⟨v, hv, rfl⟩ := h + have hvx : v.var = x := by simpa using List.find?_some hv + exact .inr ⟨v, List.mem_of_find?_eq_some hv, by rw [hvx], rfl⟩ + | _ :: _ :: _ => simp [flatGet] at h + +/-- `subsumeBy` is the identity when the constant has nothing to lose (it is zero, or the two +sit at the same condition set and the dominator has no variables) and the variables have +nothing to lose (same condition set, or no variables to be dominated by). -/ +private theorem Node.subsumeBy_id {same : Bool} {n₁ n₂ : Node} + (h₁ : n₁.const = 0 ∨ (same ∧ n₂.var = [])) + (h₂ : same ∨ n₂.var = []) : n₁.subsumeBy same n₂ = n₁ := by + simp only [Node.subsumeBy] + rcases h₁ with hz | ⟨hs, hv⟩ + · rcases h₂ with h2 | h2 <;> simp [hz, h2] + · simp [hs, hv] + +private theorem subsume_flat_id {c : Nat} {vs : List VarNode} {p₁ p₂ : List Name} {n₁ n₂ : Node} + (h₁ : flatGet c vs p₁ = some n₁) (h₂ : flatGet c vs p₂ = some n₂) : + Node.subsume p₁ n₁ p₂ n₂ = n₁ := by + rw [Node.subsume] + split <;> [rename_i hsub; rfl] + obtain ⟨rfl, rfl, -⟩ | ⟨v, -, rfl, rfl⟩ := flatGet_eq_some h₂ + · obtain ⟨rfl, rfl, -⟩ | ⟨w, -, rfl, rfl⟩ := flatGet_eq_some h₁ + · exact Node.subsumeBy_id (.inr ⟨rfl, rfl⟩) (.inl rfl) + · exact Node.subsumeBy_id (.inl rfl) (.inr rfl) + · obtain ⟨rfl, rfl, -⟩ | ⟨w, -, rfl, rfl⟩ := flatGet_eq_some h₁ + · exact absurd hsub (by simp [subset]) + · exact Node.subsumeBy_id (.inl rfl) (.inl rfl) + +/-- Nothing in a flat map subsumes anything: a condition set is empty or a singleton, and the +node carrying the constant has no variables. -/ +theorem NormLevel.subsumption_flat {s : NormLevel} {c : Nat} {vs : List VarNode} + (h : s.Flat c vs) : s.subsumption.Flat c vs := by + have hmin : ∀ (acc : NormLevel), acc.Flat c vs → ∀ p₁ n₁, flatGet c vs p₁ = some n₁ → + acc.minimize p₁ n₁ = n₁ := by + intro acc hacc p₁ n₁ h₁ + rw [NormLevel.minimize, Std.TreeMap.foldl_eq_foldl_toList] + have hmem : ∀ pn ∈ acc.toList, flatGet c vs pn.1 = some pn.2 := fun pn hp => + (hacc pn.1).symm.trans (Std.TreeMap.get?_eq_getElem? .. ▸ + Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hp) + suffices ∀ (l : List (List Name × Node)), (∀ pn ∈ l, flatGet c vs pn.1 = some pn.2) → + List.foldl (fun n pn => Node.subsume p₁ n pn.1 pn.2) n₁ l = n₁ from this _ hmem + intro l; induction l with | nil => intro; rfl | cons pn l ih + intro hl + rw [List.foldl_cons, subsume_flat_id h₁ (hl pn (.head _))] + exact ih fun q hq => hl q (.tail _ hq) + rw [NormLevel.subsumption, Std.TreeMap.foldl_eq_foldl_toList] + have hmem : ∀ pn ∈ s.toList, flatGet c vs pn.1 = some pn.2 := fun pn hp => + (h pn.1).symm.trans (Std.TreeMap.get?_eq_getElem? .. ▸ + Std.TreeMap.mem_toList_iff_getElem?_eq_some.1 hp) + suffices ∀ (l : List (List Name × Node)) (acc : NormLevel), + (∀ pn ∈ l, flatGet c vs pn.1 = some pn.2) → acc.Flat c vs → + (List.foldl (fun acc pn => + let n := acc.minimize pn.1 pn.2 + if n.isEmpty then acc.erase pn.1 else acc.insert pn.1 n) acc l).Flat c vs from + this _ _ hmem h + intro l; induction l with | nil => exact fun _ _ hacc => hacc | cons pn l ih + obtain ⟨p₁, n₁⟩ := pn + refine fun acc hl hacc => ih _ (fun q hq => hl q (.tail _ hq)) fun p => ?_ + have h₁ : flatGet c vs p₁ = some n₁ := hl _ (.head _) + have hne : n₁.isEmpty = false := by + obtain ⟨-, rfl, hc0⟩ | ⟨v, -, -, rfl⟩ := flatGet_eq_some h₁ + · simp [Node.isEmpty, hc0] + · simp [Node.isEmpty] + rw [NormLevel.subsumption_step_get?, hmin acc hacc p₁ n₁ h₁, hne] + simp only [Bool.false_eq_true, if_false] + split <;> rename_i hp + · subst hp; exact h₁.symm + · exact hacc p + +/-- The inserts of `toNormLevel` fill in the singleton keys one at a time: once the starting +map is right at every key not yet due to be written, the fold is right everywhere. -/ +private theorem toNormLevel_fold {c : Nat} {vs : List VarNode} (hvs : VarsSorted vs) : + ∀ (l : List VarNode) (s : NormLevel), (∀ w ∈ l, w ∈ vs) → + (∀ p, (∀ w ∈ l, p ≠ [w.var]) → s.get? p = flatGet c vs p) → + ∀ p, (l.foldl (fun s v => s.insert [v.var] ⟨0, [v]⟩) s).get? p = flatGet c vs p := by + intro l; induction l with | nil => intro s _ hs p; exact hs p (by simp) | cons w l ih + refine fun s hmem hs => ih _ (fun x hx => hmem x (.tail _ hx)) fun p hp => ?_ + rw [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_insert] + split <;> rename_i he + · have hpe : [w.var] = p := eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 he) + subst hpe + simp only [flatGet] + rw [(find?_var_eq_some hvs).2 ⟨hmem w (.head _), rfl⟩]; rfl + · rw [← Std.TreeMap.get?_eq_getElem?] + refine hs p fun x hx => ?_ + obtain rfl | hx := List.mem_cons.1 hx + · rintro rfl; exact he Std.ReflOrd.compare_self + · exact hp x hx + +/-- `toNormLevel` really does build a flat map. -/ +theorem toNormLevel_flat {c : Nat} {vs : List VarNode} (hvs : VarsSorted vs) : + (toNormLevel c vs).Flat c vs := by + refine toNormLevel_fold hvs vs _ (fun w hw => hw) fun p hp => ?_ + have hnone : ∀ x, p = [x] → flatGet c vs [x] = none := by + rintro x rfl; simp only [flatGet] + rw [find?_var_eq_none.2 fun v hv he => hp v hv (by rw [he])]; rfl + split <;> rename_i hc + · subst hc + match p with + | [] => rfl + | [x] => rw [hnone x rfl]; rfl + | _ :: _ :: _ => rfl + · rw [Std.TreeMap.get?_eq_getElem?, Std.TreeMap.getElem?_insert] + split <;> rename_i he + · cases eq_of_beq (Std.LawfulBEqCmp.compare_eq_iff_beq.1 he); simp [flatGet, hc] + · match p with + | [] => cases he Std.ReflOrd.compare_self + | [x] => rw [hnone x rfl]; rfl + | _ :: _ :: _ => rfl + +/-! Two maps with the same entries need not be the same tree, so the fallback -- which seeds +`normalizeAux` with `toNormLevel` rather than with the map the general path would have built +-- needs `normalizeAux` and `subsumption` to respect pointwise equality. -/ + +theorem toList_eq_of_get?_eq {A B : NormLevel} (h : ∀ p, A.get? p = B.get? p) : + A.toList = B.toList := by + refine sorted_pairs_eq Std.TreeMap.ordered_keys_toList Std.TreeMap.ordered_keys_toList ?_ + rintro ⟨p, n⟩ + rw [Std.TreeMap.mem_toList_iff_getElem?_eq_some, Std.TreeMap.mem_toList_iff_getElem?_eq_some, + ← Std.TreeMap.get?_eq_getElem?, ← Std.TreeMap.get?_eq_getElem?, h] + +theorem NormLevel.addConst_congr {A B : NormLevel} (h : ∀ p, A.get? p = B.get? p) (k path p) : + (addConst k path A).get? p = (addConst k path B).get? p := by + simp only [Std.TreeMap.get?_eq_getElem?] at h ⊢ + rw [NormLevel.addConst, NormLevel.addConst] + split <;> [exact h p; skip] + rw [Std.TreeMap.getElem?_alter, Std.TreeMap.getElem?_alter] + split <;> rw [h] + +theorem NormLevel.addNode_congr {A B : NormLevel} (h : ∀ p, A.get? p = B.get? p) (x k path p) : + (addNode x k path A).get? p = (addNode x k path B).get? p := by + simp only [Std.TreeMap.get?_eq_getElem?] at h ⊢ + rw [NormLevel.addNode, NormLevel.addNode, Std.TreeMap.getElem?_alter, Std.TreeMap.getElem?_alter] + split <;> rw [h] + +theorem NormLevel.addVar_congr {A B : NormLevel} (h : ∀ p, A.get? p = B.get? p) (x k path p) : + (addVar x k path A).get? p = (addVar x k path B).get? p := by + simp only [Std.TreeMap.get?_eq_getElem?] at h ⊢ + rw [NormLevel.addVar, NormLevel.addVar, Std.TreeMap.getElem?_modify, Std.TreeMap.getElem?_modify] + split <;> rw [h] + +theorem normalizeAux_congr {A B : NormLevel} (h : ∀ p, A.get? p = B.get? p) (u path k) : + ∀ p, (normalizeAux u path k A).get? p = (normalizeAux u path k B).get? p := by + induction u, path, k, A using normalizeAux.induct generalizing B with + | case1 path k acc => simp only [normalizeAux]; exact NormLevel.addConst_congr h k path + | case2 path k acc a => simp only [normalizeAux]; exact NormLevel.addConst_congr h k path + | case3 path k acc u ih => simp only [normalizeAux]; exact ih h + | case4 path k acc u v ih₁ ih₂ => simp only [normalizeAux]; exact ih₂ (ih₁ h) + | case5 path k acc u v ih₁ ih₂ => simp only [normalizeAux]; exact ih₂ (ih₁ h) + | case6 path k acc u v w ih₁ ih₂ => simp only [normalizeAux]; exact ih₂ (ih₁ h) + | case7 path k acc u v w ih₁ ih₂ => simp only [normalizeAux]; exact ih₂ (ih₁ h) + | case8 path k acc u v path' he ih => + simp only [normalizeAux, he] + exact ih (NormLevel.addNode_congr (NormLevel.addConst_congr h k path) v k path') + | case9 path k acc u v he acc1 => + rename_i ih + simp only [normalizeAux, he] + refine ih (B := if k = 0 then B else NormLevel.addVar v k path B) fun p => ?_ + show (if k = 0 then acc else NormLevel.addVar v k path acc).get? p = + (if k = 0 then B else NormLevel.addVar v k path B).get? p + by_cases hk : k = 0 + · simp only [if_pos hk]; exact h p + · simp only [if_neg hk]; exact NormLevel.addVar_congr h v k path p + | case10 path k acc a => simp only [normalizeAux]; exact h + | case11 path k acc a b => simp only [normalizeAux]; exact h + | case12 path k acc v path' he => + simp only [normalizeAux, he] + exact NormLevel.addNode_congr (NormLevel.addConst_congr h k path) v k path' + | case13 path acc v he => simp only [normalizeAux, he, if_pos]; exact h + | case14 path k acc v he hk => + simp only [normalizeAux, he, if_neg hk] + exact NormLevel.addVar_congr h v k path + +theorem NormLevel.subsumption_congr {A B : NormLevel} (h : ∀ p, A.get? p = B.get? p) : + ∀ p, A.subsumption.get? p = B.subsumption.get? p := by + rw [NormLevel.subsumption, NormLevel.subsumption, Std.TreeMap.foldl_eq_foldl_toList, + Std.TreeMap.foldl_eq_foldl_toList, toList_eq_of_get?_eq h] + let +generalize F acc pn := _ + suffices ∀ (l : List (List Name × Node)) (acc₁ acc₂ : NormLevel), + (∀ p, acc₁.get? p = acc₂.get? p) → ∀ p, + (List.foldl F acc₁ l).get? p = (List.foldl F acc₂ l).get? p from + this _ _ _ h + intro l; induction l with | nil => exact fun _ _ h => h | cons pn l ih + refine fun acc₁ acc₂ hacc => ih _ _ fun p => ?_ + have hmin : acc₁.minimize pn.1 pn.2 = acc₂.minimize pn.1 pn.2 := by + rw [NormLevel.minimize, NormLevel.minimize, Std.TreeMap.foldl_eq_foldl_toList, + Std.TreeMap.foldl_eq_foldl_toList, toList_eq_of_get?_eq hacc] + rw [NormLevel.subsumption_step_get?, NormLevel.subsumption_step_get?, hmin] + split <;> [rfl; exact hacc p] + +/-- What a traversal result stands for: collected data still describing the map, or a thrown +map agreeing with it entry for entry (only entry for entry, since the thrown one was rebuilt +from sorted data rather than in traversal order). -/ +def RepAcc : Except NormLevel (Nat × List VarNode) → NormLevel → Prop + | .ok (c, vs), s => VarsSorted vs ∧ s.Flat c vs + | .error s', s => ∀ p, s'.get? p = s.get? p + +/-- The traversal tracks `normalizeAux` step for step. -/ +theorem flatAux_rep (hvs : VarsSorted vs) (h : s.Flat c vs) : + RepAcc (flatAux l k (c, vs)) (normalizeAux l [] k s) := by + induction l generalizing k c vs s with simp only [flatAux, normalizeAux] + | zero => exact ⟨hvs, NormLevel.addConst_flat h⟩ + | succ l ih => exact ih hvs h + | max a b iha ihb => + have ha := iha (k := k) hvs h + cases hfa : flatAux a k (c, vs) with + | ok acc => obtain ⟨c₁, vs₁⟩ := acc; rw [hfa] at ha; exact ihb ha.1 ha.2 + | error s₁ => rw [hfa] at ha; exact normalizeAux_congr ha b [] k + | param => + exact ⟨VarNode.addVar_sorted hvs, NormLevel.addNode_flat hvs (NormLevel.addConst_flat h)⟩ + | imax => exact normalizeAux_congr (fun p => (toNormLevel_flat hvs p).trans (h p).symm) _ [] k + | mvar => exact ⟨hvs, h⟩ + +private theorem compare_nil_cons {x : Name} {l : List Name} : + compare ([] : List Name) (x :: l) = .lt := by + simp [compare, List.compareLex] + +private theorem compare_singleton {x y : Name} : compare [x] [y] = compare x y := by + simp only [compare, List.compareLex] + cases Name.cmp x y <;> rfl + +/-- Adding a name that sorts after everything already there appends at the end. -/ +private theorem modifyAt_append_of_lt (f : Tree → Tree) (a : Name) : ∀ (l : List (Name × Tree)), + (∀ q ∈ l, compare q.1 a = .lt) → modifyAt f a l = l ++ [(a, f default)] + | [], _ => rfl + | (x, t) :: l, hl => by + simp only [modifyAt, Std.OrientedCmp.gt_of_lt (cmp := Name.cmp) (hl (x, t) (.head _))] + rw [modifyAt_append_of_lt f a l fun q hq => hl q (.tail _ hq)]; rfl + +/-- The edge into a singleton key's node already provides `V({x}, x, 0)`. -/ +private theorem subsumeVars_singleton_self (v : VarNode) : + subsumeVars [v] [⟨v.var, 0⟩] = if v.offset == 0 then [] else [v] := by + simp only [subsumeVars, Std.ReflCmp.compare_self] + by_cases h : v.offset = 0 <;> simp [h] <;> omega + +/-- Folding the singleton keys of a flat map appends one child per parameter, in name order. -/ +private theorem flat_toTree_fold (s : NormLevel) (a : Nat) (b : List VarNode) : + ∀ (vs : List VarNode) (ch : List (Name × Tree)), + VarsSorted vs → + (∀ v ∈ vs, s.lexChain 1 [v.var] = [v.var]) → + (∀ v ∈ vs, ∀ q ∈ ch, compare q.1 v.var = .lt) → + List.foldl (fun t pn => + let path := s.lexChain (List.length pn.1) pn.1 + let var := if let v :: _ := path then subsumeVars pn.2.var [⟨v, 0⟩] else pn.2.var + Tree.modify path (fun t => { t with const := pn.2.const, var }) t) + ⟨a, b, ch⟩ (vs.map fun v => ([v.var], (⟨0, [v]⟩ : Node))) + = ⟨a, b, ch ++ vs.map fun v => (v.var, (⟨0, if v.offset == 0 then [] else [v], []⟩ : Tree))⟩ + | [], ch, _, _, _ => by simp + | v :: vs, ch, hvs, hlex, hch => by + have hch' : ∀ w ∈ vs, ∀ q ∈ ch ++ [(v.var, + (⟨0, if v.offset == 0 then [] else [v], []⟩ : Tree))], compare q.1 w.var = .lt := by + intro w hw q hq + rcases List.mem_append.1 hq with hq | hq + · exact hch w (.tail _ hw) q hq + · rw [List.mem_singleton] at hq; subst hq; exact hvs.head _ hw + have ih := flat_toTree_fold s a b vs _ hvs.of_cons (fun w hw => hlex w (.tail _ hw)) hch' + simp only [List.map_cons, List.foldl_cons, List.length_cons, List.length_nil, + hlex v (.head _), Tree.modify, subsumeVars_singleton_self] + rw [modifyAt_append_of_lt _ _ ch (fun q hq => hch v (.head _) q hq)] + exact ih.trans (by simp) + +/-- The entry list of a flat map, in key order. -/ +private theorem NormLevel.Flat.toList {s : NormLevel} {c : Nat} {vs : List VarNode} + (hvs : VarsSorted vs) (h : s.Flat c vs) : + s.toList = (if c = 0 then [] else [([], (⟨c, []⟩ : Node))]) ++ + vs.map fun v => ([v.var], (⟨0, [v]⟩ : Node)) := by + refine sorted_pairs_eq Std.TreeMap.ordered_keys_toList ?_ fun ⟨p, n⟩ => ?_ + · refine List.pairwise_append.2 ⟨?_, ?_, ?_⟩ + · by_cases hc0 : c = 0 <;> simp [hc0] + · rw [List.pairwise_map] + exact hvs.imp fun {u w} huw => by rw [compare_singleton]; exact huw + · intro x hx y hy + by_cases hc0 : c = 0 + · simp [hc0] at hx + · rw [if_neg hc0, List.mem_singleton] at hx + subst hx + obtain ⟨w, -, rfl⟩ := List.mem_map.1 hy + exact compare_nil_cons + · rw [Std.TreeMap.mem_toList_iff_getElem?_eq_some, ← Std.TreeMap.get?_eq_getElem?, h p] + constructor <;> intro hp + · obtain ⟨rfl, rfl, hc0⟩ | ⟨v, hv, rfl, rfl⟩ := flatGet_eq_some hp + · exact List.mem_append_left _ (by rw [if_neg hc0]; exact List.mem_singleton.2 rfl) + · exact List.mem_append_right _ (List.mem_map.2 ⟨v, hv, rfl⟩) + · obtain hp | hp := List.mem_append.1 hp + · split at hp <;> [cases hp; rename_i hc] + rw [List.mem_singleton] at hp; cases hp; simp [flatGet, hc] + · obtain ⟨v, hv, he⟩ := List.mem_map.1 hp + cases he; simp only [flatGet] + rw [(find?_var_eq_some hvs).2 ⟨hv, rfl⟩]; rfl + +/-- A singleton key's chain is forced: its one element is `addable` on the empty set, thanks +to the entry itself, and nothing remains to be completed. -/ +private theorem NormLevel.Flat.lexChain_singleton {s : NormLevel} {c : Nat} {vs : List VarNode} + (hvs : VarsSorted vs) (h : s.Flat c vs) {v : VarNode} (hv : v ∈ vs) : + s.lexChain 1 [v.var] = [v.var] := by + have haddable : s.addable v.var [] := by + rw [NormLevel.addable, Std.TreeMap.any_eq_any_toList, List.any_eq_true] + refine ⟨([v.var], ⟨0, [v]⟩), Std.TreeMap.mem_toList_iff_getElem?_eq_some.2 ?_, ?_⟩ + · rw [← Std.TreeMap.get?_eq_getElem?, h [v.var]] + simp only [flatGet] + rw [(find?_var_eq_some hvs).2 ⟨hv, rfl⟩]; rfl + · simp [subset] + rw [NormLevel.lexChain, List.find?_cons_of_pos] + · simp [NormLevel.lexChain] + · simp only [List.erase_cons_head, haddable, Bool.true_and]; rfl + +/-- Reading the tree off a flat map: every key is a singleton, so its `lexChain` is forced, +and the fold just adds one child per parameter in name order. -/ +theorem NormLevel.Flat.toTree {s : NormLevel} {c : Nat} {vs : List VarNode} + (hvs : VarsSorted vs) (h : s.Flat c vs) : s.toTree = flatTree c vs := by + rw [NormLevel.toTree, Std.TreeMap.foldl_eq_foldl_toList, NormLevel.Flat.toList hvs h] + have key := flat_toTree_fold s c [] vs [] hvs + (fun v => NormLevel.Flat.lexChain_singleton hvs h) (by simp) + by_cases hc0 : c = 0 + · subst hc0; rw [if_pos rfl]; exact key + · rw [if_neg hc0]; exact key + /-- The sublevels of a single node keyed at `p`. -/ def Node.HasSub (p : List Name) (n : Node) : Sub → Prop | .const q k => p = q ∧ n.const = k ∧ k ≠ 0 @@ -3282,31 +3738,6 @@ through `toList`, so equal normal forms reify to syntactically equal levels. (`T equality itself does not follow from `==`: the internal tree shape depends on insertion order.) -/ -private theorem listName_compare_self {p : List Name} : compare p p = .eq := - Std.LawfulBEqCmp.compare_eq_iff_beq.2 (by simp) - -theorem sorted_pairs_eq : ∀ {l₁ l₂ : List (List Name × Node)}, - l₁.Pairwise (compare ·.1 ·.1 = .lt) → l₂.Pairwise (compare ·.1 ·.1 = .lt) → - (∀ x, x ∈ l₁ ↔ x ∈ l₂) → l₁ = l₂ - | [], [], _, _, _ => rfl - | [], _ :: _, _, _, h => nomatch (h _).2 (.head _) - | _ :: _, [], _, _, h => nomatch (h _).1 (.head _) - | a :: l₁, b :: l₂, h₁, h₂, h => by - have head₁ := (List.pairwise_cons.1 h₁).1 - have head₂ := (List.pairwise_cons.1 h₂).1 - cases show a = b by - rcases List.mem_cons.1 ((h a).1 (.head _)) with rfl | ha <;> [rfl; skip] - rcases List.mem_cons.1 ((h b).2 (.head _)) with rfl | hb <;> [rfl; skip] - cases Std.OrientedCmp.not_lt_of_lt (head₁ _ hb) (head₂ _ ha) - refine congrArg (a :: ·) (sorted_pairs_eq (List.pairwise_cons.1 h₁).2 - (List.pairwise_cons.1 h₂).2 fun x => ⟨fun hx => ?_, fun hx => ?_⟩) - · rcases List.mem_cons.1 ((h x).1 (.tail _ hx)) with rfl | hx' - · have := head₁ _ hx; rw [listName_compare_self] at this; cases this - · exact hx' - · rcases List.mem_cons.1 ((h x).2 (.tail _ hx)) with rfl | hx' - · have := head₂ _ hx; rw [listName_compare_self] at this; cases this - · exact hx' - theorem NormLevel.toList_eq {A B : NormLevel} (h : A == B) : A.toList = B.toList := by simp +instances only [instBEqNormLevel, Std.TreeMap.all_eq_all_toList, Bool.and_eq_true, List.all_eq_true] at h @@ -3358,11 +3789,25 @@ theorem NormLevel.toTree_congr {A B : NormLevel} (h : A.toList = B.toList) : funext t pn rw [lexChain_congr h] +/-- The fast path is transparent: it computes the same tree the general path does. -/ +theorem normalize'_eq (l : Level) : normalize' l = (normalize l).toTree.reify := by + rw [normalize'] + have hrep := flatAux_rep (l := l) (k := 0) (c := 0) (vs := []) (s := {}) .nil + (fun p => by match p with | [] | [_] | _::_::_ => simp [flatGet]) + match hf : flatAux l 0 (0, []) with + | .ok (c, vs) => + rw [hf] at hrep + obtain ⟨hvs, hflat⟩ := hrep + rw [normalize, (NormLevel.subsumption_flat hflat).toTree hvs] + | .error s => + rw [hf] at hrep; dsimp only + rw [normalize, NormLevel.toTree_congr (toList_eq_of_get?_eq (NormLevel.subsumption_congr hrep))] + end Normalize theorem isEquiv'_wf (h : isEquiv' u v) (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') : u' ≈ v' := by - simp only [isEquiv', Bool.or_eq_true, beq_iff_eq] at h + simp only [isEquiv', Bool.or_eq_true] at h obtain h | h := h · exact isEquiv_wf h hu hv · refine VLevel.equiv_def.2 fun ρ => ?_ @@ -3377,7 +3822,7 @@ nothing is lost, since every entry is recorded at the end of its chain. -/ theorem normalize'_eval (hu : VLevel.ofLevel ls u = some u') : Level.eval (Normalize.evalParam ls ρ) μ (normalize' u) = u'.eval ρ := by open Normalize in - rw [normalize', Tree.reify_eval, NormLevel.toTree_eval normalize_sorted normalize_feas] + rw [normalize'_eq, Tree.reify_eval, NormLevel.toTree_eval normalize_sorted normalize_feas] exact normalize_eval hu theorem geq'_wf (hu : VLevel.ofLevel ls u = some u') (hv : VLevel.ofLevel ls v = some v') @@ -3406,7 +3851,7 @@ theorem normalize'_complete (hu : VLevel.ofLevel ls u = some u') refine ⟨fun h => ?_, fun h => ?_⟩ · refine VLevel.equiv_def.2 fun ρ => ?_ rw [← normalize'_eval (μ := fun _ => 0) hu, ← normalize'_eval hv, h] - · simp only [normalize'] + · rw [Normalize.normalize'_eq, Normalize.normalize'_eq] rw [← Normalize.normalize_complete hu hv] at h rw [Normalize.NormLevel.toTree_congr (Normalize.NormLevel.toList_eq h)] From c22d790d885b86fdec5ea2fe7482d7cb62dd2b7e Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Tue, 11 Aug 2026 12:54:33 -0400 Subject: [PATCH 47/51] docs: activate L4L-15R reconciliation and eta divergence policy MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Roadmap: schedule the v4.33 upstream reconciliation as the active integration-only milestone L4L-15R (merge upstream master 1a16b72d, v4.31 precedent 7f864b45); requeue L4L-15B with the former upstream-approval gate replaced by the documented-divergence protocol (design note, ledger entry, implementation; approved 2026-08-11); retire all jcb/induct references — origin/jcb/formalization2 is the sole publication bookmark. --- plans/roadmap.md | 148 ++++++++++++++++++++++++++++++++++------------- 1 file changed, 108 insertions(+), 40 deletions(-) diff --git a/plans/roadmap.md b/plans/roadmap.md index c647ede4..df065ca4 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -2,7 +2,8 @@ **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. +publication (pushing `jcb/formalization2` to origin) remains a separate +boundary. **Versioning.** `plans/roadmap.md` is intentionally tracked so the status-bearing milestone ladder travels with each checkpoint; other files @@ -67,8 +68,8 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| 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 | +| Ladder position | **L4L-15R active** (v4.33 upstream reconciliation, integration-only); L4L-14, L4L-15A, and L4L-15C are complete and pruned from §5; L4L-15B is queued next with its former upstream-approval gate replaced by the documented-divergence policy (2026-08-11) | +| Current formalization source | the structure-eta staging checkpoint `ae6ee9d6` at `jcb/formalization2` (L4L-15A closure `e8ccc70f`, L4L-15C migration `867675ad`); `origin/jcb/formalization2` is the live publication bookmark and lags the local head | | 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 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 | @@ -337,7 +338,8 @@ The remaining v4.31-added sorry is classified: inductive language remains a growing subset rather than kernel-complete; projection semantics landed at L4L-13A/B and projection structural/checker verification closed at L4L-14/L4L-15A; structure eta and unit-like - comparison remain at the L4L-15B decision gate. `pat_wf` carries + comparison are queued as L4L-15B behind the L4L-15R reconciliation, + proceeding as a documented divergence. `pat_wf` carries the Church–Rosser development's transitional unique-typing closure until L4L-16/17 close it. - The L4L-15C consumer-neutral audit is complete. Generic spine laws, @@ -528,8 +530,9 @@ 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 +the blocked semantics. L4L-15C closed under this exception while L4L-15B +stood at the former structure-eta approval gate. This keeps one auditable +claim per checkpoint and prevents several half-migrated public artifact paths from being live simultaneously. @@ -537,20 +540,60 @@ 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. +### Upstream reconciliation (L4L-15R) + +**L4L-15R — v4.33 upstream reconciliation (active, integration-only).** +lean4-nix landed v4.33 support (2026-08-11), unblocking the deferred +digama0 sync. Merge upstream `master` head `1a16b72d` as an +integration-only checkpoint — first parent this line's head, second +parent the upstream commit, following the v4.31 precedent `7f864b45` — +with no semantic milestone work riding in the merge. + +Scope: + +- Toolchain: bump the Lean and lean4-nix pins to v4.33, drop the + `batteries431CycleFix` override (the fix ships in batteries ≥ v4.32), + run `lake update batteries`, and refresh `flake.lock` + (`nix flake lock --update-input lean4-nix`). +- Banked from the abandoned v4.32-era attempt (recoverable via + `jj op log`, merge `9c326a2a`): only three files overlapped through + upstream `408edad8` — `Verify/TypeChecker/Reduce.lean` (take + upstream's do-elaborator-shaped `reduceNat.WF`, then port our + `Expr.eqv_const` → `Expr.structuralEq_const` rename at the relocated + unary case), `divergences.md` (keep our NormLevel wording, bump the + source link), and `EquivManager.lean` (auto-merges). +- The five upstream commits above the v4.33 bump carry real Verify + overlap and need a fresh conflict survey against the L4L-14/15 work: + front-end declaration checking #28 (`cbb70bc`, `addDecl.WF` + territory, L4L-19B), unsafe/mutual definition blocks (`bd9e576`), + dead `cheapRec` removal (`88cade6` — touches the freshly certified + WHNF/projection-reduction proofs), stdlib level-ops verification #23 + (`1a16b72d` — overlaps our verified level comparator; reconcile, + do not duplicate), and docs/workflow changes. +- Post-merge re-audit: the full §6 gate on v4.33; the exact sorry + frontier with any upstream-added sorries classified into tiers; the + divergence ledger (retire rows upstream absorbed, add rows the merge + creates — including the outstanding rows for the concrete + `TrProj`/`Theory/Projection.lean` API and the executable + `inferProj`/`tryEtaStructCore` changes); the cached-field axiom + classification against the v4.33 implementation; and this file's + lineage/toolchain rows. +*Exit:* the merge checkpoint is green on v4.33 with all §6 gates; the +frontier and ledger are re-audited; no semantic work is mixed into the +merge. + ### 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. +**L4L-15B — structure eta and unit-like comparison (queued; divergence +approved).** Derive `tryEtaStructCore.WF` and `isDefEqUnitLike.WF` on the +reconciled v4.33 base. Adding the structure-eta rule is a metatheory +change; upstream agreement is no longer an implementation blocker — +proceeding as a tracked, documented fork divergence was approved +2026-08-11, with upstream review deferred to the L4L-20C PR series. The 2026-08-11 derivability audit reached that gate. The pinned Lean sources implement eta for nonrecursive, single-constructor, zero-index structures as @@ -583,21 +626,41 @@ registered Theory view; and the sorry-free proof bodies 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 -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. +projection-frontier `sorryAx` dependencies). The unconditional roots and +`VEnv.IsDefEq` remain untouched until the steps below run. + +The decided rule is an explicit registered structure-eta rule, restricted +to checked nonrecursive, single-constructor, zero-index structure views. +The mandatory order of work: + +1. **Design note first.** The exact rule form; subject reduction from the + registered constructor/projector typing package (the rule-independent + half, `etaRebuild_hasType_of_constructorPrefix`, is already proved); + updated injectivity/discrimination arguments; confluence and + standardization critical-pair coverage against beta, iota, proof + irrelevance, and registered extra rules; and a complete inventory of + every exhaustive `IsDefEq` consumer and environment-monotonicity + proof that gains a case arm — including how the Tier R statements + (`parRed`, the inversion family) and the generic `[Params]` + development absorb the rule. +2. **Ledger entry before the rule lands.** Record the divergence in + `upstream-divergence.md`: owner, rule, downstream impact, the + parallel upstream conversation, and the removal condition — upstream + adopts the rule or an agreed alternative by the L4L-20C series, + revisited at every reconciliation checkpoint. If upstream ultimately + declines any Theory change, the recorded fallback is disabling the + two executable heuristics rather than certifying them from an absent + rule. +3. **Implementation.** Add the rule, derive `VEnv.HasStructureEta` for + registered views, let the staged conditional proofs close both + unconditional Tier V roots, and repair every case arm from the + inventory. No existing proved root may regress silently: any proof + that cannot yet absorb its new case is re-sorried into the frontier + with an explicit tier, and this milestone does not close over it. +*Exit:* both roots are sorry-free and audited on the v4.33 base; the +design note and ledger entry are committed with +subject-reduction/injectivity/confluence and downstream-impact evidence; +the `IsDefEq` case inventory shows no silent regression. ### Metatheory closure (L4L-16–L4L-18B) @@ -751,9 +814,9 @@ slice and fixtures; (4) indexed/normalization/small-elimination/ recursive-argument support; (5) mutual and nested support; (6) the pattern package and Verify `AddInduct` alignment; (7) the projection structure view, laws, and checker proofs; (8) injectivity/Church-Rosser completion; (9) the -remaining checker and axiom-minimization work. Do not rewrite the published -`jcb/induct` checkpoints: each PR series is extracted onto a fresh review -branch rebased on its current upstream target. Do not mix the large +remaining checker and axiom-minimization work. Do not rewrite published +`jcb/formalization2` checkpoints: each PR series is extracted onto a fresh +review branch rebased on its current upstream target. Do not mix the large Nix/fork-infrastructure delta into proof PRs unless upstream asks. Record every PR in the divergence ledger. *Exit:* the final release revision is green; every fork delta is upstreamed @@ -803,8 +866,9 @@ Additionally: **Publication.** Publish only after the complete gate passes on one committed checkpoint; never publish a red or semantically split state (for example -midway through an artifact or transaction switch). Only `origin/jcb/induct` -moves; local/remote `master` and every digama/upstream ref stay fixed, and +midway through an artifact or transaction switch). Only +`origin/jcb/formalization2` moves; local/remote `master` and every +digama/upstream ref move only at explicit reconciliation checkpoints, and remote-ref verification is part of each publication. Keep published checkpoints recoverable, and refresh the divergence ledger and sorry-frontier wording with each checkpoint. @@ -824,9 +888,11 @@ assume an oracle or axiom. ## 7. Principal risks and decision points -- **Checkpoint drift.** The published `jcb/induct` line is ahead of `master`. - Keep published checkpoints recoverable, require Linux/Darwin CI builds at - release boundaries, and record any replacement hash here. +- **Checkpoint drift.** The `jcb/formalization2` line is ahead of `master`, + and the local head runs ahead of `origin/jcb/formalization2` between + publications. Keep published checkpoints recoverable, require + Linux/Darwin CI builds at release boundaries, and record any replacement + hash here. - **A subset masquerading as the spec.** A sorry-free `stageN` definition can still be incomplete. Final acceptance is kernel coverage plus negative agreement, not the absence of sorries. @@ -846,9 +912,11 @@ 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. -- **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. +- **Structure eta changes Theory as a tracked divergence.** The new defeq + constructor affects injectivity, confluence, standardization, and + downstream consumers. The design note and ledger entry come first + (decision 2026-08-11); upstream review moves to the L4L-20C PR series, + and every reconciliation checkpoint revisits the divergence. - **Pattern-interface mismatch.** The upstream `Params` fields (`extra_pat`'s syntactic match, `pat_wf`'s bare-`HasType` premise) cannot be satisfied by tower-registered environments, including From e29c85839fe14f169e0f0f8f82744d4f3d766fb3 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Tue, 11 Aug 2026 18:12:10 -0400 Subject: [PATCH 48/51] docs: record v4.33 reconciliation publication origin/jcb/formalization2 was pushed to the L4L-15R merge checkpoint 99a7f8ae; the roadmap's publication wording follows. --- plans/roadmap.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plans/roadmap.md b/plans/roadmap.md index 58a38368..3f7854f3 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -69,7 +69,7 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| | Ladder position | **L4L-15B active** (structure eta and unit-like comparison, proceeding as a documented divergence); the L4L-15R v4.33 reconciliation is complete and pruned from §5 (2026-08-11) | -| Current formalization source | this v4.33 reconciliation merge checkpoint (jj change `zxwpwkpp`) at `jcb/formalization2` (first parent the L4L-15R planning commit `c22d790d` atop the structure-eta staging checkpoint `ae6ee9d6`); `origin/jcb/formalization2` is the live publication bookmark and lags the local head | +| Current formalization source | this v4.33 reconciliation merge checkpoint (jj change `zxwpwkpp`) at `jcb/formalization2` (first parent the L4L-15R planning commit `c22d790d` atop the structure-eta staging checkpoint `ae6ee9d6`); `origin/jcb/formalization2` is the live publication bookmark and was published at this checkpoint (2026-08-11) | | Parent lineage | this upstream-reconciliation merge (second parent: digama `upstream/master` `b292275c`, which superseded the planned `1a16b72d` before execution); Lean on v4.33.0 final, lean4-nix on `argumentcomputer/lean4-nix` (upstream pins v4.33.0-rc2 — ledger D018) | | Fixed `master` baseline | `1fb7d6ef9042c5a80b2de9320c88ac0f3ce404cb` | | Trust frontier | exactly 18 sorried proof declarations (12 Tier V, 6 Tier R; `NormalEq.parRed` carries two tokens) plus six kernel-rejection recovery declarations — 24 compiled allowlist entries — and 34 custom-axiom declarations; all are pinned by exact audits. Eight Tier V entries are new at this checkpoint: upstream's `checkPrimitiveDef.WF` boundary, the six D017 front-end/`ProjectionReady`-transport and quotient-initialization entries, and the `aliasFormerAlignmentRun` fixture repair debt | From 01bfdce9191d1f4bb7e3784e0fefc331800b5a8d Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Tue, 11 Aug 2026 18:24:34 -0400 Subject: [PATCH 49/51] docs: approve registered structure eta divergence --- .gitignore | 1 + plans/l4l-15-structure-eta-design.md | 218 +++++++++++++++++++++++++++ plans/roadmap.md | 3 + upstream-divergence.md | 36 +++++ 4 files changed, 258 insertions(+) create mode 100644 plans/l4l-15-structure-eta-design.md diff --git a/.gitignore b/.gitignore index a27c2eff..4a9d98a4 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,4 @@ # Keep scratch plans local while versioning the authoritative execution ladder. /plans/* !/plans/roadmap.md +!/plans/l4l-15-structure-eta-design.md diff --git a/plans/l4l-15-structure-eta-design.md b/plans/l4l-15-structure-eta-design.md new file mode 100644 index 00000000..6f5f9209 --- /dev/null +++ b/plans/l4l-15-structure-eta-design.md @@ -0,0 +1,218 @@ +# L4L-15B registered structure-eta design + +Date: 2026-08-11 + +Status: approved fork divergence; implementation target is the reconciled +v4.33 base at merge checkpoint `99a7f8ae7b89`. Upstream review is deferred to +the L4L-20C PR series. This note is the mandatory pre-implementation design +record for ledger entry D019. + +## Scope and kernel behavior + +Lean gives eta conversion to nonrecursive, single-constructor inductives with +no indices. For a checked structure family `S`, constructor `C`, parameters +`ps`, canonical generated projectors `proj_i`, and a well-typed major `e`, the +new Theory step is the contraction + +```text +C ps (proj_0 e) ... (proj_n e) ≡ e : S ps. +``` + +The zero-field case is the same rule with an empty projector list. Prop-valued +structures remain convertible by proof irrelevance as well; using one +eligibility artifact for Prop and Type keeps host metadata alignment uniform. + +The previous derivability audit is unchanged by the v4.33 reconciliation. +Recursor iota rules reduce a projector only on a constructor-headed major, +function eta applies only at Pi types, and proof irrelevance covers only Prop. +Consequently the neutral reconstruction equation above is not derivable from +the existing `VEnv.IsDefEq` constructors. + +## Lower-layer descriptor and registry + +`VStructEta` lives below `Typing.Basic`. It contains only Theory syntax and +the syntactic stability laws needed by generic equality transport: + +```text +structure VStructEta where + uvars : Nat + nparams : Nat + nfields : Nat + familyName : Name + familyType : VExpr + constructorName : Name + projectors : List VLevel -> List VExpr -> List VExpr + + projectors_length : levels.length = uvars -> + params.length = nparams -> + (projectors levels params).length = nfields + projectors_liftN : ... + projectors_instN : ... + projectors_instL : ... +``` + +The omitted equations are literal naturality equations: mapping `liftN`, term +substitution, or universe instantiation over a projector list equals asking +the descriptor for the correspondingly transformed levels and parameters. +They are equations about syntax, not semantic equality assumptions. + +The descriptor defines, rather than stores as caller-selected callbacks: + +```text +structureType levels params = const familyName levels |>.appN params +rebuild levels params major = + const constructorName levels |>.appN + (params ++ (projectors levels params).map (.app . major)) +``` + +`VEnv` gains a monotone `structEtas : VStructEta -> Prop` registry and an +`addStructEta` extension operation. `empty` registers none; `addConst` and +`addDefEq` preserve registrations; `VEnv.LE` transports them. `Ordered` gains +one constructor whose premise is `VStructEta.WF env`, and +`Ordered.structEtaWF` recovers that certificate for every registered +descriptor. + +`VStructEta.WF env` is the subject-reduction package. Given a well-formed +context, well-formed universe arguments of the exact length, an exact family +parameter `SpineWF`, and `major : structureType levels params`, its +`rebuild_hasType` field produces the same type for `rebuild levels params +major`. This package contains no equality premise. + +`VStructureView.toStructEta` is the only checked generation bridge used by +the verifier. It sets `projectors` to the deterministic +`VStructureView.projectionCodes` projector list. Its naturality laws are the +existing `projectionCodes_liftN`, `projectionCodes_instN`, and +`projectionCodes_instL` theorems; its subject-reduction proof is +`ProgramsWF.etaRebuild_hasType_of_constructorPrefix` plus the registered +constructor telescope. A `ProjectionArtifact` records membership of this +exact descriptor, so host readiness cannot substitute arbitrary projector +syntax. + +## Equality rule + +The new constructor in `VEnv.IsDefEq` has the following exact logical shape +(notation abbreviated): + +```text +IsDefEq.structEta + (registered : env.structEtas rule) + (levelsWF : every level in levels is WF at U) + (levelsLength : levels.length = rule.uvars) + (paramsLength : params.length = rule.nparams) + (paramsSpine : familyType.instL levels consumes params to a sort) + (majorTyped : Gamma |- major : rule.structureType levels params) + (rebuildTyped : Gamma |- rule.rebuild levels params major : + rule.structureType levels params) + : Gamma |- rule.rebuild levels params major == major : + rule.structureType levels params +``` + +Both endpoint typings are deliberately constructor premises. Thus +`IsDefEq.hasType` and `IsDefEq.isType'` remain structural for arbitrary +environments; `Ordered.structEtaWF` supplies `rebuildTyped` at registered +call sites rather than becoming a hidden equality oracle. The parameter spine +and exact lengths make the primitive unavailable on partial applications. + +Weakening and term/universe substitution rebuild the same constructor with +the descriptor naturality equations. Context-defeq transport preserves the +syntax and transports the two typing premises. Environment monotonicity uses +the new `VEnv.LE.structEtas` component. + +## Strong typing, inversion, and discrimination + +`IsDefEqStrong` gains the same registered step with strong certificates for +the common structure type and both endpoints. The weak-to-strong translation +obtains these from the recursive typing premises; strong-to-weak erases them. +The `HasTypeStrong` inversion family sees the new case only through those +endpoint certificates. + +Sort/Pi/constant-head discrimination does not discard the case by syntactic +pattern matching. If the arbitrary major has the queried head, its explicit +typing is compared with the registered `const familyName ... |>.appN params` +type via the existing strong unique-typing/inversion path. The reconstruction +endpoint is constructor-headed. This keeps the existing L4L-16/L4L-17 +frontier visible rather than embedding injectivity in the descriptor. + +## Confluence and standardization + +Structure eta is represented in `NormalEq` by left and right reconstruction +forms, analogously to function eta. The congruence payload relates the major +terms and every parameter/projector occurrence at one registered descriptor. +The descriptor naturality laws provide weakening and substitution directly. + +The parallel-reduction compatibility proof must cover these cases explicitly: + +1. constructor major versus generated projector iota; +2. nested reconstruction, contracting either layer first; +3. beta/delta/iota reduction inside the major and its repeated projector + occurrences; +4. dependent later projector types after an earlier projection changes; +5. proof fields and Prop-valued structures; and +6. overlap with a registered `.extra` rule under the generic `[Params]` + pattern interface. + +No new `sorry`, axiom, or final-result field is added to `Params`. The generic +development may gain primitive descriptor coverage/disjointness premises, +but the actual triangle/join statements remain proved theorems. The concrete +checked-view bridge must discharge those premises from constructor-headed +syntax and the deterministic projector programs. + +`WHRed` does not contract structure eta: as in Lean's equality procedure it +is a conversion rule, not weak-head computation. Head standardization gains +only the cases needed to transport the enlarged `NormalEq` relation. + +## Exhaustive consumer inventory + +Before the rule lands, the direct constructor-aligned source inventory is: + +| File | Direct aligned sites | Required work | +|---|---:|---| +| `Typing/Basic.lean` | 1 | rule and subject-reduction-facing aliases | +| `Typing/Lemmas.lean` | 9 | closure, levels, mono, weak/inst/context transport | +| `Typing/Strong.lean` | 12 | strong relation, translations, inversion | +| `Typing/NestedTransport.lean` | 1 | nested environment transport | +| `Typing/ChurchRosser.lean` | 26 | `NormalEq`, parallel joins, CR translation | +| `Typing/HeadReduction.lean` | 12 | standardization interaction | + +The compiler-driven audit also covers dependent consumers in +`UniqueTyping`, `Injectivity`, `InductiveLemmas`, `Projection`, and Verify. +Every failed exhaustive match after adding the constructor is treated as an +inventory defect, not silenced with a wildcard. + +Environment-schema consumers are `VEnv`, `Typing.Lemmas` (`Ordered`), +`Typing.Env`/`EnvLemmas`, Verify's `TrEnv'`/`VEnvAt` construction, and the few +explicit `VEnv.LE` records in Verify environment extension proofs. + +## Checker closure and fixtures + +`ProjectionArtifact` and `ProjectionReady` retain the exact registered eta +descriptor for any host family/constructor accepted by +`isNonRecStructure`. This supplies both `StructureEtaReady` and descriptor +membership. `VEnv.HasStructureEta` is then a theorem derived from +`IsDefEq.structEta`, not a new assumption. The already proved +`tryEtaStructCore.WF_of_structureEta` and +`isDefEqUnitLike.WF_of_structureEta` become the bodies of the unconditional +roots. + +Focused executable/Theory fixtures cover: + +- a dependent parameterized structure and neutral major; +- a parameterized zero-field structure; +- a proof field; +- a Prop-valued one-constructor inductive; and +- recursive, multi-constructor, and indexed negative cases. + +Exact `#print axioms` guards cover descriptor registration, +`VStructEta.WF.rebuild_hasType`, the primitive equality step, its +Church--Rosser translation, and both checker roots. The L4L-15B checkpoint may +inherit already classified frontier dependencies, but its source diff adds +no `sorry` and the compiled frontier may not grow. + +## Removal and upstream path + +D019 is revisited at every upstream reconciliation. It is removed when +upstream adopts this registered primitive or an agreed equivalent and the +fork migrates. If upstream ultimately rejects any Theory representation of +structure eta, the recorded fallback is to disable `tryEtaStruct` and +`isDefEqUnitLike`; certifying the current runtime against a weaker relation is +not an option. diff --git a/plans/roadmap.md b/plans/roadmap.md index 3f7854f3..4a1b8503 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -602,6 +602,8 @@ The mandatory order of work: proof that gains a case arm — including how the Tier R statements (`parRed`, the inversion family) and the generic `[Params]` development absorb the rule. + The committed design record is + `plans/l4l-15-structure-eta-design.md`. 2. **Ledger entry before the rule lands.** Record the divergence in `upstream-divergence.md`: owner, rule, downstream impact, the parallel upstream conversation, and the removal condition — upstream @@ -610,6 +612,7 @@ The mandatory order of work: declines any Theory change, the recorded fallback is disabling the two executable heuristics rather than certifying them from an absent rule. + This is ledger entry D019. 3. **Implementation.** Add the rule, derive `VEnv.HasStructureEta` for registered views, let the staged conditional proofs close both unconditional Tier V roots, and repair every case arm from the diff --git a/upstream-divergence.md b/upstream-divergence.md index 8d824bf8..8429ac55 100644 --- a/upstream-divergence.md +++ b/upstream-divergence.md @@ -1096,6 +1096,42 @@ to the replacement. - **Removal condition:** upstream bumps to the final release (expected imminently); no code delta is attached to this row. +## D019 — registered structure eta in Theory + +- **Status:** approved intentional fork divergence; L4L-15B implementation + in progress on the reconciled v4.33 base. +- **Owner:** John C. Burnham; semantic review is part of the L4L-20C PR + series. +- **Delta:** extend Theory with an explicit environment-registered + structure-eta descriptor and a typed `VEnv.IsDefEq.structEta` rule for the + same nonrecursive, single-constructor, zero-index structures accepted by + Lean's kernel. The descriptor fixes the family and constructor heads and + the deterministic recursor-encoded projector list, and carries syntactic + lift/substitution laws. Registration is monotone and ordered; the equality + constructor retains an exact family parameter spine and both endpoint + typings. The complete design and case inventory are recorded in + `plans/l4l-15-structure-eta-design.md`. +- **Downstream impact:** every exhaustive `IsDefEq` consumer gains a case, + including strong typing/inversion, weakening and substitution, environment + monotonicity, Church--Rosser/parallel reduction, head standardization, + nested transport, and the Verify structure-artifact bridge. Downstream + Theory consumers see an additive descriptor/registry API and one additional + definitional-equality constructor. +- **Tests:** dependent parameterized, zero-field parameterized, proof-field, + and Prop-valued positive fixtures; recursive, multi-constructor, and indexed + negative fixtures; exact axiom guards for registration, subject reduction, + Church--Rosser, `tryEtaStructCore.WF`, and `isDefEqUnitLike.WF`; full sorry + frontier and release gate. +- **Axiom note:** no new project axiom or source `sorry` is permitted. Existing + L4L-16--L4L-18 frontier dependencies remain explicit in per-root manifests. +- **Parallel upstream conversation:** implementation is intentionally allowed + to proceed in the fork as of 2026-08-11; upstream review is deferred to the + L4L-20C proof-PR sequence. Record the issue/PR URL here when opened. +- **Removal condition:** upstream adopts the registered rule or an agreed + equivalent and the fork migrates. If upstream rejects a Theory eta rule, + disable the two executable structure-eta heuristics and remove this + divergence rather than retaining an unsound verifier claim. + ## Review checklist At each publish or ix pin boundary: From 7c1e89fc53fb32305ec46aec534b0c9d6c0f8028 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Tue, 11 Aug 2026 18:47:48 -0400 Subject: [PATCH 50/51] feat: verify registered structure eta --- Lean4Lean/Audit/SorryFrontier.lean | 13 +- Lean4Lean/Tests/ProjectionExpressibility.lean | 24 +- Lean4Lean/Tests/StructureEtaCapability.lean | 113 +++- Lean4Lean/Theory/Inductive.lean | 14 - Lean4Lean/Theory/InductiveFixtures.lean | 47 +- Lean4Lean/Theory/Projection.lean | 102 +++- Lean4Lean/Theory/Typing/Basic.lean | 57 ++ Lean4Lean/Theory/Typing/ChurchRosser.lean | 552 +++++++++++++++++- Lean4Lean/Theory/Typing/Env.lean | 6 + Lean4Lean/Theory/Typing/EnvLemmas.lean | 39 +- Lean4Lean/Theory/Typing/HeadReduction.lean | 2 + Lean4Lean/Theory/Typing/InductiveLemmas.lean | 137 ++--- .../Theory/Typing/InductivePatternWF.lean | 23 +- Lean4Lean/Theory/Typing/Lemmas.lean | 216 ++++++- Lean4Lean/Theory/Typing/NestedTransport.lean | 36 +- Lean4Lean/Theory/Typing/Strong.lean | 101 +++- Lean4Lean/Theory/Typing/UniqueTyping.lean | 26 +- Lean4Lean/Theory/VEnv.lean | 166 +++++- Lean4Lean/Theory/VExpr.lean | 27 + Lean4Lean/Verify/Environment/Basic.lean | 11 + .../Environment/ConstructorValidation.lean | 4 +- .../ConstructorValidityReplay.lean | 14 + .../Verify/Environment/DeepNestedReplay.lean | 5 +- Lean4Lean/Verify/Environment/Extension.lean | 54 +- .../Environment/IndexedVecSemanticReplay.lean | 56 ++ .../Verify/Environment/InductiveFixtures.lean | 80 ++- Lean4Lean/Verify/Environment/Lemmas.lean | 12 + .../Environment/MutualInductiveFixtures.lean | 69 +-- .../Verify/Environment/Normalization.lean | 3 + .../Environment/SingletonParityReplay.lean | 31 +- Lean4Lean/Verify/TypeChecker.lean | 4 + Lean4Lean/Verify/TypeChecker/Basic.lean | 57 ++ Lean4Lean/Verify/TypeChecker/InferType.lean | 9 +- Lean4Lean/Verify/TypeChecker/IsDefEq.lean | 28 +- plans/roadmap.md | 125 +--- upstream-divergence.md | 36 +- 36 files changed, 1820 insertions(+), 479 deletions(-) diff --git a/Lean4Lean/Audit/SorryFrontier.lean b/Lean4Lean/Audit/SorryFrontier.lean index d8ccc12d..2d2806c1 100644 --- a/Lean4Lean/Audit/SorryFrontier.lean +++ b/Lean4Lean/Audit/SorryFrontier.lean @@ -145,11 +145,12 @@ private def allowlist : Array Lean.Name := #[ -- recognizer (Verify/Environment/Boundaries.lean), added by #28 at the -- v4.33 reconciliation. `Lean4Lean.checkPrimitiveDef.WF, - -- `ProjectionReady` transport across the front-end environment extensions - -- (Verify/Environment/Extension.lean): upstream's proved v4.33 declaration - -- chains meet this fork's projection-readiness obligation on `VContext`; - -- the transport proofs are L4L-19B content. The mutual-block entry is the - -- compiled recursive functional of `VEnvAt.addAxioms`. + -- `ProjectionReady`/registered `StructureEtaReady` transport across the + -- front-end environment extensions (Verify/Environment/Extension.lean): + -- upstream's proved v4.33 declaration chains do not establish these fork + -- obligations on `VContext`; the transport proofs are L4L-19B content. The + -- mutual-block entry is the compiled recursive functional of + -- `VEnvAt.addAxioms`. `Lean4Lean.VEnvAt.addAxioms._f, `Lean4Lean.addConstCore.WF, `Lean4Lean.addDef.WF, @@ -165,8 +166,6 @@ private def allowlist : Array Lean.Name := #[ -- statement is unchanged (Verify/Environment/InductiveFixtures.lean). `Lean4Lean.InductiveReplayFixtures.aliasFormerAlignmentRun, `Lean4Lean.TypeChecker.Inner.reduceRecursor.WF, - `Lean4Lean.TypeChecker.Inner.tryEtaStructCore.WF, - `Lean4Lean.TypeChecker.Inner.isDefEqUnitLike.WF, -- Tier R — research-grade metatheory (upstream-driven, not scheduled) `Lean4Lean.VEnv.IsDefEqU.sort_inv, `Lean4Lean.VEnv.IsDefEqU.forallE_inv_stratified, diff --git a/Lean4Lean/Tests/ProjectionExpressibility.lean b/Lean4Lean/Tests/ProjectionExpressibility.lean index c7204099..57320417 100644 --- a/Lean4Lean/Tests/ProjectionExpressibility.lean +++ b/Lean4Lean/Tests/ProjectionExpressibility.lean @@ -93,7 +93,7 @@ theorem dependentRecordDecl_wf : VInductDecl.recFieldIdxs, VInductDecl.sortLevel, VExpr.dropN, VExpr.resultOf, VExpr.forallN, VExpr.liftTelN, VExpr.appArgs] - rfl + exact .nil theorem dependentRecordGeneration_wf : dependentRecordGeneration.WF VEnv.empty := @@ -249,8 +249,8 @@ theorem symbolicParams_spine : (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⟩ + .cons (by type_tac) ?_⟩ + exact .cons (by type_tac) .nil theorem symbolicMajor_hasType : dependentRecordEnv.HasType 2 symbolicContext symbolicMajor @@ -333,8 +333,8 @@ theorem symbolicMajorBinder_isType : dependentRecordEnv.IsType 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⟩ + refine .cons (by type_tac) ?_ + exact .cons (by type_tac) .nil have hfamily := VEnv.HasType.const (Γ := [symbolicFamilyType, symbolicAlphaType]) dependentRecord_view_wf.family symbolicLevels_wf (by rfl) @@ -408,9 +408,9 @@ theorem symbolicKeyRule_spine : symbolicKeyRuleArgs symbolicKeyRuleResult := by rw [symbolicKeyRuleType_eq] unfold symbolicKeyRuleArgs symbolicKeyRuleResult - refine ⟨_, _, rfl, by type_tac, ?_⟩ - refine ⟨_, _, rfl, by type_tac, ?_⟩ - refine ⟨_, _, rfl, ?_, ?_⟩ + refine .cons (by type_tac) ?_ + refine .cons (by type_tac) ?_ + refine .cons ?_ ?_ · have hMotiveShape : symbolicKeyMotive = .lam ((dependentRecordView.structureType symbolicLevels @@ -424,7 +424,7 @@ theorem symbolicKeyRule_spine : dependentRecordView.structureType symbolicLevels symbolicMajorParams]) exact VEnv.HasType.lam (u := structureLevel) hstructure (by type_tac) - · refine ⟨_, _, rfl, ?_, ?_⟩ + · refine .cons ?_ ?_ · change dependentRecordEnv.HasType 2 symbolicFieldContext symbolicKeyMinor (.forallE (.bvar 5) @@ -502,8 +502,8 @@ theorem symbolicKeyRule_spine : (.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⟩ + · refine .cons (by type_tac) ?_ + exact .cons (by type_tac) .nil def symbolicKeyRuleBinders : List VExpr := takeLamDomains 6 (symbolicKeyRule.lhs.instL symbolicKeyRuleLevels) @@ -1233,7 +1233,7 @@ theorem emptyRecordDecl_wf : emptyRecordDecl.WF VEnv.empty := by VInductDecl.ctorFields, VInductDecl.recFieldIdxs, VInductDecl.sortLevel, VExpr.dropN, VExpr.resultOf, VExpr.forallN, VExpr.liftTelN, VExpr.appArgs] - rfl + exact .nil theorem emptyRecordGeneration_wf : emptyRecordGeneration.WF VEnv.empty := diff --git a/Lean4Lean/Tests/StructureEtaCapability.lean b/Lean4Lean/Tests/StructureEtaCapability.lean index 3a46d994..9f1047f1 100644 --- a/Lean4Lean/Tests/StructureEtaCapability.lean +++ b/Lean4Lean/Tests/StructureEtaCapability.lean @@ -1,23 +1,94 @@ import Lean4Lean.Verify.TypeChecker.IsDefEq +import Lean4Lean.Theory.Typing.ChurchRosser /-! -# Conditional structure-eta checker surface +# Registered 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. +These guards pin the complete registered bridge. Host metadata resolves to +the exact checked-view descriptor, subject reduction comes from its ordered +registry certificate, and the primitive Theory rule closes both executable +checker roots. -/ namespace Lean4Lean.Tests.StructureEtaCapability open Lean4Lean.TypeChecker.Inner +/-! ## Kernel eligibility and conversion matrix -/ + +namespace Fixtures + +open Lean Elab Command + +elab "#guard_eta_eligible " n:ident : command => do + let env ← getEnv + unless Kernel.Environment.isNonRecStructure env.toKernelEnv n.getId do + throwError "expected {n.getId} to be structure-eta eligible" + +elab "#guard_eta_ineligible " n:ident : command => do + let env ← getEnv + if Kernel.Environment.isNonRecStructure env.toKernelEnv n.getId then + throwError "expected {n.getId} not to be structure-eta eligible" + +universe u v + +/-- Parameterized, dependent fields exercise the ordered projector spine. -/ +structure EtaDependent (α : Type u) (family : α → Type v) where + key : α + value : family key + +/-- The unit-like path is the empty projector-spine specialization. -/ +structure EtaEmpty (α : Type u) where + +/-- A proof field in a Type-valued structure remains eta eligible. -/ +structure EtaProofField (p : Prop) where + witness : p + +/-- Prop-valued structures share the same eligibility path. -/ +structure EtaProp (p : Prop) : Prop where + witness : p + +inductive EtaRecursive : Type where + | mk (tail : Option EtaRecursive) + +inductive EtaMulti : Type where + | left + | right + +inductive EtaIndexed : Bool → Type where + | mk : EtaIndexed true + +#guard_eta_eligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaDependent +#guard_eta_eligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaEmpty +#guard_eta_eligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaProofField +#guard_eta_eligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaProp +#guard_eta_ineligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaRecursive +#guard_eta_ineligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaMulti +#guard_eta_ineligible Lean4Lean.Tests.StructureEtaCapability.Fixtures.EtaIndexed + +/-- Neutral-major reconstruction is kernel conversion, including dependence. -/ +example (x : EtaDependent α family) : + EtaDependent.mk x.key x.value = x := rfl + +example (x : EtaEmpty α) : EtaEmpty.mk = x := rfl + +example (x : EtaProofField p) : EtaProofField.mk x.witness = x := rfl + +example (x : EtaProp p) : EtaProp.mk x.witness = x := rfl + +end Fixtures + #check VEnv.HasStructureEta +#check VEnv.hasStructureEta_of_registry +#check VStructEta.WF.rebuild_hasType +#check VEnv.IsDefEq.structEta +#check VEnv.IsDefEq.church_rosser #check StructureEtaArtifact #check StructureEtaReady #check tryEtaStructCore.WF_of_structureEta #check isDefEqUnitLike.WF_of_structureEta +#check tryEtaStructCore.WF +#check isDefEqUnitLike.WF /-- info: 'Lean4Lean.VEnv.HasStructureEta' depends on axioms: [propext, Quot.sound] @@ -26,7 +97,31 @@ info: 'Lean4Lean.VEnv.HasStructureEta' depends on axioms: [propext, Quot.sound] #print axioms VEnv.HasStructureEta /-- -info: 'Lean4Lean.TypeChecker.Inner.tryEtaStructCore.WF_of_structureEta' depends on axioms: [propext, +info: 'Lean4Lean.VEnv.hasStructureEta_of_registry' depends on axioms: [propext, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.hasStructureEta_of_registry + +/-- +info: 'Lean4Lean.VStructEta.WF.rebuild_hasType' depends on axioms: [propext] +-/ +#guard_msgs in +#print axioms VStructEta.WF.rebuild_hasType + +/-- +info: 'Lean4Lean.VEnv.IsDefEq.structEta' depends on axioms: [propext] +-/ +#guard_msgs in +#print axioms VEnv.IsDefEq.structEta + +/-- +info: 'Lean4Lean.VEnv.IsDefEq.church_rosser' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound] +-/ +#guard_msgs in +#print axioms VEnv.IsDefEq.church_rosser + +/-- +info: 'Lean4Lean.TypeChecker.Inner.tryEtaStructCore.WF' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound, @@ -38,10 +133,10 @@ info: 'Lean4Lean.TypeChecker.Inner.tryEtaStructCore.WF_of_structureEta' depends Lean.PersistentHashMap.WF.toList'_insert] -/ #guard_msgs in -#print axioms tryEtaStructCore.WF_of_structureEta +#print axioms tryEtaStructCore.WF /-- -info: 'Lean4Lean.TypeChecker.Inner.isDefEqUnitLike.WF_of_structureEta' depends on axioms: [propext, +info: 'Lean4Lean.TypeChecker.Inner.isDefEqUnitLike.WF' depends on axioms: [propext, sorryAx, Classical.choice, Quot.sound, @@ -50,6 +145,6 @@ info: 'Lean4Lean.TypeChecker.Inner.isDefEqUnitLike.WF_of_structureEta' depends o Lean.PersistentHashMap.WF.toList'_insert] -/ #guard_msgs in -#print axioms isDefEqUnitLike.WF_of_structureEta +#print axioms isDefEqUnitLike.WF end Lean4Lean.Tests.StructureEtaCapability diff --git a/Lean4Lean/Theory/Inductive.lean b/Lean4Lean/Theory/Inductive.lean index 97337409..24f876e0 100644 --- a/Lean4Lean/Theory/Inductive.lean +++ b/Lean4Lean/Theory/Inductive.lean @@ -41,10 +41,6 @@ preserves the constants occurring in a Theory expression. -/ induction expression generalizing lift <;> simp [VExpr.hasConst, *] -def VExpr.appN (f : VExpr) : List VExpr → VExpr - | [] => f - | a :: as => (f.app a).appN as - /-- `[.bvar (off+m-1), ..., .bvar off]`: the spine referring to the last `m` binders, skipping the innermost `off`. -/ def VExpr.bvarRevRange (off : Nat) : Nat → List VExpr @@ -117,16 +113,6 @@ def VEnv.TelDefEq (env : VEnv) (U : Nat) : TelDefEq env U (A :: Γ) As As' | _, _, _ => False -/-- Typing of an application spine against an iterated pi type: peeling the -expressions of `es` off `A` one instantiation at a time ends at `B`. This is -the pointwise typing evidence for index spines; `addInduct_WF` consumes it -wherever a recursive field or a constructor result applies the block to -index arguments. -/ -def VEnv.SpineWF (env : VEnv) (U : Nat) (Γ : List VExpr) : VExpr → List VExpr → VExpr → Prop - | A, [], B => A = B - | A, e :: es, B => ∃ A₁ A₂, A = .forallE A₁ A₂ ∧ env.HasType U Γ e A₁ ∧ - SpineWF env U Γ (A₂.inst e) es B - namespace VInductDecl variable (U : Nat) (T : Name) (np : Nat) diff --git a/Lean4Lean/Theory/InductiveFixtures.lean b/Lean4Lean/Theory/InductiveFixtures.lean index caccb3ba..5e07b842 100644 --- a/Lean4Lean/Theory/InductiveFixtures.lean +++ b/Lean4Lean/Theory/InductiveFixtures.lean @@ -186,8 +186,7 @@ theorem punitDecl_wf : punitDecl.WF VEnv.empty := by constructor · change True trivial - · change VExpr.sort (.param 0) = VExpr.sort (.param 0) - rfl + · exact .nil def punitEnv : VEnv := (VEnv.empty.addInduct punitDecl).get (by decide) @@ -626,7 +625,7 @@ theorem accDecl_wf : accDecl.WF VEnv.empty := by (.forallE (.bvar 4) (.sort .zero)) [.bvar 1] (.sort .zero) constructor · exact ⟨⟨_, by type_tac⟩, ⟨⟨_, by type_tac⟩, trivial⟩⟩ - · exact ⟨_, _, rfl, by type_tac, rfl⟩ + · exact .cons (by type_tac) .nil · intro h change false = true at h contradiction @@ -639,7 +638,7 @@ theorem accDecl_wf : accDecl.WF VEnv.empty := by .forallE (.bvar 0) (.forallE (.bvar 1) (.sort .zero)), .sort (.param 0)] (.forallE (.bvar 3) (.sort .zero)) [.bvar 1] (.sort .zero) - exact ⟨_, _, rfl, by type_tac, rfl⟩ + exact .cons (by type_tac) .nil /-- The concrete public Acc transaction preserves environment order. -/ def accEnv : VEnv := (VEnv.empty.addInduct accDecl).get (by decide) @@ -792,14 +791,14 @@ theorem annotatedPiViewDecl_wf : annotatedPiViewDecl.WF VEnv.empty := by refine ⟨annotatedPiRecArg, ?_, ?_, ?_⟩ · rfl · simp [annotatedPiRecArg] - · exact ⟨⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩, rfl⟩ + · exact ⟨⟨⟨_, VEnv.HasType.sort (by decide)⟩, trivial⟩, .nil⟩ · intro h change false = true at h contradiction · change VEnv.empty.SpineWF 0 [.forallE (.sort .zero) (.const ``AnnotatedPi [])] (.sort (.succ .zero)) [] (.sort (.succ .zero)) - rfl + exact .nil theorem annotatedPiViewChecked_wf : annotatedPiViewChecked.WF outParamEnv := by @@ -933,7 +932,7 @@ theorem annotatedParamViewDecl_wf : List.mem_singleton.1 (by simpa [annotatedParamViewType] using hc) subst c - exact ⟨trivial, rfl⟩ + exact ⟨trivial, .nil⟩ /-- Exact Theory environment after staging the stored family constant. -/ def annotatedParamTypeEnv : VEnv := @@ -1210,7 +1209,7 @@ theorem aliasFormerViewDecl_wf : List.mem_singleton.1 (by simpa [aliasFormerViewType, aliasFormerRawType] using hc) subst c - exact ⟨trivial, rfl⟩ + exact ⟨trivial, .nil⟩ /-- The paired block carries both the semantic normalization certificate and the checked normalized view required by downstream generation. -/ @@ -1567,8 +1566,8 @@ theorem aliasRecViewDecl_wf : aliasRecViewDecl.WF recAliasEnv := by have hc' : c = aliasRecViewCtor := List.mem_singleton.1 (by simpa [aliasRecViewType] using hc) subst c - refine ⟨?_, rfl⟩ - exact ⟨.inl rfl, fun _ => rfl, trivial⟩ + refine ⟨?_, .nil⟩ + exact ⟨.inl rfl, fun _ => .nil, trivial⟩ /-- Recursive-field recognition is certified on the normalized view while the paired block continues to retain the raw aliased constructor syntax. -/ @@ -2348,33 +2347,33 @@ theorem normalizationMatrixViewChecked_wf : · refine ⟨?_, ?_, ?_⟩ · exact .inl rfl · intro _ - exact ⟨_, _, rfl, - normalizationMatrixIndexAlias_app_hasType .rfl - (by type_tac), rfl⟩ + exact .cons + (normalizationMatrixIndexAlias_app_hasType .rfl + (by type_tac)) .nil · refine ⟨?_, ?_, ?_⟩ · refine .inr (.inl ⟨_, rfl, by decide, ?_⟩) constructor · exact ⟨⟨_, by type_tac⟩, trivial⟩ - · exact ⟨_, _, rfl, - normalizationMatrixIndexAlias_app_hasType .rfl - (by type_tac), rfl⟩ + · exact .cons + (normalizationMatrixIndexAlias_app_hasType .rfl + (by type_tac)) .nil · intro h change false = true at h contradiction · refine ⟨?_, ?_, ?_⟩ · exact .inl rfl · intro _ - exact ⟨_, _, rfl, - normalizationMatrixIndexAlias_app_hasType .rfl - (by type_tac), rfl⟩ + exact .cons + (normalizationMatrixIndexAlias_app_hasType .rfl + (by type_tac)) .nil · refine ⟨?_, ?_, trivial⟩ · exact .inl rfl · intro _ - exact ⟨_, _, rfl, - normalizationMatrixIndexAlias_app_hasType .rfl - (by type_tac), rfl⟩ - · exact ⟨_, _, rfl, - normalizationMatrixIndexAlias_app_hasType .rfl (by type_tac), rfl⟩ + exact .cons + (normalizationMatrixIndexAlias_app_hasType .rfl + (by type_tac)) .nil + · exact .cons + (normalizationMatrixIndexAlias_app_hasType .rfl (by type_tac)) .nil theorem normalizationMatrixBlock_wf : normalizationMatrixBlock.WF normalizationMatrixAliasEnv := diff --git a/Lean4Lean/Theory/Projection.lean b/Lean4Lean/Theory/Projection.lean index d29a4c1a..771d9e85 100644 --- a/Lean4Lean/Theory/Projection.lean +++ b/Lean4Lean/Theory/Projection.lean @@ -629,13 +629,7 @@ private theorem VEnv.OnSortTel.instRevParams {env : VEnv} 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 + .cons harg hrest, hlen, hfields => by have hparams : args.length = params.length := by simpa using hlen have W := Ctx.InstN.consTel (Γ₀ := Γ) (e₀ := arg) (A₀ := param) params (.zero) @@ -1601,7 +1595,7 @@ private theorem ProgramsWF.projectionArgsSpineAux intro count hcount induction count with | zero => - exact ⟨_, rfl, rfl⟩ + exact ⟨_, rfl, .nil⟩ | succ count ih => have hcountLt : count < (view.specializedFields levels params).length := by omega @@ -2022,16 +2016,84 @@ private theorem WF.motiveLevel_projectionLevels · rfl · simp [VExpr.instTelN_length] +/-- The exact lower-layer structure-eta descriptor generated by a checked +structure view. Its projector syntax is the deterministic projector program +list already certified by the view; the proof fields are only the three +syntactic naturality laws required by Theory transport. -/ +def WF.toStructEta (self : VStructureView.WF view env) + (henv : env.Ordered) : VStructEta where + uvars := view.uvars + nparams := view.nparams + nfields := view.fields.length + familyName := view.name + familyType := view.familyType + constructorName := view.constructorName + projectors := fun levels params => + (view.projectionCodes levels params).map (·.projector) + projectors_length := by + intro levels params _ _ + simp [VStructureView.specializedFields, VStructureView.fields] + projectors_liftN := by + intro levels params n k hparams + have h := self.projectionCodes_liftN henv levels params hparams n k + simpa [List.map_map, ProjectionCode.liftN, Function.comp_def] using + congrArg (List.map (·.projector)) h + projectors_instN := by + intro levels params a k hparams + have h := self.projectionCodes_instN henv levels params hparams a k + simpa [List.map_map, ProjectionCode.instN, Function.comp_def] using + congrArg (List.map (·.projector)) h + projectors_instL := by + intro levels params ls + have h := projectionCodes_instL view levels params ls + simpa [List.map_map, ProjectionCode.instL, Function.comp_def] using + congrArg (List.map (·.projector)) h + +@[simp] theorem WF.toStructEta_structureType + (self : VStructureView.WF view env) (henv : env.Ordered) + (levels : List VLevel) (params : List VExpr) : + (self.toStructEta henv).structureType levels params = + view.structureType levels params := rfl + +@[simp] theorem WF.toStructEta_rebuild + (self : VStructureView.WF view env) (henv : env.Ordered) + (levels : List VLevel) (params : List VExpr) (major : VExpr) : + (self.toStructEta henv).rebuild levels params major = + view.etaRebuild levels params major := by + simp only [VStructEta.rebuild, VStructEta.projectionArgs, WF.toStructEta, + VStructureView.etaRebuild, VStructureView.projectionArgs] + rw [← view.projectionCodes_length levels params, List.take_length] + simp [List.map_map, Function.comp_def] + end VStructureView namespace VEnv +/-- Registered checked views supply the former semantic structure-eta +capability. The registry contributes only membership; subject reduction is +recovered from the ordered environment, and the equality itself is the +primitive `IsDefEq.structEta` step. -/ +theorem hasStructureEta_of_registry (henv : env.Ordered) + (registered : ∀ (view : VStructureView) + (hview : view.WF env) (_ : view.ProgramsWF env), + env.structEtas (hview.toStructEta henv)) : + env.HasStructureEta := by + intro view hview programs U Γ levels params major hΓ hlevels + hlevelsLength hparamsLength hparamsSpine hmajor + let rule := hview.toStructEta henv + have hregistered : env.structEtas rule := registered view hview programs + have hruleWF : rule.WF env := henv.structEtaWF hregistered + obtain ⟨resultLevel, hparamsSpine⟩ := hparamsSpine + have hrebuild := hruleWF.rebuild_hasType VEnv.LE.rfl hΓ hlevels + hlevelsLength hparamsLength ⟨resultLevel, hparamsSpine⟩ hmajor + have heta := IsDefEq.structEta hregistered hlevels hlevelsLength + hparamsLength hparamsSpine hmajor hrebuild + simpa [rule] using heta + private theorem SpineWF.monoProjection {env env' : VEnv} (henv : env ≤ env') : ∀ {A es B}, env.SpineWF U Γ A es B → env'.SpineWF U Γ A es B - | _, [], _, h => h - | _, _ :: _, _, ⟨A₁, A₂, rfl, he, hrest⟩ => - ⟨A₁, A₂, rfl, he.mono henv, SpineWF.monoProjection henv hrest⟩ + | _, _, _, h => h.mono henv /-- The view-facing direction of `TelDefEq.spine_sort`: arguments checked against the retained raw telescope also consume its definitionally equal @@ -2045,12 +2107,7 @@ theorem TelDefEq.spine_sort_view | _, [], [], [], _, _, 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 + .cons he hrest, hlen => by have heView : env.HasType U Γ e A' := hA.defeq he have hTinst := TelDefEq.instN henv he (.zero) hT have hrest' : env.SpineWF U Γ @@ -2064,7 +2121,7 @@ theorem TelDefEq.spine_sort_view exact hlen' have hout := TelDefEq.spine_sort_view henv hTinst hrest' hlenInst - refine ⟨A', VExpr.forallN As' (.sort l), rfl, heView, ?_⟩ + refine .cons heView ?_ simpa [VExpr.instN_forallN, VExpr.inst] using hout /-- Parameters accepted by the structure family also consume the stored raw @@ -2688,14 +2745,7 @@ theorem SpineWF.instNProjection {env : VEnv} {U k : Nat} ∀ {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⟩ + | _, _, _, h => h.instN henv W h₀ /-- A generated projector computes on the matching generated constructor once the registered rule's capture spine has been checked. This is the diff --git a/Lean4Lean/Theory/Typing/Basic.lean b/Lean4Lean/Theory/Typing/Basic.lean index c7ae89a9..bffbe36c 100644 --- a/Lean4Lean/Theory/Typing/Basic.lean +++ b/Lean4Lean/Theory/Typing/Basic.lean @@ -7,6 +7,12 @@ inductive Lookup : List VExpr → Nat → VExpr → Prop where | zero : Lookup (ty::Γ) 0 ty.lift | succ : Lookup Γ n ty → Lookup (A::Γ) (n+1) ty.lift +/-- A context-wide predicate, exposing each binder in its preceding context. -/ +def OnCtx (Γ : List VExpr) (P : List VExpr → VExpr → Prop) : Prop := + match Γ with + | [] => True + | A::Γ => OnCtx Γ P ∧ P Γ A + namespace VEnv section @@ -15,6 +21,8 @@ local notation:65 Γ " ⊢ " e " : " A:30 => IsDefEq Γ e e A local notation:65 Γ " ⊢ " e1 " ≡ " e2 " : " A:30 => IsDefEq Γ e1 e2 A variable (env : VEnv) (uvars : Nat) +mutual + inductive IsDefEq : List VExpr → VExpr → VExpr → VExpr → Prop where | bvar : Lookup Γ i A → Γ ⊢ .bvar i : A | symm : Γ ⊢ e ≡ e' : A → Γ ⊢ e' ≡ e : A @@ -48,6 +56,17 @@ inductive IsDefEq : List VExpr → VExpr → VExpr → VExpr → Prop where | eta : Γ ⊢ e : .forallE A B → Γ ⊢ .lam A (.app e.lift (.bvar 0)) ≡ e : .forallE A B + | structEta : + env.structEtas rule → + (∀ level ∈ levels, level.WF uvars) → + levels.length = rule.uvars → + params.length = rule.nparams → + SpineWF Γ (rule.familyType.instL levels) params (.sort resultLevel) → + Γ ⊢ major : rule.structureType levels params → + Γ ⊢ rule.rebuild levels params major : + rule.structureType levels params → + Γ ⊢ rule.rebuild levels params major ≡ major : + rule.structureType levels params | proofIrrel : Γ ⊢ p : .sort .zero → Γ ⊢ h : p → Γ ⊢ h' : p → Γ ⊢ h ≡ h' : p @@ -55,6 +74,21 @@ inductive IsDefEq : List VExpr → VExpr → VExpr → VExpr → Prop where env.defeqs df → (∀ l ∈ ls, l.WF uvars) → ls.length = df.uvars → Γ ⊢ df.lhs.instL ls ≡ df.rhs.instL ls : df.type.instL ls +/-- Typing of an application spine against an iterated pi type: peeling the +expressions of `es` off `A` one instantiation at a time ends at `B`. + +This judgment is mutually inductive with `IsDefEq` so rules whose validity +depends on an exact application spine retain induction hypotheses for every +argument typing derivation. -/ +inductive SpineWF : List VExpr → VExpr → List VExpr → VExpr → Prop where + | nil : SpineWF Γ A [] A + | cons : + IsDefEq Γ e e A₁ → + SpineWF Γ (A₂.inst e) es B → + SpineWF Γ (.forallE A₁ A₂) (e :: es) B + +end + end def HasType (env : VEnv) (U : Nat) (Γ : List VExpr) (e A : VExpr) : Prop := @@ -74,3 +108,26 @@ def VConstant.WF (env : VEnv) (ci : VConstant) : Prop := env.IsType ci.uvars [] def VDefEq.WF (env : VEnv) (df : VDefEq) : Prop := env.HasType df.uvars [] df.lhs df.type ∧ env.HasType df.uvars [] df.rhs df.type + +/-- Subject-reduction package attached to a registered structure-eta +descriptor. It consumes the exact family parameter spine but contains no +equality premise. -/ +structure VStructEta.WF (rule : VStructEta) (env : VEnv) : Prop where + /-- The retained family declaration is a closed constant type. This is the + syntactic fact which lets an exact parameter-spine certificate survive term + weakening and substitution. -/ + familyType_closed : rule.familyType.ClosedN + rebuild_hasType : + ∀ {env' : VEnv}, env ≤ env' → + ∀ {U : Nat} {Γ : List VExpr} {levels : List VLevel} + {params : List VExpr} {major : VExpr}, + OnCtx Γ (env'.IsType U) → + (∀ level ∈ levels, level.WF U) → + levels.length = rule.uvars → + params.length = rule.nparams → + (∃ resultLevel, + env'.SpineWF U Γ (rule.familyType.instL levels) + params (.sort resultLevel)) → + env'.HasType U Γ major (rule.structureType levels params) → + env'.HasType U Γ (rule.rebuild levels params major) + (rule.structureType levels params) diff --git a/Lean4Lean/Theory/Typing/ChurchRosser.lean b/Lean4Lean/Theory/Typing/ChurchRosser.lean index 83e0215f..976f9b33 100644 --- a/Lean4Lean/Theory/Typing/ChurchRosser.lean +++ b/Lean4Lean/Theory/Typing/ChurchRosser.lean @@ -27,6 +27,51 @@ class Params where extra_pat : env.defeqs df → (∀ l ∈ ls, l.WF uvars) → ls.length = df.uvars → ∃ p r m1 m2, Pat p r ∧ p.Matches (df.lhs.instL ls) m1 m2 ∧ r.2.OK (IsDefEqU env univs Γ) m1 m2 ∧ df.rhs.instL ls = r.1.apply m1 m2 + /-- Registered-family typing is reflected through weakening. This is the + structure-family specialization of `IsDefEqU.weakN_iff`: it retains the + registered head witness, which the untyped theorem intentionally erases. -/ + structEta_weakN_inv : + env.structEtas rule → + (∀ level ∈ levels, level.WF univs) → + levels.length = rule.uvars → + params.length = rule.nparams → + OnCtx Γ' (env.IsType univs) → + Ctx.LiftN n k Γ Γ' → + IsDefEq env univs Γ' (e₁.liftN n k) (e₂.liftN n k) + (rule.structureType levels params) → + ∃ levels' params' resultLevel, + levels'.length = rule.uvars ∧ + params'.length = rule.nparams ∧ + (∀ level ∈ levels', level.WF univs) ∧ + SpineWF env univs Γ (rule.familyType.instL levels') params' + (.sort resultLevel) ∧ + IsDefEq env univs Γ e₁ e₂ + (rule.structureType levels' params') + /-- A registered structure-family application is disjoint from the two + rigid type heads used by head standardization. These are primitive head + coverage facts, not confluence or equality conclusions. -/ + structEta_sort_disjoint : + env.structEtas rule → + (∀ level ∈ levels, level.WF univs) → + levels.length = rule.uvars → + params.length = rule.nparams → + ¬ IsDefEqU env univs Γ + (rule.structureType levels params) (.sort u) + structEta_forallE_disjoint : + env.structEtas rule → + (∀ level ∈ levels, level.WF univs) → + levels.length = rule.uvars → + params.length = rule.nparams → + ¬ IsDefEqU env univs Γ + (rule.structureType levels params) (.forallE A B) + /-- Function-head typing is reflected through weakening. This is the + primitive head-inversion coverage needed when a residual structure-eta + equality is closed pointwise under ordinary function eta. -/ + forallE_weakN_inv : + OnCtx Γ' (env.IsType univs) → + Ctx.LiftN n k Γ Γ' → + HasType env univs Γ' (f.liftN n k) (.forallE A B) → + ∃ A' B', HasType env univs Γ f (.forallE A' B') variable [Params] open Params @@ -78,6 +123,63 @@ theorem _root_.Lean4Lean.Pattern.Matches.hasType {p : Pattern} {e : VExpr} {m1 m set_option hygiene false local notation:65 Γ " ⊢ " e1 " ≡ₚ " e2:30 => NormalEq Γ e1 e2 +/-- Residual conversion generated by a registered structure family. + +The two seed constructors retain the *actual* left- or right-reconstruction +shape. Their two equality payloads relate the majors and the complete +constructor spines (hence every retained parameter and generated projector +occurrence) at one descriptor. The final two premises compose ordinary +conversion around that seed without forgetting it; unlike the former broad +base case, the reconstruction witness remains part of every `StructEq`. +`forallE` is the pointwise closure needed when structure eta appears beneath +ordinary function eta. -/ +inductive StructEq : List VExpr → VExpr → VExpr → Prop where + | etaL : + env.structEtas rule → + (∀ level ∈ levels, level.WF univs) → + levels.length = rule.uvars → + params.length = rule.nparams → + SpineWF env univs Γ (rule.familyType.instL levels) params + (.sort resultLevel) → + Γ ⊢ major₁ : rule.structureType levels params → + Γ ⊢ major₂ : rule.structureType levels params → + Γ ⊢ rule.rebuild levels params major₁ : + rule.structureType levels params → + Γ ⊢ rule.rebuild levels params major₂ : + rule.structureType levels params → + Γ ⊢ major₁ ≡ major₂ : rule.structureType levels params → + Γ ⊢ rule.rebuild levels params major₁ ≡ + rule.rebuild levels params major₂ : rule.structureType levels params → + Γ ⊢ e₁ ≡ rule.rebuild levels params major₁ : + rule.structureType levels params → + Γ ⊢ major₂ ≡ e₂ : rule.structureType levels params → + StructEq Γ e₁ e₂ + | etaR : + env.structEtas rule → + (∀ level ∈ levels, level.WF univs) → + levels.length = rule.uvars → + params.length = rule.nparams → + SpineWF env univs Γ (rule.familyType.instL levels) params + (.sort resultLevel) → + Γ ⊢ major₁ : rule.structureType levels params → + Γ ⊢ major₂ : rule.structureType levels params → + Γ ⊢ rule.rebuild levels params major₁ : + rule.structureType levels params → + Γ ⊢ rule.rebuild levels params major₂ : + rule.structureType levels params → + Γ ⊢ major₁ ≡ major₂ : rule.structureType levels params → + Γ ⊢ rule.rebuild levels params major₁ ≡ + rule.rebuild levels params major₂ : rule.structureType levels params → + Γ ⊢ e₁ ≡ major₁ : rule.structureType levels params → + Γ ⊢ rule.rebuild levels params major₂ ≡ e₂ : + rule.structureType levels params → + StructEq Γ e₁ e₂ + | forallE : + Γ ⊢ f : .forallE A B → + Γ ⊢ g : .forallE A B' → + StructEq (A::Γ) (.app f.lift (.bvar 0)) (.app g.lift (.bvar 0)) → + StructEq Γ f g + inductive NormalEq : List VExpr → VExpr → VExpr → Prop where | refl : Γ ⊢ e : A → Γ ⊢ e ≡ₚ e | sortDF : l₁.WF univs → l₂.WF univs → l₁ ≈ l₂ → Γ ⊢ .sort l₁ ≡ₚ .sort l₂ @@ -109,10 +211,221 @@ inductive NormalEq : List VExpr → VExpr → VExpr → Prop where Γ ⊢ e' : .forallE A B → A::Γ ⊢ .app e'.lift (.bvar 0) ≡ₚ e → Γ ⊢ e' ≡ₚ .lam A e + | structural : StructEq Γ e₁ e₂ → Γ ⊢ e₁ ≡ₚ e₂ | proofIrrel : Γ ⊢ p : .sort .zero → Γ ⊢ h : p → Γ ⊢ h' : p → Γ ⊢ h ≡ₚ h' +variable! (hΓ : OnCtx Γ (env.IsType univs)) in +theorem StructEq.defeq (H : StructEq Γ e₁ e₂) : Γ ⊢ e₁ ≡ e₂ := by + induction H with + | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine + _ hmajor₂ _ hrebuild₂ _ hrebuildEq hleft hright => + exact ⟨_, .trans hleft <| .trans hrebuildEq <| .trans + (.structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₂ hrebuild₂) hright⟩ + | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ _ hrebuild₁ _ _ hrebuildEq hleft hright => + exact ⟨_, .trans hleft <| .trans (.symm <| + .structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hrebuild₁) <| .trans hrebuildEq hright⟩ + | forallE hf hg _ ih => + have ⟨_, AB⟩ := hf.isType henv hΓ + have ⟨⟨_, hA⟩, _⟩ := AB.forallE_inv henv + have hΓ' : OnCtx (_ :: _) (env.IsType univs) := + ⟨hΓ, ⟨_, hA.hasType.1⟩⟩ + have ⟨_, he⟩ := ih hΓ' + have hleft := IsDefEqU.symm ⟨_, .eta hf⟩ + have hmid := IsDefEq.lamDF hA he + exact ⟨_, .transU_r henv hΓ hleft <| hmid.transU_l henv hΓ ⟨_, .eta hg⟩⟩ + +variable! (hΓ : OnCtx Γ (env.IsType univs)) in +theorem StructEq.not_sort_r (hu : u.WF univs) : ¬StructEq Γ e (.sort u) + | .etaL hreg hlevels hlevelsLength hparamsLength _ _ _ _ _ _ _ _ hright + | .etaR hreg hlevels hlevelsLength hparamsLength _ _ _ _ _ _ _ _ hright => + structEta_sort_disjoint hreg hlevels hlevelsLength hparamsLength + (hright.hasType.2.uniqU henv hΓ (HasType.sort hu)) + | .forallE _ hg _ => + ((HasType.sort hu).uniqU henv hΓ hg).sort_forallE_inv henv hΓ + +variable! (hΓ : OnCtx Γ (env.IsType univs)) in +theorem StructEq.not_forallE_r + (hAB : Γ ⊢ .forallE A B : .sort u) : ¬StructEq Γ e (.forallE A B) + | .etaL hreg hlevels hlevelsLength hparamsLength _ _ _ _ _ _ _ _ hright + | .etaR hreg hlevels hlevelsLength hparamsLength _ _ _ _ _ _ _ _ hright => + structEta_sort_disjoint hreg hlevels hlevelsLength hparamsLength + (hright.hasType.2.uniqU henv hΓ hAB) + | .forallE _ hg _ => + (hAB.uniqU henv hΓ hg).sort_forallE_inv henv hΓ + +variable! (hΓ : OnCtx Γ (env.IsType univs)) in +theorem StructEq.symm (H : StructEq Γ e₁ e₂) : StructEq Γ e₂ e₁ := by + induction H with + | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft hright => + exact .etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₂ hmajor₁ hrebuild₂ hrebuild₁ hmajorEq.symm + hrebuildEq.symm hright.symm hleft.symm + | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft hright => + exact .etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₂ hmajor₁ hrebuild₂ hrebuild₁ hmajorEq.symm + hrebuildEq.symm hright.symm hleft.symm + | forallE hf hg _ ih => + have ⟨_, AB⟩ := hf.isType henv hΓ + exact .forallE hg hf (ih ⟨hΓ, (AB.forallE_inv henv).1⟩) + +theorem StructEq.weakN (W : Ctx.LiftN n k Γ Γ') + (H : StructEq Γ e₁ e₂) : + StructEq Γ' (e₁.liftN n k) (e₂.liftN n k) := by + induction H generalizing k Γ' with + | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft hright => + have hparamsSpine := hparamsSpine.weakN henv W + rw [(henv.ordered.structEtaWF hreg).familyType_closed.instL.liftN_eq + (Nat.zero_le _)] at hparamsSpine + have hmajor₁ := hmajor₁.weakN henv W + have hmajor₂ := hmajor₂.weakN henv W + have hrebuild₁ := hrebuild₁.weakN henv W + have hrebuild₂ := hrebuild₂.weakN henv W + have hmajorEq := hmajorEq.weakN henv W + have hrebuildEq := hrebuildEq.weakN henv W + have hleft := hleft.weakN henv W + have hright := hright.weakN henv W + simp only [VStructEta.structureType_liftN] at hmajor₁ hmajor₂ hmajorEq hright + simp only [VStructEta.rebuild_liftN _ _ _ _ hparamsLength, + VStructEta.structureType_liftN] at hrebuild₁ hrebuild₂ hrebuildEq hleft + exact .etaL hreg hlevels hlevelsLength (by simpa using hparamsLength) + hparamsSpine hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq + hrebuildEq hleft hright + | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft hright => + have hparamsSpine := hparamsSpine.weakN henv W + rw [(henv.ordered.structEtaWF hreg).familyType_closed.instL.liftN_eq + (Nat.zero_le _)] at hparamsSpine + have hmajor₁ := hmajor₁.weakN henv W + have hmajor₂ := hmajor₂.weakN henv W + have hrebuild₁ := hrebuild₁.weakN henv W + have hrebuild₂ := hrebuild₂.weakN henv W + have hmajorEq := hmajorEq.weakN henv W + have hrebuildEq := hrebuildEq.weakN henv W + have hleft := hleft.weakN henv W + have hright := hright.weakN henv W + simp only [VStructEta.structureType_liftN] at hmajor₁ hmajor₂ hmajorEq hleft + simp only [VStructEta.rebuild_liftN _ _ _ _ hparamsLength, + VStructEta.structureType_liftN] at hrebuild₁ hrebuild₂ hrebuildEq hright + exact .etaR hreg hlevels hlevelsLength (by simpa using hparamsLength) + hparamsSpine hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq + hrebuildEq hleft hright + | forallE hf hg _ ih => + refine .forallE (hf.weakN henv W) (hg.weakN henv W) ?_ + simpa [liftN, lift_liftN'] using ih W.succ + +variable! (h₀ : Γ₀ ⊢ e₀ : A₀) in +theorem StructEq.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) + (H : StructEq Γ₁ e₁ e₂) : + StructEq Γ (e₁.inst e₀ k) (e₂.inst e₀ k) := by + induction H generalizing Γ k with + | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft hright => + have hparamsSpine := hparamsSpine.instN henv W h₀ + rw [(henv.ordered.structEtaWF hreg).familyType_closed.instL.instN_eq + (Nat.zero_le _)] at hparamsSpine + have hmajor₁ := hmajor₁.instN henv W h₀ + have hmajor₂ := hmajor₂.instN henv W h₀ + have hrebuild₁ := hrebuild₁.instN henv W h₀ + have hrebuild₂ := hrebuild₂.instN henv W h₀ + have hmajorEq := hmajorEq.instN henv h₀ W + have hrebuildEq := hrebuildEq.instN henv h₀ W + have hleft := hleft.instN henv h₀ W + have hright := hright.instN henv h₀ W + simp only [VStructEta.structureType_instN] at hmajor₁ hmajor₂ hmajorEq hright + simp only [VStructEta.rebuild_instN _ _ _ _ _ hparamsLength, + VStructEta.structureType_instN] at hrebuild₁ hrebuild₂ hrebuildEq hleft + exact .etaL hreg hlevels hlevelsLength (by simpa using hparamsLength) + hparamsSpine hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq + hrebuildEq hleft hright + | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft hright => + have hparamsSpine := hparamsSpine.instN henv W h₀ + rw [(henv.ordered.structEtaWF hreg).familyType_closed.instL.instN_eq + (Nat.zero_le _)] at hparamsSpine + have hmajor₁ := hmajor₁.instN henv W h₀ + have hmajor₂ := hmajor₂.instN henv W h₀ + have hrebuild₁ := hrebuild₁.instN henv W h₀ + have hrebuild₂ := hrebuild₂.instN henv W h₀ + have hmajorEq := hmajorEq.instN henv h₀ W + have hrebuildEq := hrebuildEq.instN henv h₀ W + have hleft := hleft.instN henv h₀ W + have hright := hright.instN henv h₀ W + simp only [VStructEta.structureType_instN] at hmajor₁ hmajor₂ hmajorEq hleft + simp only [VStructEta.rebuild_instN _ _ _ _ _ hparamsLength, + VStructEta.structureType_instN] at hrebuild₁ hrebuild₂ hrebuildEq hright + exact .etaR hreg hlevels hlevelsLength (by simpa using hparamsLength) + hparamsSpine hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq + hrebuildEq hleft hright + | forallE hf hg _ ih => + refine .forallE (hf.instN henv W h₀) (hg.instN henv W h₀) ?_ + simpa [inst, lift_instN_lo] using ih W.succ + +variable! (hΓ : OnCtx Γ (env.IsType univs)) in +theorem StructEq.app (H : StructEq Γ f g) + (hf : Γ ⊢ f : .forallE A B) (ha : Γ ⊢ a : A) : + StructEq Γ (.app f a) (.app g a) := by + cases H with + | etaL hreg hlevels hlevelsLength hparamsLength _ _ _ _ _ _ _ hleft _ => + exact (structEta_forallE_disjoint hreg hlevels hlevelsLength + hparamsLength (hleft.hasType.1.uniqU henv hΓ hf)).elim + | etaR hreg hlevels hlevelsLength hparamsLength _ _ _ _ _ _ _ hleft _ => + exact (structEta_forallE_disjoint hreg hlevels hlevelsLength + hparamsLength (hleft.hasType.1.uniqU henv hΓ hf)).elim + | forallE hf' hg' h => + have ⟨⟨_, hA⟩, _⟩ := (hf.uniqU henv hΓ hf').forallE_inv henv hΓ + simpa [inst, inst_lift, instN_bvar0] using + h.instN (hA.defeq ha) .zero + +private theorem SpineWF.defeqDFC_early + (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂) : + ∀ {A es B}, SpineWF env univs Γ₁ A es B → + SpineWF env univs Γ₂ A es B + | _, [], _, .nil => .nil + | _, _ :: _, _, .cons he hrest => + .cons (he.defeqDFC henv W) (SpineWF.defeqDFC_early W hrest) + +variable! (H₀ : OnCtx Γ₀ (IsType env univs)) in +theorem StructEq.defeqDFC (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂) + (H : StructEq Γ₁ e₁ e₂) : StructEq Γ₂ e₁ e₂ := by + induction H generalizing Γ₂ with + | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft hright => + exact .etaL hreg hlevels hlevelsLength hparamsLength + (hparamsSpine.defeqDFC_early W) + (.defeqDFC henv W hmajor₁) (.defeqDFC henv W hmajor₂) + (.defeqDFC henv W hrebuild₁) (.defeqDFC henv W hrebuild₂) + (.defeqDFC henv W hmajorEq) (.defeqDFC henv W hrebuildEq) + (.defeqDFC henv W hleft) (.defeqDFC henv W hright) + | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft hright => + exact .etaR hreg hlevels hlevelsLength hparamsLength + (hparamsSpine.defeqDFC_early W) + (.defeqDFC henv W hmajor₁) (.defeqDFC henv W hmajor₂) + (.defeqDFC henv W hrebuild₁) (.defeqDFC henv W hrebuild₂) + (.defeqDFC henv W hmajorEq) (.defeqDFC henv W hrebuildEq) + (.defeqDFC henv W hleft) (.defeqDFC henv W hright) + | forallE hf hg _ ih => + have ⟨⟨_, hA⟩, _⟩ := + let ⟨_, h⟩ := hf.isType henv (W.isType' H₀); h.forallE_inv henv + exact .forallE (.defeqDFC henv W hf) (.defeqDFC henv W hg) + (ih (W.succ hA)) + variable! (hΓ : OnCtx Γ (env.IsType univs)) in theorem NormalEq.defeq (H : Γ ⊢ e1 ≡ₚ e2) : Γ ⊢ e1 ≡ e2 := by induction H with @@ -138,6 +451,7 @@ theorem NormalEq.defeq (H : Γ ⊢ e1 ≡ₚ e2) : Γ ⊢ e1 ≡ e2 := by have ⟨⟨_, hA⟩, _⟩ := AB.forallE_inv henv refine have hΓ' := ⟨hΓ, _, hA.hasType.1⟩; have ⟨_, he⟩ := ih hΓ'; ?_ exact ⟨_, .transU_l henv hΓ (.symm (.eta h1)) ⟨_, .lamDF hA he⟩⟩ + | structural h => exact h.defeq hΓ | proofIrrel h1 h2 h3 => exact ⟨_, .proofIrrel h1 h2 h3⟩ variable! (hΓ : OnCtx Γ (env.IsType univs)) in @@ -159,6 +473,7 @@ theorem NormalEq.symm (H : Γ ⊢ e1 ≡ₚ e2) : Γ ⊢ e2 ≡ₚ e1 := by | etaR h1 _ ih => have ⟨_, AB⟩ := h1.isType henv hΓ exact .etaL h1 (ih ⟨hΓ, (AB.forallE_inv henv).1⟩) + | structural h => exact .structural (h.symm hΓ) | proofIrrel h1 h2 h3 => exact .proofIrrel h1 h3 h2 theorem NormalEq.weakN (W : Ctx.LiftN n k Γ Γ') (H : Γ ⊢ e1 ≡ₚ e2) : @@ -182,6 +497,7 @@ theorem NormalEq.weakN (W : Ctx.LiftN n k Γ Γ') (H : Γ ⊢ e1 ≡ₚ e2) : refine .etaR (h1.weakN henv W) ?_ have := ih W.succ simp [liftN] at this; rwa [lift_liftN'] + | structural h => exact .structural (h.weakN W) | proofIrrel h1 h2 h3 => exact .proofIrrel (h1.weakN henv W) (h2.weakN henv W) (h3.weakN henv W) @@ -204,6 +520,7 @@ theorem NormalEq.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) (H : Γ₁ ⊢ | etaR h1 _ ih => refine .etaR (h1.instN henv W h₀) ?_ simpa [inst, lift_instN_lo] using ih W.succ + | structural h => exact .structural (h.instN h₀ W) | proofIrrel h1 h2 h3 => exact .proofIrrel (h1.instN henv W h₀) (h2.instN henv W h₀) (h3.instN henv W h₀) variable! (hΓ₁ : OnCtx Γ₁ (env.IsType univs)) (h₀ : Γ₀ ⊢ e₀ : A₀) (H' : Γ₀ ⊢ e₀ ≡ₚ e₀') in @@ -265,6 +582,7 @@ theorem NormalEq.defeqDFC (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂) | etaR h1 _ ih => have ⟨⟨_, h2⟩, _⟩ := let ⟨_, h⟩ := h1.isType henv (W.isType' H₀); h.forallE_inv henv refine .etaR (.defeqDFC henv W h1) (ih (W.succ h2)) + | structural h => exact .structural (h.defeqDFC H₀ W) | proofIrrel h1 h2 h3 => exact .proofIrrel (.defeqDFC henv W h1) (.defeqDFC henv W h2) (.defeqDFC henv W h3) @@ -273,6 +591,116 @@ variable! (hΓ : OnCtx Γ (IsType env univs)) in theorem NormalEq.defeq_l (W : Γ ⊢ A ≡ A' : sort u) (H : A::Γ ⊢ e1 ≡ₚ e2) : A'::Γ ⊢ e1 ≡ₚ e2 := defeqDFC hΓ (.succ .zero W) H +private theorem hasType_app_bvar0_early + (hΓ : OnCtx (A::Γ) (IsType env univs)) + (H : A :: Γ ⊢ e.lift.app (bvar 0) : B) : + ∃ B', Γ ⊢ e : .forallE A B' := by + have ⟨_, _, c1, c2⟩ := H.app_inv henv hΓ + replace c1 := + have ⟨_, d1⟩ := c1.isType henv hΓ + have ⟨_, _, d3⟩ := d1.forallE_inv henv + have ⟨_, d4⟩ := c2.uniq henv hΓ (.bvar .zero) + HasType.defeqU_r henv hΓ ⟨_, d4.forallEDF d3⟩ c1 + have heta := c1.eta + rw [show A.lift.lam (e.lift.lift.app (bvar 0)) = + (A.lam (e.lift.app (bvar 0))).lift by + simp [VExpr.liftN, liftN'_liftN_lo, liftN_liftN]] at heta + have ⟨_, f1⟩ := (IsDefEqU.weakN_iff henv hΓ .one).1 ⟨_, heta⟩ + have ⟨⟨_, f2⟩, _, f3⟩ := f1.hasType.1.lam_inv henv hΓ.1 + exact ⟨_, (HasType.lam f2 f3).defeqU_l henv hΓ.1 ⟨_, f1⟩⟩ + +variable! (hΓ₀ : OnCtx Γ₀ (IsType env univs)) in +theorem StructEq.weakN_inv_DFC + (W : Ctx.LiftN n k Γ Γ₂) + (W₂ : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂) + (H : StructEq Γ₁ (e₁.liftN n k) (e₂.liftN n k)) : + StructEq Γ e₁ e₂ := by + generalize eq0 : Γ₁ = Γ₁' at H + generalize eq1 : e₁.liftN n k = e₁' at H + generalize eq2 : e₂.liftN n k = e₂' at H + revert W₂ + induction H generalizing Γ Γ₁ Γ₂ e₁ e₂ k with + | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft hright => + intro W₂ + subst eq1 + subst eq2 + subst_vars + have hΓ₁ := W₂.isType' hΓ₀ + have hΓ₂ := (W₂.symm henv).isType' hΓ₀ + have hseed : Γ₁ ⊢ e₁.liftN n k ≡ e₂.liftN n k : + _ := .trans hleft <| .trans hrebuildEq <| .trans + (.structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₂ hrebuild₂) hright + obtain ⟨levels', params', resultLevel', hlevelsLength', hparamsLength', + hlevels', hparamsSpine', h'⟩ := + structEta_weakN_inv hreg hlevels hlevelsLength hparamsLength hΓ₂ W + (hseed.defeqDFC henv W₂) + have hΓ := hΓ₂.weakN_inv henv W + have hmajor := h'.hasType.2 + have hrebuild := (henv.ordered.structEtaWF hreg).rebuild_hasType + VEnv.LE.rfl hΓ hlevels' hlevelsLength' hparamsLength' + ⟨resultLevel', hparamsSpine'⟩ hmajor + have heta := IsDefEq.structEta hreg hlevels' hlevelsLength' + hparamsLength' hparamsSpine' hmajor hrebuild + exact .etaL hreg hlevels' hlevelsLength' hparamsLength' hparamsSpine' + hmajor hmajor hrebuild hrebuild hmajor hrebuild + (.trans h' heta.symm) hmajor + | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft hright => + intro W₂ + subst eq1 + subst eq2 + subst_vars + have hΓ₁ := W₂.isType' hΓ₀ + have hΓ₂ := (W₂.symm henv).isType' hΓ₀ + have hseed : Γ₁ ⊢ e₁.liftN n k ≡ e₂.liftN n k : + _ := .trans hleft <| .trans (.symm <| + .structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hrebuild₁) <| .trans hrebuildEq hright + obtain ⟨levels', params', resultLevel', hlevelsLength', hparamsLength', + hlevels', hparamsSpine', h'⟩ := + structEta_weakN_inv hreg hlevels hlevelsLength hparamsLength hΓ₂ W + (hseed.defeqDFC henv W₂) + have hΓ := hΓ₂.weakN_inv henv W + have hmajor := h'.hasType.2 + have hrebuild := (henv.ordered.structEtaWF hreg).rebuild_hasType + VEnv.LE.rfl hΓ hlevels' hlevelsLength' hparamsLength' + ⟨resultLevel', hparamsSpine'⟩ hmajor + have heta := IsDefEq.structEta hreg hlevels' hlevelsLength' + hparamsLength' hparamsSpine' hmajor hrebuild + exact .etaL hreg hlevels' hlevelsLength' hparamsLength' hparamsSpine' + hmajor hmajor hrebuild hrebuild hmajor hrebuild + (.trans h' heta.symm) hmajor + | forallE hf hg _ ih => + intro W₂ + subst eq1 + subst eq2 + subst_vars + have hΓ₁ := W₂.isType' hΓ₀ + have ⟨⟨_, hA⟩, _, _⟩ := + let ⟨_, h⟩ := hf.isType henv hΓ₁; h.forallE_inv henv + have hf' := hf.defeqDFC henv W₂ + have hΓ₂ := (W₂.symm henv).isType' hΓ₀ + obtain ⟨A₀, B₀, hf₀⟩ := forallE_weakN_inv hΓ₂ W hf' + have ⟨⟨_, hAeq⟩, _⟩ := + (hf'.uniqU henv hΓ₂ (hf₀.weakN henv W)).forallE_inv henv hΓ₂ + have hAeq' := hAeq.defeqDFC henv (W₂.symm henv) + have hbody := ih (e₁ := e₁.lift.app (.bvar 0)) + (e₂ := e₂.lift.app (.bvar 0)) W.succ rfl + (by simp [liftN, lift_liftN']) (by simp [liftN, lift_liftN']) + (W₂.succ hAeq') + have hΓ := hΓ₂.weakN_inv henv W + have ⟨_, hfunType⟩ := hf₀.isType henv hΓ + have ⟨⟨_, hA₀⟩, _⟩ := hfunType.forallE_inv henv + have hΓ' : OnCtx (_ :: Γ) (env.IsType univs) := + ⟨hΓ, ⟨_, hA₀.hasType.1⟩⟩ + obtain ⟨_, hg₀⟩ := hasType_app_bvar0_early hΓ' + (hbody.defeq hΓ').choose_spec.hasType.2 + exact .forallE hf₀ hg₀ hbody + variable! (hΓ₀ : OnCtx Γ₀ (IsType env univs)) in theorem NormalEq.weakN_inv_DFC (W : Ctx.LiftN n k Γ Γ₂) (W₂ : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂) (H : Γ₁ ⊢ e1.liftN n k ≡ₚ e2.liftN n k) : Γ ⊢ e1 ≡ₚ e2 := by @@ -365,6 +793,10 @@ theorem NormalEq.weakN_inv_DFC (W : Ctx.LiftN n k Γ Γ₂) (W₂ : IsDefEqCtx e have := (IsDefEq.weakN_iff (A := .forallE ..) henv hΓ₂'.1 W).1 <| IsDefEq.defeq (.forallEDF hA' hu) h1' refine .etaR this (ih W.succ (W₂.succ hA) (by simp [liftN, lift_liftN']) rfl) + | structural h => + subst eq1 + subst eq2 + exact .structural (h.weakN_inv_DFC hΓ₀ W W₂) | proofIrrel h1 h2 h3 => subst eq1; subst eq2 have h1' := h1.defeqDFC henv W₂ @@ -393,6 +825,36 @@ omit [Params] in private theorem meas_liftN : meas (e.liftN n k) = meas e := by induction e generalizing k <;> simp [*, meas, liftN] omit [Params] in private theorem meas_lift : meas e.lift = meas e := meas_liftN +variable! (hΓ : OnCtx Γ (IsType env univs)) in +theorem StructEq.trans_right (H : StructEq Γ e₁ e₂) + (h : Γ ⊢ e₂ ≡ e₃) : StructEq Γ e₁ e₃ := by + induction H generalizing e₃ with + | etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft hright => + exact .etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft (hright.transU_l henv hΓ h) + | etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft hright => + exact .etaR hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor₁ hmajor₂ hrebuild₁ hrebuild₂ hmajorEq hrebuildEq + hleft (hright.transU_l henv hΓ h) + | forallE hf hg _ ih => + have ⟨_, AB⟩ := hf.isType henv hΓ + have ⟨⟨_, hA⟩, _⟩ := AB.forallE_inv henv + have hΓ' : OnCtx (_ :: _) (env.IsType univs) := + ⟨hΓ, ⟨_, hA.hasType.1⟩⟩ + have hfun := h.of_l henv hΓ hg + have happ := IsDefEq.appDF (hfun.weakN henv .one) (.bvar .zero) + exact .forallE hf hfun.hasType.2 (ih hΓ' ⟨_, happ⟩) + +variable! (hΓ : OnCtx Γ (IsType env univs)) in +theorem StructEq.trans_left (h : Γ ⊢ e₀ ≡ e₁) + (H : StructEq Γ e₁ e₂) : StructEq Γ e₀ e₂ := + ((H.symm hΓ).trans_right hΓ h.symm).symm hΓ + attribute [local simp] meas meas_lift in theorem NormalEq.trans (hΓ : OnCtx Γ (IsType env univs)) : Γ ⊢ e1 ≡ₚ e2 → Γ ⊢ e2 ≡ₚ e3 → Γ ⊢ e1 ≡ₚ e3 @@ -431,6 +893,14 @@ theorem NormalEq.trans (hΓ : OnCtx Γ (IsType env univs)) : have hw := let ⟨_, h⟩ := hA.isType henv hΓ; h.sort_inv henv exact ⟨_, .sortDF ⟨hw, ⟨⟩⟩ ⟨⟩ rfl⟩ | appDF _ _ _ _ ih => exact (NormalEq.weakN_iff (by exact ⟨hΓ, _, hA⟩) .one).1 ih + | structural hs => + have hΓ' : OnCtx (_ :: _) (env.IsType univs) := + ⟨hΓ, ⟨_, hA.hasType.1⟩⟩ + have ⟨_, hse⟩ := hs.defeq hΓ' + obtain ⟨_, hr⟩ := hasType_app_bvar0_early hΓ' hse.hasType.2 + exact .structural (.forallE l1 hr hs) + | .structural hs, H2 => by + exact .structural (hs.trans_right hΓ (H2.defeq hΓ)) | .refl h, H2 => H2 | .proofIrrel l1 l2 l3, H2 => .proofIrrel l1 l2 (.defeqU_l henv hΓ (H2.defeq hΓ) l3) | .etaL l1 ih, H2 => by @@ -446,6 +916,8 @@ theorem NormalEq.trans (hΓ : OnCtx Γ (IsType env univs)) : refine .appDF ((r1.defeqU_l henv hΓ (H1.defeq hΓ).symm).weakN henv .one) (r1.weakN henv .one) (.bvar .zero) (.bvar .zero) (.weakN .one H1) (.refl (.bvar .zero)) + | H1, .structural hs => by + exact .structural (hs.trans_left hΓ (H1.defeq hΓ)) | H1, .proofIrrel h1 h2 h3 => .proofIrrel h1 (.defeqU_l henv hΓ (H1.defeq hΓ).symm h2) h3 termination_by meas e1 + meas e2 + meas e3 @@ -1038,6 +1510,32 @@ theorem hasType_app_bvar0 have ⟨⟨_, f2⟩, _, f3⟩ := f1.hasType.1.lam_inv henv hΓ.1 exact ⟨_, (HasType.lam f2 f3).defeqU_l henv hΓ.1 ⟨_, f1⟩⟩ +variable! (hΓ : OnCtx Γ (IsType env univs)) in +theorem ParRedExt.beta_defeq (l : ParRedExt) (W : l.depth ≤ Γ.length) + (H : Γ ⊢ l.apply ((lam A e').lift.app (bvar 0)) : T) : + Γ ⊢ l.apply ((lam A e').lift.app (bvar 0)) ≡ l.apply e' := by + induction l generalizing Γ T with + | base => + simp only [apply] at H ⊢ + have ⟨_, _, hfun, harg⟩ := H.app_inv henv hΓ + have ⟨⟨_, hA⟩, _, hbody⟩ := hfun.lam_inv henv hΓ + have ⟨⟨_, hdom⟩, _⟩ := + ((hA.lam hbody).uniqU henv hΓ hfun).forallE_inv henv hΓ + simpa [liftN, instN_bvar0] using + (IsDefEq.toU (.beta hbody (hdom.symm.defeq harg))) + | lift l ih => + let _ :: Γ' := Γ + have ⟨_, H'⟩ := (VExpr.WF.weakN_iff henv hΓ .one).1 ⟨_, H⟩ + simpa [apply] using + (ih hΓ.1 (Nat.le_of_succ_le_succ W) H').weakN henv (.one) + | app l ih => + let _ :: Γ' := Γ + obtain ⟨_, hfun⟩ := hasType_app_bvar0 hΓ H + have heq := ih hΓ.1 (Nat.le_of_succ_le_succ W) hfun + have happ := IsDefEq.appDF + ((heq.of_l henv hΓ.1 hfun).weakN henv .one) (.bvar .zero) + simpa [apply] using IsDefEq.toU happ + variable! (hΓ : OnCtx Γ (IsType env univs)) in theorem ParRedExt.parRed_beta : Γ ⊢ f ≡ₚ lam A e' → ∀ {a B}, Γ ⊢ f.app a : B → ∃ e, Γ ⊢ f.app a ≫* e ∧ Γ ⊢ e ≡ₚ e'.inst a := by @@ -1071,6 +1569,17 @@ theorem ParRedExt.parRed_beta : have := a2.instN (.defeq u1 H2) .zero simp [inst, inst_lift] at this exact ⟨_, .rfl, this⟩ + | structural hs => + have ⟨_, _, H1, H2⟩ := h2.app_inv henv hΓ + have hsApp := hs.app hΓ H1 H2 + have hse := hs.defeq hΓ + have hlam := (hse.of_l henv hΓ H1).hasType.2 + have ⟨⟨_, hA⟩, _, hbody⟩ := hlam.lam_inv henv hΓ + have ⟨⟨_, hdom⟩, _⟩ := + ((hA.lam hbody).uniqU henv hΓ hlam).forallE_inv henv hΓ + have hbeta : Γ ⊢ (lam A e').app a ≡ e'.inst a := + ⟨_, .beta hbody (hdom.symm.defeq H2)⟩ + exact ⟨_, .rfl, .structural (hsApp.trans_right hΓ hbeta)⟩ | proofIrrel a1 a2 a3 => have ⟨_, _, H1, H2⟩ := h2.app_inv henv hΓ have hf := a2.uniqU henv hΓ H1; have := a1.defeqU_l henv hΓ hf @@ -1142,6 +1651,11 @@ theorem ParRedExt.parRed_beta : have ⟨_, c1⟩ := b2.defeq hΓ' let ⟨_, b3⟩ := hasType_app_bvar0 hΓ' c1.hasType.2 exact ⟨_, .lam .rfl b1, .etaL b3 b2⟩ + | structural hs => + subst eq + have ⟨_, heq⟩ := hs.defeq hΓ + exact ⟨_, .rfl, .structural <| + hs.trans_right hΓ (l.beta_defeq hΓ W heq.hasType.2)⟩ | @proofIrrel _ p _ _ a1 a2 a3 => subst eq; refine ⟨_, .rfl, .proofIrrel a1 a2 ?_⟩ clear a2; induction l generalizing Γ p with @@ -1174,6 +1688,33 @@ theorem ParRedExt.parRed_beta : exact .defeqU_r henv hΓ H.symm this | _ => cases l.isApp eq +/-! +`StructEq` retains an oriented, registered eta seed plus the complete typed +constructor-spine congruence. Consequently one parallel step at its right +endpoint is absorbed without erasing that seed. This is the common typed +join for all six structure-eta interactions from the L4L-15B design: + +* constructor-major projector iota and an overlapping registered rule are + both `ParRed.extra`; `ParRed.defeq` discharges them through `pat_wf`; +* nested reconstructions retain their inner `etaL`/`etaR` seed when + `StructEq.trans_right` composes the outer endpoint; +* beta and congruence steps inside the major, including every repeated + projector occurrence, are the `beta` and `app` parallel cases; +* dependent later fields are transported by the common endpoint type in the + resulting `IsDefEq` proof; and +* proof fields and Prop-valued structures use the same typed transport, with + `NormalEq.proofIrrel` remaining available for the residual proof endpoints. + +The helper is intentionally proved from `ParRed.defeq`, not assumed in +`Params`; the generic pattern interface therefore remains responsible for +the `.extra` overlap. +-/ +variable! (hΓ : OnCtx Γ (IsType env univs)) in +theorem StructEq.parRed_right (H : StructEq Γ e₁ e₂) + (R : Γ ⊢ e₂ ≫ e₂') : StructEq Γ e₁ e₂' := by + have ⟨_, heq⟩ := H.defeq hΓ + exact H.trans_right hΓ ⟨_, R.defeq hΓ heq.hasType.2⟩ + variable! (hΓ : OnCtx Γ (IsType env univs)) in theorem NormalEq.parRed (H1 : Γ ⊢ e₁ ≡ₚ e₂) (H2 : Γ ⊢ e₂ ≫ e₂') : ∃ e₁', Γ ⊢ e₁ ≫* e₁' ∧ Γ ⊢ e₁' ≡ₚ e₂' := by @@ -1277,6 +1818,8 @@ theorem NormalEq.parRed (H1 : Γ ⊢ e₁ ≡ₚ e₂) (H2 : Γ ⊢ e₂ ≫ e | extra b1 b2 b3 b4 => cases b2 with | app _ h => cases h | var => cases pat_not_var b1 | extra _ r2 => cases r2 + | structural hs => + exact ⟨_, .rfl, .structural (hs.parRed_right hΓ H2)⟩ | proofIrrel l1 l2 l3 => exact ⟨_, .rfl, .proofIrrel l1 l2 (H2.hasType hΓ l3)⟩ variable! (hΓ : OnCtx Γ (IsType env univs)) in @@ -1346,7 +1889,8 @@ theorem IsDefEq.church_rosser have mk {Γ e₁ e₂ A e₁' e₂'} (H : Γ ⊢ e₁ ≡ e₂ : A) (h1 : Γ ⊢ e₁ ≫* e₁') (h2 : Γ ⊢ e₂ ≫* e₂') (h3 : Γ ⊢ e₁' ≡ₚ e₂') : Γ ⊢ e₁≫≪ e₂ := ⟨⟨_, H.hasType.1⟩, ⟨_, H.hasType.2⟩, _, _, h1, h2, h3⟩ - induction H with + induction H using IsDefEq.rec + (motive_2 := fun _ _ _ _ _ => True) with | bvar h => exact .refl hΓ (.bvar h) | symm _ ih => exact (ih hΓ).symm hΓ | trans _ _ ih1 ih2 => exact (ih1 hΓ).trans hΓ (ih2 hΓ) @@ -1378,9 +1922,15 @@ theorem IsDefEq.church_rosser | eta h1 ih1 => have := h1.hasType.1 exact .normalEq hΓ <| .etaL this <| .refl <| .app (this.weak henv) (.bvar .zero) + | structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor hrebuild _ _ _ => + exact .normalEq hΓ <| .structural <| + .etaL hreg hlevels hlevelsLength hparamsLength hparamsSpine + hmajor hmajor hrebuild hrebuild hmajor hrebuild hrebuild hmajor | proofIrrel h1 h2 h3 ih1 ih2 ih3 => exact .normalEq hΓ <| .proofIrrel h1.hasType.1 h2.hasType.1 h3.hasType.1 | @extra _ _ Γ h1 h2 h3 => have ⟨_, _, _, _, a1, a2, a3, a4⟩ := extra_pat h1 h2 h3 (Γ := Γ) refine have h := .extra h1 h2 h3; mk h (.tail .rfl (.extra a1 a2 a3 fun _ => .rfl)) .rfl ?_ exact a4 ▸ .refl h.hasType.2 + | nil | cons => trivial diff --git a/Lean4Lean/Theory/Typing/Env.lean b/Lean4Lean/Theory/Typing/Env.lean index c16e9421..1e3ac97a 100644 --- a/Lean4Lean/Theory/Typing/Env.lean +++ b/Lean4Lean/Theory/Typing/Env.lean @@ -57,6 +57,12 @@ inductive VDecl.WF : VEnv → VDecl → VEnv → Prop where inductive VEnv.WF' : List VDecl → VEnv → Prop where | empty : VEnv.WF' [] .empty | decl {env} : VDecl.WF env d env' → env.WF' ds → env'.WF' (d::ds) + /-- A checked structure-eta descriptor is an environment capability, not a + source declaration. Keep it in the environment history without inventing + a `VDecl`; its subject-reduction certificate is exactly the premise used by + `Ordered.structEta`. -/ + | structEta {env : VEnv} {rule : VStructEta} : rule.WF env → env.WF' ds → + (env.addStructEta rule).WF' ds def VEnv.WF (env : VEnv) : Prop := ∃ ds, VEnv.WF' ds env diff --git a/Lean4Lean/Theory/Typing/EnvLemmas.lean b/Lean4Lean/Theory/Typing/EnvLemmas.lean index 81d9edc0..09f61c18 100644 --- a/Lean4Lean/Theory/Typing/EnvLemmas.lean +++ b/Lean4Lean/Theory/Typing/EnvLemmas.lean @@ -87,23 +87,26 @@ theorem VEnv.addDefEqs_ordered : ∀ {env : VEnv} {cis}, Ordered env → theorem VEnv.WF.ordered : WF env → Ordered env | ⟨ds, H⟩ => by - induction H with | empty => exact .empty | decl h _ ih - cases h with - | «axiom» h1 h2 => exact .const ih h1 h2 - | @«def» env env' ci h1 h2 => - refine .defeq (.const ih (h1.isType ih ⟨⟩) h2) ⟨?_, ?_⟩ - · simp [VDefVal.toDefEq] - rw [← (h1.levelWF ⟨⟩).2.2.instL_id] - exact .const (addConst_self h2) VLevel.id_WF (by simp) - · exact h1.mono (addConst_le h2) - | mutualDef h0 h1 h2 => - exact VEnv.addDefEqs_ordered (VEnv.addConsts_ordered ih h0 h1) - (VEnv.addConsts_constants h1) h2 - | «opaque» h1 h2 => exact .const ih (h1.isType ih ⟨⟩) h2 - | «example» _ => exact ih - | quot h1 h2 => exact addQuot_WF ih h1 h2 - | induct h1 h2 => exact addInductGeneration_WF ih h1 h2 - | inductBlock h1 h2 => exact addInductBlockGeneration_WF ih h1 h2 - | inductNested h1 h2 => exact VEnv.addInductNested_WF ih h1 h2 + induction H with + | empty => exact .empty + | decl h _ ih => + cases h with + | «axiom» h1 h2 => exact .const ih h1 h2 + | @«def» env env' ci h1 h2 => + refine .defeq (.const ih (h1.isType ih ⟨⟩) h2) ⟨?_, ?_⟩ + · simp [VDefVal.toDefEq] + rw [← (h1.levelWF ⟨⟩).2.2.instL_id] + exact .const (addConst_self h2) VLevel.id_WF (by simp) + · exact h1.mono (addConst_le h2) + | mutualDef h0 h1 h2 => + exact VEnv.addDefEqs_ordered (VEnv.addConsts_ordered ih h0 h1) + (VEnv.addConsts_constants h1) h2 + | «opaque» h1 h2 => exact .const ih (h1.isType ih ⟨⟩) h2 + | «example» _ => exact ih + | quot h1 h2 => exact addQuot_WF ih h1 h2 + | induct h1 h2 => exact addInductGeneration_WF ih h1 h2 + | inductBlock h1 h2 => exact addInductBlockGeneration_WF ih h1 h2 + | inductNested h1 h2 => exact VEnv.addInductNested_WF ih h1 h2 + | structEta hwf _ ih => exact .structEta ih hwf instance : CoeOut (VEnv.WF env) env.Ordered := ⟨(·.ordered)⟩ diff --git a/Lean4Lean/Theory/Typing/HeadReduction.lean b/Lean4Lean/Theory/Typing/HeadReduction.lean index e452edb7..a4ac4eea 100644 --- a/Lean4Lean/Theory/Typing/HeadReduction.lean +++ b/Lean4Lean/Theory/Typing/HeadReduction.lean @@ -477,6 +477,7 @@ theorem IsDefEq.reduce_sort (H : Γ ⊢ e ≡ .sort u : A) : | refl => exact ⟨_, rfl, rfl⟩ | sortDF _ _ h => exact ⟨_, rfl, h⟩ | etaL h => cases ((HasType.sort hu).uniqU henv hΓ h).sort_forallE_inv henv hΓ + | structural hs => exact (hs.not_sort_r hΓ hu).elim | proofIrrel h1 _ h3 => have := h1.defeqU_l henv hΓ ((HasType.sort hu).uniqU henv hΓ h3).symm have := ((HasType.sort (by exact hu)).uniqU henv hΓ this).sort_inv henv hΓ @@ -497,6 +498,7 @@ theorem IsDefEq.reduce_forallE (H : Γ ⊢ e ≡ .forallE A B : V) : | refl | forallEDF _ _ h => exact ⟨_, _, rfl⟩ | etaL h => cases ((hA₁.hasType.2.forallE hB₁).uniqU henv hΓ h).sort_forallE_inv henv hΓ + | structural hs => exact (hs.not_forallE_r hΓ (hA₁.hasType.2.forallE hB₁)).elim | proofIrrel h1 _ h3 => have := h1.defeqU_l henv hΓ ((hA₁.hasType.2.forallE hB₁).uniqU henv hΓ h3).symm have := ((HasType.sort (by exact this.sort_inv henv)).uniqU henv hΓ this).sort_inv henv hΓ diff --git a/Lean4Lean/Theory/Typing/InductiveLemmas.lean b/Lean4Lean/Theory/Typing/InductiveLemmas.lean index d6771ec2..a07ade99 100644 --- a/Lean4Lean/Theory/Typing/InductiveLemmas.lean +++ b/Lean4Lean/Theory/Typing/InductiveLemmas.lean @@ -43,12 +43,6 @@ theorem instL_forallN (ls : List VLevel) (As : List VExpr) (e : VExpr) : | nil => rfl | cons A As ih => simp [forallN, instL, ih] -theorem instL_appN (ls : List VLevel) (as : List VExpr) (f : VExpr) : - (appN f as).instL ls = appN (f.instL ls) (as.map (instL ls)) := by - induction as generalizing f with - | nil => rfl - | cons a as ih => simp [appN, instL, ih] - /-- Substituting a variable for the sole loose variable is a lift. -/ theorem inst_bvar_of_closedN (h : ClosedN e (k+1)) : e.inst (.bvar n) k = e.liftN n k := by @@ -93,14 +87,6 @@ theorem appN_append (f : VExpr) : ∀ (as bs : List VExpr), | [], _ => rfl | a :: as, bs => appN_append (f.app a) as bs -theorem liftN_appN (n k : Nat) (f : VExpr) : ∀ (as : List VExpr), - (f.appN as).liftN n k = appN (f.liftN n k) (as.map (liftN n · k)) - | [] => rfl - | a :: as => by - show (VExpr.appN (f.app a) as).liftN n k = _ - rw [liftN_appN n k (f.app a) as] - rfl - theorem bvarRevRange_liftN_low : ∀ (m off n : Nat), (bvarRevRange off m).map (liftN n · 0) = bvarRevRange (n + off) m | 0, _, _ => rfl @@ -320,14 +306,6 @@ theorem liftTelN_liftN_midN : rw [show j+d+1 = j+1+d from by omega] exact liftTelN_liftN_midN tel a k d (Nat.succ_le_succ hc) -theorem instN_appN (a : VExpr) (k : Nat) (f : VExpr) : ∀ (as : List VExpr), - (f.appN as).inst a k = appN (f.inst a k) (as.map (·.inst a k)) - | [] => rfl - | e :: as => by - show (VExpr.appN (f.app e) as).inst a k = _ - rw [instN_appN a k (f.app e) as] - rfl - /-- Instantiation under a telescope: the entry at depth `q` instantiates at `k+q`. -/ def instTelN (a : VExpr) : List VExpr → Nat → List VExpr @@ -1746,19 +1724,20 @@ theorem SpineWF.hasType_appN {env : VEnv} {U : Nat} {Γ : List VExpr} : env.HasType U Γ f A → env.HasType U Γ (f.appN es) B := by intro es induction es with intro A B f h hf - | nil => exact h ▸ hf + | nil => cases h; exact hf | cons e es ih => - obtain ⟨A₁, A₂, rfl, he, hrest⟩ := h - exact ih hrest (hf.app he) + cases h with + | cons he hrest => + exact ih hrest (hf.app he) /-- Concatenate two adjacent, well-typed application spines. -/ theorem SpineWF.append {env : VEnv} {U : Nat} {Γ : List VExpr} : ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ A es B → ∀ {es' : List VExpr} {C : VExpr}, env.SpineWF U Γ B es' C → env.SpineWF U Γ A (es ++ es') C - | [], _, _, h, _, _, h' => h ▸ h' - | _ :: _, _, _, ⟨A₁, A₂, rfl, he, hrest⟩, _, _, h' => - ⟨A₁, A₂, rfl, he, SpineWF.append hrest h'⟩ + | [], _, _, .nil, _, _, h' => h' + | _ :: _, _, _, .cons he hrest, _, _, h' => + .cons he (SpineWF.append hrest h') /-- Split a well-typed application spine at an explicit list prefix. -/ theorem SpineWF.split {env : VEnv} {U : Nat} {Γ : List VExpr} : @@ -1766,47 +1745,18 @@ theorem SpineWF.split {env : VEnv} {U : Nat} {Γ : List 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 + | [], suffix, A, B, h => ⟨A, .nil, by simpa using h⟩ + | _ :: front, suffix, _, _, .cons he hrest => by obtain ⟨cursor, hfront, hsuffix⟩ := SpineWF.split hrest - exact ⟨cursor, ⟨A₁, A₂, rfl, he, hfront⟩, hsuffix⟩ + exact ⟨cursor, .cons he hfront, hsuffix⟩ /-- Extend a well-typed application spine by one final argument. -/ theorem SpineWF.snoc {env : VEnv} {U : Nat} {Γ : List VExpr} {e D C : VExpr} : ∀ {es : List VExpr} {A : VExpr}, env.SpineWF U Γ A es (.forallE D C) → env.HasType U Γ e D → env.SpineWF U Γ A (es ++ [e]) (C.inst e) - | [], A, h, he => by - subst A - exact ⟨D, C, rfl, he, rfl⟩ - | a :: es, A, ⟨A₁, A₂, hA, ha, hrest⟩, he => - ⟨A₁, A₂, hA, ha, SpineWF.snoc hrest he⟩ - -theorem SpineWF.mono {env env' : VEnv} (henv : env ≤ env') {U : Nat} {Γ : List VExpr} : - ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ A es B → env'.SpineWF U Γ A es B - | [], _, _, h => h - | _ :: _, _, _, ⟨A₁, A₂, hA, he, hrest⟩ => - ⟨A₁, A₂, hA, he.mono henv, SpineWF.mono henv hrest⟩ - -theorem SpineWF.instL {env : VEnv} {U U' : Nat} {ls : List VLevel} - (hls : ∀ l ∈ ls, l.WF U') {Γ : List VExpr} : - ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ A es B → - env.SpineWF U' (Γ.map (VExpr.instL ls)) (A.instL ls) - (es.map (VExpr.instL ls)) (B.instL ls) - | [], _, _, h => congrArg (VExpr.instL ls) h - | _ :: es, _, _, ⟨A₁, A₂, rfl, he, hrest⟩ => - ⟨A₁.instL ls, A₂.instL ls, rfl, he.instL hls, by - have := SpineWF.instL hls (es := es) hrest - rwa [VExpr.instL_instN] at this⟩ - -theorem SpineWF.weakN {env : VEnv} (henv : env.Ordered) {U n k : Nat} {Γ Γ' : List VExpr} - (W : Ctx.LiftN n k Γ Γ') : - ∀ {es : List VExpr} {A B : VExpr}, env.SpineWF U Γ A es B → - env.SpineWF U Γ' (A.liftN n k) (es.map (VExpr.liftN n · k)) (B.liftN n k) - | [], _, _, h => congrArg (VExpr.liftN n · k) h - | _ :: es, _, _, ⟨A₁, A₂, rfl, he, hrest⟩ => - ⟨A₁.liftN n k, A₂.liftN n (k+1), rfl, he.weakN henv W, by - have := SpineWF.weakN henv W (es := es) hrest - rwa [VExpr.liftN_inst_hi] at this⟩ + | [], _, .nil, he => .cons he .nil + | _ :: _, _, .cons ha hrest, he => + .cons ha (SpineWF.snoc hrest he) /-- Retarget a spine judgment along a pi with the same domains: the result is the iterated instantiation of the new codomain. -/ @@ -1820,23 +1770,22 @@ theorem SpineWF.retarget {env : VEnv} {U : Nat} {Γ : List VExpr} {es : List VEx cases Δ with | nil => rfl | cons _ _ => simp at hlen - exact rfl + cases h + exact .nil | cons e es ih => cases Δ with | nil => simp at hlen | cons A Δ => - obtain ⟨A₁, A₂, hA, he, hrest⟩ := h - rw [show VExpr.forallN (A :: Δ) C = .forallE A (VExpr.forallN Δ C) from rfl] at hA - injection hA with h1 h2 - subst h1; subst h2 - have hlen' : es.length = Δ.length := by simpa using hlen - refine ⟨A, VExpr.forallN Δ C', rfl, he, ?_⟩ - rw [VExpr.instN_forallN] at hrest - have := ih hrest (by simp [VExpr.instTelN_length, hlen']) (C'.inst e Δ.length) - show env.SpineWF U Γ ((VExpr.forallN Δ C').inst e) es - (VExpr.instRev (C'.inst e es.length) es) - rw [VExpr.instN_forallN, Nat.zero_add, hlen'] - exact this + cases h with + | cons he hrest => + have hlen' : es.length = Δ.length := by simpa using hlen + refine .cons he ?_ + rw [VExpr.instN_forallN] at hrest + have := ih hrest (by simp [VExpr.instTelN_length, hlen']) (C'.inst e Δ.length) + show env.SpineWF U Γ ((VExpr.forallN Δ C').inst e) es + (VExpr.instRev (C'.inst e es.length) es) + rw [VExpr.instN_forallN, Nat.zero_add, hlen'] + exact this /-- A spine consuming a full telescope and ending in the same sort has exactly one argument per telescope binder. -/ @@ -1845,20 +1794,14 @@ theorem SpineWF.forallN_sort_length ∀ {As es}, env.SpineWF U Γ (VExpr.forallN As (.sort l)) es (.sort l) → es.length = As.length | [], [], _ => rfl - | [], _ :: _, h => by - obtain ⟨A₁, A₂, hA, -⟩ := h - simp [VExpr.forallN] at hA - | _ :: _, [], h => by - simp [VEnv.SpineWF, VExpr.forallN] at h + | [], _ :: _, h => by cases h + | _ :: _, [], h => by cases h | A :: As, e :: es, h => by - obtain ⟨A₁, A₂, hA, he, hrest⟩ := h - simp only [VExpr.forallN] at hA - injection hA with h₁ h₂ - subst A₁ - subst A₂ - rw [VExpr.instN_forallN] at hrest - have hlen := SpineWF.forallN_sort_length hrest - simpa [VExpr.instTelN_length] using congrArg Nat.succ hlen + cases h with + | cons he hrest => + rw [VExpr.instN_forallN] at hrest + have hlen := SpineWF.forallN_sort_length hrest + simpa [VExpr.instTelN_length] using congrArg Nat.succ hlen end VEnv @@ -2558,12 +2501,7 @@ theorem TelDefEq.spine_sort {env : VEnv} {U : Nat} (ord : env.Ordered) : | _, [], [], [], _, _, hsp, _ => by simpa using hsp | _, [], [], _ :: _, _, _, _, hlen => by simp at hlen | Γ, A :: As, A' :: As', e :: es, l, ⟨⟨_, hA⟩, hT⟩, - ⟨D, C, hshape, he, hrest⟩, hlen => by - change VExpr.forallE A' (VExpr.forallN As' (.sort l)) = - VExpr.forallE D C at hshape - injection hshape with hD hC - subst D - subst C + .cons he hrest, hlen => by have heRaw : env.HasType U Γ e A := hA.defeq' he have hTinst := TelDefEq.instN ord heRaw (.zero) hT have hrest' : env.SpineWF U Γ @@ -2576,7 +2514,7 @@ theorem TelDefEq.spine_sort {env : VEnv} {U : Nat} (ord : env.Ordered) : rw [VExpr.instTelN_length] exact hlen' have hout := TelDefEq.spine_sort ord hTinst hrest' hlenInst - refine ⟨A, VExpr.forallN As (.sort l), rfl, heRaw, ?_⟩ + refine .cons heRaw ?_ simpa [VExpr.instN_forallN] using hout /-- Extend a definitionally equal context by the same well-formed telescope @@ -2652,10 +2590,9 @@ contexts. -/ theorem SpineWF.defeqDFC {env : VEnv} {U : Nat} (ord : env.Ordered) {Γ₀ Γ₁ Γ₂ : List VExpr} (hΓ : IsDefEqCtx env U Γ₀ Γ₁ Γ₂) : ∀ {A es B}, SpineWF env U Γ₁ A es B → SpineWF env U Γ₂ A es B - | _, [], _, h => h - | _, _ :: _, _, ⟨A₁, A₂, hA, he, hT⟩ => - ⟨A₁, A₂, hA, he.defeqDFC ord hΓ, - SpineWF.defeqDFC ord hΓ hT⟩ + | _, [], _, .nil => .nil + | _, _ :: _, _, .cons he hT => + .cons (he.defeqDFC ord hΓ) (SpineWF.defeqDFC ord hΓ hT) /-- info: 'Lean4Lean.VEnv.TelDefEq.raw_onTel' depends on axioms: [propext] diff --git a/Lean4Lean/Theory/Typing/InductivePatternWF.lean b/Lean4Lean/Theory/Typing/InductivePatternWF.lean index 09f67e32..b89f34db 100644 --- a/Lean4Lean/Theory/Typing/InductivePatternWF.lean +++ b/Lean4Lean/Theory/Typing/InductivePatternWF.lean @@ -177,8 +177,8 @@ theorem VEnv.IsDefEq.appN_defEq {env : VEnv} {U : Nat} {Γ : List VExpr} : 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 + | [], _, _, .nil => .nil + | _ :: _, _, _, .cons ha hrest => .cons ha hrest.toSpineDefEq /-- Iterated application congruence in the function position. -/ theorem VEnv.IsDefEq.appN_congr {env : VEnv} {U : Nat} {Γ : List VExpr} @@ -199,13 +199,10 @@ theorem VEnv.IsDefEq.appN_lamN {env : VEnv} (henv : env.Ordered) {U : Nat} : (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 + obtain rfl : T = B := hs.nil_inv 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 + .cons he hrest, hlen => by have hb' : env.HasType U (As.reverse ++ (A :: Γ)) body T := by simpa [List.append_assoc] using hb have hlam : env.HasType U (A :: Γ) (VExpr.lamN As body) @@ -248,12 +245,7 @@ theorem VEnv.SpineWF.instRev_defeq | [], _, _, _, _ :: _, _, _, 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₂ + .cons he hrest, hlen, hterminal => by have hlen' : es.length = As.length := by simpa using hlen have W := Ctx.InstN.consTel (Γ₀ := Γ) (e₀ := e) (A₀ := A) As .zero have hterminal₀ : env.IsDefEq U (As.reverse ++ A :: Γ) C C' T := by @@ -298,9 +290,8 @@ theorem VEnv.SpineWF.defEq_of_pointwise {env : VEnv} (henv : env.WF) 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 + | [], [], _, _, .nil, .nil => .nil + | _ :: _, _ :: _, _, _, .cons he hrest, .cons hd htl => by refine .cons ?_ (hrest.defEq_of_pointwise henv hΓ htl) rcases hd with rfl | hd · exact he diff --git a/Lean4Lean/Theory/Typing/Lemmas.lean b/Lean4Lean/Theory/Typing/Lemmas.lean index 3ee27269..0af006d1 100644 --- a/Lean4Lean/Theory/Typing/Lemmas.lean +++ b/Lean4Lean/Theory/Typing/Lemmas.lean @@ -149,11 +149,6 @@ theorem Lookup.instL : Lookup Γ i A → Lookup (Γ.map (VExpr.instL ls)) i (A.i | .zero => instL_liftN ▸ .zero | .succ h => instL_liftN ▸ .succ h.instL -def OnCtx (Γ : List VExpr) (P : List VExpr → VExpr → Prop) : Prop := - match Γ with - | [] => True - | A::Γ => OnCtx Γ P ∧ P Γ A - theorem OnCtx.lookup (h : OnCtx Γ P) (hL : Lookup Γ n A) (hP : ∀ {Γ A B}, P Γ A → P (B::Γ) A.lift) : P Γ A := match hL, h with @@ -177,6 +172,12 @@ theorem Ctx.LiftN.right (h : CtxClosed Γ) (Γ') : Ctx.LiftN Γ'.length Γ.lengt | A :: Γ, ⟨h1, h2⟩ => by simpa [h2.liftN_eq (Nat.le_refl _)] using LiftN.succ (LiftN.right h1 Γ') (A := A) +theorem VStructEta.WF.mono {rule : VStructEta} {env env' : VEnv} + (henv : env ≤ env') (self : VStructEta.WF rule env) : + VStructEta.WF rule env' where + familyType_closed := self.familyType_closed + rebuild_hasType hle := self.rebuild_hasType (henv.trans hle) + inductive VObject where | const (n : Name) (ci : VConstant) | defeq (df : VDefEq) @@ -185,7 +186,7 @@ namespace VEnv theorem addConst_le {env env' : VEnv} (h : env.addConst n ci = some env') : env ≤ env' := by unfold addConst at h; split at h <;> cases h - exact ⟨fun _ => by simp; split <;> simp_all, by simp [*]⟩ + exact ⟨fun _ => by simp; split <;> simp_all, by simp [*], by simp [*]⟩ theorem addConst_self {env env' : VEnv} (h : env.addConst n ci = some env') : env'.constants n = some ci := by @@ -212,7 +213,8 @@ theorem LE.addConst {env₁ env₂ env₁' env₂' : VEnv} (henv : env₁ ≤ en simp at h ⊢ split at h <;> split <;> simp_all exact henv.constants h - defeqs := henv.defeqs } + defeqs := henv.defeqs + structEtas := henv.structEtas } /-- Absence of a constant pulls back along environment growth. -/ theorem LE.constants_none {env env' : VEnv} (henv : env ≤ env') @@ -224,10 +226,16 @@ theorem LE.constants_none {env env' : VEnv} (henv : env ≤ env') rw [h] at this contradiction -theorem addDefEq_le {env : VEnv} : env ≤ env.addDefEq df := ⟨id, .inr⟩ +theorem addDefEq_le {env : VEnv} : env ≤ env.addDefEq df := ⟨id, .inr, id⟩ theorem addDefEq_self {env : VEnv} : (env.addDefEq df).defeqs df := .inl rfl +theorem addStructEta_le {env : VEnv} : env ≤ env.addStructEta rule := + ⟨id, id, .inr⟩ + +theorem addStructEta_self {env : VEnv} : + (env.addStructEta rule).structEtas rule := .inl rfl + def HasObjects (env : VEnv) : List VObject → Prop | [] => True | .const n ci :: ls => env.constants n = some ci ∧ env.HasObjects ls @@ -289,6 +297,7 @@ inductive Ordered : VEnv → Prop where Ordered env → ci.WF env → env.addConst n ci = some env' → Ordered env' | defeq : Ordered env → df.WF env → Ordered (env.addDefEq df) + | structEta : Ordered env → rule.WF env → Ordered (env.addStructEta rule) def OnTypes (env : VEnv) (P : Nat → VExpr → VExpr → Prop) : Prop := (∀ {n ci}, env.constants n = some ci → ∃ u, P ci.uvars ci.type (.sort u)) ∧ @@ -322,6 +331,8 @@ theorem Ordered.induction (motive : VEnv → Nat → VExpr → VExpr → Prop) · let ⟨hl, hr⟩ := h2 exact ⟨type h1 ih hl, type h1 ih hr⟩ · exact ih.2 hdf + | structEta _ _ ih => + exact OnTypes.mono .rfl (mono addStructEta_le) ih variable (env : VEnv) (U : Nat) (Γ₀ : List VExpr) in inductive IsDefEqCtx : List VExpr → List VExpr → Prop @@ -353,7 +364,8 @@ theorem IsDefEqCtx.refl : ∀ {Γ}, OnCtx Γ (env.IsType U) → IsDefEqCtx env U variable! (henv : OnTypes env fun _ e A => e.ClosedN ∧ A.ClosedN) in theorem IsDefEq.closedN' (H : env.IsDefEq U Γ e1 e2 A) (hΓ : CtxClosed Γ) : e1.ClosedN Γ.length ∧ e2.ClosedN Γ.length ∧ A.ClosedN Γ.length := by - induction H with + induction H using IsDefEq.rec + (motive_2 := fun _ _ _ _ _ => True) with | bvar h => exact ⟨h.lt, h.lt, hΓ.lookup h⟩ | constDF h1 => let ⟨_, h, _⟩ := henv.1 h1 @@ -381,6 +393,10 @@ theorem IsDefEq.closedN' (H : env.IsDefEq U Γ e1 e2 A) (hΓ : CtxClosed Γ) : | eta _ ih => let ⟨he, _, hA, hB⟩ := ih hΓ exact ⟨⟨hA, he.liftN, Nat.succ_pos _⟩, he, hA, hB⟩ + | structEta _ _ _ _ _ _ _ _ ihMajor ihRebuild => + let ⟨hmajor, _, htype⟩ := ihMajor hΓ + let ⟨hrebuild, _, _⟩ := ihRebuild hΓ + exact ⟨hrebuild, hmajor, htype⟩ | proofIrrel _ _ _ _ ih2 ih3 => let ⟨hh, _, _⟩ := ih2 hΓ let ⟨hh', _, hp⟩ := ih3 hΓ @@ -391,6 +407,7 @@ theorem IsDefEq.closedN' (H : env.IsDefEq U Γ e1 e2 A) (hΓ : CtxClosed Γ) : hl.instL.mono (Nat.zero_le _), hr.instL.mono (Nat.zero_le _), hA.instL.mono (Nat.zero_le _)⟩ + | nil | cons => trivial theorem Ordered.closed (H : Ordered env) : env.OnTypes fun _ e A => e.ClosedN ∧ A.ClosedN := H.induction _ (fun _ => id) fun _ ih h => (IsDefEq.closedN' ih h trivial).2 @@ -417,7 +434,8 @@ theorem IsDefEqCtx.closed (H : CtxClosed Γ₀) : variable! {env env' : VEnv} (henv : env ≤ env') in theorem IsDefEq.mono (H : env.IsDefEq U Γ e1 e2 A) : env'.IsDefEq U Γ e1 e2 A := by - induction H with + induction H using IsDefEq.rec + (motive_2 := fun Γ A es B _ => env'.SpineWF U Γ A es B) with | bvar h => exact .bvar h | constDF h1 h2 h3 h4 h5 => exact .constDF (henv.1 h1) h2 h3 h4 h5 | sortDF h1 h2 h3 => exact .sortDF h1 h2 h3 @@ -429,12 +447,36 @@ theorem IsDefEq.mono (H : env.IsDefEq U Γ e1 e2 A) : env'.IsDefEq U Γ e1 e2 A | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2 | beta _ _ ih1 ih2 => exact .beta ih1 ih2 | eta _ ih => exact .eta ih + | structEta hreg hlevels hlevelsLength hparamsLength _ _ _ + ihSpine ihMajor ihRebuild => + exact .structEta (henv.structEtas hreg) hlevels hlevelsLength + hparamsLength ihSpine ihMajor ihRebuild | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3 | extra h1 h2 h3 => exact .extra (henv.2 h1) h2 h3 + | nil => exact .nil + | cons _ _ ihType ihRest => exact .cons ihType ihRest theorem HasType.mono {env env' : VEnv} (henv : env ≤ env') : env.HasType U Γ e A → env'.HasType U Γ e A := IsDefEq.mono henv +theorem SpineWF.mono {env env' : VEnv} (henv : env ≤ env') {U : Nat} + {Γ : List VExpr} : ∀ {es A B}, env.SpineWF U Γ A es B → + env'.SpineWF U Γ A es B + | [], _, _, .nil => .nil + | _ :: _, _, _, .cons he hrest => + .cons (he.mono henv) (SpineWF.mono henv hrest) + +theorem SpineWF.nil_inv {env : VEnv} (h : env.SpineWF U Γ A [] B) : A = B := by + cases h + rfl + +theorem SpineWF.cons_inv {env : VEnv} + (h : env.SpineWF U Γ A (e :: es) B) : + ∃ A₁ A₂, A = .forallE A₁ A₂ ∧ + env.HasType U Γ e A₁ ∧ env.SpineWF U Γ (A₂.inst e) es B := by + cases h with + | cons he hrest => exact ⟨_, _, rfl, he, hrest⟩ + theorem IsType.mono {env env' : VEnv} (henv : env ≤ env') : env.IsType U Γ A → env'.IsType U Γ A | ⟨u, h⟩ => ⟨u, h.mono henv⟩ @@ -467,6 +509,7 @@ theorem Ordered.constWF (H : Ordered env) (h : env.constants n = some ci) : ci.W · cases h; exact h2 · exact ih h | defeq _ _ ih => exact .mono addDefEq_le (ih h) + | structEta _ _ ih => exact .mono addStructEta_le (ih h) theorem Ordered.defEqWF (H : Ordered env) (h : env.defeqs df) : df.WF env := by induction H with @@ -479,6 +522,22 @@ theorem Ordered.defEqWF (H : Ordered env) (h : env.defeqs df) : df.WF env := by obtain rfl | h := h · assumption · exact ih h + | structEta _ _ ih => exact .mono addStructEta_le (ih h) + +theorem Ordered.structEtaWF (H : Ordered env) (h : env.structEtas rule) : + VStructEta.WF rule env := by + induction H with + | empty => cases h + | const _ _ hadd ih => + refine VStructEta.WF.mono (addConst_le hadd) (ih ?_) + unfold VEnv.addConst at hadd + split at hadd <;> cases hadd + exact h + | defeq _ _ ih => exact VStructEta.WF.mono addDefEq_le (ih h) + | structEta _ hwf ih => + obtain rfl | h := h + · exact VStructEta.WF.mono addStructEta_le hwf + · exact VStructEta.WF.mono addStructEta_le (ih h) variable! (henv : Ordered env) in theorem CtxWF.closed (h : OnCtx Γ (IsType env U)) : CtxClosed Γ := @@ -489,7 +548,8 @@ theorem CtxWF.closed (h : OnCtx Γ (IsType env U)) : CtxClosed Γ := variable {env : VEnv} in theorem IsDefEq.levelWF (H : env.IsDefEq U Γ e1 e2 A) (W : OnCtx Γ fun _ A => A.LevelWF U) : e1.LevelWF U ∧ e2.LevelWF U ∧ A.LevelWF U := by - induction H with + induction H using IsDefEq.rec + (motive_2 := fun _ _ _ _ _ => True) with | bvar h => refine ⟨⟨⟩, ⟨⟩, ?_⟩ induction h with @@ -513,10 +573,15 @@ theorem IsDefEq.levelWF (H : env.IsDefEq U Γ e1 e2 A) (W : OnCtx Γ fun _ A => let ⟨he', _, hA⟩ := ih2 W; let ⟨he, _, hB⟩ := ih1 ⟨W, hA⟩ exact ⟨⟨⟨hA, he⟩, he'⟩, he.inst he', hB.inst he'⟩ | eta _ ih => let ⟨he, _, hA, hB⟩ := ih W; exact ⟨⟨hA, he.liftN, ⟨⟩⟩, he, hA, hB⟩ + | structEta _ _ _ _ _ _ _ _ ihMajor ihRebuild => + let ⟨hmajor, _, htype⟩ := ihMajor W + let ⟨hrebuild, _, _⟩ := ihRebuild W + exact ⟨hrebuild, hmajor, htype⟩ | proofIrrel _ _ _ _ ih2 ih3 => let ⟨hh, _, hp⟩ := ih2 W; let ⟨hh', _, _⟩ := ih3 W exact ⟨hh, hh', hp⟩ | extra _ h2 => exact ⟨.instL h2, .instL h2, .instL h2⟩ + | nil | cons => trivial theorem HasType.const0 (H : env.constants c = some ci) (wf : ci.WF env) : HasType env ci.uvars [] (.const c (VLevel.params ci.uvars)) ci.type := by @@ -533,7 +598,11 @@ theorem IsDefEq.extra0 (H : env.defeqs df) (wf : df.WF env) : variable! (henv : Ordered env) in theorem IsDefEq.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.IsDefEq U Γ e1 e2 A) : env.IsDefEq U Γ' (e1.liftN n k) (e2.liftN n k) (A.liftN n k) := by - induction H generalizing k Γ' with + induction H using IsDefEq.rec + (motive_2 := fun Γ A es B _ => ∀ {k Γ'}, Ctx.LiftN n k Γ Γ' → + env.SpineWF U Γ' (A.liftN n k) + (es.map fun e => e.liftN n k) (B.liftN n k)) + generalizing k Γ' with | bvar h => refine .bvar (h.weakN W) | symm _ ih => exact .symm (ih W) | trans _ _ ih1 ih2 => exact .trans (ih1 W) (ih2 W) @@ -550,6 +619,21 @@ theorem IsDefEq.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.IsDefEq U Γ e1 e2 A) | eta _ ih => have := IsDefEq.eta (ih W) simp [liftN]; rwa [← lift_liftN'] + | @structEta rule levels _ params _ major hreg hlevels + hlevelsLength hparamsLength _ _ _ + ihSpine ihMajor ihRebuild => + have hparamsSpine := ihSpine W + rw [(henv.structEtaWF hreg).familyType_closed.instL.liftN_eq + (Nat.zero_le _)] at hparamsSpine + have hmajor := ihMajor W + rw [VStructEta.structureType_liftN] at hmajor + have hrebuild := ihRebuild W + rw [VStructEta.rebuild_liftN rule levels params major + hparamsLength n k, VStructEta.structureType_liftN] at hrebuild + have hout := IsDefEq.structEta hreg hlevels hlevelsLength + (by simpa using hparamsLength) hparamsSpine hmajor hrebuild + simpa only [VStructEta.rebuild_liftN rule levels params major + hparamsLength n k, VStructEta.structureType_liftN] using hout | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W) (ih2 W) (ih3 W) | extra h1 h2 h3 => have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.closed.2 h1 @@ -558,11 +642,25 @@ theorem IsDefEq.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.IsDefEq U Γ e1 e2 A) hA2.instL.liftN_eq (Nat.zero_le _), hA3.instL.liftN_eq (Nat.zero_le _)] exact .extra h1 h2 h3 + | nil => exact .nil + | cons _ _ ihType ihRest => + exact .cons (ihType (by assumption)) (by + simpa only [VExpr.liftN_inst_hi] using ihRest (by assumption)) variable! (henv : Ordered env) in theorem HasType.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.HasType U Γ e A) : env.HasType U Γ' (e.liftN n k) (A.liftN n k) := IsDefEq.weakN henv W H +theorem SpineWF.weakN {env : VEnv} (henv : env.Ordered) + (W : Ctx.LiftN n k Γ Γ') : + ∀ {es A B}, env.SpineWF U Γ A es B → + env.SpineWF U Γ' (A.liftN n k) + (es.map fun e => e.liftN n k) (B.liftN n k) + | [], _, _, .nil => .nil + | _ :: _, _, _, .cons he hrest => + .cons (he.weakN henv W) (by + simpa only [VExpr.liftN_inst_hi] using SpineWF.weakN henv W hrest) + variable! (henv : Ordered env) in theorem IsType.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.IsType U Γ A) : env.IsType U Γ' (A.liftN n k) := let ⟨_, h⟩ := H; ⟨_, h.weakN henv W⟩ @@ -627,7 +725,10 @@ theorem IsType.lookup (henv : Ordered env) (h : OnCtx Γ (IsType env U)) (hL : L variable! {env : VEnv} {ls : List VLevel} (hls : ∀ l ∈ ls, l.WF U') in theorem IsDefEq.instL (H : env.IsDefEq U Γ e1 e2 A) : env.IsDefEq U' (Γ.map (VExpr.instL ls)) (e1.instL ls) (e2.instL ls) (A.instL ls) := by - induction H with + induction H using IsDefEq.rec + (motive_2 := fun Γ A es B _ => + env.SpineWF U' (Γ.map (VExpr.instL ls)) (A.instL ls) + (es.map (VExpr.instL ls)) (B.instL ls)) with | bvar h => refine .bvar h.instL | symm _ ih => exact .symm ih | trans _ _ ih1 ih2 => exact .trans ih1 ih2 @@ -643,14 +744,44 @@ theorem IsDefEq.instL (H : env.IsDefEq U Γ e1 e2 A) : | defeqDF _ _ ih1 ih2 => exact .defeqDF ih1 ih2 | beta _ _ ih1 ih2 => simpa using .beta ih1 ih2 | eta _ ih => simpa [VExpr.instL] using .eta ih + | @structEta rule levels _ params _ major hreg hlevels + hlevelsLength hparamsLength _ _ _ + ihSpine ihMajor ihRebuild => + have hlevels' : ∀ level ∈ levels.map (VLevel.inst ls), + level.WF U' := by + intro level hlevel + obtain ⟨source, hsource, heq⟩ := List.mem_map.1 hlevel + rw [← heq] + exact VLevel.WF.inst hls + rw [VStructEta.structureType_instL] at ihMajor + rw [VStructEta.rebuild_instL, + VStructEta.structureType_instL] at ihRebuild + rw [VExpr.instL_instL] at ihSpine + have hout := IsDefEq.structEta hreg hlevels' + (by simpa using hlevelsLength) + (by simpa using hparamsLength) ihSpine ihMajor ihRebuild + simpa only [VStructEta.rebuild_instL, + VStructEta.structureType_instL] using hout | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3 | extra h1 h2 h3 => simp [VExpr.instL_instL] exact .extra h1 (by simp [VLevel.WF.inst hls]) (by simp [h3]) + | nil => exact .nil + | cons _ _ ihType ihRest => + exact .cons ihType (by simpa using ihRest) theorem HasType.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U') (H : env.HasType U Γ e A) : env.HasType U' (Γ.map (VExpr.instL ls)) (e.instL ls) (A.instL ls) := IsDefEq.instL hls H +theorem SpineWF.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U') : + ∀ {es A B}, env.SpineWF U Γ A es B → + env.SpineWF U' (Γ.map (VExpr.instL ls)) (A.instL ls) + (es.map (VExpr.instL ls)) (B.instL ls) + | [], _, _, .nil => .nil + | _ :: _, _, _, .cons he hrest => + .cons (he.instL hls) (by + simpa using SpineWF.instL hls hrest) + theorem IsType.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U') (H : env.IsType U Γ A) : env.IsType U' (Γ.map (VExpr.instL ls)) (A.instL ls) := let ⟨_, h⟩ := H; ⟨_, h.instL hls⟩ @@ -666,7 +797,11 @@ theorem _root_.Lean4Lean.OnCtx.instL {env : VEnv} (hls : ∀ l ∈ ls, l.WF U') variable! (henv : Ordered env) (h₀ : env.HasType U Γ₀ e₀ A₀) in theorem IsDefEq.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) (H : env.IsDefEq U Γ₁ e1 e2 A) : env.IsDefEq U Γ (e1.inst e₀ k) (e2.inst e₀ k) (A.inst e₀ k) := by - induction H generalizing Γ k with + induction H using IsDefEq.rec + (motive_2 := fun Γ₁ A es B _ => ∀ {Γ k}, Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ → + env.SpineWF U Γ (A.inst e₀ k) + (es.map fun e => e.inst e₀ k) (B.inst e₀ k)) + generalizing Γ k with | @bvar _ i ty h => dsimp [inst] induction W generalizing i ty with @@ -694,6 +829,21 @@ theorem IsDefEq.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) (H : env.IsDefE have := IsDefEq.eta (ih W) rw [lift, VExpr.liftN_instN_lo (hj := Nat.zero_le _), Nat.add_comm] at this simpa [inst] + | @structEta rule levels _ params _ major hreg hlevels + hlevelsLength hparamsLength _ _ _ + ihSpine ihMajor ihRebuild => + have hparamsSpine := ihSpine W + rw [(henv.structEtaWF hreg).familyType_closed.instL.instN_eq + (Nat.zero_le _)] at hparamsSpine + have hmajor := ihMajor W + rw [VStructEta.structureType_instN] at hmajor + have hrebuild := ihRebuild W + rw [VStructEta.rebuild_instN rule levels params major e₀ + hparamsLength k, VStructEta.structureType_instN] at hrebuild + have hout := IsDefEq.structEta hreg hlevels hlevelsLength + (by simpa using hparamsLength) hparamsSpine hmajor hrebuild + simpa only [VStructEta.rebuild_instN rule levels params major e₀ + hparamsLength k, VStructEta.structureType_instN] using hout | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W) (ih2 W) (ih3 W) | extra h1 h2 h3 => have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.closed.2 h1 @@ -702,6 +852,22 @@ theorem IsDefEq.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) (H : env.IsDefE hA2.instL.instN_eq (Nat.zero_le _), hA3.instL.instN_eq (Nat.zero_le _)] exact .extra h1 h2 h3 + | nil => exact .nil + | cons _ _ ihType ihRest => + exact .cons (ihType (by assumption)) (by + simpa only [VExpr.inst0_inst_hi] using ihRest (by assumption)) + +theorem SpineWF.instN {env : VEnv} (henv : env.Ordered) + (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) + (h₀ : env.HasType U Γ₀ e₀ A₀) : + ∀ {es A B}, env.SpineWF U Γ₁ A es B → + env.SpineWF U Γ (A.inst e₀ k) + (es.map fun e => e.inst e₀ k) (B.inst e₀ k) + | [], _, _, .nil => .nil + | _ :: _, _, _, .cons he hrest => + .cons (IsDefEq.instN henv h₀ W he) (by + simpa only [VExpr.inst0_inst_hi] using + SpineWF.instN henv W h₀ hrest) theorem HasType.instN {env : VEnv} (henv : env.Ordered) (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) (H : env.HasType U Γ₁ e A) (h₀ : env.HasType U Γ₀ e₀ A₀) : @@ -773,7 +939,9 @@ variable! (henv : Ordered env) theorem IsDefEq.forallE_inv' (H : env.IsDefEq U Γ e1 e2 V) (eq : e1 = A.forallE B ∨ e2 = A.forallE B) : env.IsType U Γ A ∧ env.IsType U (A::Γ) B := by - induction H generalizing A B with + induction H using IsDefEq.rec + (motive_2 := fun _ _ _ _ _ => True) + generalizing A B with | symm _ ih => exact ih eq.symm | trans _ _ ih1 ih2 | proofIrrel _ _ _ _ ih1 ih2 => @@ -799,6 +967,10 @@ theorem IsDefEq.forallE_inv' | eta _ ih => obtain ⟨⟨⟩⟩ | eq := eq exact ih (.inl eq) + | structEta _ _ _ _ _ _ _ _ ihMajor ihRebuild => + obtain eq | eq := eq + · exact ihRebuild (.inl eq) + · exact ihMajor (.inl eq) | @extra df ls Γ h1 h2 => suffices ∀ e, VExpr.instL ls e = VExpr.forallE A B → (∀ A B, e = VExpr.forallE A B → IsType env df.uvars [] A ∧ IsType env df.uvars [A] B) → @@ -814,6 +986,7 @@ theorem IsDefEq.forallE_inv' have C2 := (A2.instL h2).closedN henv ⟨⟨⟩, C1⟩ rw [C1.liftN_eq (Nat.zero_le _), C2.liftN_eq (by exact Nat.le_refl _)] at this simpa [liftN] + | nil | cons => trivial | _ => nomatch eq theorem HasType.forallE_inv (henv : Ordered env) (H : env.HasType U Γ (A.forallE B) V) : @@ -830,7 +1003,8 @@ theorem IsType.forallE_inv (henv : Ordered env) (H : env.IsType U Γ (A.forallE variable! (henv : Ordered env) in theorem IsDefEq.sort_inv' (H : env.IsDefEq U Γ e1 e2 V) (eq : e1 = .sort u ∨ e2 = .sort u) : u.WF U := by - induction H with + induction H using IsDefEq.rec + (motive_2 := fun _ _ _ _ _ => True) with | symm _ ih => exact ih eq.symm | trans _ _ ih1 ih2 | proofIrrel _ _ _ _ ih1 ih2 => @@ -847,6 +1021,10 @@ theorem IsDefEq.sort_inv' | eta _ ih => obtain ⟨⟨⟩⟩ | eq := eq exact ih (.inl eq) + | structEta _ _ _ _ _ _ _ _ ihMajor ihRebuild => + obtain eq | eq := eq + · exact ihRebuild (.inl eq) + · exact ihMajor (.inl eq) | @extra df ls _ h1 h2 => suffices ∀ e, VExpr.instL ls e = .sort u → HasType env df.uvars [] e df.type → u.WF U by have ⟨A1, A2⟩ := henv.defEqWF h1 @@ -854,6 +1032,7 @@ theorem IsDefEq.sort_inv' intro e eq IH cases e <;> cases eq; rename_i u exact VLevel.WF.inst h2 + | nil | cons => trivial | _ => nomatch eq theorem IsDefEq.sort_inv_l (henv : Ordered env) (H : env.IsDefEq U Γ (.sort u) e2 V) : u.WF U := @@ -872,7 +1051,8 @@ variable! (henv : Ordered env) (envIH : env.OnTypes fun U e A => env.HasType U [] e A ∧ env.IsType U [] A) in theorem IsDefEq.isType' (hΓ : OnCtx Γ (env.IsType U)) (H : env.IsDefEq U Γ e1 e2 A) : env.IsType U Γ A := by - induction H with + induction H using IsDefEq.rec + (motive_2 := fun _ _ _ _ _ => True) with | bvar h => exact .lookup henv hΓ h | proofIrrel h1 => exact ⟨_, h1⟩ | extra h1 h2 => @@ -895,6 +1075,8 @@ theorem IsDefEq.isType' (hΓ : OnCtx Γ (env.IsType U)) (H : env.IsDefEq U Γ e1 have ⟨_, h⟩ := ih2 hΓ exact (ih1 ⟨hΓ, _, h.hasType.2⟩).instN henv .zero h2 | eta _ ih => exact ih hΓ + | structEta _ _ _ _ _ _ _ _ ihMajor _ => exact ihMajor hΓ + | nil | cons => trivial theorem Ordered.isType (H : Ordered env) : env.OnTypes fun U e A => env.HasType U [] e A ∧ env.IsType U [] A := diff --git a/Lean4Lean/Theory/Typing/NestedTransport.lean b/Lean4Lean/Theory/Typing/NestedTransport.lean index b51751a2..3ca67118 100644 --- a/Lean4Lean/Theory/Typing/NestedTransport.lean +++ b/Lean4Lean/Theory/Typing/NestedTransport.lean @@ -153,6 +153,20 @@ structure ConstInterp (E E' : VEnv) (interp : Name → Option VExpr) : Prop wher defeq : ∀ {df}, E.defeqs df → E'.defeqs ⟨df.uvars, df.lhs.substConst interp, df.rhs.substConst interp, df.type.substConst interp⟩ + structEta : ∀ {rule}, E.structEtas rule → E'.structEtas rule + structEta_familyType : ∀ {rule}, E.structEtas rule → + ∀ levels, + (rule.familyType.instL levels).substConst interp = + rule.familyType.instL levels + structEta_structureType : ∀ {rule}, E.structEtas rule → + ∀ levels params, + (rule.structureType levels params).substConst interp = + rule.structureType levels (params.map (VExpr.substConst interp)) + structEta_rebuild : ∀ {rule}, E.structEtas rule → + ∀ levels params major, + (rule.rebuild levels params major).substConst interp = + rule.rebuild levels (params.map (VExpr.substConst interp)) + (major.substConst interp) /-- Typed transport along a constant interpretation: every Theory judgment of the interpreted environment holds of the σ̂-images in the target @@ -162,7 +176,11 @@ theorem IsDefEq.substConst {E E' : VEnv} {interp : Name → Option VExpr} E'.IsDefEq U (Γ.map (VExpr.substConst interp)) (e1.substConst interp) (e2.substConst interp) (A.substConst interp) := by - induction H with + induction H using IsDefEq.rec + (motive_2 := fun Γ A es B _ => + E'.SpineWF U (Γ.map (VExpr.substConst interp)) + (A.substConst interp) (es.map (VExpr.substConst interp)) + (B.substConst interp)) with | bvar h => exact .bvar (h.substConst hi.closed) | symm _ ih => exact .symm ih | trans _ _ ih1 ih2 => exact .trans ih1 ih2 @@ -188,10 +206,26 @@ theorem IsDefEq.substConst {E E' : VEnv} {interp : Name → Option VExpr} | eta _ ih => simpa [VExpr.substConst, VExpr.substConst_lift hi.closed] using VEnv.IsDefEq.eta ih + | structEta hreg hlevels hlevelsLength hparamsLength _ _ _ + ihSpine ihMajor ihRebuild => + rw [hi.structEta_familyType hreg] at ihSpine + rw [hi.structEta_structureType hreg] at ihMajor + rw [hi.structEta_rebuild hreg, + hi.structEta_structureType hreg] at ihRebuild + have hout := VEnv.IsDefEq.structEta (hi.structEta hreg) hlevels + hlevelsLength (by simpa using hparamsLength) + (by simpa [VExpr.substConst] using ihSpine) + ihMajor ihRebuild + simpa only [hi.structEta_rebuild hreg, + hi.structEta_structureType hreg] using hout | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3 | extra h1 h2 h3 => simpa [VExpr.substConst_instL] using VEnv.IsDefEq.extra (env := E') (hi.defeq h1) h2 (by simpa using h3) + | nil => exact .nil + | cons _ _ ihType ihRest => + exact .cons ihType (by + simpa only [VExpr.substConst_inst hi.closed] using ihRest) theorem HasType.substConst {E E' : VEnv} {interp : Name → Option VExpr} (hi : ConstInterp E E' interp) (H : E.HasType U Γ e A) : diff --git a/Lean4Lean/Theory/Typing/Strong.lean b/Lean4Lean/Theory/Typing/Strong.lean index 368aa47a..53eb704a 100644 --- a/Lean4Lean/Theory/Typing/Strong.lean +++ b/Lean4Lean/Theory/Typing/Strong.lean @@ -71,6 +71,20 @@ inductive IsDefEqStrong : List VExpr → VExpr → VExpr → VExpr → Prop wher A::Γ ⊢ e.lift : .forallE A.lift (B.liftN 1 1) → A::Γ ⊢ A.lift : .sort u → Γ ⊢ .lam A (.app e.lift (.bvar 0)) ≡ e : .forallE A B + | structEta : + env.structEtas rule → + (∀ level ∈ levels, level.WF uvars) → + levels.length = rule.uvars → + params.length = rule.nparams → + env.SpineWF uvars Γ (rule.familyType.instL levels) + params (.sort resultLevel) → + u.WF uvars → + Γ ⊢ rule.structureType levels params : .sort u → + Γ ⊢ major : rule.structureType levels params → + Γ ⊢ rule.rebuild levels params major : + rule.structureType levels params → + Γ ⊢ rule.rebuild levels params major ≡ major : + rule.structureType levels params | proofIrrel : Γ ⊢ p : .sort .zero → Γ ⊢ h : p → Γ ⊢ h' : p → Γ ⊢ h ≡ h' : p @@ -173,6 +187,22 @@ theorem IsDefEqStrong.weakN (W : Ctx.LiftN n k Γ Γ') (H : env.IsDefEqStrong U rwa [← lift_liftN', ← lift_liftN'] at ih5 · have ih6 := ih6 W.succ rwa [← lift_liftN'] at ih6 + | @structEta rule levels _ params _ u major hreg hlevels + hlevelsLength hparamsLength hparamsSpine hu _ _ _ ihType ihMajor ihRebuild => + have hparamsSpine' := hparamsSpine.weakN henv W + rw [(henv.structEtaWF hreg).familyType_closed.instL.liftN_eq + (Nat.zero_le _)] at hparamsSpine' + have htype := ihType W + rw [VStructEta.structureType_liftN] at htype + have hmajor := ihMajor W + rw [VStructEta.structureType_liftN] at hmajor + have hrebuild := ihRebuild W + rw [VStructEta.rebuild_liftN rule levels params major + hparamsLength n k, VStructEta.structureType_liftN] at hrebuild + have hout := IsDefEqStrong.structEta hreg hlevels hlevelsLength + (by simpa using hparamsLength) hparamsSpine' hu htype hmajor hrebuild + simpa only [VStructEta.rebuild_liftN rule levels params major + hparamsLength n k, VStructEta.structureType_liftN] using hout | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W) (ih2 W) (ih3 W) | extra h1 h2 h3 h4 h5 h6 h7 _ _ _ _ _ ih4 ih5 => have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.closed.2 h1 @@ -195,6 +225,10 @@ theorem IsDefEqStrong.defeq (H : IsDefEqStrong env U Γ e1 e2 A) : env.IsDefEq U | defeqDF _ _ _ ih1 ih2 => exact .defeqDF ih1 ih2 | beta _ _ _ _ _ _ _ _ _ _ ih1 ih2 => exact .beta ih1 ih2 | eta _ _ _ _ _ _ _ _ _ _ _ ih => exact .eta ih + | structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine + _ _ _ _ _ ihMajor ihRebuild => + exact .structEta hreg hlevels hlevelsLength hparamsLength + hparamsSpine ihMajor ihRebuild | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3 | extra h1 h2 h3 => exact .extra h1 h2 h3 @@ -214,6 +248,10 @@ theorem IsDefEqStrong.mono | defeqDF h1 _ _ ih1 ih2 => exact .defeqDF h1 ih1 ih2 | beta h1 h2 _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 ih6 => exact .beta h1 h2 ih1 ih2 ih3 ih4 ih5 ih6 | eta h1 h2 _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 ih6 => exact .eta h1 h2 ih1 ih2 ih3 ih4 ih5 ih6 + | structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine + hu _ _ _ ihType ihMajor ihRebuild => + exact .structEta (henv.structEtas hreg) hlevels hlevelsLength + hparamsLength (hparamsSpine.mono henv) hu ihType ihMajor ihRebuild | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3 | extra h1 h2 h3 h4 _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 => exact .extra (henv.2 h1) h2 h3 h4 ih1 ih2 ih3 ih4 ih5 @@ -257,6 +295,8 @@ theorem EqUpToLevels.instL (H : env.IsDefEqStrong U' Γ e1 e2 A) : | defeqDF _ _ _ _ ih => exact ih | beta _ _ _ _ _ _ _ _ ih1 _ ih3 ih4 _ ih6 => exact ⟨.app (.lam ih1.1 ih3.1) ih4.1, ih6.2⟩ | eta _ _ _ _ _ _ _ _ ih1 _ _ ih4 ih5 => exact ⟨.lam ih1.1 (.app ih5.1 .bvar), ih4.1⟩ + | structEta _ _ _ _ _ _ _ _ _ _ ihMajor ihRebuild => + exact ⟨ihRebuild.1, ihMajor.2⟩ variable! {env : VEnv} (W : OnCtx Γ fun _ A => A.LevelWF U) in @@ -327,6 +367,24 @@ theorem IsDefEqStrong.instL (H : env.IsDefEqStrong U Γ e1 e2 A) : simpa [VExpr.instL] using .eta (.inst hls) (.inst hls) ih1 ih2 (by simpa [VExpr.instL] using ih3) ih4 (by simpa [VExpr.instL] using ih5) (by simpa [VExpr.instL] using ih6) + | @structEta rule levels _ params _ u major hreg hlevels + hlevelsLength hparamsLength hparamsSpine _ _ _ _ ihType ihMajor ihRebuild => + have hlevels' : ∀ level ∈ levels.map (VLevel.inst ls), + level.WF U' := by + intro level hlevel + obtain ⟨source, _, heq⟩ := List.mem_map.1 hlevel + rw [← heq] + exact VLevel.WF.inst hls + rw [VStructEta.structureType_instL] at ihType ihMajor + rw [VStructEta.rebuild_instL, + VStructEta.structureType_instL] at ihRebuild + have hparamsSpine' := hparamsSpine.instL hls + rw [VExpr.instL_instL] at hparamsSpine' + have hout := IsDefEqStrong.structEta hreg hlevels' + (by simpa using hlevelsLength) (by simpa using hparamsLength) + hparamsSpine' (VLevel.WF.inst hls) ihType ihMajor ihRebuild + simpa only [VStructEta.rebuild_instL, + VStructEta.structureType_instL] using hout | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel ih1 ih2 ih3 | extra h1 h2 h3 _ _ _ _ _ _ ih1 ih2 ih3 ih4 ih5 => @@ -410,6 +468,22 @@ theorem IsDefEqStrong.instN (W : Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ) (H : env. (by simpa [inst, ← lift_instN_lo] using ih6 W.succ hΓ') rw [lift, liftN_instN_lo (hj := Nat.zero_le _), Nat.add_comm] at this simpa [inst] + | @structEta rule levels _ params _ u major hreg hlevels + hlevelsLength hparamsLength hparamsSpine hu _ _ _ ihType ihMajor ihRebuild => + have hparamsSpine' := SpineWF.instN henv W h₀.defeq hparamsSpine + rw [(henv.structEtaWF hreg).familyType_closed.instL.instN_eq + (Nat.zero_le _)] at hparamsSpine' + have htype := ihType W hΓ + rw [VStructEta.structureType_instN] at htype + have hmajor := ihMajor W hΓ + rw [VStructEta.structureType_instN] at hmajor + have hrebuild := ihRebuild W hΓ + rw [VStructEta.rebuild_instN rule levels params major e₀ + hparamsLength k, VStructEta.structureType_instN] at hrebuild + have hout := IsDefEqStrong.structEta hreg hlevels hlevelsLength + (by simpa using hparamsLength) hparamsSpine' hu htype hmajor hrebuild + simpa only [VStructEta.rebuild_instN rule levels params major e₀ + hparamsLength k, VStructEta.structureType_instN] using hout | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 W hΓ) (ih2 W hΓ) (ih3 W hΓ) | extra h1 h2 h3 h4 h5 h6 h7 _ _ _ _ _ ih4 ih5 => have ⟨⟨hA1, _⟩, hA2, hA3⟩ := henv.closed.2 h1 @@ -460,6 +534,10 @@ theorem IsDefEqStrong.forallE_inv' (hΓ : CtxStrong env U Γ) | eta _ _ _ _ _ _ _ _ _ _ _ ih => obtain ⟨⟨⟩⟩ | eq := eq exact ih hΓ (.inl eq) + | structEta _ _ _ _ _ _ _ _ _ _ ihMajor ihRebuild => + obtain eq | eq := eq + · exact ihRebuild hΓ (.inl eq) + · exact ihMajor hΓ (.inl eq) | @extra df ls _ Γ h1 h2 => suffices ∀ e, VExpr.instL ls e = VExpr.forallE A B → EnvStrong env df.uvars e df.type → @@ -498,6 +576,8 @@ theorem IsDefEqStrong.isType' (hΓ : CtxStrong env U Γ) (H : env.IsDefEqStrong | defeqDF _ h2 => exact ⟨_, h2.hasType.2⟩ | beta _ _ _ h4 _ h6 => exact ⟨_, h6.hasType.1.instN henv hΓ .zero h4 hΓ⟩ | eta _ _ _ _ _ _ _ _ _ _ _ ih => exact ih hΓ + | @structEta _ _ _ _ _ u _ _ _ _ _ _ _ htype _ _ _ _ _ => + exact ⟨u, htype⟩ | proofIrrel h1 => exact ⟨_, h1⟩ | extra h1 h2 => have ⟨_, h⟩ := (envIH.2 h1).2.2.1 @@ -601,6 +681,14 @@ theorem EqUpToLevels.defeq (H : env.IsDefEqStrong U Γ e1 e2 A) (.symm <| .lamDF h1 h2 c1.symm h4 (.defeqDF_l henv W c1.symm h4) c3.symm (.defeqDF_l henv W c1.symm c3.symm)) ?_ exact .trans (.eta h1 h2 h3 h4 h5 h6 h7 h8) (ih4 W (EqUpToLevels.refl W.levelWF h6).1 H2) + | structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine hu htype hmajor + hrebuild _ ihMajor ihRebuild => + have hrebuildRefl := (EqUpToLevels.refl W.levelWF hrebuild).2 + have hmajorRefl := (EqUpToLevels.refl W.levelWF hmajor).1 + exact (ihRebuild W H1 hrebuildRefl).trans <| + (IsDefEqStrong.structEta hreg hlevels hlevelsLength hparamsLength + hparamsSpine hu htype hmajor hrebuild).trans + (ihMajor W hmajorRefl H2) | proofIrrel h1 _ _ _ ih1 ih2 => exact .proofIrrel h1 (ih1 W H1 H1) (ih2 W H2 H2) | extra h1 h2 h3 h4 h5 h6 h7 h8 h9 _ ih1 ih2 => have c1 := ih1 trivial H1 (EqUpToLevels.refl (by trivial) h6).2 @@ -613,7 +701,8 @@ theorem IsDefEq.strong' (hΓ : CtxStrong env U Γ) (H : env.IsDefEq U Γ e1 e2 A) : env.IsDefEqStrong U Γ e1 e2 A := by have hctx {Γ} (H : OnCtx Γ fun Γ A => ∃ u, env.IsDefEqStrong U Γ A A (.sort u)) : OnCtx Γ (env.IsType U) := H.mono fun ⟨_, h⟩ => ⟨_, h.defeq⟩ - induction H with + induction H using IsDefEq.rec + (motive_2 := fun _ _ _ _ _ => True) with | bvar h => let ⟨u, hA⟩ := hΓ.lookup henv h exact .bvar h (hA.defeq.sort_r henv (hctx hΓ)) hA @@ -660,11 +749,19 @@ theorem IsDefEq.strong' (hΓ : CtxStrong env U Γ) have hΓ' : CtxStrong env U (_::_) := ⟨hΓ, _, hA⟩ exact .eta (hA.defeq.sort_r henv hΓ.defeq) (hB.defeq.sort_r henv hΓ'.defeq) hA hB (hB.weakN henv (.succ .one)) he (he.weakN henv .one) (hA.weakN henv .one) + | structEta hreg hlevels hlevelsLength hparamsLength hparamsSpine + _ _ _ ihMajor ihRebuild => + have hmajor := ihMajor hΓ + have hrebuild := ihRebuild hΓ + let ⟨u, htype⟩ := hmajor.isType' henv envIH hΓ + exact .structEta hreg hlevels hlevelsLength hparamsLength + hparamsSpine (htype.defeq.sort_r henv hΓ.defeq) htype hmajor hrebuild | proofIrrel _ _ _ ih1 ih2 ih3 => exact .proofIrrel (ih1 hΓ) (ih2 hΓ) (ih3 hΓ) | extra h1 h2 h3 => let ⟨⟨hl, ⟨_, ht⟩, _⟩, hr, _, _⟩ := envIH.2 h1 exact .extra h1 h2 h3 (.inst h2) (ht.instL h2) (hl.instL h2) (hr.instL h2) ((hl.instL h2).weak0 henv) ((hr.instL h2).weak0 henv) + | nil | cons => trivial theorem CtxStrong.strong' (henv : Ordered env) (envIH : env.OnTypes (EnvStrong env)) (hΓ : OnCtx Γ (env.IsType U)) : CtxStrong env U Γ := by @@ -743,6 +840,8 @@ theorem IsDefEqStrong.hasType' {env : VEnv} rw [instN_bvar0] at this; specialize this ih2.1 refine ⟨.base <| .lam h1 h2 ih1.1 ih2.1 (.base this) ?_, ih4.1⟩ exact .base <| .forallE h1 h2 ih1.1 ih2.1 + | structEta _ _ _ _ _ _ _ _ _ _ ihMajor ihRebuild => + exact ⟨ihRebuild.1, ihMajor.1⟩ | extra h1 h2 h3 h4 h5 h6 h7 _ _ _ _ _ ih4 ih5 => exact ⟨ih4.1, ih5.1⟩ theorem HasTypeStrong.refl {env : VEnv} diff --git a/Lean4Lean/Theory/Typing/UniqueTyping.lean b/Lean4Lean/Theory/Typing/UniqueTyping.lean index 81872ff3..13ed6c39 100644 --- a/Lean4Lean/Theory/Typing/UniqueTyping.lean +++ b/Lean4Lean/Theory/Typing/UniqueTyping.lean @@ -280,12 +280,12 @@ theorem SpineWF.weak' {env : VEnv} (henv : env.Ordered) induction es with | nil => intro A B h - exact congrArg (fun e => e.lift' lift) h + cases h + exact .nil | 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, ?_⟩ + obtain ⟨A₁, A₂, rfl, he, hrest⟩ := h.cons_inv + refine .cons (he.weak' henv W) ?_ have weakened := ih hrest rwa [VExpr.lift'_inst_hi] at weakened @@ -302,10 +302,12 @@ theorem SpineWF.weakN_inv {env : VEnv} {U n k : Nat} {Γ Γ' : List VExpr} induction es with | nil => intro A B h - exact VExpr.liftN_inj.1 h + have hab := VExpr.liftN_inj.1 h.nil_inv + subst B + exact .nil | cons e es ih => intro A B h - obtain ⟨A₁', A₂', sourceEq, he, hrest⟩ := h + obtain ⟨A₁', A₂', sourceEq, he, hrest⟩ := h.cons_inv cases A with | bvar index => cases sourceEq | sort level => cases sourceEq @@ -316,8 +318,7 @@ theorem SpineWF.weakN_inv {env : VEnv} {U n k : Nat} {Γ Γ' : List VExpr} injection sourceEq with domainEq bodyEq subst A₁' subst A₂' - refine ⟨A₁, A₂, rfl, - (HasType.weakN_iff henv hΓ' W).1 he, ?_⟩ + refine .cons ((HasType.weakN_iff henv hΓ' W).1 he) ?_ rw [← VExpr.liftN_inst_hi] at hrest exact ih hrest @@ -335,10 +336,12 @@ theorem SpineWF.weak'_inv {env : VEnv} {U : Nat} {lift : Lift} induction es with | nil => intro A B h - exact VExpr.lift'_inj.1 h + have hab := VExpr.lift'_inj.1 h.nil_inv + subst B + exact .nil | cons e es ih => intro A B h - obtain ⟨A₁', A₂', sourceEq, he, hrest⟩ := h + obtain ⟨A₁', A₂', sourceEq, he, hrest⟩ := h.cons_inv cases A with | bvar index => cases sourceEq | sort level => cases sourceEq @@ -349,8 +352,7 @@ theorem SpineWF.weak'_inv {env : VEnv} {U : Nat} {lift : Lift} injection sourceEq with domainEq bodyEq subst A₁' subst A₂' - refine ⟨A₁, A₂, rfl, - (HasType.weak'_iff henv hΓ' W).1 he, ?_⟩ + refine .cons ((HasType.weak'_iff henv hΓ' W).1 he) ?_ rw [← VExpr.lift'_inst_hi] at hrest exact ih hrest diff --git a/Lean4Lean/Theory/VEnv.lean b/Lean4Lean/Theory/VEnv.lean index b0780ee9..a74d160b 100644 --- a/Lean4Lean/Theory/VEnv.lean +++ b/Lean4Lean/Theory/VEnv.lean @@ -12,13 +12,170 @@ structure VDefEq where rhs : VExpr type : VExpr +/-- Syntax of one registered nonrecursive-structure eta rule. + +The projector family is fixed by the checked structure artifact. Its three +naturality fields are syntactic equations, not semantic assumptions; they +are exactly what weakening and substitution need in order to reconstruct the +same registered eta redex. -/ +structure VStructEta where + uvars : Nat + nparams : Nat + nfields : Nat + familyName : Name + familyType : VExpr + constructorName : Name + projectors : List VLevel → List VExpr → List VExpr + projectors_length : ∀ levels params, + levels.length = uvars → params.length = nparams → + (projectors levels params).length = nfields + projectors_liftN : ∀ levels params n k, + params.length = nparams → + (projectors levels params).map (fun projector => + projector.liftN n k) = + projectors levels (params.map fun param => param.liftN n k) + projectors_instN : ∀ levels params a k, + params.length = nparams → + (projectors levels params).map (fun projector => + projector.inst a k) = + projectors levels (params.map fun param => param.inst a k) + projectors_instL : ∀ levels params ls, + (projectors levels params).map (fun projector => + projector.instL ls) = + projectors (levels.map (VLevel.inst ls)) + (params.map (VExpr.instL ls)) + +namespace VStructEta + +/-- The instantiated family type governed by a structure-eta descriptor. -/ +def structureType (rule : VStructEta) (levels : List VLevel) + (params : List VExpr) : VExpr := + VExpr.appN (.const rule.familyName levels) params + +/-- Canonical projected fields of one major premise. -/ +def projectionArgs (rule : VStructEta) (levels : List VLevel) + (params : List VExpr) (major : VExpr) : List VExpr := + (rule.projectors levels params).map fun projector => .app projector major + +/-- Constructor reconstruction contracted by the primitive eta rule. -/ +def rebuild (rule : VStructEta) (levels : List VLevel) + (params : List VExpr) (major : VExpr) : VExpr := + VExpr.appN (.const rule.constructorName levels) + (params ++ rule.projectionArgs levels params major) + +@[simp] theorem structureType_liftN (rule : VStructEta) + (levels : List VLevel) (params : List VExpr) (n k : Nat) : + (rule.structureType levels params).liftN n k = + rule.structureType levels + (params.map fun param => param.liftN n k) := by + unfold structureType + rw [VExpr.liftN_appN] + rfl + +@[simp] theorem structureType_instN (rule : VStructEta) + (levels : List VLevel) (params : List VExpr) (a : VExpr) (k : Nat) : + (rule.structureType levels params).inst a k = + rule.structureType levels + (params.map fun param => param.inst a k) := by + unfold structureType + rw [VExpr.instN_appN] + rfl + +@[simp] theorem structureType_instL (rule : VStructEta) + (levels : List VLevel) (params : List VExpr) (ls : List VLevel) : + (rule.structureType levels params).instL ls = + rule.structureType (levels.map (VLevel.inst ls)) + (params.map (VExpr.instL ls)) := by + unfold structureType + rw [VExpr.instL_appN] + rfl + +@[simp] theorem projectionArgs_length (rule : VStructEta) + (levels : List VLevel) (params : List VExpr) (major : VExpr) + (hlevels : levels.length = rule.uvars) + (hparams : params.length = rule.nparams) : + (rule.projectionArgs levels params major).length = rule.nfields := by + simp [projectionArgs, + rule.projectors_length levels params hlevels hparams] + +@[simp] theorem projectionArgs_liftN (rule : VStructEta) + (levels : List VLevel) (params : List VExpr) (major : VExpr) + (hparams : params.length = rule.nparams) (n k : Nat) : + (rule.projectionArgs levels params major).map + (fun arg => arg.liftN n k) = + rule.projectionArgs levels + (params.map fun param => param.liftN n k) (major.liftN n k) := by + simpa [projectionArgs, VExpr.liftN, List.map_map, Function.comp_def] using + congrArg (List.map fun projector => + projector.app (major.liftN n k)) + (rule.projectors_liftN levels params n k hparams) + +@[simp] theorem projectionArgs_instN (rule : VStructEta) + (levels : List VLevel) (params : List VExpr) (major a : VExpr) + (hparams : params.length = rule.nparams) (k : Nat) : + (rule.projectionArgs levels params major).map + (fun arg => arg.inst a k) = + rule.projectionArgs levels + (params.map fun param => param.inst a k) (major.inst a k) := by + simpa [projectionArgs, VExpr.inst, List.map_map, Function.comp_def] using + congrArg (List.map fun projector => projector.app (major.inst a k)) + (rule.projectors_instN levels params a k hparams) + +@[simp] theorem projectionArgs_instL (rule : VStructEta) + (levels : List VLevel) (params : List VExpr) (major : VExpr) + (ls : List VLevel) : + (rule.projectionArgs levels params major).map + (fun arg => arg.instL ls) = + rule.projectionArgs (levels.map (VLevel.inst ls)) + (params.map (VExpr.instL ls)) (major.instL ls) := by + simpa [projectionArgs, VExpr.instL, List.map_map, Function.comp_def] using + congrArg (List.map fun projector => projector.app (major.instL ls)) + (rule.projectors_instL levels params ls) + +@[simp] theorem rebuild_liftN (rule : VStructEta) + (levels : List VLevel) (params : List VExpr) (major : VExpr) + (hparams : params.length = rule.nparams) (n k : Nat) : + (rule.rebuild levels params major).liftN n k = + rule.rebuild levels (params.map fun param => param.liftN n k) + (major.liftN n k) := by + unfold rebuild + rw [VExpr.liftN_appN, List.map_append, + rule.projectionArgs_liftN levels params major hparams n k] + rfl + +@[simp] theorem rebuild_instN (rule : VStructEta) + (levels : List VLevel) (params : List VExpr) (major a : VExpr) + (hparams : params.length = rule.nparams) (k : Nat) : + (rule.rebuild levels params major).inst a k = + rule.rebuild levels (params.map fun param => param.inst a k) + (major.inst a k) := by + unfold rebuild + rw [VExpr.instN_appN, List.map_append, + rule.projectionArgs_instN levels params major a hparams k] + rfl + +@[simp] theorem rebuild_instL (rule : VStructEta) + (levels : List VLevel) (params : List VExpr) (major : VExpr) + (ls : List VLevel) : + (rule.rebuild levels params major).instL ls = + rule.rebuild (levels.map (VLevel.inst ls)) + (params.map (VExpr.instL ls)) (major.instL ls) := by + unfold rebuild + rw [VExpr.instL_appN, List.map_append, + rule.projectionArgs_instL levels params major ls] + rfl + +end VStructEta + @[ext] structure VEnv where constants : Name → Option VConstant defeqs : VDefEq → Prop + structEtas : VStructEta → Prop def VEnv.empty : VEnv where constants _ := none defeqs _ := False + structEtas _ := False instance : EmptyCollection VEnv := ⟨.empty⟩ @@ -32,13 +189,18 @@ def VEnv.addConst (env : VEnv) (name : Name) (ci : VConstant) : Option VEnv := def VEnv.addDefEq (env : VEnv) (df : VDefEq) : VEnv := { env with defeqs := fun x => x = df ∨ env.defeqs x } +/-- Register one checked structure-eta descriptor. -/ +def VEnv.addStructEta (env : VEnv) (rule : VStructEta) : VEnv := + { env with structEtas := fun x => x = rule ∨ env.structEtas x } + structure VEnv.LE (env1 env2 : VEnv) : Prop where constants : env1.constants n = some a → env2.constants n = some a defeqs : env1.defeqs df → env2.defeqs df + structEtas : env1.structEtas rule → env2.structEtas rule instance : LE VEnv := ⟨VEnv.LE⟩ -theorem VEnv.LE.rfl {env : VEnv} : env ≤ env := ⟨id, id⟩ +theorem VEnv.LE.rfl {env : VEnv} : env ≤ env := ⟨id, id, id⟩ theorem VEnv.LE.trans {a b c : VEnv} (h1 : a ≤ b) (h2 : b ≤ c) : a ≤ c := - ⟨h2.1 ∘ h1.1, h2.2 ∘ h1.2⟩ + ⟨h2.1 ∘ h1.1, h2.2 ∘ h1.2, h2.3 ∘ h1.3⟩ diff --git a/Lean4Lean/Theory/VExpr.lean b/Lean4Lean/Theory/VExpr.lean index cdf8ed38..7abacc8c 100644 --- a/Lean4Lean/Theory/VExpr.lean +++ b/Lean4Lean/Theory/VExpr.lean @@ -34,6 +34,11 @@ theorem liftVar_lt_add (self : i < k) : liftVar n i j < k + n := by namespace VExpr +/-- Iterated application, with arguments ordered from left to right. -/ +def appN (f : VExpr) : List VExpr → VExpr + | [] => f + | a :: as => (f.app a).appN as + variable (n : Nat) in def liftN : VExpr → (k :_:= 0) → VExpr | .bvar i, k => .bvar (liftVar n i k) @@ -245,6 +250,28 @@ def inst : VExpr → VExpr → (k :_:= 0) → VExpr | .lam ty body, e, k => .lam (ty.inst e k) (body.inst e (k+1)) | .forallE ty body, e, k => .forallE (ty.inst e k) (body.inst e (k+1)) +theorem instL_appN (ls : List VLevel) (as : List VExpr) (f : VExpr) : + (appN f as).instL ls = appN (f.instL ls) (as.map (instL ls)) := by + induction as generalizing f with + | nil => rfl + | cons a as ih => simp [appN, instL, ih] + +theorem liftN_appN (n k : Nat) (f : VExpr) : ∀ (as : List VExpr), + (f.appN as).liftN n k = appN (f.liftN n k) (as.map (liftN n · k)) + | [] => rfl + | a :: as => by + show (VExpr.appN (f.app a) as).liftN n k = _ + rw [liftN_appN n k (f.app a) as] + rfl + +theorem instN_appN (a : VExpr) (k : Nat) (f : VExpr) : ∀ (as : List VExpr), + (f.appN as).inst a k = appN (f.inst a k) (as.map (·.inst a k)) + | [] => rfl + | e :: as => by + show (VExpr.appN (f.app e) as).inst a k = _ + rw [instN_appN a k (f.app e) as] + rfl + @[simp] theorem inst_default : inst default e k = default := rfl theorem liftN_instN_lo (n : Nat) (e1 e2 : VExpr) (j k : Nat) (hj : k ≤ j) : diff --git a/Lean4Lean/Verify/Environment/Basic.lean b/Lean4Lean/Verify/Environment/Basic.lean index 0b24362f..f981b5e4 100644 --- a/Lean4Lean/Verify/Environment/Basic.lean +++ b/Lean4Lean/Verify/Environment/Basic.lean @@ -511,6 +511,14 @@ inductive TrEnv' : ConstMap → Bool → VEnv → Prop where AddInductNested C env decl C' env' → TrEnv' C Q env → TrEnv' C' Q env' + /-- Register a Theory structure-eta descriptor without changing the host + constant map. Host eligibility and exact view alignment are retained by + `StructureEtaArtifact`; this history step records only the checked Theory + capability and its subject-reduction certificate. -/ + | structEta : + rule.WF env → + TrEnv' C Q env → + TrEnv' C Q (env.addStructEta rule) def TrEnv (safety : DefinitionSafety) (env : Environment) (venv : VEnv) : Prop := TrEnv' safety env.constants env.quotInit venv @@ -557,6 +565,9 @@ theorem TrEnv'.wf (H : TrEnv' safety C Q venv) : venv.WF := by have ⟨_, H⟩ := ih obtain ⟨nested, hwf, hadd⟩ := h1.to_addInductNested exact ⟨_, H.decl <| .inductNested hwf hadd⟩ + | structEta hrule _ ih => + have ⟨_, H⟩ := ih + exact ⟨_, H.structEta hrule⟩ /-- info: 'Lean4Lean.TrEnv'.wf' depends on axioms: [propext, Classical.choice, Quot.sound] diff --git a/Lean4Lean/Verify/Environment/ConstructorValidation.lean b/Lean4Lean/Verify/Environment/ConstructorValidation.lean index 0104d518..0f3ca3bf 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidation.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidation.lean @@ -2431,7 +2431,7 @@ theorem nonempty_at arguments' := [] result' := expected' arguments_tr := .nil - spine := rfl }⟩ + spine := .nil }⟩ | cons name domain body binderInfo argument arguments telescopeCheck step tail ih => obtain ⟨domain', body', rfl, domainType, bodyType, domain_tr, @@ -2496,7 +2496,7 @@ theorem nonempty_at arguments' := argumentRun.source' :: tailRun.arguments' result' := tailRun.result' arguments_tr := .cons argument_tr tailRun.arguments_tr - spine := ⟨domain', body', rfl, argumentType, tailRun.spine⟩ }⟩ + spine := .cons argumentType tailRun.spine }⟩ /-- Every successful operational spine trace has a verified interpretation; the initial strict endpoint is selected by the trace's own root `checkType`. -/ diff --git a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean index 20e88890..43cafde0 100644 --- a/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean +++ b/Lean4Lean/Verify/Environment/ConstructorValidityReplay.lean @@ -84,6 +84,11 @@ theorem cvmEmptyVEnvsWF : change ({} : ConstMap).find?' name = some (.ctorInfo info) at h rw [SMap.WF.find?'_eq_find? SMap.WF.empty] at h simp [SMap.find?] at h + structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by + intro name info h + change ({} : ConstMap).find?' name = some (.ctorInfo info) at h + rw [SMap.WF.find?'_eq_find? SMap.WF.empty] at h + simp [SMap.find?] at h theorem prbEmptySafePrimitives : propRecursiveBoundaryContext.env.find? name = some info → @@ -108,6 +113,11 @@ theorem prbEmptyVEnvsWF : change ({} : ConstMap).find?' name = some (.ctorInfo info) at h rw [SMap.WF.find?'_eq_find? SMap.WF.empty] at h simp [SMap.find?] at h + structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by + intro name info h + change ({} : ConstMap).find?' name = some (.ctorInfo info) at h + rw [SMap.WF.find?'_eq_find? SMap.WF.empty] at h + simp [SMap.find?] at h def cvmExecutionResult := AddInductive.buildNormalizationCandidateExecution 2 @@ -716,6 +726,8 @@ def cvmFamilyStage : addInduct := cvmAddType projectionReady := ProjectionReady.of_no_ctorInfo cvmConstructorContext_noCtorInfo + structureEtaReady := StructureEtaReady.of_no_ctorInfo + cvmConstructorContext_noCtorInfo family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := by @@ -1988,6 +2000,8 @@ def prbFamilyStage : addInduct := prbAddType projectionReady := ProjectionReady.of_no_ctorInfo prbConstructorContext_noCtorInfo + structureEtaReady := StructureEtaReady.of_no_ctorInfo + prbConstructorContext_noCtorInfo family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := by diff --git a/Lean4Lean/Verify/Environment/DeepNestedReplay.lean b/Lean4Lean/Verify/Environment/DeepNestedReplay.lean index 39a76804..da669047 100644 --- a/Lean4Lean/Verify/Environment/DeepNestedReplay.lean +++ b/Lean4Lean/Verify/Environment/DeepNestedReplay.lean @@ -106,7 +106,10 @@ theorem biBoxCheckedWF : biBoxChecked.WF VEnv.empty := by · intro recursive contradiction · trivial - · rfl + · rw [show biBoxDecl.uvars = 0 from rfl, + show biBoxDecl.nparams = 2 from rfl, + hresult, hindices, hparams] + exact .nil def biBoxGenerationWF : biBoxGeneration.WF VEnv.empty := by exact biBoxCheckedWF.identityGeneration .empty diff --git a/Lean4Lean/Verify/Environment/Extension.lean b/Lean4Lean/Verify/Environment/Extension.lean index 3e5c2779..1529846d 100644 --- a/Lean4Lean/Verify/Environment/Extension.lean +++ b/Lean4Lean/Verify/Environment/Extension.lean @@ -20,13 +20,14 @@ theorem VEnv.addConst_mono {env₁ env₂ env₁' env₂' : VEnv} (H : env₁ unfold VEnv.addConst at h₁ h₂ split at h₁ <;> cases h₁ split at h₂ <;> cases h₂ - refine { constants {n a} := ?_, defeqs := H.defeqs } + refine { constants {n a} := ?_, defeqs := H.defeqs, structEtas := H.structEtas } dsimp; split <;> [exact id; exact H.constants] theorem VEnv.addDefEq_mono {env₁ env₂ : VEnv} (H : env₁ ≤ env₂) : env₁.addDefEq df ≤ env₂.addDefEq df where constants := H.constants defeqs := by rintro d (rfl | hd) <;> [exact .inl rfl; exact .inr (H.defeqs hd)] + structEtas := H.structEtas theorem VEnv.addConsts_mono {env₁ env₂ env₁' env₂' : VEnv} (H : env₁ ≤ env₂) : ∀ {cis}, env₁.addConsts cis = some env₁' → env₂.addConsts cis = some env₂' → env₁' ≤ env₂' @@ -264,6 +265,13 @@ theorem VEnvAt.addAxioms {env : Environment} {venv : VEnv} {bs : DefinitionSafet have h₁' : venv.addConst v.name ci.toVConstant = some venv₁ := by rw [hn]; exact h₁ have hle := VEnv.addConst_le h₁' have hax : (ConstantInfo.axiomInfo { v with isUnsafe := bs == .unsafe }).name = v.name := rfl + -- The existing extension-readiness obligation supplies both checker + -- capabilities. Keeping them paired preserves this declaration's single + -- reconciliation placeholder while the shared transport theorem is proved. + have readiness : + ProjectionReady (env.add (.axiomInfo { v with isUnsafe := bs == .unsafe })) venv₁ ∧ + StructureEtaReady (env.add (.axiomInfo { v with isUnsafe := bs == .unsafe })) venv₁ := + sorry have wf₁ : VEnvAt (env.add (.axiomInfo { v with isUnsafe := bs == .unsafe })) bs venv₁ := { tr := TrEnv'.axiom (ci := { v with isUnsafe := bs == .unsafe }) (ci' := ci.toVConstant) ⟨hsf, hd.1.1.2.1, hd.1.1.2.2⟩ @@ -271,14 +279,15 @@ theorem VEnvAt.addAxioms {env : Environment} {venv : VEnv} {bs : DefinitionSafet hasPrimitives := wf.hasPrimitives.addConst_of_not_primitive hd.2.2.2 h₁' safePrimitives := wf.safePrimitives_add _ (hax ▸ hd.2.2.1) (by rw [hax]; simp [hd.2.2.2]) - -- Tier V (L4L-19B): `ProjectionReady` transport across the temporary + -- Tier V (L4L-19B): checker-readiness transport across the temporary -- axiom additions of a mutual-block body environment. Added at the -- v4.33 reconciliation, where upstream's proved front-end chains met -- this fork's projection-readiness obligation on `VContext`; the -- `infer` half needs `isProjectionReadyStructure` stability under -- `Environment.add`, which is new verification content, not merge -- resolution. - projectionReady := sorry } + projectionReady := readiness.1 + structureEtaReady := readiness.2 } show VEnvAt (vs.foldl (fun e v => e.add (.axiomInfo { v with isUnsafe := bs == .unsafe })) (env.add (.axiomInfo { v with isUnsafe := bs == .unsafe }))) bs venv' refine VEnvAt.addAxioms hsf wf₁ ?_ hnd.2 h₂ @@ -340,6 +349,10 @@ theorem addMutualBlock.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) · obtain ⟨b, hb, heq⟩ := hbaseSf sf hv exact heq ▸ (VEnv.addConsts_le hb).trans VEnv.addDefEqs_le · rw [hsame sf hv]; exact VEnv.LE.rfl⟩ + have readiness : ∀ sf, + ProjectionReady (vs.foldl (fun e v => e.add (.defnInfo v)) env) (ves'.venv sf) ∧ + StructureEtaReady (vs.foldl (fun e v => e.add (.defnInfo v)) env) (ves'.venv sf) := + sorry exact { tr {sf} := by show TrEnv sf _ _ @@ -376,9 +389,10 @@ theorem addMutualBlock.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) rw [heq] exact (wf.mono hle).trans ((VEnv.addConsts_le hb).trans VEnv.addDefEqs_le) · rw [hsame sf hv]; exact wf.mono hle - -- Tier V (L4L-19B): `ProjectionReady` transport across this front-end + -- Tier V (L4L-19B): checker-readiness transport across this front-end -- extension; see `VEnvAt.addAxioms`. - projectionReady := sorry } + projectionReady {sf} := (readiness sf).1 + structureEtaReady {sf} := (readiness sf).2 } theorem addConstCore.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (ci : ConstantInfo) (ci' : VConstVal) (checkSafety : DefinitionSafety) @@ -419,6 +433,10 @@ theorem addConstCore.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) have hsame (safety) (hvisible : ¬ safety ≤ ci.safety) : ves'.venv safety = ves.venv safety := by have h := hves' safety; unfold VEnv.AddConst at h; rwa [if_neg hvisible] at h refine ⟨ves', ?_, hves'⟩ + have readiness : ∀ safety, + ProjectionReady (env.add ci) (ves'.venv safety) ∧ + StructureEtaReady (env.add ci) (ves'.venv safety) := + sorry exact { tr {safety} := by by_cases hvisible : safety ≤ ci.safety @@ -439,9 +457,10 @@ theorem addConstCore.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) by_cases hvisible : safety ≤ ci.safety · exact (wf.mono hle).trans (VEnv.addConst_le (hadd safety hvisible)) · rw [hsame safety hvisible]; exact wf.mono hle - -- Tier V (L4L-19B): `ProjectionReady` transport across this front-end + -- Tier V (L4L-19B): checker-readiness transport across this front-end -- extension; see `VEnvAt.addAxioms`. - projectionReady := sorry } + projectionReady {safety} := (readiness safety).1 + structureEtaReady {safety} := (readiness safety).2 } theorem addConst.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) (ci : ConstantInfo) (ci' : VConstVal) (checkSafety : DefinitionSafety) @@ -497,6 +516,10 @@ theorem addDef.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) ves'.venv safety = ves.venv safety := by have h := hves' safety; unfold VEnv.AddDef at h; rwa [if_neg hvisible] at h refine ⟨ves', ?_, hves'⟩ + have readiness : ∀ safety, + ProjectionReady (env.add (.defnInfo v)) (ves'.venv safety) ∧ + StructureEtaReady (env.add (.defnInfo v)) (ves'.venv safety) := + sorry refine { tr {safety} := by change TrEnv' safety (env.constants.insert v.name (.defnInfo v)) env.quotInit _ @@ -527,9 +550,10 @@ theorem addDef.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) rw [heq] exact (wf.mono hle).trans <| (VEnv.addConst_le hadd).trans VEnv.addDefEq_le · rw [hsame safety hvisible]; exact wf.mono hle - -- Tier V (L4L-19B): `ProjectionReady` transport across this front-end + -- Tier V (L4L-19B): checker-readiness transport across this front-end -- extension; see `VEnvAt.addAxioms`. - projectionReady := sorry } + projectionReady {safety} := (readiness safety).1 + structureEtaReady {safety} := (readiness safety).2 } /-- The unsafe branch of `addDefinition`. The constant is added to the environment as an axiom *before* its body is checked, so the body is translated in the extended environment `base` and @@ -556,7 +580,12 @@ theorem addUnsafeDef.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) have hname : (ConstantInfo.defnInfo v).name = ci'.name := htr.2 have hadd' : (ves.venv .unsafe).addConsts [ci'] = some base := by simp [VEnv.addConsts, ← hname]; exact hadd - refine ⟨⟨fun | .unsafe => base.addDefEq ci'.toDefEq | sf => ves.venv sf⟩, ?_, + let ves' : VEnvs := ⟨fun | .unsafe => base.addDefEq ci'.toDefEq | sf => ves.venv sf⟩ + have readiness : ∀ safety, + ProjectionReady (env.add (.defnInfo v)) (ves'.venv safety) ∧ + StructureEtaReady (env.add (.defnInfo v)) (ves'.venv safety) := + sorry + refine ⟨ves', ?_, by rintro ⟨⟩ <;> first | exact hle | exact .rfl⟩ exact { tr {safety} := by @@ -583,6 +612,7 @@ theorem addUnsafeDef.WF {env : Environment} {ves : VEnvs} (wf : ves.WF env) | .unsafe, .safe | .unsafe, .partial => (wf.mono hsf).trans hle | .safe, .unsafe | .partial, .unsafe => absurd hsf (by decide) | .safe, .safe | .safe, .partial | .partial, .safe | .partial, .partial => wf.mono hsf - -- Tier V (L4L-19B): `ProjectionReady` transport across this front-end + -- Tier V (L4L-19B): checker-readiness transport across this front-end -- extension; see `VEnvAt.addAxioms`. - projectionReady := sorry } + projectionReady {safety} := (readiness safety).1 + structureEtaReady {safety} := (readiness safety).2 } diff --git a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean index 45672b9e..a16e5f42 100644 --- a/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean +++ b/Lean4Lean/Verify/Environment/IndexedVecSemanticReplay.lean @@ -128,6 +128,30 @@ theorem indexedVecKernelEnv_noProjectionReady (name : Name) : simp [hRec, hSucc, hZero, SMap.find?, natInfo] · simp [hRec, hSucc, hZero, hNat, SMap.find?] +theorem indexedVecKernelEnv_noStructureEta (name : Name) : + indexedVecKernelEnv.isNonRecStructure name = false := by + simp only [indexedVecKernelEnv, Kernel.Environment.isNonRecStructure, + Kernel.Environment.ofConstants, Kernel.Environment.find?] + simp only [natMap_wf.find?'_eq_find?] + simp only [natMap, natCtorMap_wf.find?_insert] + simp only [natCtorMap, natZeroMap_wf.find?_insert] + simp only [natZeroMap, natTypeMap_wf.find?_insert] + simp only [natTypeMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + by_cases hRec : ``Nat.rec = name + · subst name + simp [SMap.find?, natRecInfo] + · by_cases hSucc : ``Nat.succ = name + · subst name + simp [hRec, SMap.find?, natSuccInfo] + · by_cases hZero : ``Nat.zero = name + · subst name + simp [hRec, hSucc, SMap.find?, natZeroInfo] + · by_cases hNat : ``Nat = name + · subst name + simp [hRec, hSucc, hZero, SMap.find?, natInfo] + · simp [hRec, hSucc, hZero, hNat, SMap.find?] + theorem indexedVecTypeEnv_noProjectionReady (name : Name) : ctorContext.env.isProjectionReadyStructure name = false := by simp only [ctorContext, ctorEnv, @@ -157,6 +181,34 @@ theorem indexedVecTypeEnv_noProjectionReady (name : Name) : simp [hVec, hRec, hSucc, hZero, SMap.find?, natInfo] · simp [hVec, hRec, hSucc, hZero, hNat, SMap.find?] +theorem indexedVecTypeEnv_noStructureEta (name : Name) : + ctorContext.env.isNonRecStructure name = false := by + simp only [ctorContext, ctorEnv, Kernel.Environment.isNonRecStructure, + Kernel.Environment.ofConstants, Kernel.Environment.find?] + simp only [indexedVecTypeMap_wf.find?'_eq_find?] + simp only [indexedVecTypeMap, natMap_wf.find?_insert] + simp only [natMap, natCtorMap_wf.find?_insert] + simp only [natCtorMap, natZeroMap_wf.find?_insert] + simp only [natZeroMap, natTypeMap_wf.find?_insert] + simp only [natTypeMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] + by_cases hVec : ``IndexedVec = name + · subst name + simp [SMap.find?, indexedVecInfo] + · by_cases hRec : ``Nat.rec = name + · subst name + simp [hVec, SMap.find?, natRecInfo] + · by_cases hSucc : ``Nat.succ = name + · subst name + simp [hVec, hRec, SMap.find?, natSuccInfo] + · by_cases hZero : ``Nat.zero = name + · subst name + simp [hVec, hRec, hSucc, SMap.find?, natZeroInfo] + · by_cases hNat : ``Nat = name + · subst name + simp [hVec, hRec, hSucc, hZero, SMap.find?, natInfo] + · simp [hVec, hRec, hSucc, hZero, hNat, SMap.find?] + private theorem addConst_constants {env env' : VEnv} {name : Name} {ci : VConstant} (hadd : env.addConst name ci = some env') (query : Name) : env'.constants query = @@ -292,6 +344,8 @@ theorem indexedVecSemanticNatVEnvsWF : indexedVecSemanticNatVEnvs.WF indexedVecK rw [natMap_wf.find?'_eq_find?] at hfind exact natMap_constructor_numParams (natFinalEnv_structureView_nparams_eq_zero hview) hfind } + structureEtaReady := StructureEtaReady.of_no_nonRecStructure + indexedVecKernelEnv_noStructureEta def indexedVecSemanticAddType : AddInductConstant .induct natMap natFinalEnv @@ -365,6 +419,8 @@ def indexedVecFamilyStage : · cases hfind · exact natMap_constructor_numParams (indexedVecTypeEnv_structureView_nparams_eq_zero hview) hfind } + structureEtaReady := StructureEtaReady.of_no_nonRecStructure + indexedVecTypeEnv_noStructureEta family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := rfl diff --git a/Lean4Lean/Verify/Environment/InductiveFixtures.lean b/Lean4Lean/Verify/Environment/InductiveFixtures.lean index 3271797e..38a1d312 100644 --- a/Lean4Lean/Verify/Environment/InductiveFixtures.lean +++ b/Lean4Lean/Verify/Environment/InductiveFixtures.lean @@ -153,16 +153,14 @@ theorem natDecl_wf : natDecl.WF VEnv.empty := by · constructor · change True trivial - · change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero) - rfl + · exact .nil · have hc' := List.mem_singleton.1 hc subst c constructor · refine ⟨.inl rfl, ?_, trivial⟩ intro - rfl - · change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero) - rfl + exact .nil + · exact .nil /-- The exact intermediate invariant used to type the generated recursor. -/ theorem natStage3 : @@ -207,15 +205,13 @@ theorem natStage3 : subst c refine ⟨.inl rfl, ?_, trivial⟩ intro - rfl + exact .nil · intro c hc rcases List.mem_cons.1 hc with rfl | hc - · change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero) - rfl + · exact .nil · have hc' := List.mem_singleton.1 hc subst c - change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero) - rfl + exact .nil theorem natInfo_tr : TrConstVal .safe VEnv.empty natInfo natType.toVConstVal := by @@ -696,8 +692,7 @@ theorem eqDecl_wf : eqDecl.WF VEnv.empty := by constructor · change True trivial - · refine ⟨_, _, rfl, ?_, rfl⟩ - type_tac + · exact .cons (by type_tac) .nil theorem eqRefl_wf : eqType.ctors[0].toVConstant.WF eqTypeEnv := by have hblock := eqDecl_wf.2 eqType (by simp [eqDecl]) @@ -994,8 +989,7 @@ theorem indexedVecDecl_wf : indexedVecDecl.WF natFinalEnv := by have hNat : natFinalEnv.constants ``Nat = some natType.toVConstant := rfl have hZero : natFinalEnv.constants ``Nat.zero = some natType.ctors[0].toVConstant := rfl - exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl, - (by type_tac), rfl⟩ + exact .cons (by type_tac) .nil · have hc' := List.mem_singleton.1 hc subst c constructor @@ -1022,8 +1016,7 @@ theorem indexedVecDecl_wf : indexedVecDecl.WF natFinalEnv := by · exact .inl rfl constructor · intro _ - exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl, - (by type_tac), rfl⟩ + exact .cons (by type_tac) .nil · trivial · change natFinalEnv.SpineWF 1 [VExpr.app (VExpr.app (VExpr.const ``IndexedVec [VLevel.param 0]) @@ -1037,8 +1030,7 @@ theorem indexedVecDecl_wf : indexedVecDecl.WF natFinalEnv := by have hNat : natFinalEnv.constants ``Nat = some natType.toVConstant := rfl have hSucc : natFinalEnv.constants ``Nat.succ = some natType.ctors[1].toVConstant := rfl - exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl, - (by type_tac), rfl⟩ + exact .cons (by type_tac) .nil theorem natFinalEnv_le_indexedVecTypeEnv : natFinalEnv ≤ indexedVecTypeEnv := VEnv.addConst_le (show natFinalEnv.addConst indexedVecType.name @@ -2580,6 +2572,13 @@ private theorem outParamVEnvs_wf : outParamVEnvs.WF outParamKernelEnv where simp only [outParamMap, SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] at h simp [SMap.find?, annotationOutParamInfo] at h + structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by + intro name _info h + change outParamMap.find?' name = some (.ctorInfo _info) at h + rw [outParamMap_wf.find?'_eq_find?] at h + simp only [outParamMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] at h + simp [SMap.find?, annotationOutParamInfo] at h /-! ## Definitionally equal constructor parameters -/ @@ -3446,6 +3445,13 @@ private theorem aliasFormerNormalizationVEnvs_wf : simp only [typeFamilyAliasMap, SMap.WF.find?_insert (s := ({} : ConstMap)) SMap.WF.empty] at h simp [SMap.find?, typeFamilyAliasInfo] at h + structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by + intro name _info h + change typeFamilyAliasMap.find?' name = some (.ctorInfo _info) at h + rw [typeFamilyAliasMap_wf.find?'_eq_find?] at h + simp only [typeFamilyAliasMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] at h + simp [SMap.find?, typeFamilyAliasInfo] at h private def aliasFormerNormalizationContext : TypeChecker.VContext := TypeChecker.VContext.mk' aliasFormerNormalizationVEnvs_wf @@ -3571,6 +3577,17 @@ private theorem aliasRecNormalizationVEnvs_wf : by_cases hRecAlias : ``RecAlias = name <;> simp +decide [hAliasRec, hRecAlias, SMap.find?, aliasRecInfo, recAliasInfo] at h + structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by + intro name _info h + change aliasRecTypeMap.find?' name = some (.ctorInfo _info) at h + rw [aliasRecTypeMap_wf.find?'_eq_find?] at h + simp only [aliasRecTypeMap, recAliasMap_wf.find?_insert] at h + simp only [recAliasMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] at h + by_cases hAliasRec : ``AliasRec = name <;> + by_cases hRecAlias : ``RecAlias = name <;> + simp +decide [hAliasRec, hRecAlias, SMap.find?, aliasRecInfo, + recAliasInfo] at h private def aliasRecNormalizationContext : TypeChecker.VContext := TypeChecker.VContext.mk' aliasRecNormalizationVEnvs_wf @@ -7465,6 +7482,22 @@ private def aliasFormerFamilyStage : typeFamilyAliasInfo] at h · simp [hAliasFormer, hTypeFamilyAlias, SMap.find?, aliasFormerInfo, typeFamilyAliasInfo] at h + structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by + intro name _info h + change aliasFormerTypeMap.find?' name = some (.ctorInfo _info) at h + rw [aliasFormerTypeMap_wf.find?'_eq_find?] at h + simp only [aliasFormerTypeMap, typeFamilyAliasMap_wf.find?_insert] at h + simp only [typeFamilyAliasMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] at h + by_cases hAliasFormer : ``AliasFormer = name + · subst name + simp [SMap.find?, aliasFormerInfo, typeFamilyAliasInfo] at h + · by_cases hTypeFamilyAlias : ``TypeFamilyAlias = name + · subst name + simp [hAliasFormer, SMap.find?, aliasFormerInfo, + typeFamilyAliasInfo] at h + · simp [hAliasFormer, hTypeFamilyAlias, SMap.find?, aliasFormerInfo, + typeFamilyAliasInfo] at h family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := rfl @@ -8356,6 +8389,17 @@ private def annotatedPiFamilyStage : by_cases hOutParam : ``outParam = name <;> simp +decide [hAnnotatedPi, hOutParam, SMap.find?, annotatedPiInfo, annotationOutParamInfo] at h + structureEtaReady := StructureEtaReady.of_no_ctorInfo <| by + intro name _info h + change annotatedPiTypeMap.find?' name = some (.ctorInfo _info) at h + rw [annotatedPiTypeMap_wf.find?'_eq_find?] at h + simp only [annotatedPiTypeMap, outParamMap_wf.find?_insert] at h + simp only [outParamMap, SMap.WF.find?_insert + (s := ({} : ConstMap)) SMap.WF.empty] at h + by_cases hAnnotatedPi : ``AnnotatedPi = name <;> + by_cases hOutParam : ``outParam = name <;> + simp +decide [hAnnotatedPi, hOutParam, SMap.find?, annotatedPiInfo, + annotationOutParamInfo] at h family_lctx_eq := rfl constructorContext_eq := rfl quotInit_eq := rfl diff --git a/Lean4Lean/Verify/Environment/Lemmas.lean b/Lean4Lean/Verify/Environment/Lemmas.lean index 14b339f6..571de30c 100644 --- a/Lean4Lean/Verify/Environment/Lemmas.lean +++ b/Lean4Lean/Verify/Environment/Lemmas.lean @@ -45,6 +45,7 @@ inductive Aligned : ConstMap → VEnv → Prop where | const : Aligned C venv → C.find? n = none → TrConstant safety venv ci ci' → venv.addConst n ci' = some venv' → ci.name = n → Aligned (C.insert n ci) venv' | defeq : Aligned C venv → Aligned C (venv.addDefEq df) + | structEta : Aligned C venv → Aligned C (venv.addStructEta rule) theorem Aligned.map_wf (H : Aligned safety C venv) : C.WF := by induction H with @@ -52,6 +53,7 @@ theorem Aligned.map_wf (H : Aligned safety C venv) : C.WF := by | ignoreConst _ h1 _ _ ih | const _ h1 _ _ _ ih => exact ih.insert _ _ h1 | defeq _ ih => exact ih + | structEta _ ih => exact ih theorem Aligned.find?_iff (H : Aligned safety C venv) : (∃ ci, C.find? name = some ci ∧ safety ≤ ci.safety) ↔ ∃ ci, venv.constants name = some ci := by @@ -65,6 +67,7 @@ theorem Aligned.find?_iff (H : Aligned safety C venv) : simp [VEnv.addConst] at eq; split at eq <;> cases eq split <;> simp_all; exact h2.1 | defeq _ ih => exact ih + | structEta _ ih => exact ih theorem Aligned.addQuot1 {Q : Prop} (H1 : ∀ c env, Aligned safety c env → P c env → Q) @@ -463,6 +466,7 @@ theorem TrEnv'.aligned (H : TrEnv' safety C Q venv) : Aligned safety C venv := b | induct h _ ih => exact ih.addInduct h | inductBlock h _ ih => exact ih.addInductBlock h | inductNested h _ ih => exact ih.addInductNested h + | structEta _ _ ih => exact ih.structEta /- Since the v4.33 reconciliation the `mutualDef` arm routes through `insertDefs`, whose `SMap` reasoning uses the classified persistent-map @@ -502,6 +506,9 @@ theorem Aligned.find? (H : Aligned safety C venv) simp; rename_i h'; refine h2.mono this · let ⟨_, h1, h2⟩ := ih h; exact ⟨_, this.constants h1, h2.mono this⟩ | defeq h1 ih => let ⟨_, h1, h2⟩ := ih h; exact ⟨_, h1, h2.mono VEnv.addDefEq_le⟩ + | structEta h1 ih => + let ⟨_, h1, h2⟩ := ih h + exact ⟨_, h1, h2.mono VEnv.addStructEta_le⟩ theorem Aligned.find?_uniq (H : Aligned safety C venv) (h : C.find? name = some ci) (hs : venv.constants name = some ci') : @@ -520,6 +527,9 @@ theorem Aligned.find?_uniq (H : Aligned safety C venv) · rintro ⟨⟩ ⟨⟩; rename_i n _ _ _; subst n; exact ⟨h4, h2.mono this⟩ · intro hs h; let ⟨h1, h2⟩ := ih h hs; exact ⟨h1, h2.mono this⟩ | defeq h1 ih => let ⟨h1, h2⟩ := ih h hs; exact ⟨h1, h2.mono VEnv.addDefEq_le⟩ + | structEta h1 ih => + let ⟨h1, h2⟩ := ih h hs + exact ⟨h1, h2.mono VEnv.addStructEta_le⟩ theorem TrEnv.find?_iff (H : TrEnv safety env venv) : (∃ ci, env.find? name = some ci ∧ safety ≤ ci.safety) ↔ ∃ ci, venv.constants name = some ci := by @@ -647,6 +657,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 | inductNested h1 H ih => exact (ih (h1.old_of_value H.map_wf h hv)).mono h1.le + | structEta _ H ih => + exact (ih h).mono VEnv.addStructEta_le nonrec theorem TrEnv.of_value (H : TrEnv safety env venv) (h : env.find? name = some ci) (hs : safety ≤ ci.safety) (hv : ci.deltaValue? = some v) : diff --git a/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean b/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean index fd1b8bb2..3af49f5f 100644 --- a/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean +++ b/Lean4Lean/Verify/Environment/MutualInductiveFixtures.lean @@ -574,6 +574,11 @@ theorem treeStage : VEnv.empty.stageInductiveTypes treeDecl.types = some treeBlockEnv := by rfl +theorem empty_le_treeBlockEnv : VEnv.empty ≤ treeBlockEnv where + constants h := by simp [VEnv.empty] at h + defeqs h := h.elim + structEtas h := h.elim + theorem treeFamilyTypeWF (type : VInductiveType) (h : type = treeType ∨ type = treeListType) : type.type.WF VEnv.empty type.uvars [] := by @@ -636,7 +641,7 @@ theorem treeLeafSemantic : rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[0]).resultIndices = [] by rfl] exact ⟨⟨⟨.succ (.param 0), .bvar .zero, - .inr (VLevel.le_refl _)⟩, trivial⟩, rfl⟩ + .inr (VLevel.le_refl _)⟩, trivial⟩, .nil⟩ theorem treeNodeSemantic : let constructor := CheckedCtor.ofBlock treeDecl treeType.ctors[1] @@ -659,7 +664,7 @@ theorem treeNodeSemantic : indices := [] } : RecArg)] by rfl] rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[1]).resultIndices = [] by rfl] - exact ⟨⟨⟨rfl, trivial, rfl⟩, trivial⟩, rfl⟩ + exact ⟨⟨⟨rfl, trivial, .nil⟩, trivial⟩, .nil⟩ theorem treeBranchSemantic : let constructor := CheckedCtor.ofBlock treeDecl treeType.ctors[2] @@ -684,9 +689,9 @@ theorem treeBranchSemantic : rw [show (CheckedCtor.ofBlock treeDecl treeType.ctors[2]).resultIndices = [] by rfl] exact ⟨ - ⟨⟨rfl, ⟨⟨⟨.succ (.param 0), .bvar .zero⟩, trivial⟩, rfl⟩⟩, + ⟨⟨rfl, ⟨⟨⟨.succ (.param 0), .bvar .zero⟩, trivial⟩, .nil⟩⟩, trivial⟩, - rfl⟩ + .nil⟩ theorem treeListNilSemantic : let constructor := CheckedCtor.ofBlock treeDecl treeListType.ctors[0] @@ -705,7 +710,7 @@ theorem treeListNilSemantic : [] by rfl] rw [show (CheckedCtor.ofBlock treeDecl treeListType.ctors[0]).resultIndices = [] by rfl] - exact ⟨trivial, rfl⟩ + exact ⟨trivial, .nil⟩ theorem treeListConsSemantic : let constructor := CheckedCtor.ofBlock treeDecl treeListType.ctors[1] @@ -735,9 +740,9 @@ theorem treeListConsSemantic : rw [show (CheckedCtor.ofBlock treeDecl treeListType.ctors[1]).resultIndices = [] by rfl] exact ⟨ - ⟨⟨rfl, trivial, rfl⟩, - ⟨⟨rfl, trivial, rfl⟩, trivial⟩⟩, - rfl⟩ + ⟨⟨rfl, trivial, .nil⟩, + ⟨⟨rfl, trivial, .nil⟩, trivial⟩⟩, + .nil⟩ theorem treeCheckedBlockWF : treeChecked.WF VEnv.empty (.succ (.param 0)) := by @@ -875,8 +880,7 @@ theorem indexedTreeLeafSemantic : some InductiveFixtures.natType.toVConstant := rfl have hZero : natFinalEnv.constants ``Nat.zero = some InductiveFixtures.natType.ctors[0].toVConstant := rfl - exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl, - (by type_tac), rfl⟩ + exact .cons (by type_tac) .nil theorem indexedTreeNodeSemantic : let constructor := CheckedCtor.ofBlock indexedTreeDecl @@ -914,10 +918,8 @@ theorem indexedTreeNodeSemantic : refine ⟨?_, ?_⟩ · refine ⟨⟨.succ .zero, (by type_tac), .inr (VLevel.succ_le_succ VLevel.zero_le)⟩, ?_⟩ - exact ⟨⟨rfl, trivial, ⟨.const ``Nat [], - .sort (.succ (.param 0)), rfl, (by type_tac), rfl⟩⟩, trivial⟩ - · exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl, - (by type_tac), rfl⟩ + exact ⟨⟨rfl, trivial, .cons (by type_tac) .nil⟩, trivial⟩ + · exact .cons (by type_tac) .nil theorem indexedTreeListNilSemantic : let constructor := CheckedCtor.ofBlock indexedTreeDecl @@ -945,8 +947,7 @@ theorem indexedTreeListNilSemantic : some InductiveFixtures.natType.toVConstant := rfl have hZero : natFinalEnv.constants ``Nat.zero = some InductiveFixtures.natType.ctors[0].toVConstant := rfl - exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl, - (by type_tac), rfl⟩ + exact .cons (by type_tac) .nil theorem indexedTreeListConsSemantic : let constructor := CheckedCtor.ofBlock indexedTreeDecl @@ -992,12 +993,9 @@ theorem indexedTreeListConsSemantic : refine ⟨?_, ?_⟩ · refine ⟨⟨.succ .zero, (by type_tac), .inr (VLevel.succ_le_succ VLevel.zero_le)⟩, ?_⟩ - refine ⟨⟨rfl, trivial, ⟨.const ``Nat [], - .sort (.succ (.param 0)), rfl, (by type_tac), rfl⟩⟩, ?_⟩ - exact ⟨⟨rfl, trivial, ⟨.const ``Nat [], - .sort (.succ (.param 0)), rfl, (by type_tac), rfl⟩⟩, trivial⟩ - · exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl, - (by type_tac), rfl⟩ + refine ⟨⟨rfl, trivial, .cons (by type_tac) .nil⟩, ?_⟩ + exact ⟨⟨rfl, trivial, .cons (by type_tac) .nil⟩, trivial⟩ + · exact .cons (by type_tac) .nil theorem indexedTreeCheckedBlockWF : indexedTreeChecked.WF natFinalEnv (.succ (.param 0)) := by @@ -1106,7 +1104,7 @@ theorem treeLeafGenerationWF : · intro recursive hrecursive change recursive ∈ [] at hrecursive nomatch hrecursive - · exact treeLeafSemantic.2 + · exact treeLeafSemantic.2.mono empty_le_treeBlockEnv theorem treeNodeGenerationWF : NormalizedBlockCtor.WF treeGeneration treeGeneration.flatCtors[1] @@ -1160,8 +1158,8 @@ theorem treeNodeGenerationWF : refine ⟨treeGeneration.families[1], ?_, rfl, ?_, ?_⟩ · exact .tail _ (.head _) · exact ⟨.app (.const ``TreeList [.param 0]) (.bvar 0), rfl, rfl⟩ - · exact ⟨trivial, rfl⟩ - · exact treeNodeSemantic.2 + · exact ⟨trivial, .nil⟩ + · exact treeNodeSemantic.2.mono empty_le_treeBlockEnv theorem treeBranchGenerationWF : NormalizedBlockCtor.WF treeGeneration treeGeneration.flatCtors[2] @@ -1202,7 +1200,7 @@ theorem treeBranchGenerationWF : emittedResult := hresult owner := ?_ recursive := ?_ - resultSpine := treeBranchSemantic.2 } + resultSpine := treeBranchSemantic.2.mono empty_le_treeBlockEnv } · refine ⟨treeGeneration.families[0], ?_, rfl, rfl, rfl⟩ exact .head _ · intro recursive hrecursive @@ -1217,7 +1215,7 @@ theorem treeBranchGenerationWF : · exact .tail _ (.head _) · exact ⟨.forallE (.bvar 0) (.app (.const ``TreeList [.param 0]) (.bvar 1)), rfl, rfl⟩ - · exact ⟨⟨⟨_, VEnv.HasType.bvar .zero⟩, trivial⟩, rfl⟩ + · exact ⟨⟨⟨_, VEnv.HasType.bvar .zero⟩, trivial⟩, .nil⟩ theorem treeListNilGenerationWF : NormalizedBlockCtor.WF treeGeneration treeGeneration.flatCtors[3] @@ -1243,7 +1241,7 @@ theorem treeListNilGenerationWF : emittedResult := hresult owner := ?_ recursive := ?_ - resultSpine := treeListNilSemantic.2 } + resultSpine := treeListNilSemantic.2.mono empty_le_treeBlockEnv } · refine ⟨treeGeneration.families[1], ?_, rfl, rfl, rfl⟩ exact .tail _ (.head _) · intro recursive hrecursive @@ -1292,7 +1290,7 @@ theorem treeListConsGenerationWF : emittedResult := hresult owner := ?_ recursive := ?_ - resultSpine := treeListConsSemantic.2 } + resultSpine := treeListConsSemantic.2.mono empty_le_treeBlockEnv } · refine ⟨treeGeneration.families[1], ?_, rfl, rfl, rfl⟩ exact .tail _ (.head _) · intro recursive hrecursive @@ -1310,11 +1308,11 @@ theorem treeListConsGenerationWF : · refine ⟨treeGeneration.families[0], ?_, rfl, ?_, ?_⟩ · exact .head _ · exact ⟨.app (.const ``Tree [.param 0]) (.bvar 0), rfl, rfl⟩ - · exact ⟨trivial, rfl⟩ + · exact ⟨trivial, .nil⟩ · refine ⟨treeGeneration.families[1], ?_, rfl, ?_, ?_⟩ · exact .tail _ (.head _) · exact ⟨.app (.const ``TreeList [.param 0]) (.bvar 1), rfl, rfl⟩ - · exact ⟨trivial, rfl⟩ + · exact ⟨trivial, .nil⟩ theorem treeBlockGenerationWF : treeGeneration.WF VEnv.empty treeBlockEnv := by @@ -1531,8 +1529,7 @@ theorem indexedTreeNodeGenerationWF : (.app (.const ``IndexedTreeList [.param 0]) (.bvar 1)) (.bvar 0), rfl, rfl⟩ · refine ⟨trivial, ?_⟩ - exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl, - VEnv.HasType.bvar .zero, rfl⟩ + exact .cons (VEnv.HasType.bvar .zero) .nil theorem indexedTreeListConsGenerationWF : NormalizedBlockCtor.WF indexedTreeGeneration @@ -1628,16 +1625,14 @@ theorem indexedTreeListConsGenerationWF : (.app (.const ``IndexedTree [.param 0]) (.bvar 1)) (.bvar 0), rfl, rfl⟩ · refine ⟨trivial, ?_⟩ - exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl, - VEnv.HasType.bvar .zero, rfl⟩ + exact .cons (VEnv.HasType.bvar .zero) .nil · refine ⟨indexedTreeGeneration.families[1], ?_, rfl, ?_, ?_⟩ · exact .tail _ (.head _) · exact ⟨.app (.app (.const ``IndexedTreeList [.param 0]) (.bvar 2)) (.bvar 1), rfl, rfl⟩ · refine ⟨trivial, ?_⟩ - exact ⟨.const ``Nat [], .sort (.succ (.param 0)), rfl, - VEnv.HasType.bvar (.succ .zero), rfl⟩ + exact .cons (VEnv.HasType.bvar (.succ .zero)) .nil theorem indexedTreeBlockGenerationWF : indexedTreeGeneration.WF natFinalEnv indexedTreeBlockEnv := by diff --git a/Lean4Lean/Verify/Environment/Normalization.lean b/Lean4Lean/Verify/Environment/Normalization.lean index 153548dd..9d6e6db2 100644 --- a/Lean4Lean/Verify/Environment/Normalization.lean +++ b/Lean4Lean/Verify/Environment/Normalization.lean @@ -3472,6 +3472,7 @@ structure CandidateFamilyStagedInput artifact; any already-complete host structure remains backed by a registered Theory view. -/ projectionReady : ProjectionReady constructorContext.env typeEnv + structureEtaReady : StructureEtaReady constructorContext.env typeEnv family_lctx_eq : familyContext.lctx = {} constructorContext_eq : constructorContext = { familyContext with env := constructorContext.env } @@ -3536,6 +3537,7 @@ def CandidateFamilyStagedInput.postContext rw [input.quotInit_eq] exact postTr projectionReady := input.projectionReady + structureEtaReady := input.structureEtaReady mlctx := .nil mlctx_wf := trivial lctx_eq := by @@ -3654,6 +3656,7 @@ theorem CandidateFamilyStagedInput.validationContextRunFromPre simpa only [validationSafety, postEnv, postVenv] using input.postContext.trenv projectionReady := input.postContext.projectionReady + structureEtaReady := input.postContext.structureEtaReady mlctx_wf := by simpa only [terminalLparams] using postMLWF } have validationContextEq : validationContext.toContext = diff --git a/Lean4Lean/Verify/Environment/SingletonParityReplay.lean b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean index f105dda1..88261d5b 100644 --- a/Lean4Lean/Verify/Environment/SingletonParityReplay.lean +++ b/Lean4Lean/Verify/Environment/SingletonParityReplay.lean @@ -260,15 +260,13 @@ theorem boolDeclWF07 : boolDecl.WF VEnv.empty := by · constructor · change True trivial - · change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero) - rfl + · exact .nil · have hctor' := List.mem_singleton.1 hctor subst ctor constructor · change True trivial - · change VExpr.sort (.succ .zero) = VExpr.sort (.succ .zero) - rfl + · exact .nil def boolGenerationWF07 : boolGenerationChecked.WF VEnv.empty := by exact (boolChecked.wf_of_decl boolDeclWF07).identityGeneration .empty @@ -459,7 +457,7 @@ theorem listCheckedWF07 : listChecked.WF VEnv.empty := by · constructor · change True trivial - · rfl + · exact .nil · have hctor' := List.mem_singleton.1 hctor subst ctor constructor @@ -477,9 +475,9 @@ theorem listCheckedWF07 : listChecked.WF VEnv.empty := by · exact .inl rfl constructor · intro _ - rfl + exact .nil · trivial - · rfl + · exact .nil def listGenerationWF07 : listGenerationChecked.WF VEnv.empty := by exact listCheckedWF07.identityGeneration .empty @@ -689,7 +687,7 @@ theorem optionDeclWF07 : optionDecl.WF VEnv.empty := by · constructor · change True trivial - · rfl + · exact .nil · have hctor' := List.mem_singleton.1 hctor subst ctor constructor @@ -702,7 +700,7 @@ theorem optionDeclWF07 : optionDecl.WF VEnv.empty := by · intro recursive contradiction · trivial - · rfl + · exact .nil def optionGenerationWF07 : optionGenerationChecked.WF VEnv.empty := by exact (optionChecked.wf_of_decl optionDeclWF07).identityGeneration .empty @@ -925,7 +923,7 @@ theorem prodCheckedWF07 : prodChecked.WF VEnv.empty := by · intro recursive contradiction · trivial - · rfl + · exact .nil def prodGenerationWF07 : prodGenerationChecked.WF VEnv.empty := by exact prodCheckedWF07.identityGeneration .empty @@ -1094,7 +1092,7 @@ theorem andCheckedWF07 : andChecked.WF VEnv.empty := by · intro recursive contradiction · trivial - · rfl + · exact .nil def andGenerationWF07 : andGenerationChecked.WF VEnv.empty := by exact andCheckedWF07.identityGeneration .empty @@ -1257,7 +1255,7 @@ theorem orCheckedWF07 : orChecked.WF VEnv.empty := by · intro recursive contradiction · trivial - · rfl + · exact .nil · have hctor' := List.mem_singleton.1 hctor subst ctor constructor @@ -1269,7 +1267,7 @@ theorem orCheckedWF07 : orChecked.WF VEnv.empty := by · intro recursive contradiction · trivial - · rfl + · exact .nil def orGenerationWF07 : orGenerationChecked.WF VEnv.empty := by exact orCheckedWF07.identityGeneration .empty @@ -1478,8 +1476,7 @@ theorem heqCheckedWF07 : heqChecked.WF VEnv.empty := by (.forallE (.sort (.param 0)) (.forallE (.bvar 0) (.sort .zero))) [.bvar 1, .bvar 0] (.sort .zero) - refine ⟨_, _, rfl, (by type_tac), ?_⟩ - exact ⟨_, _, rfl, (by type_tac), rfl⟩ + exact .cons (by type_tac) <| .cons (by type_tac) .nil def heqGenerationWF07 : heqGenerationChecked.WF VEnv.empty := by exact heqCheckedWF07.identityGeneration .empty @@ -1905,7 +1902,7 @@ theorem finCheckedWF07 : finChecked.WF finInputEnv07 := by · intro recursive contradiction · trivial - · rfl + · exact .nil def finGenerationWF07 : finGenerationChecked.WF finInputEnv07 := by exact finCheckedWF07.identityGeneration finInputEnv_ordered07 @@ -2275,7 +2272,7 @@ theorem vectorCheckedWF07 : vectorChecked.WF vectorInputEnv07 := by · intro recursive contradiction · trivial - · rfl + · exact .nil def vectorGenerationWF07 : vectorGenerationChecked.WF vectorInputEnv07 := by diff --git a/Lean4Lean/Verify/TypeChecker.lean b/Lean4Lean/Verify/TypeChecker.lean index a0c7a65e..ce15a2ac 100644 --- a/Lean4Lean/Verify/TypeChecker.lean +++ b/Lean4Lean/Verify/TypeChecker.lean @@ -17,6 +17,7 @@ structure VEnvs.WF (env : Environment) (ves : VEnvs) where Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = [] mono : safety ≤ safety' → ves.venv safety' ≤ ves.venv safety projectionReady : ProjectionReady env (ves.venv safety) + structureEtaReady : StructureEtaReady env (ves.venv safety) /-- Assemble a `VEnvs` from a pointwise existential. `DefinitionSafety` has three elements, so this is a finite case split rather than an appeal to choice -- the name records what it replaces. -/ @@ -37,6 +38,7 @@ structure VEnvAt (env : Environment) (safety : DefinitionSafety) (venv : VEnv) : safePrimitives : env.find? n = some ci → Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = [] projectionReady : ProjectionReady env venv + structureEtaReady : StructureEtaReady env venv theorem VEnvs.WF.toVEnvAt {env : Environment} {ves : VEnvs} (wf : ves.WF env) (safety : DefinitionSafety) : VEnvAt env safety (ves.venv safety) where @@ -44,6 +46,7 @@ theorem VEnvs.WF.toVEnvAt {env : Environment} {ves : VEnvs} (wf : ves.WF env) hasPrimitives := wf.hasPrimitives safePrimitives := wf.safePrimitives projectionReady := wf.projectionReady + structureEtaReady := wf.structureEtaReady namespace TypeChecker open Inner @@ -72,6 +75,7 @@ def VContext.mk1 {env : Environment} {safety : DefinitionSafety} {venv : VEnv} safePrimitives := wf.safePrimitives trenv := wf.tr projectionReady := wf.projectionReady + structureEtaReady := wf.structureEtaReady mlctx := .nil mlctx_wf := trivial lctx_eq := rfl diff --git a/Lean4Lean/Verify/TypeChecker/Basic.lean b/Lean4Lean/Verify/TypeChecker/Basic.lean index 066dcbb6..877b073f 100644 --- a/Lean4Lean/Verify/TypeChecker/Basic.lean +++ b/Lean4Lean/Verify/TypeChecker/Basic.lean @@ -150,6 +150,12 @@ structure StructureEtaArtifact (env : Environment) (familyName : Name) projection : ProjectionArtifact env familyName familyInfo venv constructor_name_eq : projection.view.constructorName = constructorName constructor_info_eq : projection.constructorInfo = constructorInfo + /-- The ordered registry proof fixes the exact descriptor generated from + the checked view. It contains no equality oracle: the associated + subject-reduction package is recovered by `Ordered.structEtaWF`. -/ + etaOrdered : venv.Ordered + etaRegistered : venv.structEtas + (projection.viewWF.toStructEta etaOrdered) /-- Host-metadata coherence required whenever the executable checker accepts a family/constructor pair as a nonrecursive structure. This deliberately @@ -190,6 +196,38 @@ theorem StructureEtaReady.resolveConstructor | ctorInfo _ => simp at hshape | recInfo _ => simp at hshape +/-- Consume the exact registered descriptor retained by a resolved host +structure artifact. Reconstruction typing comes from the registry's +`VStructEta.WF` certificate; the equality is precisely the primitive Theory +rule. -/ +theorem StructureEtaArtifact.eta + (self : StructureEtaArtifact env familyName familyInfo constructorName + constructorInfo venv) + {U : Nat} {Γ : List VExpr} {levels : List VLevel} + {params : List VExpr} {major : VExpr} + (hΓ : OnCtx Γ (venv.IsType U)) + (hlevels : ∀ level ∈ levels, level.WF U) + (hlevelsLength : levels.length = self.projection.view.uvars) + (hparamsLength : params.length = self.projection.view.nparams) + (hparamsSpine : ∃ resultLevel, + venv.SpineWF U Γ + (self.projection.view.familyType.instL levels) + params (.sort resultLevel)) + (hmajor : venv.HasType U Γ major + (self.projection.view.structureType levels params)) : + venv.IsDefEq U Γ + (self.projection.view.etaRebuild levels params major) major + (self.projection.view.structureType levels params) := by + let rule := self.projection.viewWF.toStructEta self.etaOrdered + have hruleWF : rule.WF venv := + self.etaOrdered.structEtaWF self.etaRegistered + obtain ⟨resultLevel, hparamsSpine⟩ := hparamsSpine + have hrebuild := hruleWF.rebuild_hasType VEnv.LE.rfl hΓ hlevels + hlevelsLength hparamsLength ⟨resultLevel, hparamsSpine⟩ hmajor + have heta := VEnv.IsDefEq.structEta self.etaRegistered hlevels + hlevelsLength hparamsLength hparamsSpine hmajor hrebuild + simpa [rule] using heta + /-- Environments which contain no constructor metadata satisfy projection readiness vacuously. This is the common staging case for validation fixtures: families may already be present, but their constructors have not been @@ -207,6 +245,24 @@ theorem ProjectionReady.of_no_ctorInfo constructorNumParams _view info _hview hfind := (hnoCtor _ info hfind).elim +/-- Environments with no constructor metadata also satisfy structure-eta +readiness vacuously. -/ +theorem StructureEtaReady.of_no_ctorInfo + (hnoCtor : ∀ name info, + env.find? name ≠ some (.ctorInfo info)) : + StructureEtaReady env venv where + resolve _ _ constructorName constructorInfo _ hctor _ := + (hnoCtor constructorName constructorInfo hctor).elim + +/-- A convenient negative readiness witness for staging/indexed environments +where the host recognizes no eta-eligible structure family. -/ +theorem StructureEtaReady.of_no_nonRecStructure + (hnone : ∀ name, env.isNonRecStructure name = false) : + StructureEtaReady env venv where + resolve familyName _ _ _ _ _ hnonrec := by + rw [hnone familyName] at hnonrec + contradiction + namespace TypeChecker inductive MLCtx where @@ -300,6 +356,7 @@ structure VContext extends Context where Environment.primitives.contains n → ci.safety = .safe ∧ ci.levelParams = [] trenv : TrEnv safety env venv projectionReady : ProjectionReady env venv + structureEtaReady : StructureEtaReady env venv mlctx : MLCtx mlctx_wf : mlctx.WF venv lparams lctx_eq : mlctx.lctx = lctx diff --git a/Lean4Lean/Verify/TypeChecker/InferType.lean b/Lean4Lean/Verify/TypeChecker/InferType.lean index 13f18bb8..1dd8e012 100644 --- a/Lean4Lean/Verify/TypeChecker/InferType.lean +++ b/Lean4Lean/Verify/TypeChecker/InferType.lean @@ -394,7 +394,7 @@ theorem AppStack.toSpineWF {c : VContext} cases As with | nil => let .head hfull := H - exact ⟨[], .nil, rfl, by simpa⟩ + exact ⟨[], .nil, .nil, by simpa⟩ | cons _ _ => simp at hlen | cons arg args ih => cases As with @@ -410,8 +410,7 @@ theorem AppStack.toSpineWF {c : VContext} 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, ?_⟩, ?_⟩ + refine ⟨_ :: args', .cons harg' hargs', .cons hargA ?_, ?_⟩ have hlenArgsAs : args'.length = As.length := hargs'.length_eq.symm.trans hlen' rw [VExpr.instN_forallN] @@ -435,14 +434,14 @@ theorem inferProjParams.WF {c : VContext} {s : VState} induction hargs generalizing r R s with | nil => simp [inferProjParams] at hspine ⊢ - exact hspine ▸ .pure ⟨hrBelow, hr⟩ + exact hspine.nil_inv ▸ .pure ⟨hrBelow, hr⟩ | @cons arg arg' args args' harg hargs ih => simp only [inferProjParams] have hargBelow := hargsBelow arg (by simp) have hargsBelow' : ∀ arg ∈ args, c.FVarsBelow proj arg := by intro arg harg exact hargsBelow arg (by simp [harg]) - obtain ⟨A, B, rfl, hargType, hrest⟩ := hspine + obtain ⟨A, B, rfl, hargType, hrest⟩ := hspine.cons_inv obtain ⟨r', hrS, hrEq⟩ := hr refine (whnf.WF hrS).bind fun out s' _ ⟨houtBelow, ⟨out', hout, houtEq⟩⟩ => ?_ diff --git a/Lean4Lean/Verify/TypeChecker/IsDefEq.lean b/Lean4Lean/Verify/TypeChecker/IsDefEq.lean index 27e57ada..be8db9e2 100644 --- a/Lean4Lean/Verify/TypeChecker/IsDefEq.lean +++ b/Lean4Lean/Verify/TypeChecker/IsDefEq.lean @@ -237,7 +237,7 @@ private theorem AppStack.toSpineWF_of_isType {c : VContext} let .head hhead := H cases As with | nil => - refine ⟨[], .nil, rfl, ?_⟩ + refine ⟨[], .nil, .nil, ?_⟩ change c.TrExprS f f' exact hhead | cons A As => @@ -264,8 +264,7 @@ private theorem AppStack.toSpineWF_of_isType {c : VContext} 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, ?_⟩, ?_⟩ + refine ⟨_ :: args', .cons hargTr hargs, .cons hargA ?_, ?_⟩ · rw [VExpr.instN_forallN] rw [Nat.zero_add] rw [(show (VExpr.sort resultLevel).ClosedN 0 by trivial).instN_eq @@ -290,8 +289,6 @@ private theorem forall₂_of_getElem? {R : α → β → Prop} : 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 @@ -314,7 +311,7 @@ theorem tryEtaStructCore.WF_of_structureEta {c : VContext} {s : VState} rename_i htypesTrue unfold F1 obtain ⟨familyInfo, hfamily, ⟨artifact⟩⟩ := - ready.resolveConstructor hfind hnonrec + c.structureEtaReady.resolveConstructor hfind hnonrec have ⟨head', hstack⟩ := AppStack.build <| e₂.mkAppList_getAppArgsList ▸ he₂ have hheadTr := hstack.tr @@ -471,8 +468,7 @@ theorem tryEtaStructCore.WF_of_structureEta {c : VContext} {s : VState} 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 + have heta := artifact.eta c.Δwf hlevelsWF hlevelsLength hparamsLength ⟨_, hparamsSpine⟩ haStruct have hF1Size : F1.size = args'.length := by calc @@ -760,7 +756,8 @@ theorem tryEtaStructCore.WF_of_structureEta {c : VContext} {s : VState} theorem tryEtaStructCore.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : - RecM.WF c s (tryEtaStructCore e₁ e₂) fun b _ => b → c.IsDefEqU e₁' e₂' := sorry + RecM.WF c s (tryEtaStructCore e₁ e₂) fun b _ => b → c.IsDefEqU e₁' e₂' := + tryEtaStructCore.WF_of_structureEta he₁ he₂ theorem tryEtaStruct.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : @@ -995,8 +992,6 @@ theorem tryStringLitExpansion.WF {c : VContext} {s : VState} 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 @@ -1044,7 +1039,7 @@ theorem isDefEqUnitLike.WF_of_structureEta {c : VContext} {s : VState} unfold Kernel.Environment.isNonRecStructure rw [hfamily] rfl - obtain ⟨artifact⟩ := ready.resolve familyName familyInfo ctorName + obtain ⟨artifact⟩ := c.structureEtaReady.resolve familyName familyInfo ctorName constructorInfo hfamily hctor hnonrec have ⟨head', hstack⟩ := AppStack.build <| normalizedType.mkAppList_getAppArgsList ▸ tTypeTr @@ -1117,11 +1112,9 @@ theorem isDefEqUnitLike.WF_of_structureEta {c : VContext} {s : VState} 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 + have heta₁ := artifact.eta c.Δwf hlevelsWF hlevelsLength hparamsLength ⟨_, hparamsFamily⟩ haStruct - have heta₂ := eta artifact.projection.view artifact.projection.viewWF - artifact.projection.programsWF c.Δwf hlevelsWF hlevelsLength + have heta₂ := artifact.eta c.Δwf hlevelsWF hlevelsLength hparamsLength ⟨_, hparamsFamily⟩ hbStruct have hfieldsLength : artifact.projection.view.fields.length = 0 := by calc @@ -1143,7 +1136,8 @@ theorem isDefEqUnitLike.WF_of_structureEta {c : VContext} {s : VState} theorem isDefEqUnitLike.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : - RecM.WF c s (isDefEqUnitLike e₁ e₂) fun b _ => b = .true → c.IsDefEqU e₁' e₂' := sorry + RecM.WF c s (isDefEqUnitLike e₁ e₂) fun b _ => b = .true → c.IsDefEqU e₁' e₂' := + isDefEqUnitLike.WF_of_structureEta he₁ he₂ theorem isDefEqCore'.WF {c : VContext} {s : VState} (he₁ : c.TrExprS e₁ e₁') (he₂ : c.TrExprS e₂ e₂') : diff --git a/plans/roadmap.md b/plans/roadmap.md index 4a1b8503..69ed52cd 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -68,12 +68,12 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| Ladder position | **L4L-15B active** (structure eta and unit-like comparison, proceeding as a documented divergence); the L4L-15R v4.33 reconciliation is complete and pruned from §5 (2026-08-11) | -| Current formalization source | this v4.33 reconciliation merge checkpoint (jj change `zxwpwkpp`) at `jcb/formalization2` (first parent the L4L-15R planning commit `c22d790d` atop the structure-eta staging checkpoint `ae6ee9d6`); `origin/jcb/formalization2` is the live publication bookmark and was published at this checkpoint (2026-08-11) | -| Parent lineage | this upstream-reconciliation merge (second parent: digama `upstream/master` `b292275c`, which superseded the planned `1a16b72d` before execution); Lean on v4.33.0 final, lean4-nix on `argumentcomputer/lean4-nix` (upstream pins v4.33.0-rc2 — ledger D018) | +| Ladder position | **L4L-16 active** (route selection and sort inversion); L4L-15B structure eta and unit-like comparison is complete and pruned from §5 (2026-08-11) | +| Current formalization source | this L4L-15B checkpoint (jj change `xuzusmnl`) at `jcb/formalization2`, atop the approved design/ledger checkpoint `01bfdce9`; `origin/jcb/formalization2` is the publication bookmark moved only after the complete gate | +| Parent lineage | the L4L-15B implementation descends from the v4.33 reconciliation merge `99a7f8ae7b89` (second parent: digama `upstream/master` `b292275c`); Lean on v4.33.0 final, lean4-nix on `argumentcomputer/lean4-nix` (upstream pins v4.33.0-rc2 — ledger D018) | | Fixed `master` baseline | `1fb7d6ef9042c5a80b2de9320c88ac0f3ce404cb` | -| Trust frontier | exactly 18 sorried proof declarations (12 Tier V, 6 Tier R; `NormalEq.parRed` carries two tokens) plus six kernel-rejection recovery declarations — 24 compiled allowlist entries — and 34 custom-axiom declarations; all are pinned by exact audits. Eight Tier V entries are new at this checkpoint: upstream's `checkPrimitiveDef.WF` boundary, the six D017 front-end/`ProjectionReady`-transport and quotient-initialization entries, and the `aliasFormerAlignmentRun` fixture repair debt | -| Gates | the full §6 gate is green on this checkpoint: the 212-job default Lake build, the Nix flake checks, the 24-entry exact sorry frontier, the Theory-only import/axiom audit, downstream-consumer and CLI checks, and whitespace hygiene | +| Trust frontier | exactly 16 sorried proof declarations (10 Tier V, 6 Tier R; `NormalEq.parRed` carries two tokens) plus six kernel-rejection recovery declarations — 22 compiled allowlist entries — and 34 custom-axiom declarations; all are pinned by exact audits. L4L-15B removed the two structure-eta checker roots from the direct frontier; their inherited L4L-16--19 dependencies remain explicit in exact axiom guards | +| Gates | the full §6 gate is green on this checkpoint: the 212-job default Lake build, the Nix flake checks, the 22-entry exact sorry frontier, the Theory-only import/axiom audit, downstream-consumer and CLI checks, and whitespace hygiene | ### 2.1 What is green @@ -290,6 +290,25 @@ string branches of `reduceProj.WF`, and the enclosing WHNF/translation projection paths. Their exact guards distinguish the remaining inherited Tier-R inversion dependency from projection-specific proof debt. +**Structure eta.** L4L-15B adds the registered lower-layer `VStructEta` +descriptor, monotone `VEnv.structEtas` registry, ordered subject-reduction +certificate, and the exact `VEnv.IsDefEq.structEta` contraction for complete +parameter spines. The checked-view bridge fixes reconstruction to the +deterministic recursor-encoded projector programs; `StructureEtaArtifact` +retains the exact host family/constructor alignment and registry membership. +Weakening, substitution, strong typing, inversion/discrimination, +standardization, nested transport, and every environment-schema consumer +carry the new case. `StructEq` retains oriented reconstruction +seeds and complete typed constructor-spine congruence; its named parallel +join records the constructor/iota, nesting, internal reduction, dependent +field, proof/Prop, and registered-`.extra` interactions. The unconditional +`tryEtaStructCore.WF` and `isDefEqUnitLike.WF` roots are now proved from the +registered artifact, removing both direct Tier V sorries. Exact axiom guards +pin registration, subject reduction, the primitive rule, Church--Rosser, and +both roots; the executable/kernel fixture matrix covers dependent +parameterized, zero-field, proof-field, Prop-valued, recursive, +multi-constructor, and indexed declarations. + **Theory-only consumer surface.** The L4L-15C audit moved the generic `SpineWF` weakening/inversion laws to `Theory/Typing/UniqueTyping.lean`, primitive-environment extension and Bool-literal typing to @@ -300,8 +319,7 @@ 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. +**Not claimed.** 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 @@ -317,14 +335,14 @@ 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 18 sorried proof declarations (`NormalEq.parRed` carries two +accepts exactly 16 sorried proof declarations (`NormalEq.parRed` carries two tokens), plus six deliberately kernel-rejected fixture recoveries that are -not proof debt. The compiled allowlist therefore contains 24 declarations: +not proof debt. The compiled allowlist therefore contains 22 declarations: | Area | Live debt | |---|---| | Core metatheory (Tier R) | `Injectivity.lean` x3; `UniqueTyping.lean` x1; `Projection.lean` x1; `ChurchRosser.lean` x2 | -| Checker verification (Tier V) | `Verify/Environment.lean` x2 (`addDecl.WF` — now only its `inductDecl` case — and the re-sorried `addQuot.WF`); `Boundaries.lean` x1 (upstream's `checkPrimitiveDef.WF`); `Extension.lean` x5 (the D017 `ProjectionReady` transports); `WHNF.lean` x1; `IsDefEq.lean` x2; `InductiveFixtures.lean` x1 (`aliasFormerAlignmentRun` repair debt) | +| Checker verification (Tier V) | `Verify/Environment.lean` x2 (`addDecl.WF` — now only its `inductDecl` case — and the re-sorried `addQuot.WF`); `Boundaries.lean` x1 (upstream's `checkPrimitiveDef.WF`); `Extension.lean` x5 (the D017 checker-readiness transports); `WHNF.lean` x1; `InductiveFixtures.lean` x1 (`aliasFormerAlignmentRun` repair debt) | All Tier V entries are L4L-19A/19B territory; the eight added at the v4.33 reconciliation are classified in ledger row D017. Non-sorry debt: @@ -541,96 +559,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. -### 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; divergence -approved).** Derive `tryEtaStructCore.WF` and `isDefEqUnitLike.WF` on the -reconciled v4.33 base. Adding the structure-eta rule is a metatheory -change; upstream agreement is no longer an implementation blocker — -proceeding as a tracked, documented fork divergence was approved -2026-08-11, with upstream review deferred to the L4L-20C PR series. - -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 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 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 and -`VEnv.IsDefEq` remain untouched until the steps below run. - -The decided rule is an explicit registered structure-eta rule, restricted -to checked nonrecursive, single-constructor, zero-index structure views. -The mandatory order of work: - -1. **Design note first.** The exact rule form; subject reduction from the - registered constructor/projector typing package (the rule-independent - half, `etaRebuild_hasType_of_constructorPrefix`, is already proved); - updated injectivity/discrimination arguments; confluence and - standardization critical-pair coverage against beta, iota, proof - irrelevance, and registered extra rules; and a complete inventory of - every exhaustive `IsDefEq` consumer and environment-monotonicity - proof that gains a case arm — including how the Tier R statements - (`parRed`, the inversion family) and the generic `[Params]` - development absorb the rule. - The committed design record is - `plans/l4l-15-structure-eta-design.md`. -2. **Ledger entry before the rule lands.** Record the divergence in - `upstream-divergence.md`: owner, rule, downstream impact, the - parallel upstream conversation, and the removal condition — upstream - adopts the rule or an agreed alternative by the L4L-20C series, - revisited at every reconciliation checkpoint. If upstream ultimately - declines any Theory change, the recorded fallback is disabling the - two executable heuristics rather than certifying them from an absent - rule. - This is ledger entry D019. -3. **Implementation.** Add the rule, derive `VEnv.HasStructureEta` for - registered views, let the staged conditional proofs close both - unconditional Tier V roots, and repair every case arm from the - inventory. No existing proved root may regress silently: any proof - that cannot yet absorb its new case is re-sorried into the frontier - with an explicit tier, and this milestone does not close over it. -*Exit:* both roots are sorry-free and audited on the v4.33 base; the -design note and ledger entry are committed with -subject-reduction/injectivity/confluence and downstream-impact evidence; -the `IsDefEq` case inventory shows no silent regression. - ### Metatheory closure (L4L-16–L4L-18B) Scheduled completion work; coordinate with Mario because upstream has active research branches. -**L4L-16 — route selection and sort inversion.** Evaluate two routes in a -small, focused proof branch: (1) finish and bridge the fetched +**L4L-16 — route selection and sort inversion (active).** Evaluate two routes +in a small, focused proof branch: (1) finish and bridge the fetched `logrel@upstream` approach (`ShapeLogRel`, adequacy, and `Experimental/UniqueTyping`) into live VExpr judgments; or (2) complete the current stratified `HasTypeStrong` proof directly. The spike must list every diff --git a/upstream-divergence.md b/upstream-divergence.md index 8429ac55..aa080766 100644 --- a/upstream-divergence.md +++ b/upstream-divergence.md @@ -1059,15 +1059,18 @@ to the replacement. - **Removal condition:** upstream adopts the reshapes or the proofs stop needing named intermediate steps. -## D017 — projection readiness meets the v4.33 front-end chains +## D017 — checker readiness meets the v4.33 front-end chains - **Status:** intentional-fork (transitional), created by the v4.33 reconciliation -- **Delta:** this fork's `VContext`/`VEnvs.WF` carry a `ProjectionReady` - obligation that upstream's newly proved front-end declaration chains (#28) - do not establish. The merge added the field to upstream's `VEnvAt` - (supplied honestly by `VEnvs.WF.toVEnvAt`) and left the extension-transport - obligations as five named Tier V sorries (`VEnvAt.addAxioms._f`, +- **Delta:** this fork's `VContext`/`VEnvs.WF` carry `ProjectionReady` and, + since L4L-15B, registered `StructureEtaReady` obligations that upstream's + newly proved front-end declaration chains (#28) do not establish. The merge + added the projection field to upstream's `VEnvAt`; L4L-15B paired the exact + same five transitional declarations with structure-eta readiness, without + adding or renaming a frontier entry. Both fields are supplied honestly by + `VEnvs.WF.toVEnvAt`; their extension-transport obligations remain the five + named Tier V sorries (`VEnvAt.addAxioms._f`, `addConstCore.WF`, `addDef.WF`, `addMutualBlock.WF`, `addUnsafeDef.WF`). Upstream's vacuous quotient-initialization proof (`checkEqType.WF` via `TrEnv'.no_inductInfo`) is refutable on this fork — the inductive boundary @@ -1083,8 +1086,9 @@ to the replacement. (L4L-19B territory), plus upstream's `checkPrimitiveDef.WF` boundary. - **Upstream issue/PR:** not applicable upstream (the obligation is fork-only); resolved by the L4L-19B transport proofs. -- **Removal condition:** L4L-19B proves `ProjectionReady` transport across - `Environment.add`/`addConsts` and the constructive quotient initialization, +- **Removal condition:** L4L-19B proves both readiness transports across + `Environment.add`/`addConsts`, registers every newly completed eligible + structure artifact, and proves constructive quotient initialization, emptying the six entries. ## D018 — v4.33.0 final toolchain (upstream pins v4.33.0-rc2) @@ -1098,8 +1102,8 @@ to the replacement. ## D019 — registered structure eta in Theory -- **Status:** approved intentional fork divergence; L4L-15B implementation - in progress on the reconciled v4.33 base. +- **Status:** implemented intentional fork divergence; L4L-15B completed on + the reconciled v4.33 base (2026-08-11). - **Owner:** John C. Burnham; semantic review is part of the L4L-20C PR series. - **Delta:** extend Theory with an explicit environment-registered @@ -1117,11 +1121,13 @@ to the replacement. nested transport, and the Verify structure-artifact bridge. Downstream Theory consumers see an additive descriptor/registry API and one additional definitional-equality constructor. -- **Tests:** dependent parameterized, zero-field parameterized, proof-field, - and Prop-valued positive fixtures; recursive, multi-constructor, and indexed - negative fixtures; exact axiom guards for registration, subject reduction, - Church--Rosser, `tryEtaStructCore.WF`, and `isDefEqUnitLike.WF`; full sorry - frontier and release gate. +- **Tests:** executable metadata and kernel-conversion fixtures cover + dependent parameterized neutral majors, parameterized zero-field, + proof-field, and Prop-valued positives plus recursive, multi-constructor, + and indexed negatives. Exact axiom guards cover registration, subject + reduction, the primitive rule, Church--Rosser, `tryEtaStructCore.WF`, and + `isDefEqUnitLike.WF`; the latter two left the direct sorry frontier, reducing + it from 24 to 22 entries. The full release gate is green. - **Axiom note:** no new project axiom or source `sorry` is permitted. Existing L4L-16--L4L-18 frontier dependencies remain explicit in per-root manifests. - **Parallel upstream conversation:** implementation is intentionally allowed From 96aeab5ca7f08de215a1c86f384bfc6d6b878419 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Wed, 12 Aug 2026 02:05:46 -0400 Subject: [PATCH 51/51] feat: implement proof-carrying extension reductions --- Lean4Lean/Theory/Typing/ChurchRosser.lean | 147 ++++++++++---- Lean4Lean/Theory/Typing/HeadReduction.lean | 65 ++++-- .../Theory/Typing/InductivePatternEnv.lean | 185 +++++++++++++++-- .../Typing/InductivePatternFixtures.lean | 40 ++++ .../Theory/Typing/InductivePatternWF.lean | 51 +++++ Lean4Lean/Theory/Typing/Pattern.lean | 16 ++ plans/l4l-16-sort-inversion-decision.md | 175 ++++++++++++++++ plans/l4l-18b-extension-interface-design.md | 180 +++++++++++++++++ plans/roadmap.md | 187 ++++++++++-------- upstream-divergence.md | 42 ++++ 10 files changed, 923 insertions(+), 165 deletions(-) create mode 100644 plans/l4l-16-sort-inversion-decision.md create mode 100644 plans/l4l-18b-extension-interface-design.md diff --git a/Lean4Lean/Theory/Typing/ChurchRosser.lean b/Lean4Lean/Theory/Typing/ChurchRosser.lean index 976f9b33..34201234 100644 --- a/Lean4Lean/Theory/Typing/ChurchRosser.lean +++ b/Lean4Lean/Theory/Typing/ChurchRosser.lean @@ -9,6 +9,12 @@ namespace VEnv open VExpr +/-- The combinatorial pattern interface used by parallel reduction. + +Membership and non-overlap facts classify possible contractions; they do not +certify that a matched redex is equal to a payload. Operational soundness is +carried by each `.extra` step, and raw registered-equation joining is supplied +separately by `Params.Extension`. -/ class Params where env : VEnv henv : env.WF @@ -17,16 +23,11 @@ class Params where pat_simple : Pat p r → ∃ sp : SimplePattern, p = sp.toPattern pat_uniq : Pat p₁ r → Pat p₂ r' → Subpattern p₃ p₁ → p₂.inter p₃ = some p₄ → p₁ = p₂ ∧ p₂ = p₃ ∧ r ≍ r' - pat_wf : Pat p r → p.Matches e m1 m2 → HasType env univs Γ e A → - r.2.OK (IsDefEqU env univs Γ) m1 m2 → IsDefEqU env univs Γ e (r.1.apply m1 m2) pat_app_l : Pat p r → Subpattern (.app p₁ p₂) p → ¬Subpattern (.app p₃ p₄) p₁ pat_app_l_uniq : Pat p r → Pat p' r' → Subpattern (.app p₁ p₂) p → Subpattern (.app p₁' p₂') p' → Subpattern (.var p₃) p₁ → p₁'.inter p₃ = none pat_app_uniq : Pat p r → Pat p' r' → Subpattern (.app p₁ p₂) p → Subpattern (.app p₁' p₂') p' → Subpattern p₃ p₁ → Subpattern p₃' p₂' → p₃.inter p₃' = none - extra_pat : env.defeqs df → (∀ l ∈ ls, l.WF uvars) → ls.length = df.uvars → - ∃ p r m1 m2, Pat p r ∧ p.Matches (df.lhs.instL ls) m1 m2 ∧ r.2.OK (IsDefEqU env univs Γ) m1 m2 ∧ - df.rhs.instL ls = r.1.apply m1 m2 /-- Registered-family typing is reflected through weakening. This is the structure-family specialization of `IsDefEqU.weakN_iff`: it retains the registered head witness, which the untyped theorem intentionally erases. -/ @@ -947,12 +948,18 @@ inductive ParRed : List VExpr → VExpr → VExpr → Prop where | lam : Γ ⊢ A ≫ A' → A::Γ ⊢ body ≫ body' → Γ ⊢ .lam A body ≫ .lam A' body' | forallE : Γ ⊢ A ≫ A' → A::Γ ⊢ B ≫ B' → Γ ⊢ .forallE A B ≫ .forallE A' B' | beta : A::Γ ⊢ e₁ ≫ e₁' → Γ ⊢ e₂ ≫ e₂' → Γ ⊢ .app (.lam A e₁) e₂ ≫ e₁'.inst e₂' + /-- A consumer-certified pattern contraction. The equality certificate is + carried by the step itself: membership in `Pat` and a successful match do + not make an external equation trusted. -/ | extra : Pat p r → p.Matches e m1 m2 → r.2.OK (IsDefEqU env univs Γ) m1 m2 → + IsDefEqU env univs Γ e (r.1.apply m1 m2) → (∀ a, Γ ⊢ m2 a ≫ m2' a) → Γ ⊢ e ≫ r.1.apply m1 m2' def NonNeutral (Γ : List VExpr) (e : VExpr) : Prop := (∃ A e₁ e₂, e = .app (.lam A e₁) e₂) ∨ - (∃ p r m1 m2, Pat p r ∧ p.Matches e m1 m2 ∧ r.2.OK (IsDefEqU env univs Γ) m1 m2) + (∃ p r m1 m2, Pat p r ∧ p.Matches e m1 m2 ∧ + r.2.OK (IsDefEqU env univs Γ) m1 m2 ∧ + IsDefEqU env univs Γ e (r.1.apply m1 m2)) inductive CParRed : List VExpr → VExpr → VExpr → Prop where | bvar : Γ ⊢ .bvar i ⋙ .bvar i @@ -963,6 +970,7 @@ inductive CParRed : List VExpr → VExpr → VExpr → Prop where | forallE : Γ ⊢ A ⋙ A' → A::Γ ⊢ B ⋙ B' → Γ ⊢ .forallE A B ⋙ .forallE A' B' | beta : A::Γ ⊢ e₁ ⋙ e₁' → Γ ⊢ e₂ ⋙ e₂' → Γ ⊢ .app (.lam A e₁) e₂ ⋙ e₁'.inst e₂' | extra : Pat p r → p.Matches e m1 m2 → r.2.OK (IsDefEqU env univs Γ) m1 m2 → + IsDefEqU env univs Γ e (r.1.apply m1 m2) → (∀ a, Γ ⊢ m2 a ⋙ m2' a) → Γ ⊢ e ⋙ r.1.apply m1 m2' protected theorem ParRed.rfl : ∀ {e}, Γ ⊢ e ≫ e @@ -983,10 +991,12 @@ theorem ParRed.weakN (W : Ctx.LiftN n k Γ Γ') (H : Γ ⊢ e1 ≫ e2) : | beta _ _ ih1 ih2 => simp [liftN, liftN_inst_hi] exact .beta (ih1 W.succ) (ih2 W) - | extra h1 h2 h3 _ ih => + | extra h1 h2 h3 h4 _ ih => + have h4 := h4.weakN henv W + rw [Pattern.RHS.liftN_apply] at h4 rw [Pattern.RHS.liftN_apply] refine .extra h1 (Pattern.matches_liftN.2 ⟨_, h2, funext_iff.1 rfl⟩) - (h3.weakN W) (fun a => ih _ W) + (h3.weakN W) h4 (fun a => ih _ W) variable! (H₀ : Γ₀ ⊢ a1 ≫ a2) (H₀' : Γ₀ ⊢ a1 : A₀) in theorem ParRed.instN (W : Ctx.InstN Γ₀ a1 A₀ k Γ₁ Γ) @@ -1010,9 +1020,12 @@ theorem ParRed.instN (W : Ctx.InstN Γ₀ a1 A₀ k Γ₁ Γ) | beta _ _ ih1 ih2 => simp [inst, inst0_inst_hi] exact .beta (ih1 W.succ) (ih2 W) - | extra h1 h2 h3 _ ih => + | extra h1 h2 h3 h4 _ ih => + have h4 := h4.instN henv W H₀' + rw [Pattern.RHS.instN_apply] at h4 rw [Pattern.RHS.instN_apply] - exact .extra h1 (Pattern.matches_instN h2) (h3.instN W H₀') (fun a => ih _ W) + exact .extra h1 (Pattern.matches_instN h2) (h3.instN W H₀') + h4 (fun a => ih _ W) variable! (hΓ : OnCtx Γ (IsType env univs)) in theorem ParRed.defeq (H : Γ ⊢ e ≫ e') (he : Γ ⊢ e : A) : Γ ⊢ e ≡ e' : A := by @@ -1036,9 +1049,10 @@ theorem ParRed.defeq (H : Γ ⊢ e ≫ e') (he : Γ ⊢ e : A) : Γ ⊢ e ≡ e' exact .trans_l henv hΓ he <| .trans (.symm <| .appDF (.symm <| .lamDF hA (ih1 ⟨hΓ, _, hA⟩ hb)) (.symm <| ih2 hΓ ha)) (.beta (ih1 ⟨hΓ, _, hA⟩ hb).hasType.2 (ih2 hΓ ha).hasType.2) - | @extra p r e m1 m2 Γ m2' h1 h2 h3 _ ih => - exact .trans_l henv hΓ he <| .transU_r henv hΓ (pat_wf h1 h2 he h3) <| - .apply_pat hΓ (fun _ _ h => ⟨_, ih _ hΓ h⟩) (.defeqU_l henv hΓ (pat_wf h1 h2 he h3) he) + | @extra p r e m1 m2 Γ m2' h1 h2 h3 h4 _ ih => + exact .trans_l henv hΓ he <| .transU_r henv hΓ h4 <| + .apply_pat hΓ (fun _ _ h => ⟨_, ih _ hΓ h⟩) + (.defeqU_l henv hΓ h4 he) variable! (hΓ : OnCtx Γ (IsType env univs)) in theorem ParRed.hasType (H : Γ ⊢ e ≫ e') (he : Γ ⊢ e : A) : Γ ⊢ e' : A := @@ -1064,9 +1078,11 @@ theorem ParRed.defeqDFC (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂) have ⟨_, _, hf, ha⟩ := h.app_inv henv (W.isType' hΓ₀) have ⟨⟨_, hA⟩, _, hb⟩ := hf.lam_inv henv (W.isType' hΓ₀) exact .beta (ih1 (W.succ hA) hb) (ih2 W ha) - | @extra p r e m1 m2 Γ m2' h1 h2 h3 _ ih => - exact .extra h1 h2 (h3.map fun a b h => h.defeqDFC henv W) fun a => - let ⟨_, h⟩ := h2.hasType (W.isType' hΓ₀) h a; ih a W h + | @extra p r e m1 m2 Γ m2' h1 h2 h3 h4 _ ih => + exact .extra h1 h2 (h3.map fun a b h => h.defeqDFC henv W) + (h4.defeqDFC henv W) fun a => + let ⟨_, h⟩ := h2.hasType (W.isType' hΓ₀) h a + ih a W h theorem ParRed.apply_pat {p : Pattern} (r : p.RHS) {m1 m2 m3} (H : ∀ a, Γ ⊢ m2 a ≫ m3 a) : Γ ⊢ r.apply m1 m2 ≫ r.apply m1 m3 := by @@ -1145,30 +1161,32 @@ theorem ParRed.weakN_inv (W : Ctx.LiftN n k Γ Γ') obtain ⟨_, a1, rfl⟩ := ih1 (by exact ⟨hΓ, _, hA⟩) W.succ hb rfl obtain ⟨_, b1, rfl⟩ := ih2 hΓ W ha rfl exact ⟨_, .beta a1 b1, (liftN_inst_hi ..).symm⟩ - | @extra p r e m1 m2 Γ' m2' h1 h2 h3 h4 ih => + | @extra p r e m1 m2 Γ' m2' h1 h2 h3 h4 h5 ih => suffices ∃ m3 m3' : _ → _, p.Matches e1 m1 m3 ∧ (∀ a, Γ ⊢ m3 a ≫ m3' a) ∧ (∀ a, m2 a = (m3 a).liftN n k) ∧ (∀ a, m2' a = (m3' a).liftN n k) by let ⟨m3, m3', a1, a2, a3, a4⟩ := this - refine ⟨_, .extra h1 a1 (h3.map fun _ _ h => ?_) a2, + refine ⟨_, .extra h1 a1 (h3.map fun _ _ h => ?_) ?_ a2, .trans (by congr; funext; apply a4) r.1.apply_liftN.symm⟩ rw [(funext a3 : m2 = _), ← Pattern.RHS.apply_liftN, ← Pattern.RHS.apply_liftN] at h exact (IsDefEqU.weakN_iff henv hΓ W).1 h - clear h1 h3 r + rw [← eq, (funext a3 : m2 = _), ← Pattern.RHS.apply_liftN] at h4 + exact (IsDefEqU.weakN_iff henv hΓ W).1 h4 + clear h1 h3 h4 r induction h2 generalizing e1 A with | const => cases e1 <;> cases eq; exact ⟨_, nofun, .const, nofun, nofun, nofun⟩ | var h1 ih1 => cases e1 <;> cases eq have ⟨_, _, hf, ha⟩ := h.app_inv henv hΓ - have ⟨_, _, a1, a2, a3, a4⟩ := ih1 (h4 <| some ·) (ih <| some ·) hf rfl + have ⟨_, _, a1, a2, a3, a4⟩ := ih1 (h5 <| some ·) (ih <| some ·) hf rfl have ⟨_, b2, b4⟩ := ih none hΓ W ha rfl exact ⟨_, Option.rec _ _, .var a1, Option.rec b2 a2, Option.rec rfl a3, Option.rec b4 a4⟩ | app h1 h2 ih1 ih2 => cases e1 <;> cases eq have ⟨_, _, hf, ha⟩ := h.app_inv henv hΓ - have ⟨_, _, a1, a2, a3, a4⟩ := ih1 (h4 <| .inl ·) (ih <| .inl ·) hf rfl - have ⟨_, _, b1, b2, b3, b4⟩ := ih2 (h4 <| .inr ·) (ih <| .inr ·) ha rfl + have ⟨_, _, a1, a2, a3, a4⟩ := ih1 (h5 <| .inl ·) (ih <| .inl ·) hf rfl + have ⟨_, _, b1, b2, b3, b4⟩ := ih2 (h5 <| .inr ·) (ih <| .inr ·) ha rfl exact ⟨_, Sum.rec _ _, .app a1 b1, Sum.rec a2 b2, Sum.rec a3 b3, Sum.rec a4 b4⟩ theorem CParRed.toParRed (H : Γ ⊢ e ⋙ e') : Γ ⊢ e ≫ e' := by @@ -1180,7 +1198,7 @@ theorem CParRed.toParRed (H : Γ ⊢ e ⋙ e') : Γ ⊢ e ≫ e' := by | lam _ _ ih1 ih2 => exact .lam ih1 ih2 | forallE _ _ ih1 ih2 => exact .forallE ih1 ih2 | beta _ _ ih1 ih2 => exact .beta ih1 ih2 - | extra h1 h2 h3 _ ih3 => exact .extra h1 h2 h3 ih3 + | extra h1 h2 h3 h4 _ ih3 => exact .extra h1 h2 h3 h4 ih3 variable! (hΓ : OnCtx Γ (IsType env univs)) in theorem CParRed.exists (H : Γ ⊢ e : A) : ∃ e', Γ ⊢ e ⋙ e' := by @@ -1188,15 +1206,15 @@ theorem CParRed.exists (H : Γ ⊢ e : A) : ∃ e', Γ ⊢ e ⋙ e' := by revert e_ih; change let motive := ?_; ∀ _: e.below (motive := motive), _; intro motive e_ih have neut {e} (H' : Γ ⊢ e : A) (e_ih : e.below (motive := motive)) : NonNeutral Γ e → ∃ e', Γ ⊢ e ⋙ e' := by - rintro (⟨A, e, a, rfl⟩ | ⟨p, r, m1, m2, h1, hp2, hp3⟩) + rintro (⟨A, e, a, rfl⟩ | ⟨p, r, m1, m2, h1, hp2, hp3, hp4⟩) · have ⟨_, _, hf, ha⟩ := H'.app_inv henv hΓ have ⟨⟨_, hA⟩, _, he⟩ := hf.lam_inv henv hΓ have ⟨_, he⟩ := e_ih.1.2.2.1 (by exact ⟨hΓ, _, hA⟩) he have ⟨_, ha⟩ := e_ih.2.1 hΓ ha exact ⟨_, .beta he ha⟩ · suffices ∃ m3 : p.Path → VExpr, ∀ a, Γ ⊢ m2 a ⋙ m3 a from - let ⟨_, h3⟩ := this; ⟨_, .extra h1 hp2 hp3 h3⟩ - clear H r h1 hp3 + let ⟨_, h3⟩ := this; ⟨_, .extra h1 hp2 hp3 hp4 h3⟩ + clear H r h1 hp3 hp4 induction p generalizing e m1 A with | const => exact ⟨nofun, nofun⟩ | app f a ih1 ih2 => @@ -1248,7 +1266,7 @@ theorem ParRed.triangle (H1 : Γ ⊢ e : A) (H : Γ ⊢ e ≫ e') (H2 : Γ ⊢ e | const hn => cases H with | const => exact ⟨_, .rfl, .refl H1⟩ - | extra h1 h2 h3 => cases hn (.inr ⟨_, _, _, _, h1, h2, h3⟩) + | extra h1 h2 h3 h4 => cases hn (.inr ⟨_, _, _, _, h1, h2, h3, h4⟩) | app hn _ _ ih1 ih2 => have ⟨_, _, l1, l2⟩ := H1.app_inv henv hΓ cases H with @@ -1257,7 +1275,7 @@ theorem ParRed.triangle (H1 : Γ ⊢ e : A) (H : Γ ⊢ e ≫ e') (H2 : Γ ⊢ e have o1 := p1.hasType hΓ (r1.hasType hΓ l1); have o2 := p2.hasType hΓ (r2.hasType hΓ l2) exact ⟨_, .app p1 p2, .appDF o1 (.defeqU_l henv hΓ (n1.defeq hΓ) o1) o2 (.defeqU_l henv hΓ (n2.defeq hΓ) o2) n1 n2⟩ - | extra h1 h2 h3 => cases hn (.inr ⟨_, _, _, _, h1, h2, h3⟩) + | extra h1 h2 h3 h4 => cases hn (.inr ⟨_, _, _, _, h1, h2, h3, h4⟩) | beta => cases hn (.inl ⟨_, _, _, rfl⟩) | lam _ _ ih1 ih2 => have ⟨⟨_, l1⟩, _, l2⟩ := H1.lam_inv henv hΓ @@ -1307,14 +1325,14 @@ theorem ParRed.triangle (H1 : Γ ⊢ e : A) (H : Γ ⊢ e ≫ e') (H2 : Γ ⊢ e (p2.hasType hΓ' (re.hasType hΓ' le))) (.instN (l2.toParRed.hasType hΓ la') .zero n2) | extra h1 h2 => cases h2 with | app h | var h => cases h - | @extra p r e m1 m2 Γ m2' l1 l2 l3 l4 ih => + | @extra p r e m1 m2 Γ m2' l1 l2 l3 l4 l5 ih => have : (∃ m3 m3' : p.Path → VExpr, p.Matches e' m1 m3 ∧ (∀ a, Γ ⊢ m2 a ≫ m3 a) ∧ (∀ a, Γ ⊢ m3 a ≫ m3' a) ∧ (∀ a, Γ ⊢ m3' a ≡ₚ m2' a)) ∨ (∃ p₁ e₁' e₁ m1₁ m2₁, Subpattern p₁ p ∧ (p₁ = p → e₁ = e ∧ e₁' = e' ∧ m1₁ ≍ m1 ∧ m2₁ ≍ m2) ∧ p₁.Matches e₁ m1₁ m2₁ ∧ ∃ p' r m1 m2 m2', Pat p' r ∧ p'.Matches e₁ m1 m2 ∧ (∀ a, Γ ⊢ m2 a ≫ m2' a) ∧ e₁' = r.1.apply m1 m2') := by - clear l1 l3 l4 r + clear l1 l3 l4 l5 r induction H generalizing p m1 A with | const => cases id l2; exact .inl ⟨_, _, l2, nofun, fun _ => .rfl, nofun⟩ @@ -1344,18 +1362,28 @@ theorem ParRed.triangle (H1 : Γ ⊢ e : A) (H : Γ ⊢ e ≫ e') (H2 : Γ ⊢ e exact .inl ⟨_, Sum.elim _ _, .app f1 a1, (·.casesOn f2 a2), (·.casesOn f3 a3), (·.casesOn f4 a4)⟩ | beta _ _ => cases l2 with | var h | app h => cases h - | @extra _ _ _ _ _ _ _ r1 r2 _ r4 => + | @extra _ _ _ _ _ _ _ r1 r2 _ _ r4 => exact .inr ⟨_, _, _, _, _, .refl, fun _ => ⟨rfl, rfl, .rfl, .rfl⟩, l2, _, _, _, _, _, r1, r2, r4, rfl⟩ | _ => cases l2 match this with | .inl ⟨m3, m3', h1, h2, h3, h4⟩ => - refine - have h := .extra l1 h1 (l3.map fun _ _ ⟨_, h1⟩ => ?_) h3 - ⟨_, h, .apply_pat hΓ (fun a _ _ => h4 a) (h.hasType hΓ (H.hasType hΓ H1))⟩ - refine ⟨_, .trans - (.symm <| .apply_pat hΓ (fun _ _ h => ⟨_, (h2 _).defeq hΓ h⟩) h1.hasType.1) - (.trans h1 <| .apply_pat hΓ (fun _ _ h => ⟨_, (h2 _).defeq hΓ h⟩) h1.hasType.2)⟩ + have hcheck : r.2.OK (IsDefEqU env univs Γ) m1 m3 := + l3.map fun _ _ ⟨_, hc⟩ => by + refine ⟨_, .trans + (.symm <| .apply_pat hΓ + (fun _ _ h => ⟨_, (h2 _).defeq hΓ h⟩) hc.hasType.1) + (.trans hc <| .apply_pat hΓ + (fun _ _ h => ⟨_, (h2 _).defeq hΓ h⟩) hc.hasType.2)⟩ + have he' : IsDefEqU env univs Γ e e' := ⟨_, H.defeq hΓ H1⟩ + have hrhs : IsDefEqU env univs Γ (r.1.apply m1 m2) (r.1.apply m1 m3) := + ⟨_, IsDefEq.apply_pat hΓ + (fun _ _ h => ⟨_, (h2 _).defeq hΓ h⟩) l4.choose_spec.hasType.2⟩ + have hsound := IsDefEqU.trans henv hΓ he'.symm + (IsDefEqU.trans henv hΓ l4 hrhs) + have h : Γ ⊢ e' ≫ r.1.apply m1 m3' := .extra l1 h1 hcheck hsound h3 + exact ⟨_, h, .apply_pat hΓ (fun a _ _ => h4 a) + (h.hasType hΓ (H.hasType hΓ H1))⟩ | .inr ⟨_, _, _, _, _, h1, h2, l2', _, _, _, _, m3, r1, r2, r4, e⟩ => obtain ⟨_, -, -, hr, -⟩ := Pattern.matches_inter.1 ⟨⟨_, _, r2⟩, ⟨_, _, l2'⟩⟩ obtain ⟨rfl, rfl, ⟨⟩⟩ := pat_uniq l1 r1 h1 hr @@ -1365,7 +1393,7 @@ theorem ParRed.triangle (H1 : Γ ⊢ e : A) (H : Γ ⊢ e ≫ e') (H2 : Γ ⊢ e let ⟨m3', h3, h4⟩ := this refine ⟨_, ?h3, .apply_pat hΓ (fun a _ _ => h4 a) ((?h3).hasType hΓ (H.hasType hΓ H1))⟩ exact .apply_pat _ h3 - clear H r l1 l2 l3 l4 this h1 h2 r1 r2 hr + clear H r l1 l2 l3 l4 l5 this h1 h2 r1 r2 hr induction l2' generalizing A with | const => exact ⟨nofun, nofun, nofun⟩ | app _ _ ih1 ih2 => @@ -1695,7 +1723,7 @@ endpoint is absorbed without erasing that seed. This is the common typed join for all six structure-eta interactions from the L4L-15B design: * constructor-major projector iota and an overlapping registered rule are - both `ParRed.extra`; `ParRed.defeq` discharges them through `pat_wf`; + both `ParRed.extra`; each step retains its own typed equality certificate; * nested reconstructions retain their inner `etaL`/`etaR` seed when `StructEq.trans_right` composes the outer endpoint; * beta and congruence steps inside the major, including every repeated @@ -1883,6 +1911,43 @@ theorem CRDefEq.trans : Γ ⊢ e₁ ≫≪ e₂ → Γ ⊢ e₂ ≫≪ e₃ → let ⟨_, b1, b2⟩ := (r5.symm hΓ).parRedS hΓ m2 exact ⟨l1, r2, _, _, .trans l3 a1, .trans r4 b1, a2.trans hΓ <| m3.trans hΓ (b2.symm hΓ)⟩ +/-- Operational coverage for the environment's registered equations. + +This is deliberately separate from `Params.Pat`: registering a `VDefEq`, or +merely classifying a pattern, does not make a reduction available. For every +registered equation and well-formed context, a consumer must supply endpoint +typings plus parallel-reduction paths to endpoints related by `NormalEq`; +that is exactly `CRDefEq`. Symmetry and congruence closure are then derived by +Church--Rosser rather than assumed as additional oracle fields. + +At each pattern contraction, `ParRed.extra` independently requires a +successful match, satisfied checks, and a typed equality from that particular +redex to the instantiated template. Thus this oracle cannot turn registration +or pattern membership into an automatically trusted rewrite. Lambda-tower +registrations expose their useful pattern only underneath the tower, after +beta collapse, without pretending that the closed tower itself matches a +first-order pattern. -/ +class Params.Extension [Params] where + join : OnCtx Γ (env.IsType univs) → + env.defeqs df → (∀ l ∈ ls, l.WF univs) → ls.length = df.uvars → + CRDefEq Γ (df.lhs.instL ls) (df.rhs.instL ls) + +theorem Params.Extension.extra [Params.Extension] + (hΓ : OnCtx Γ (env.IsType univs)) + (hreg : env.defeqs df) (hlevels : ∀ l ∈ ls, l.WF univs) + (hlevelsLength : ls.length = df.uvars) : + CRDefEq Γ (df.lhs.instL ls) (df.rhs.instL ls) := + Params.Extension.join hΓ hreg hlevels hlevelsLength + +theorem Params.Extension.extra_symm [Params.Extension] + (hΓ : OnCtx Γ (env.IsType univs)) + (hreg : env.defeqs df) (hlevels : ∀ l ∈ ls, l.WF univs) + (hlevelsLength : ls.length = df.uvars) : + CRDefEq Γ (df.rhs.instL ls) (df.lhs.instL ls) := + (Params.Extension.extra hΓ hreg hlevels hlevelsLength).symm hΓ + +variable [Params.Extension] + variable! (hΓ : OnCtx Γ (IsType env univs)) in theorem IsDefEq.church_rosser (H : Γ ⊢ e₁ ≡ e₂ : A) : Γ ⊢ e₁ ≫≪ e₂ := by @@ -1930,7 +1995,5 @@ theorem IsDefEq.church_rosser | proofIrrel h1 h2 h3 ih1 ih2 ih3 => exact .normalEq hΓ <| .proofIrrel h1.hasType.1 h2.hasType.1 h3.hasType.1 | @extra _ _ Γ h1 h2 h3 => - have ⟨_, _, _, _, a1, a2, a3, a4⟩ := extra_pat h1 h2 h3 (Γ := Γ) - refine have h := .extra h1 h2 h3; mk h (.tail .rfl (.extra a1 a2 a3 fun _ => .rfl)) .rfl ?_ - exact a4 ▸ .refl h.hasType.2 + exact Params.Extension.extra hΓ h1 h2 h3 | nil | cons => trivial diff --git a/Lean4Lean/Theory/Typing/HeadReduction.lean b/Lean4Lean/Theory/Typing/HeadReduction.lean index a4ac4eea..c0d1ef17 100644 --- a/Lean4Lean/Theory/Typing/HeadReduction.lean +++ b/Lean4Lean/Theory/Typing/HeadReduction.lean @@ -61,6 +61,7 @@ inductive WHRed (Γ : List VExpr) : VExpr → VExpr → Prop where | major : IsMajorPremise f → Γ ⊢ a ⤳ a' → Γ ⊢ .app f a ⤳ .app f a' | beta : Γ ⊢ .app (.lam A e) a ⤳ e.inst a | extra : Pat p r → p.Matches e m1 m2 → r.2.OK (IsDefEqU env univs Γ) m1 m2 → + IsDefEqU env univs Γ e (r.1.apply m1 m2) → Γ ⊢ e ⤳ r.1.apply m1 m2 theorem WHRed.defeqDFC (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂) @@ -69,16 +70,20 @@ theorem WHRed.defeqDFC (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂) | app _ ih1 => exact .app (ih1 W) | major h1 _ ih1 => exact .major h1 (ih1 W) | beta => exact .beta - | extra h1 h2 h3 => exact .extra h1 h2 <| h3.map fun a b h => h.defeqDFC henv W + | extra h1 h2 h3 h4 => + exact .extra h1 h2 (h3.map fun a b h => h.defeqDFC henv W) (h4.defeqDFC henv W) theorem WHRed.weak' (W : Ctx.Lift' ρ Γ Γ') : Γ ⊢ e1 ⤳ e2 → Γ' ⊢ e1.lift' ρ ⤳ e2.lift' ρ | .app h1 => .app (h1.weak' W) | .major h1 h2 => .major (IsMajorPremise.lift'.2 h1) (h2.weak' W) | .beta => by rw [VExpr.lift'_inst_hi]; exact .beta - | .extra h1 h2 h3 => by + | .extra h1 h2 h3 h4 => by + have h4 := h4.weak' henv W + rw [Pattern.RHS.apply_lift'] at h4 rw [Pattern.RHS.apply_lift'] - refine .extra h1 (Pattern.matches_lift'.2 ⟨_, h2, fun _ => rfl⟩) <| h3.map fun _ _ h => ?_ + refine .extra h1 (Pattern.matches_lift'.2 ⟨_, h2, fun _ => rfl⟩) + (h3.map fun _ _ h => ?_) h4 simp only [← Pattern.RHS.apply_lift']; exact h.weak' henv W theorem WHRed.weakN (W : Ctx.LiftN n k Γ Γ') (H : Γ ⊢ e1 ⤳ e2) : @@ -97,10 +102,12 @@ theorem WHRed.weakU_inv (W : Ctx.Lift' ρ Γ Γ') (H : Γ' ⊢ e1.lift' ρ ⤳ e | beta => let .app e1 _ := e1; let .lam .. := e1; cases he simp [← VExpr.lift'_inst_hi, VExpr.lift'_inj]; exact .beta - | extra h1 h2 h3 => + | extra h1 h2 h3 hsound => subst he obtain ⟨_, h4, h5⟩ := Pattern.matches_lift'.1 h2; cases funext h5 - refine ⟨_, (Pattern.RHS.apply_lift' _).symm, .extra h1 h4 <| h3.map fun _ _ h => ?_⟩ + rw [← Pattern.RHS.apply_lift'] at hsound + refine ⟨_, (Pattern.RHS.apply_lift' _).symm, .extra h1 h4 (h3.map fun _ _ h => ?_) + ((IsDefEqU.weak'_iff henv hΓ W).1 hsound)⟩ simp only [← Pattern.RHS.apply_lift'] at h exact (IsDefEqU.weak'_iff henv hΓ W).1 h @@ -109,7 +116,7 @@ theorem WHRed.parRed (H : Γ ⊢ e1 ⤳ e2) : Γ ⊢ e1 ≫ e2 := by | app _ ih => exact .app ih .rfl | major _ _ ih => exact .app .rfl ih | beta => exact .beta .rfl .rfl - | extra h1 h2 h3 => exact .extra h1 h2 h3 fun _ => .rfl + | extra h1 h2 h3 h4 => exact .extra h1 h2 h3 h4 fun _ => .rfl variable! (hΓ : OnCtx Γ (IsType env univs)) in theorem WHRed.defeq (H : Γ ⊢ e1 ⤳ e2) (he : Γ ⊢ e1 : A) : Γ ⊢ e1 ≡ e2 : A := @@ -125,9 +132,11 @@ theorem WHRed.instN (W : Ctx.InstN Γ₀ a A₀ k Γ₁ Γ) | app _ ih => exact .app ih | major h1 _ ih => exact .major h1.instN ih | beta => rw [(by apply inst_inst_hi : (inst ..).inst _ _ = _)]; exact .beta - | extra h1 h2 h3 => + | extra h1 h2 h3 h4 => + have h4 := h4.instN henv W H₀ + rw [Pattern.RHS.instN_apply] at h4 rw [Pattern.RHS.instN_apply] - exact .extra h1 (Pattern.matches_instN h2) (h3.instN W H₀) + exact .extra h1 (Pattern.matches_instN h2) (h3.instN W H₀) h4 def WHNF (Γ : List VExpr) (e : VExpr) := ∀ e', ¬Γ ⊢ e ⤳ e' @@ -429,19 +438,33 @@ theorem StRed.triangle (W : IsDefEqCtx env univs Γ₀ Γ₁ Γ₂) have ⟨⟨_, u1⟩, _, u2⟩ := (c1.uniqU henv hΓ (hA.lam he)).forallE_inv henv hΓ exact .whRed (a1.trans a4.app |>.tail .beta) <| (ih2 W ha a3).instN (u1.defeq ha) .zero (ih1 (W.succ (a5.defeq hΓ hA)) he a6) - | @extra p r e₁ m1 m2 Γ₂ m2' h1 h2 h3 _ ih => + | @extra p r e₀ m1 m2 Γ₂ m2' h1 h2 h3 h4 _ ih => have hΓ := W.isType' hΓ₀ - suffices ∀ p' m1 m2, Subpattern p' p → p'.Matches e₁ m1 m2 → + suffices ∀ p' m1 m2, Subpattern p' p → p'.Matches e₀ m1 m2 → ∃ e₁ m3, Γ₁ ⊢ e ⤳* e₁ ∧ p'.Matches e₁ m1 m3 ∧ (∀ x, Γ₁ ⊢ m3 x ⤳< m2 x) by let ⟨e₁, m3, a1, a2, a3⟩ := this _ _ _ .refl h2 - have := (a1.hasType hΓ h).matches_inv hΓ a2 - refine .whRed (.tail a1 (.extra h1 a2 <| h3.map fun a b ⟨_, h⟩ => ?_)) - (.apply_pat _ fun x => let ⟨_, h⟩ := this x; ih x W h (a3 x)) - replace h := h.defeqDFC henv (W.symm henv) - refine have {r} := IsDefEq.apply_pat hΓ (r := r) fun a A h => ?_ - ⟨_, (this h.hasType.1).symm.trans <| h.trans (this h.hasType.2)⟩ - let ⟨_, h'⟩ := this a; exact ⟨_, ((a3 a).defeq hΓ h').symm⟩ - clear h2 ih h; intro p' m1 m2 hp h2 + have hcap := (a1.hasType hΓ h).matches_inv hΓ a2 + have hcheck : r.2.OK (IsDefEqU env univs Γ₁) m1 m3 := + h3.map fun a b ⟨_, hc⟩ => by + replace hc := hc.defeqDFC henv (W.symm henv) + have move {rhs : p.RHS} {T} + (ht : Γ₁ ⊢ rhs.apply m1 m2 : T) : + Γ₁ ⊢ rhs.apply m1 m2 ≡ rhs.apply m1 m3 : T := + IsDefEq.apply_pat hΓ + (fun a _ _ => let ⟨_, ha⟩ := hcap a; ⟨_, ((a3 a).defeq hΓ ha).symm⟩) ht + exact ⟨_, (move hc.hasType.1).symm.trans <| hc.trans (move hc.hasType.2)⟩ + have hsound₀ := h4.defeqDFC henv (W.symm henv) + have he' : IsDefEqU env univs Γ₁ e₁ e₀ := + ⟨_, (a1.defeq hΓ h).symm.trans (H1.defeq hΓ h)⟩ + have hrhs : IsDefEqU env univs Γ₁ (r.1.apply m1 m2) (r.1.apply m1 m3) := + ⟨_, IsDefEq.apply_pat hΓ + (fun a _ _ => let ⟨_, ha⟩ := hcap a; ⟨_, ((a3 a).defeq hΓ ha).symm⟩) + hsound₀.choose_spec.hasType.2⟩ + have hsound := IsDefEqU.trans henv hΓ he' + (IsDefEqU.trans henv hΓ hsound₀ hrhs) + refine .whRed (.tail a1 (.extra h1 a2 hcheck hsound)) + (.apply_pat _ fun x => let ⟨_, h⟩ := hcap x; ih x W h (a3 x)) + clear h2 h4 ih h; intro p' m1 m2 hp h2 induction h2 generalizing e with | const => let .const H1 := H1; exact ⟨_, _, H1, .const, nofun⟩ | app l1 l2 ih1 ih2 => @@ -466,7 +489,7 @@ variable! (hΓ : OnCtx Γ (IsType env univs)) in theorem ParRedS.standard (h : Γ ⊢ e : A) (H : Γ ⊢ e ≫* e') : Γ ⊢ e ⤳< e' := .triangleS hΓ .zero h .rfl H -variable! (hΓ : OnCtx Γ (IsType env univs)) in +variable! [Params.Extension] (hΓ : OnCtx Γ (IsType env univs)) in theorem IsDefEq.reduce_sort (H : Γ ⊢ e ≡ .sort u : A) : ∃ u', Γ ⊢ e ⤳* .sort u' ∧ u' ≈ u := by have ⟨_, _, e', _, h1, h2, h3⟩ := H.church_rosser hΓ @@ -485,7 +508,7 @@ theorem IsDefEq.reduce_sort (H : Γ ⊢ e ≡ .sort u : A) : let .sort h1 := h1.standard hΓ H.hasType.1 exact ⟨_, h1, a1⟩ -variable! (hΓ : OnCtx Γ (IsType env univs)) in +variable! [Params.Extension] (hΓ : OnCtx Γ (IsType env univs)) in theorem IsDefEq.reduce_forallE (H : Γ ⊢ e ≡ .forallE A B : V) : ∃ A' B', Γ ⊢ e ⤳* .forallE A' B' := by have ⟨_, _, e', _, h1, h2, h3⟩ := H.church_rosser hΓ @@ -631,7 +654,7 @@ theorem InferType.inst (H₀ : Γ ⊢ a ▷ A₀) (H : A₀::Γ ⊢ e ▷ A) : have ⟨_, hA⟩ := (H₀.hasType hΓ).isType henv hΓ .instN hΓ (by exact ⟨hΓ, _, hA⟩) H₀ .zero H -variable! (hΓ : OnCtx Γ (IsType env univs)) in +variable! [Params.Extension] (hΓ : OnCtx Γ (IsType env univs)) in theorem InferType.exists (H : Γ ⊢ a : A) : ∃ A', Γ ⊢ a ▷ A' := by replace H := (H.strong henv hΓ).hasType'.1 generalize true = b at H diff --git a/Lean4Lean/Theory/Typing/InductivePatternEnv.lean b/Lean4Lean/Theory/Typing/InductivePatternEnv.lean index d5c34712..444f728e 100644 --- a/Lean4Lean/Theory/Typing/InductivePatternEnv.lean +++ b/Lean4Lean/Theory/Typing/InductivePatternEnv.lean @@ -14,33 +14,175 @@ Church–Rosser instantiation and downstream consumers need: 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. -/ + certificate's own pattern payload. `CertifiedExtension.covers` records + the match at the beta-collapsed body of a registered lambda tower, never + at the closed tower itself. No open-environment `Params` instance is + installed. -/ namespace Lean4Lean +namespace VExpr + +/-- Remove the leading lambda tower from an expression. This is the +syntactic point at which first-order reduction patterns are matched; a +closed lambda tower itself is deliberately not a `Pattern`. -/ +def stripLams : VExpr → VExpr + | .lam _ body => stripLams body + | e => e + +@[simp] theorem stripLams_lamN (binders : List VExpr) (body : VExpr) : + stripLams (lamN binders body) = stripLams body := by + induction binders with + | nil => rfl + | cons _ binders ih => exact ih + +/-- Universe instantiation commutes with exposing the body of a lambda +tower. -/ +theorem stripLams_instL (e : VExpr) (ls : List VLevel) : + stripLams (e.instL ls) = (stripLams e).instL ls := by + induction e with + | lam _ _ _ ih => exact ih + | _ => rfl + +end VExpr + 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. -/ +its registered defeq, a simple pattern, and the pattern payload. Coverage is +stated at `VExpr.stripLams (df.lhs.instL ls)`, the beta-collapsed pattern +site, rather than at `df.lhs.instL ls`, which is generally a closed lambda +tower. Check obligations and the typed equality from the matched redex to +the RHS are discharged by the consumer at the reduction site and are +carried by `ParRed.extra`; this certificate does not make either fact true +by registration alone. -/ structure CertifiedExtension where df : VDefEq pat : SimplePattern rhs : (pat.toPattern).RHS check : (pat.toPattern).Check covers : ∀ (ls : List VLevel), ls.length = df.uvars → - ∃ m1 m2, (pat.toPattern).Matches (df.lhs.instL ls) m1 m2 ∧ - df.rhs.instL ls = rhs.apply m1 m2 + ∃ m1 m2, (pat.toPattern).Matches + (VExpr.stripLams (df.lhs.instL ls)) m1 m2 + +namespace CertifiedExtension + +/-- The first-order pattern exposed by the body of `quotDefEq`: five +arguments to `Quot.lift`, followed by a three-argument `Quot.mk` major. -/ +def quotPattern : SimplePattern := + .iota ``Quot.lift 5 ``Quot.mk 3 + +private def quotRecPaths := + Pattern.varNPaths (.const ``Quot.lift) 5 + +private def quotCtorPaths := + Pattern.varNPaths (.const ``Quot.mk) 3 + +/-- The six arguments of the registered quotient tower: all five lift +arguments followed by the quotient representative. -/ +def quotCaptureArgs : List (quotPattern.toPattern.RHS) := + quotRecPaths.map (fun path => .var (.inl path)) ++ + (quotCtorPaths.drop 2).map (fun path => .var (.inr path)) + +/-- The registered right tower applied to the captures selected by the +collapsed quotient pattern. -/ +def quotRHS : quotPattern.toPattern.RHS := + Pattern.RHS.appN (.fixed quotDefEq.rhs (by decide)) quotCaptureArgs + +/-- The constructor-side `α` and relation arguments must agree with the +corresponding `Quot.lift` arguments. -/ +def quotCheck : quotPattern.toPattern.Check := + ((quotCtorPaths.take 2).zip (quotRecPaths.take 2)).foldr + (fun paths rest => .defeq (.var (.inr paths.1)) + (.var (.inl paths.2)) rest) .true + +/-- Exact non-lambda body of the registered quotient equation. -/ +def quotLhsBody : VExpr := + .app + (VExpr.appN (.const ``Quot.lift [.param 0, .param 1]) + [.bvar 5, .bvar 4, .bvar 3, .bvar 2, .bvar 1]) + (VExpr.appN (.const ``Quot.mk [.param 0]) + [.bvar 5, .bvar 4, .bvar 0]) + +theorem quotDefEq_lhsBody : + VExpr.stripLams quotDefEq.lhs = quotLhsBody := rfl + +/-- `quotDefEq` satisfies the same beta-collapsed registration contract as +generated iota rules. This is a kernel proof of pattern coverage, not a +project axiom and not an operational equality oracle. -/ +def quot : CertifiedExtension where + df := quotDefEq + pat := quotPattern + rhs := quotRHS + check := quotCheck + covers := by + intro ls hlen + have hlen' : ls.length = 2 := by simpa [quotDefEq] using hlen + have hlevels : [.param 0, .param 1].map (VLevel.inst ls) = ls := + VLevel.inst_map_id hlen' + let mkLevels := [.param 0].map (VLevel.inst ls) + have hleft : HeadConstN ``Quot.lift ls 5 + (VExpr.appN (.const ``Quot.lift ls) + [.bvar 5, .bvar 4, .bvar 3, .bvar 2, .bvar 1]) := by + have h0 : HeadConstN ``Quot.lift ls 0 (.const ``Quot.lift ls) := .const + simpa using h0.appN + [.bvar 5, .bvar 4, .bvar 3, .bvar 2, .bvar 1] + have hright : HeadConstN ``Quot.mk mkLevels 3 + (VExpr.appN (.const ``Quot.mk mkLevels) + [.bvar 5, .bvar 4, .bvar 0]) := by + have h0 : HeadConstN ``Quot.mk mkLevels 0 (.const ``Quot.mk mkLevels) := .const + simpa using h0.appN [.bvar 5, .bvar 4, .bvar 0] + obtain ⟨m2, hm⟩ := RecursorIotaPattern.matches_of hleft hright + refine ⟨ls, m2, ?_⟩ + rw [VExpr.stripLams_instL, quotDefEq_lhsBody] + have hbody : quotLhsBody.instL ls = + .app + (VExpr.appN (.const ``Quot.lift ls) + [.bvar 5, .bvar 4, .bvar 3, .bvar 2, .bvar 1]) + (VExpr.appN (.const ``Quot.mk mkLevels) + [.bvar 5, .bvar 4, .bvar 0]) := by + simp [quotLhsBody, VExpr.instL, VExpr.instL_appN, hlevels, mkLevels] + rw [hbody] + exact hm + +end CertifiedExtension namespace BlockGenerationChecked variable {source : VInductDecl} (gen : source.BlockGenerationChecked) +/-- Every generated iota rule satisfies the beta-collapsed extension shape. +The witness is derived from the generated rule body and is independent of +the rule's semantic soundness proof (`pat_wf`). -/ +def iotaExtension (hcl : gen.RuleClosure) {i : Nat} + {constructor : NormalizedBlockCtor} (h : gen.ruleEntry i constructor) : + CertifiedExtension where + df := gen.rule i constructor + pat := gen.rulePattern constructor + rhs := gen.ruleRHS hcl h + check := gen.ruleCheck hcl (List.mem_of_getElem? h) + covers := by + intro ls hlen + obtain ⟨m2, hm⟩ := gen.ruleLhsBody_matches constructor + have hm := hm.instL ls + have hlevels : gen.recLevels.map (VLevel.inst ls) = ls := + VLevel.inst_map_id (hlen.trans (gen.rule_uvars i constructor)) + rw [hlevels] at hm + refine ⟨ls, (fun x => (m2 x).instL ls), ?_⟩ + rw [gen.rule_lhs, VExpr.instL_lamN, VExpr.stripLams_lamN] + have hbody : gen.ruleLhsBody constructor = + .app (VExpr.appN + (gen.recBase (gen.ruleFieldCount constructor) constructor.owner) + (gen.ruleIdx constructor)) (gen.ruleCtorApp constructor) := by + rw [ruleLhsBody, VExpr.appN_append] + rfl + have hstrip : VExpr.stripLams ((gen.ruleLhsBody constructor).instL ls) = + (gen.ruleLhsBody constructor).instL ls := by + rw [hbody] + rfl + rw [hstrip] + exact hm + /-- The assembled block-local environment: dependency constants from the base, the block's four insertion phases, and the certified extension defeqs. -/ @@ -202,17 +344,16 @@ theorem AssembledPat.pat_simple {hcl : gen.RuleClosure} | 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. -/ +/-- Extension defeqs of the assembled set expose their pattern at the +beta-collapsed body of the registered lambda tower. -/ theorem AssembledPat.ext_covers {hcl : gen.RuleClosure} {exts : List CertifiedExtension} {ext : CertifiedExtension} (hmem : ext ∈ exts) {ls : List VLevel} (hls : ls.length = ext.df.uvars) : ∃ p r m1 m2, gen.AssembledPat hcl exts p r ∧ - p.Matches (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 + p.Matches (VExpr.stripLams (ext.df.lhs.instL ls)) m1 m2 := by + obtain ⟨m1, m2, hmatch⟩ := ext.covers ls hls exact ⟨ext.pat.toPattern, (ext.rhs, ext.check), m1, m2, - .ext ext hmem, hmatch, hrhs⟩ + .ext ext hmem, hmatch⟩ end BlockGenerationChecked @@ -222,6 +363,18 @@ end Lean4Lean /-! ## Axiom closures -/ +/-- info: 'Lean4Lean.Pattern.Matches.instL' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.Pattern.Matches.instL + +/-- info: 'Lean4Lean.VInductDecl.CertifiedExtension.quot' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.CertifiedExtension.quot + +/-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.iotaExtension' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.iotaExtension + /-- info: 'Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_defeqs' depends on axioms: [propext, Quot.sound] -/ #guard_msgs in #print axioms Lean4Lean.VInductDecl.BlockGenerationChecked.assembleEnv_defeqs diff --git a/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean b/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean index ed0c9574..96807143 100644 --- a/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean +++ b/Lean4Lean/Theory/Typing/InductivePatternFixtures.lean @@ -105,6 +105,46 @@ theorem patTreeClosure : patTreeGen.RuleClosure := theorem patVecClosure : patVecGen.RuleClosure := RuleClosure.of_all _ (by decide) (by decide) +/-! ## Beta-collapsed tower certificates + +The concrete generated block and the built-in quotient equation both expose +their first-order match only after stripping the registered lambda tower. +These examples pin that contract without constructing a `Params` instance or +assuming an equality from pattern membership. -/ + +/-- Every registered iota rule of the concrete mutual block has a +beta-collapsed pattern witness. -/ +theorem patTreeIotaExtension_covers {i : Nat} + {constructor : NormalizedBlockCtor} (hentry : patTreeGen.ruleEntry i constructor) + (ls : List VLevel) (hlen : ls.length = (patTreeGen.rule i constructor).uvars) : + ∃ m1 m2, (patTreeGen.rulePattern constructor).toPattern.Matches + (VExpr.stripLams ((patTreeGen.rule i constructor).lhs.instL ls)) m1 m2 := + (patTreeGen.iotaExtension patTreeClosure hentry).covers ls hlen + +/-- `quotDefEq` satisfies the same beta-collapsed coverage contract. -/ +theorem quotDefEq_covers (ls : List VLevel) + (hlen : ls.length = quotDefEq.uvars) : + ∃ m1 m2, CertifiedExtension.quotPattern.toPattern.Matches + (VExpr.stripLams (quotDefEq.lhs.instL ls)) m1 m2 := + CertifiedExtension.quot.covers ls hlen + +/-! +The tower witnesses stay on the standard logical baseline. In particular, +neither closure contains a project axiom or `sorryAx`. +-/ + +/-- +info: 'Lean4Lean.InductivePatternFixtures.patTreeIotaExtension_covers' depends on axioms: [propext, + Classical.choice, + Quot.sound] +-/ +#guard_msgs in +#print axioms patTreeIotaExtension_covers + +/-- info: 'Lean4Lean.InductivePatternFixtures.quotDefEq_covers' depends on axioms: [propext, Quot.sound] -/ +#guard_msgs in +#print axioms quotDefEq_covers + /-! ## The instantiated pattern sets Both blocks now carry complete pattern payloads: `patTreeGen.IotaPat diff --git a/Lean4Lean/Theory/Typing/InductivePatternWF.lean b/Lean4Lean/Theory/Typing/InductivePatternWF.lean index b89f34db..48ec3f00 100644 --- a/Lean4Lean/Theory/Typing/InductivePatternWF.lean +++ b/Lean4Lean/Theory/Typing/InductivePatternWF.lean @@ -187,6 +187,45 @@ theorem VEnv.IsDefEq.appN_congr {env : VEnv} {U : Nat} {Γ : List VExpr} env.IsDefEq U Γ (VExpr.appN X es) (VExpr.appN Y es) B := h.appN_defEq hs.toSpineDefEq +/-- A registered equation remains available after environment growth. + +This is the primitive transport operation for consumer-certified extension +rules: `VEnv.LE` transports registration, while the core `.extra` constructor +still requires the exact universe instantiation side conditions. -/ +theorem VEnv.LE.extra {env env' : VEnv} (henv : env ≤ env') {U : Nat} + {Γ : List VExpr} {df : VDefEq} {ls : List VLevel} + (hreg : env.defeqs df) (hlevels : ∀ l ∈ ls, l.WF U) + (hlevelsLength : ls.length = df.uvars) : + env'.IsDefEq U Γ (df.lhs.instL ls) (df.rhs.instL ls) + (df.type.instL ls) := + .extra (henv.defeqs hreg) hlevels hlevelsLength + +/-- Transport a registered equation through environment growth and then +apply it to a well-typed spine. This is the beta-tower consumer boundary: +registration supplies only the tower equality; application congruence and +spine typing remain explicit proof obligations. -/ +theorem VEnv.LE.extra_appN {env env' : VEnv} (henv : env ≤ env') {U : Nat} + {Γ : List VExpr} {df : VDefEq} {ls : List VLevel} {args : List VExpr} + {B : VExpr} (hreg : env.defeqs df) + (hlevels : ∀ l ∈ ls, l.WF U) (hlevelsLength : ls.length = df.uvars) + (hspine : env.SpineWF U Γ (df.type.instL ls) args B) : + env'.IsDefEq U Γ + (VExpr.appN (df.lhs.instL ls) args) + (VExpr.appN (df.rhs.instL ls) args) B := + (henv.extra hreg hlevels hlevelsLength).appN_congr (hspine.mono henv) + +/-- The symmetric applied transport is derived, not a second trusted +extension direction. -/ +theorem VEnv.LE.extra_appN_symm {env env' : VEnv} (henv : env ≤ env') + {U : Nat} {Γ : List VExpr} {df : VDefEq} {ls : List VLevel} + {args : List VExpr} {B : VExpr} (hreg : env.defeqs df) + (hlevels : ∀ l ∈ ls, l.WF U) (hlevelsLength : ls.length = df.uvars) + (hspine : env.SpineWF U Γ (df.type.instL ls) args B) : + env'.IsDefEq U Γ + (VExpr.appN (df.rhs.instL ls) args) + (VExpr.appN (df.lhs.instL ls) args) B := + (henv.extra_appN hreg hlevels hlevelsLength hspine).symm + /-- Applying a lambda telescope to a full well-typed spine collapses to the iterated instantiation of its body. -/ theorem VEnv.IsDefEq.appN_lamN {env : VEnv} (henv : env.Ordered) {U : Nat} : @@ -884,6 +923,18 @@ milestones land, with no restatement. -/ #guard_msgs in #print axioms Lean4Lean.VEnv.IsDefEq.appN_defEq +/-- info: 'Lean4Lean.VEnv.LE.extra' depends on axioms: [propext] -/ +#guard_msgs in +#print axioms Lean4Lean.VEnv.LE.extra + +/-- info: 'Lean4Lean.VEnv.LE.extra_appN' depends on axioms: [propext] -/ +#guard_msgs in +#print axioms Lean4Lean.VEnv.LE.extra_appN + +/-- info: 'Lean4Lean.VEnv.LE.extra_appN_symm' depends on axioms: [propext] -/ +#guard_msgs in +#print axioms Lean4Lean.VEnv.LE.extra_appN_symm + /-- info: 'Lean4Lean.Pattern.varN_matches_paths' depends on axioms: [propext, Classical.choice, Quot.sound] -/ #guard_msgs in #print axioms Lean4Lean.Pattern.varN_matches_paths diff --git a/Lean4Lean/Theory/Typing/Pattern.lean b/Lean4Lean/Theory/Typing/Pattern.lean index f8750cd5..44faa7f6 100644 --- a/Lean4Lean/Theory/Typing/Pattern.lean +++ b/Lean4Lean/Theory/Typing/Pattern.lean @@ -164,6 +164,22 @@ theorem Pattern.matches_instN {p : Pattern} {e : VExpr} {m1 m2} (H : p.Matches e rw [(_ : (fun _ => _) = _)]; exact ih1.app ih2 ext (_|_) <;> rfl +/-- Universe instantiation preserves a successful match. The universe +capture is instantiated pointwise and every expression capture is +instantiated by the same level substitution. -/ +theorem Pattern.Matches.instL {p : Pattern} {e : VExpr} {m1 m2} + (H : p.Matches e m1 m2) (ls : List VLevel) : + p.Matches (e.instL ls) (m1.map (VLevel.inst ls)) + fun x => (m2 x).instL ls := by + induction H with + | const => erw [show (fun _ : Empty => _) = _ by ext ⟨⟩]; exact .const + | var _ ih => + rw [(_ : (fun _ => _) = _)]; exact ih.var + ext (_|_) <;> rfl + | app _ _ ih1 ih2 => + rw [(_ : (fun _ => _) = _)]; exact ih1.app ih2 + ext (_|_) <;> rfl + theorem Pattern.matches_inter {p q : Pattern} {e : VExpr} : (∃ m1 m2, p.Matches e m1 m2) ∧ (∃ m1 m2, q.Matches e m1 m2) ↔ (∃ r m1 m2, p.inter q = some r ∧ r.Matches e m1 m2) := by diff --git a/plans/l4l-16-sort-inversion-decision.md b/plans/l4l-16-sort-inversion-decision.md new file mode 100644 index 00000000..9040ae27 --- /dev/null +++ b/plans/l4l-16-sort-inversion-decision.md @@ -0,0 +1,175 @@ +# L4L-16 sort-inversion route decision + +Date: 2026-08-12 + +Status: route selected and prerequisite interface landed. The post-v4.33 +spike selected the semantic route; L4L-18B completed its prerequisite +proof-carrying extension interface on 2026-08-12, so L4L-16 is now active. +This note does not weaken the theorem, add an assumption, or change the +accepted trust closure. + +## Gate theorem + +The only proof gate for this milestone is the existing live statement in +`Theory/Typing/Injectivity.lean`: + +```lean +theorem VEnv.IsDefEqU.sort_inv + (henv : VEnv.WF env) + (hΓ : OnCtx Γ (env.IsType U)) + (h1 : env.IsDefEqU U Γ (.sort u) (.sort v)) : u ≈ v +``` + +The current declaration is still admitted. It is one of the 16 proof-debt +declarations in `Audit/SorryFrontier.lean`; therefore the compiled allowlist +remains at 22 entries (16 proof declarations plus six deliberately rejected +kernel fixtures). + +The accepted exit closure is the ordinary Theory baseline only: any subset +of `propext`, `Classical.choice`, and `Quot.sound`. In particular, +`sorryAx`, a generated environment oracle, or a project-specific pattern +axiom is not an acceptable bridge. + +## Route 1: shape logical relation + +Decision: retain this as the technically credible long-term route, but do +not merge the fetched experimental branch as an L4L-16 proof. + +The semantic idea is validated by the completed companion development +`domain-semantics-lean`: finite shape approximations prove definitional +inversion in the presence of non-normalizing fixed points and eta. The +lean4lean `logrel` branch is an earlier version extended with constants and +rewrite patterns. Its endpoint theorem is the right shape, but its live +closure is not acceptable: + +```text +Lean4Lean.SExpr.sort_inv + [propext, sorryAx, Classical.choice, Quot.sound, + Lean4Lean.SExpr.Params.extra_pat] +``` + +The post-sync closure was reproduced by building +`Lean4Lean.Experimental.UniqueTyping` and printing the dependencies. The +remaining assumptions on the path are concrete: + +1. `SExpr.IsDefEq.strong` is admitted. Its constructor case needs the + classification/type bridge below. +2. `SExpr.IsDefEqStrong.defeq` is admitted. +3. `Params.ctor_ty` is admitted; the current `Params` classification has no + proved connection from a constructor classification to the translated + constant type required by `CtorBundle`. +4. `LR.adequacy` has one live admitted branch: constant adequacy. +5. `Params.extra_pat` is a project axiom rather than a class field or a + derived environment theorem. +6. The unmerged VExpr-to-SExpr bridge from PR 37 translates the pre-eta + equality judgment only. It predates the live `IsDefEq.structEta` + constructor and therefore is not exhaustive for the current Theory + judgment. +7. The current pattern contract cannot be instantiated by a live `VEnv.WF`. + `extra_pat` asks for a syntactic `Matches` proof for `df.lhs`, while + generated iota and quotient equations are registered as closed lambda + towers. Their useful pattern appears only after a typed beta collapse. + `CertifiedExtension.covers` and `IsDefEq.appN_lamN` record the needed + spine-level fact, but they intentionally do not manufacture a global + `Params` instance. +8. A global environment bridge must cover definitions, mutual definitions, + quotient rules, ordinary and block inductives, nested inductives, and the + registered structure-eta capability. The current block-local assembler + covers one certified block plus explicitly certified extensions; it is + not that global bridge. + +Items 5 and 7 are exactly the interface decision assigned to L4L-18B. +Nested-rule transport and the missing current-judgment coverage overlap the +later L4L-19 work. Pulling them into L4L-16 would not be a focused promotion +of a completed experimental proof; it would be the extension-interface and +consumer-bridge redesign themselves. + +## Route 2: live stratified derivations + +Decision: discard this as the L4L-16 implementation route. + +The live `Strong.lean` development is complete through strong translation, +stratification, weakening, substitution, and type-shape recovery. The +remaining obstruction is not bookkeeping in the final sort case: + +1. A converted typing of a sort can have an arbitrary syntactic intermediate + type (for example, an application reducing to a sort). A proof specialized + only to sort syntax must therefore establish uniqueness for that arbitrary + middle term. +2. In the application case, the same function can be typed at two candidate + Pi types. Aligning the result universes requires Pi--Pi injectivity for + those function types; equality of their outer `imax` levels is not enough + to recover the codomain levels. +3. The live stratified uniqueness proof consequently calls + `forallE_inv_stratified` in its application case and `sort_inv` throughout + its conversion cases. Those are the first two public admissions in + `Injectivity.lean`, not smaller lemmas hidden behind the current theorem. +4. The explicit level-indexed prototype reaches the same boundary at + `Experimental/Stronger.lean`: `IsDefEqStrong.sort_invL` is proved, but + `IsDefEqStrong.uniqL'` stops in its application case with the note that it + needs unique typing. + +A bounded mutual induction does not remove this dependency. It must prove +sort inversion, Pi--Pi injectivity, and type uniqueness together. That +absorbs the central L4L-17 theorem into L4L-16 rather than completing the +advertised sort-only route. The current ordering, in which L4L-17 builds on +`sort_inv`, is therefore circular for route 2. + +## Checked non-routes + +- The current Church--Rosser development is not an independent escape hatch. + It imports `UniqueTyping`, consumes the same sort/Pi inversion frontier, + and still has the two `NormalEq.parRed` admissions assigned to L4L-18A. +- No completed proof exists on the fetched upstream `logrel` branch, the + current public upstream branches, or the argumentcomputer development + branch. The VExpr translation branch deliberately leaves construction of + `Params` and constant adequacy open. +- The completed companion semantic formalization validates the mathematical + route, but its calculus has fixed points and closed type formers rather + than lean4lean's declaration-indexed constants, generated equations, and + registered structure eta. It is not a theorem that can be imported as the + missing environment bridge. + +## Required decision to resume + +One prerequisite ordering must change before implementation can resume: + +1. **Semantic route (recommended):** move the `Params`/beta-collapsed + extension contract and the live-environment semantic bridge ahead of the + L4L-16 exit, including a current `structEta` soundness case; then finish + constant adequacy and promote only the resulting accepted-closure proof. +2. **Joint inversion route:** explicitly merge the L4L-16 and L4L-17 research + gates and implement sort inversion, Pi injectivity/discrimination, and + unique typing as one mutually founded development. + +Until one of those scopes is approved, the honest repository state is the +unchanged public `sorry`, unchanged exact allowlist, and this blocked route +decision. Replacing the gap with `Params.extra_pat`, another generated +oracle, or a theorem whose closure still contains `sorryAx` is forbidden. + +## Resolution (2026-08-12) + +Option 1 is adopted, with an independence rider: the metatheory ladder is +reordered to land L4L-18B first, and every upstream-coordination gate is +removed from the roadmap. The `Params`/beta-collapsed extension interface +is a fork-owned decision; it ships with a design note plus a +divergence-ledger row when implemented, and upstream engagement +consolidates in the L4L-20C PR series. The new execution order is +L4L-18B (extension contract and pattern interface), then the re-scoped +L4L-16 (live-environment semantic bridge with registered structure eta, +current-judgment VExpr-to-SExpr translation, the SExpr admissions and +constant adequacy, and promotion of the public `sort_inv` closure out of +`Experimental/`), then L4L-17 (remaining inversion/uniqueness statements, +now including `registeredStructureHeadInversion`), then L4L-18A against +the redesigned interface. The joint L4L-16/L4L-17 merge was declined: on +the semantic route the inversion statements arrive from one adequacy +development, so the milestone split is no longer circular. + +L4L-18B subsequently removed `pat_wf` and `extra_pat` from Theory's `Params`, +made each operational pattern step carry its exact local equality, introduced +the explicit `Params.Extension.join` Church--Rosser obligation, and proved +beta-collapsed coverage for generated iota rules and `quotDefEq` (design note +`plans/l4l-18b-extension-interface-design.md`, ledger D020). The remaining +work in this record is therefore the live semantic environment instance, +current-judgment translation, adequacy, and public theorem promotion assigned +to L4L-16. diff --git a/plans/l4l-18b-extension-interface-design.md b/plans/l4l-18b-extension-interface-design.md new file mode 100644 index 00000000..584080b9 --- /dev/null +++ b/plans/l4l-18b-extension-interface-design.md @@ -0,0 +1,180 @@ +# L4L-18B extension contract and pattern-interface design + +Date: 2026-08-12 + +Status: implemented fork divergence on the reconciled v4.33 base. This note +records the interface decision owned by ledger entry D020. Construction of a +whole-live-environment semantic instance remains L4L-16 work. + +## Problem + +The upstream-shaped `Params` interface coupled two facts that do not hold at +the same syntactic point in lean4lean: + +1. `extra_pat` required a `Pattern.Matches` witness for + `df.lhs.instL levels`. +2. `pat_wf` accepted a pattern match, checks, and a bare typing of the redex, + then had to manufacture equality with the RHS template. + +Generated iota equations and `quotDefEq` are registered as closed lambda +towers. A first-order iota pattern cannot match the tower itself. The useful +recursor/constructor application appears only underneath the leading lambdas, +after applying a typed spine and beta-collapsing the tower. The proved +generated-rule soundness theorem consequently needs that typed spine +decomposition; bare `HasType` does not contain it. + +Leaving either mismatch as a `Params` field would make a generated instance +an oracle: registration or pattern membership could silently assert an +operational rewrite that was not proved at the actual redex. + +## Decision: separate shape, local soundness, and global joining + +### Pattern combinatorics + +`Params` now contains only the pattern set and its combinatorial laws: +simple-pattern classification and the overlap/nonintersection properties used +by the parallel-reduction proofs. It has neither `pat_wf` nor `extra_pat`. + +Pattern membership therefore says only that a pattern and payload participate +in the reduction system. It does not imply that any term matches, that checks +hold, or that a rewrite is definitionally equal. + +### Proof-carrying contractions + +The `.extra` constructors of `ParRed`, `CParRed`, and `WHRed`, and the +corresponding `NonNeutral` witness, carry the exact local certificate + +```lean +IsDefEqU env univs Γ e (r.1.apply m1 m2) +``` + +in addition to pattern membership, the successful match, and `Check.OK`. +Weakening, substitution, context conversion, standardization, and triangle +proofs transport or reconstruct this certificate explicitly. `ParRed.defeq` +uses the carried equality; it never obtains soundness from pattern +classification. + +This makes the operational trust boundary local: the consumer selecting a +contraction must prove equality for that concrete redex and capture map. + +### Beta-collapsed tower coverage + +`CertifiedExtension.covers` now states only the syntactic fact that the +registered left side matches after its leading lambda tower is exposed: + +```lean +∃ m1 m2, pat.toPattern.Matches + (VExpr.stripLams (df.lhs.instL levels)) m1 m2 +``` + +`VExpr.stripLams_instL` and `Pattern.Matches.instL` make this stable under +universe instantiation. They do not claim that the pattern payload's RHS is +equal to the registered RHS. + +Two kernel-checked constructors pin the intended environment classes: + +- `BlockGenerationChecked.iotaExtension` derives coverage from the generated + rule body and `ruleLhsBody_matches` for every certified iota rule. +- `CertifiedExtension.quot` gives the corresponding `Quot.lift`/`Quot.mk` + pattern, captures, checks, and collapsed coverage for `quotDefEq`. + +Both have exact axiom guards containing only the standard logical baseline; +neither uses a project axiom or `sorryAx`. + +### Global registered-equation joining + +Church--Rosser's raw `IsDefEq.extra` case has a different obligation from a +local pattern contraction. It is isolated in the explicit class + +```lean +class Params.Extension [Params] where + join : OnCtx Γ (env.IsType univs) → + env.defeqs df → (∀ l ∈ levels, l.WF univs) → + levels.length = df.uvars → + CRDefEq Γ (df.lhs.instL levels) (df.rhs.instL levels) +``` + +`CRDefEq` includes typings for both endpoints and parallel-reduction paths to +endpoints related by `NormalEq`. Thus an instance must prove operational +coverage for every registered equation in every well-formed context; registry +membership alone cannot inhabit it. `Params.Extension.extra_symm` derives the +reverse direction from the join rather than adding a second oracle field. + +Only `IsDefEq.church_rosser` and results that transitively invoke it require +`[Params.Extension]`. The remaining generic reduction and standardization +lemmas stay generic in `[Params]` alone. + +The live-environment instance covering definitions, quotient rules, +ordinary/mutual/nested inductives, and registered structure eta is deliberately +not manufactured here. L4L-16 constructs it through the semantic environment +bridge. + +## Environment transport + +The named `VEnv.LE` helpers make the core registered-equation behavior under +environment growth explicit: + +- `VEnv.LE.extra` transports registry membership and reconstructs the raw + typed equality with the original level side conditions. +- `VEnv.LE.extra_appN` additionally transports a typed spine and applies + congruence to both tower endpoints. +- `VEnv.LE.extra_appN_symm` derives the reverse applied equality by symmetry. + +These theorems transport proofs already available in the smaller environment; +they do not certify a new rule or infer a reduction from a pattern. + +## Trust matrix + +| Evidence | What it establishes | What it does not establish | +|---|---|---| +| `env.defeqs df` | the raw tower equation is registered | a pattern match or reduction step | +| `CertifiedExtension.covers` | the stripped left body has the advertised shape | checks, typing, or equality to the payload RHS | +| `Check.OK` | captured side conditions hold in the current context | redex-to-RHS equality | +| local `IsDefEqU` certificate | this matched redex equals this instantiated payload | global confluence for every registered equation | +| `Params.Extension.join` | a registered raw equation has a typed Church--Rosser join | automatic permission to contract an arbitrary match | + +No row implies a later row without a proof supplied by the corresponding +consumer. + +## Downstream migration + +`ChurchRosser.lean` transports the local equality certificate through +weakening, substitution, context conversion, complete parallel reduction, +match inversion, and the triangle proof. `HeadReduction.lean` mirrors the +same certificate in weak-head steps and reconstructs it in the +standardization triangle. The broad extension-instance requirement was +narrowed to `reduce_sort`, `reduce_forallE`, and `InferType.exists`, the three +head-reduction results that actually invoke Church--Rosser. + +Later L4L-18A overlap proofs target the proof-carrying `.extra` constructor. +Later L4L-16 constructs `Params.Extension` from the promoted semantic bridge; +it may use the beta-collapsed certificates and `pat_wf`, but cannot replace +their typing premises with registry membership. + +## Rejected alternatives + +- Matching the raw lambda tower: structurally false for the supported + first-order patterns. +- Storing a collapsed RHS equation in `CertifiedExtension`: this conflates a + syntactic inventory certificate with semantic soundness and would still + omit the typed-spine premises. +- Retaining `Params.pat_wf` with bare `HasType`: insufficient for the proved + generated-rule theorem and invites a consumer oracle. +- Treating every registered equality as a reduction: equality registration + is symmetric conversion data, not an orientation or termination policy. +- Generating a global `Params`/extension instance in the assembler: the + assembler covers one block plus explicit extensions, not the whole live + environment required by the semantic proof. + +## Validation and upstream path + +Focused builds cover Church--Rosser, head reduction, the pattern environment, +and concrete pattern fixtures. Exact guards pin the new universe-match +transport, generated-iota and quotient certificates, and `VEnv.LE` transport +helpers. The full milestone gate is recorded in the landing checkpoint. + +D020 is revisited at every upstream reconciliation. It is removed when +upstream adopts the proof-carrying contraction and explicit join split, or an +equivalent interface that can represent beta-collapsed tower rules without a +trusted shape/soundness oracle. Upstream review is consolidated in the +L4L-20C proof-PR series. diff --git a/plans/roadmap.md b/plans/roadmap.md index 69ed52cd..9aa52a20 100644 --- a/plans/roadmap.md +++ b/plans/roadmap.md @@ -1,9 +1,9 @@ # Lean4Lean completion roadmap -**Status:** authoritative local roadmap, audited 2026-08-11 against the +**Status:** authoritative local roadmap, audited 2026-08-12 against the committed fork and the current `jcb/formalization2` development bookmark; -publication (pushing `jcb/formalization2` to origin) remains a separate -boundary. +publication (moving `origin/jcb/formalization2`) is a separate boundary and +currently matches the local bookmark at the L4L-15B checkpoint. **Versioning.** `plans/roadmap.md` is intentionally tracked so the status-bearing milestone ladder travels with each checkpoint; other files @@ -68,10 +68,10 @@ required for the final release; they can be reached in separate milestones. | Fact | Value | |---|---| -| Ladder position | **L4L-16 active** (route selection and sort inversion); L4L-15B structure eta and unit-like comparison is complete and pruned from §5 (2026-08-11) | -| Current formalization source | this L4L-15B checkpoint (jj change `xuzusmnl`) at `jcb/formalization2`, atop the approved design/ledger checkpoint `01bfdce9`; `origin/jcb/formalization2` is the publication bookmark moved only after the complete gate | +| Ladder position | **L4L-16 active** (semantic environment bridge and sort inversion). L4L-18B completed first on 2026-08-12: proof-carrying pattern contractions, an explicit registered-equation join contract, beta-collapsed generated-iota/`quotDefEq` coverage, and `VEnv.LE` transport now form the fork-owned interface (design note `plans/l4l-18b-extension-interface-design.md`, ledger D020) | +| Current formalization source | the L4L-18B checkpoint (jj change `oluxtqyk`) descends from the L4L-15B checkpoint `7c1e89fc` (jj change `xuzusmnl`) and is published at `jcb/formalization2` after the complete gate passed | | Parent lineage | the L4L-15B implementation descends from the v4.33 reconciliation merge `99a7f8ae7b89` (second parent: digama `upstream/master` `b292275c`); Lean on v4.33.0 final, lean4-nix on `argumentcomputer/lean4-nix` (upstream pins v4.33.0-rc2 — ledger D018) | -| Fixed `master` baseline | `1fb7d6ef9042c5a80b2de9320c88ac0f3ce404cb` | +| Fixed `master` baseline | `1a16b72d2e35932a82aa501beb29ef2c3d072580` — local `master` bookmark and `origin/master` (corrected 2026-08-12; the row previously carried a fork formalization hash that no `master` ref ever pointed at). The v4.33 reconciliation merged the later digama `upstream/master` `b292275c` as its second parent without moving `master` | | Trust frontier | exactly 16 sorried proof declarations (10 Tier V, 6 Tier R; `NormalEq.parRed` carries two tokens) plus six kernel-rejection recovery declarations — 22 compiled allowlist entries — and 34 custom-axiom declarations; all are pinned by exact audits. L4L-15B removed the two structure-eta checker roots from the direct frontier; their inherited L4L-16--19 dependencies remain explicit in exact axiom guards | | Gates | the full §6 gate is green on this checkpoint: the 212-job default Lake build, the Nix flake checks, the 22-entry exact sorry frontier, the Theory-only import/axiom audit, downstream-consumer and CLI checks, and whitespace hygiene | @@ -235,8 +235,8 @@ replay. `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 +The complete generic pattern-combinatorics obligations — `pat_simple`, match +inversion with rule-index/constructor recovery, rule distinctness, and the `pat_uniq`/`pat_app_l`/`pat_app_l_uniq`/`pat_app_uniq` non-intersection laws — are proved for one certified block from the certified inventories at guarded `propext`/`Quot.sound`-level closures. The typed β-collapse @@ -254,10 +254,16 @@ defeq set is exactly one certified block's generated rules plus separately certified extension rules over a constant base (`assembleEnv_defeqs`, `assembleEnv_WF`), and the union pattern set `AssembledPat` couples the block's facts with each -`CertifiedExtension`'s payload and spine-level `extra_pat` coverage -equation. No open-environment `Params` instance is installed; both -fixture blocks assemble over the empty base with their defeq sets pinned -to their generated rules. +`CertifiedExtension`'s payload and beta-collapsed coverage. L4L-18B removes +semantic soundness and raw-registration coverage from `Params`: each +`ParRed`/`CParRed`/`WHRed.extra` step carries the exact local `IsDefEqU` +certificate, while `Params.Extension.join` separately requires a typed +`CRDefEq` witness for every registered raw equation. Generated iota rules and +`quotDefEq` have kernel-checked `VExpr.stripLams` coverage, and named +`VEnv.LE.extra`/`extra_appN` transports preserve registered tower equality +under environment growth. No open-environment extension instance is +installed; both fixture blocks assemble over the empty base with their defeq +sets pinned to their generated rules. **Projections.** `Theory/Projection.lean` is the consumer-neutral projection boundary decided at L4L-13A/B. `VStructureView` restricts the @@ -319,12 +325,12 @@ where a public name existed. `Tests/TheoryConsumerSurface.lean` imports no Verify module and pins the availability and exact axiom closure of every migrated API. -**Not claimed.** The remaining metatheory/checker roots. -The 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 +**Not claimed.** The remaining metatheory/checker roots. The beta-collapsed +certificates do not constitute the whole-live-environment +`Params.Extension` instance: L4L-16 must construct that instance through the +semantic bridge for every supported registered equation. Pattern coverage, +checks, and registry membership never imply an operational rewrite without +the local equality certificate. The nested fixtures prove the current single-target, indexed, and queued deep two-parameter boundaries; nesting classes beyond the accepted flattened-block analyzer remain rejected. The 296-declaration notation replay is a real fresh prelude prefix, not a claim @@ -355,9 +361,8 @@ reconciliation are classified in ledger row D017. Non-sorry debt: inductive language remains a growing subset rather than kernel-complete; projection semantics landed at L4L-13A/B and projection structural/checker verification closed at L4L-14/L4L-15A; structure eta and unit-like - comparison are the active L4L-15B milestone, proceeding as a documented - divergence on the reconciled v4.33 base. `pat_wf` carries - the Church–Rosser + comparison closed at L4L-15B as a documented divergence (ledger D019) on + the reconciled v4.33 base. `pat_wf` carries the Church–Rosser development's transitional unique-typing closure until L4L-16/17 close it. - The L4L-15C consumer-neutral audit is complete. Generic spine laws, primitive-environment extension, literal typing, containment/absence, and @@ -390,9 +395,13 @@ reconciliation are classified in ledger row D017. Non-sorry debt: - `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. +- The semantic route to injectivity/unique typing runs through the in-tree + `Experimental/` `SExpr`/`ShapeLogRel` development brought over by the + v4.33 reconciliation; `plans/l4l-16-sort-inversion-decision.md` records + its measured closure (`sorryAx` plus the `Params.extra_pat` project + axiom) and the concrete remaining obligations. Nothing there merges as a + completed proof, and no experimental assumption substitutes for a + supported root's accepted closure. - The dev-branch flake rework scoped `leanSrc` to a fileset, retiring the earlier `inputs.self.outPath` source-invalidation debt; remaining flake debt is cosmetic. The `system` deprecation warning comes from the @@ -559,39 +568,55 @@ 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. -### Metatheory closure (L4L-16–L4L-18B) - -Scheduled completion work; coordinate with Mario because upstream has active -research branches. - -**L4L-16 — route selection and sort inversion (active).** Evaluate two routes -in a small, focused proof branch: (1) finish and bridge the fetched -`logrel@upstream` approach (`ShapeLogRel`, adequacy, and -`Experimental/UniqueTyping`) into live VExpr judgments; or (2) complete the -current stratified `HasTypeStrong` proof directly. The spike must list every -remaining assumption in the chosen route and close the existing public -`IsDefEqU.sort_inv` statement. Merge only that proof, its necessary generic -lemmas, and the documented route decision — not the whole experimental -branch, which changes unrelated code and still contains adequacy sorries. -*Exit:* the public sorry is removed with an exact accepted axiom closure; -the chosen and discarded routes are documented with concrete remaining -obligations. - -**L4L-17 — remaining injectivity and weakening inversion.** Building on -`sort_inv`, prove `IsDefEqU.forallE_inv_stratified`, -`IsDefEqU.sort_forallE_inv`, and `IsDefEqU.weakN_iff`; re-run -`IsDefEq.uniq`/`uniqU`, context inversion, and all downstream `#print -axioms` checks. +### Metatheory closure (L4L-16–L4L-18A) + +L4L-18B completed the prerequisite interface split on 2026-08-12 (design note +`plans/l4l-18b-extension-interface-design.md`, ledger D020). The L4L-16 route +spike (`plans/l4l-16-sort-inversion-decision.md`) can now target an explicit +`Params.Extension.join` semantic obligation instead of the impossible raw +lambda-tower `extra_pat` contract. Identifiers are stable names carried by +their deliverables; execution order is this list's order. This work proceeds +independently of upstream: no milestone blocks on upstream review or +interface approval, every interface departure is decided here and recorded, +and upstream engagement consolidates in the L4L-20C series. + +**L4L-16 — semantic environment bridge and sort inversion.** Execute the +semantic route recorded in `plans/l4l-16-sort-inversion-decision.md` on the +L4L-18B interface. Construct the live-environment instance covering +definitions, mutual definitions, quotient rules, ordinary/block/nested +inductive rules, and registered structure eta (the block-local assembler is +a seed, not this bridge); extend the VExpr-to-SExpr judgment translation to +the current Theory judgment including `IsDefEq.structEta` (the fetched +bridge branch predates eta and is not exhaustive); discharge the SExpr-side +admissions (`IsDefEq.strong`, `IsDefEqStrong.defeq`, `Params.ctor_ty`, and +constant adequacy); and close the public `IsDefEqU.sort_inv` from that +development. Promotion is part of the milestone: supported roots never +import experiments, so the consumed modules leave `Experimental/` with a +stable API and a sorry-free path and enter the audited surface. May split +into suffixed checkpoints (bridge; adequacy; promotion). +*Exit:* the public sorry is removed with an exact accepted axiom closure — +no `sorryAx`, no `extra_pat`-style axiom, and no environment oracle on the +path — and the route record is updated with any residual semantic-route +debt. + +**L4L-17 — remaining injectivity and weakening inversion.** From the same +semantic development, prove `IsDefEqU.forallE_inv_stratified`, +`IsDefEqU.sort_forallE_inv`, `IsDefEqU.weakN_iff`, and +`VEnv.WF.registeredStructureHeadInversion` (whose projection consumers shed +`sorryAx` automatically); re-run `IsDefEq.uniq`/`uniqU`, context inversion, +and all downstream `#print axioms` checks. *Exit:* the remaining public injectivity/inversion statements are sorry-free; affected Theory and checker roots have exact accepted closures. **L4L-18A — Church–Rosser `.extra` cases.** The holes in `NormalEq.parRed` -are the constant/application cases where a parallel step meets a user -defeq-pattern step. Use the generic `Params` interface, L4L-10B's match +are the constant/application cases where a parallel step meets a +proof-carrying user-defeq pattern step. Use the generic `Params` pattern +combinatorics, L4L-10B's match inversion/non-overlap library, and rule RHS congruence to prove the -commuting diagrams, keeping the theorem generic in `[Params]`. Both holes -are provable without inhabiting `Params` (the theorem is generic, and -`extra_pat` is consumed only by `IsDefEq.church_rosser`); +commuting diagrams, keeping the theorem generic in `[Params]`. Neither hole +requires `[Params.Extension]`: each operational step already carries its +local equality certificate, while the global join instance is consumed only +by `IsDefEq.church_rosser`; `ParRed.triangle`'s `.extra` case is the working template. The concrete missing lemmas: (1) `NormalEq` match inversion/spine descent — the `≡ₚ` analogue of the existing `ParRed` inversion, with proof irrelevance at a @@ -605,24 +630,6 @@ the transported match. standardization/head-reduction endpoints contain no hidden placeholder assumptions. -**L4L-18B — extension contract.** Document `.extra` as the supported hook for -consumer-certified defeqs and add the missing monotonicity/transport lemmas -under `VEnv.LE`. State exactly what a consumer-certified extension oracle -must prove (typedness, symmetry/closure as needed, pattern compatibility) and -what lean4lean does not trust automatically. 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`. - ### Checker closure (L4L-19A–L4L-19C) **L4L-19A — recursor reduction verification.** Prove `reduceRecursor.WF` for @@ -638,8 +645,10 @@ surface accordingly (`NestedBlockCertificate` currently exposes no enclosing WHNF roots have exact guards. **L4L-19B — environment-to-checker closure.** Prove the remaining -nonprojection checker refinements (including the v4.31 front-end -`addDecl.WF`) and full `TrEnv` over fixture environments containing ordinary +nonprojection checker refinements (the v4.33 front-end `addDecl.WF` — now +only its `inductDecl` case — plus the D017 `checkPrimitiveDef.WF` and +extension-transport entries and the re-sorried `addQuot.WF`) and full +`TrEnv` over fixture environments containing ordinary declarations, Quot, single/mutual/nested inductives, literals, structures, and extension defeqs; state and audit the final executable-checker soundness theorem over this full environment class. @@ -674,15 +683,17 @@ stated, manifested, version-pinned, tested, absent from Theory roots; silent release assumption; (4) forbidden — known false on a supported toolchain or unproved after the implementation changed. -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` +Immediate pre-work is already scoped by the 2026-08-10 audit, as amended +2026-08-12: delete the three dead axioms (`Level.mkLevelIMaxCore_eq`, +`Expr.liftLooseBVars_eq`, `Expr.equal_eq`); upstream's merged v4.33 proofs +consume `TreeMap.all_eq_all_toList` again, and the unmerged +`origin/ap/prove-treemap-all` branch would turn that axiom into a theorem +at a future reconciliation. After the L4L-13A/B `sorryAx` shed the forbidden cached-field trio sits in many sorry-free closures, so the forbidden-axiom CI rule waits on their actual retirement rather than a two-root cleanup. Then retire in risk order: the three remaining -cached-field -equations; the -thirteen reference equations (convert to logical definitions with +cached-field equations; the +remaining reference equations (convert to logical definitions with `@[implemented_by]` only when extensionally correct); the collection and opaque/layout equations (replace with upstream theorems or narrowly bounded WF lemmas); then decide the final platform budget explicitly (expected: the @@ -814,16 +825,20 @@ assume an oracle or axiom. downstream consumers. The design note and ledger entry come first (decision 2026-08-11); upstream review moves to the L4L-20C PR series, and every reconciliation checkpoint revisits the divergence. -- **Pattern-interface mismatch.** The upstream `Params` fields +- **Pattern-interface divergence.** The upstream `Params` fields (`extra_pat`'s syntactic match, `pat_wf`'s bare-`HasType` premise) cannot be satisfied by tower-registered environments, including - `quotDefEq`. 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. + `quotDefEq`. L4L-18B resolves this with proof-carrying contractions, + beta-collapsed coverage, and `Params.Extension.join` (ledger D020). + The residual risks are a larger upstream-review surface at L4L-20C and + reconciliation conflicts wherever upstream's own `Params` and + experimental work move — keep the redesign minimal, ledgered, and behind + compatibility shims where feasible. +- **Research-branch optimism.** The in-tree `SExpr`/`ShapeLogRel` + development is evidence of a viable path, not a drop-in solution; the + 2026-08-12 spike measured its live closure (`sorryAx` plus the + `Params.extra_pat` project axiom) and the concrete obligations now + scoped at L4L-18B/L4L-16. - **Unsound bridge axioms.** Some cache equations were documented false on older pins and remain unproved. Zero sorries is not a soundness claim until final-root axiom reachability is clean. diff --git a/upstream-divergence.md b/upstream-divergence.md index aa080766..0af2c810 100644 --- a/upstream-divergence.md +++ b/upstream-divergence.md @@ -1138,6 +1138,48 @@ to the replacement. disable the two executable structure-eta heuristics and remove this divergence rather than retaining an unsound verifier claim. +## D020 — proof-carrying extension reductions and beta-collapsed coverage + +- **Status:** implemented intentional fork divergence; L4L-18B completed on + the reconciled v4.33 base (2026-08-12). +- **Owner:** John C. Burnham; semantic review is part of the L4L-20C PR + series. +- **Delta:** split upstream's combined `Params.pat_wf`/`extra_pat` contract + into three explicit layers. `Params` retains only pattern combinatorics; + every `ParRed`/`CParRed`/`WHRed.extra` contraction carries an exact + `IsDefEqU` certificate for its concrete redex and instantiated payload; + and `Params.Extension.join` is a separate consumer-supplied `CRDefEq` + obligation for every raw registered equation in every well-formed context. + `CertifiedExtension.covers` records only a match after `VExpr.stripLams`, + where generated iota and quotient tower bodies actually expose a + first-order pattern. The full rationale and trust matrix are in + `plans/l4l-18b-extension-interface-design.md`. +- **Downstream impact:** Church--Rosser and head standardization transport the + local equality certificate through weakening, substitution, context + conversion, match inversion, and triangle proofs. Only results that invoke + raw registered-equation Church--Rosser require `[Params.Extension]`. + `VEnv.LE.extra`, `extra_appN`, and `extra_appN_symm` publish the environment + growth boundary. L4L-16 must construct the whole-live-environment join + instance through the semantic bridge; the block assembler intentionally + does not synthesize one. +- **Tests:** exact guards cover universe-instantiation of matches, the + generated-iota and `quotDefEq` beta-collapsed certificates, and all three + `VEnv.LE` transport helpers. Concrete mutual-block and quotient fixtures + compile the tower obligations. Focused Church--Rosser, head-reduction, and + pattern-environment builds plus the full release gate cover migrated + consumers. +- **Axiom note:** no new project axiom or source `sorry` is permitted. The + concrete tower witnesses have only the standard logical baseline and no + `sorryAx`; existing L4L-16--L4L-18 proof-frontier dependencies are unchanged + and remain visible in their existing guards. +- **Parallel upstream conversation:** implementation proceeds in the fork as + decided on 2026-08-12; upstream review is deferred to the L4L-20C proof-PR + sequence. Record the issue/PR URL here when opened. +- **Removal condition:** upstream adopts the proof-carrying contraction plus + explicit registered-equation join split, or an equivalent interface that + represents beta-collapsed tower rules without a trusted shape or soundness + oracle, and the fork migrates. + ## Review checklist At each publish or ix pin boundary: