diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index f5e96705d..12d67a36a 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -8,16 +8,45 @@ on: permissions: contents: read - # The zkVM gates' `gh cache list` check (for lean-test's nataddcomm.ixe cache) - # needs the Actions read scope. (actions/cache/restore uses the runner's own - # cache token, not this.) - actions: read concurrency: group: ${{ github.workflow }}-${{ github.head_ref || github.run_id }} cancel-in-progress: true jobs: + # Produce the small real-program fixture consumed by both zkVM execution + # gates independently of the full Lean test job. A workflow artifact is the + # right synchronization primitive here: the file is unique to this run and + # must be available before either consumer starts. + zkvm-fixture: + name: zkVM execution fixture + runs-on: warp-ubuntu-latest-x64-16x + steps: + - uses: actions/checkout@v7 + - uses: actions-rust-lang/setup-rust-toolchain@v1 + # Build only the compiler executable and its dependencies. In particular, + # a failure in an unrelated Tests module must not prevent fixture + # publication. Disable the Lean cache because lean-test builds the same + # revision concurrently and the two jobs must not race to save one key. + - uses: leanprover/lean-action@v1 + with: + auto-config: false + build: true + build-args: "ix --wfail -v" + use-github-cache: false + # `Nat.add_comm`'s transitive-dependency closure (~40 kB, ~40 constants) + # is a real theorem, not an empty environment. `--consts` keeps this much + # smaller than the complete Init+Std environment used by benchmarks. + - name: Compile nataddcomm.ixe + run: lake exe ix compile Ix.lean --consts Nat.add_comm --out nataddcomm.ixe + - name: Upload nataddcomm.ixe + uses: actions/upload-artifact@v4 + with: + name: nataddcomm-ixe + path: nataddcomm.ixe + if-no-files-found: error + retention-days: 1 + lean-test: runs-on: warp-ubuntu-latest-x64-16x steps: @@ -39,22 +68,6 @@ jobs: run: lake build IxTcVerify - name: Check codegen'd IxVM kernel is up to date run: lake exe ix codegen --check - # Compile the `.ixe` the zkVM execution gates run the guests over: - # `Nat.add_comm`'s transitive-dep closure (~40 kB, ~40 constants — a real - # theorem, not an empty env). Seeded from `Ix.lean` (already built above) - # via `--consts`, so it's the constant's closure, NOT the 184 MB full - # Init+Std env `bench-main`'s compile job produces. Root package has no - # Mathlib dep, so no cache fetch. Cached for the sp1-build / zisk-build - # jobs, which have no Lean toolchain to compile it. - - name: Compile nataddcomm.ixe for zkVM execution gates - run: lake exe ix compile Ix.lean --consts Nat.add_comm --out nataddcomm.ixe - # Keyed by commit sha so every run gets a fresh entry (the .ixe is not - # byte-reproducible). - - name: Cache nataddcomm.ixe for the zkVM execution gates - uses: actions/cache/save@v6 - with: - path: nataddcomm.ixe - key: nataddcomm-ixe-${{ github.sha }} - name: Test Ix CLI run: lake test --wfail -- cli - name: Aiur tests @@ -96,8 +109,8 @@ jobs: # failures by design (dropped rows, OOM sentinels), so they never turn red # on a breakage. These jobs are the red-X signal: each builds its host, then # runs the guest in the VM over `nataddcomm.ixe` (a ~40-constant closure the - # lean-test job compiles + caches). They run in parallel with lean-test, each - # waiting for that cache entry before its execute step. Both hosts exit + # dedicated zkvm-fixture job publishes). They run in parallel with lean-test + # and with each other after that narrow producer succeeds. Both hosts exit # non-zero when the kernel rejects a constant (sp1: EXIT_REJECTED; zisk: # `reject_failures`), so a guest that compiles but panics / faults / rejects # fails the job. SP1 execute is pure RISC-V emulation (no key). Zisk execute @@ -111,6 +124,7 @@ jobs: # SP1's host crates need pkg-config + libssl-dev). sp1-build: name: SP1 host build + needs: zkvm-fixture runs-on: warp-ubuntu-latest-x64-16x steps: - uses: actions/checkout@v7 @@ -132,25 +146,11 @@ jobs: # sp1-build skips the guest compilation and the host cfg-gates its # ELF embed accordingly, so this lints host code only. cargo clippy --release --workspace --all-targets -- -D warnings - # Wait 5 minutes max for `lean-test` to upload `nataddcomm.ixe` - - name: Wait for the nataddcomm.ixe cache - env: - GH_TOKEN: ${{ github.token }} - run: | - key=nataddcomm-ixe-${{ github.sha }} - for i in $(seq 1 30); do - if gh cache list --key "$key" --json id | grep -q '"id"'; then - echo "$key is cached"; exit 0 - fi - echo "waiting for $key cache ($i/30)…"; sleep 10 - done - echo "::error::timed out waiting for $key cache (did lean-test fail before caching?)" - exit 1 - - uses: actions/cache/restore@v6 + - name: Download nataddcomm.ixe + uses: actions/download-artifact@v4 with: - path: nataddcomm.ixe - key: nataddcomm-ixe-${{ github.sha }} - fail-on-cache-miss: true + name: nataddcomm-ixe + path: . # Run the guest ELF in SP1's RISC-V executor over the nataddcomm env — # pure emulation, no GPU or proving key. `--execute` exits 3 # (EXIT_REJECTED) if the kernel rejects any constant and non-zero on any @@ -163,6 +163,7 @@ jobs: zisk-build: name: Zisk host build + needs: zkvm-fixture runs-on: warp-ubuntu-latest-x64-16x steps: - uses: actions/checkout@v7 @@ -185,24 +186,11 @@ jobs: # --release shares the build's dep artifacts (including the guest # ELFs its build scripts already produced). cargo clippy --release --workspace --all-targets -- -D warnings - - name: Wait for the nataddcomm.ixe cache - env: - GH_TOKEN: ${{ github.token }} - run: | - key=nataddcomm-ixe-${{ github.sha }} - for i in $(seq 1 30); do - if gh cache list --key "$key" --json id | grep -q '"id"'; then - echo "$key is cached"; exit 0 - fi - echo "waiting for $key cache ($i/30)…"; sleep 10 - done - echo "::error::timed out waiting for $key cache (did lean-test fail before caching?)" - exit 1 - - uses: actions/cache/restore@v6 + - name: Download nataddcomm.ixe + uses: actions/download-artifact@v4 with: - path: nataddcomm.ixe - key: nataddcomm-ixe-${{ github.sha }} - fail-on-cache-miss: true + name: nataddcomm-ixe + path: . # Run the guest ELF in the Zisk VM over the nataddcomm env. `zisk-host` # exits 3 (EXIT_REJECTED, via `reject_failures`) if the kernel rejects any # constant and non-zero on any VM fault — so the tool errors on failures, diff --git a/Ix/Tc/DefEq.lean b/Ix/Tc/DefEq.lean index 2c7265fde..196baf93a 100644 --- a/Ix/Tc/DefEq.lean +++ b/Ix/Tc/DefEq.lean @@ -47,6 +47,12 @@ inductive LazyDeltaLoopResult (m : Mode) where def canonicalPair (a b : Address) : Address × Address := if a.cmpBytes b != .gt then (a, b) else (b, a) +/-- Canonical key for the narrow same-head rejection cache. -/ +def defEqFailureKey (left right : KExpr m) (ctxAddr : Address) : + Address × Address × Address := + ((canonicalPair left.addr right.addr).1, + (canonicalPair left.addr right.addr).2, ctxAddr) + /-- Head constant of an expression or app spine. -/ def headConstId (e : KExpr m) : Option (KId m) := match e with @@ -118,6 +124,22 @@ def isBoolTrue (e : KExpr m) : RecM m Bool := do return us.isEmpty && id.addr == (← prims).boolTrue.addr | _ => return false +/-- Eager Bool reduction is unconditional for closed syntax and otherwise +follows the caller's explicit eager-reduction marker. -/ +def boolTrueReductionAllowed (e : KExpr m) : RecM m Bool := do + if !e.hasFVars then + return true + return (← get).eagerReduce + +/-- Normalize a candidate and classify the resulting WHNF as `Bool.true`. -/ +def whnfIsBoolTrue (e : KExpr m) : RecM m Bool := do + isBoolTrue (← whnf e) + +/-- Whether either side is syntactically a compact String literal. -/ +def hasStringLiteralPair (a b : KExpr m) : Bool := + (match a with | .str .. => true | _ => false) || + (match b with | .str .. => true | _ => false) + /-- Is the constant delta-reducible (Definition/Theorem)? -/ def isDelta (id : KId m) : RecM m Bool := do match (← TcM.tryGetConst id) with @@ -127,6 +149,13 @@ def isDelta (id : KId m) : RecM m Bool := do | .opaq => return false | _ => return false +/-- Classify the head constant of an expression as delta-reducible. A +non-constant head is an immediate miss. -/ +def classifyDeltaHead (e : KExpr m) : RecM m Bool := + match headConstId e with + | some id => isDelta id + | none => pure false + /-- Regular reducibility hints (guards the same-head-spine attempt). -/ def isRegular (id : KId m) : RecM m Bool := do match (← TcM.tryGetConst id) with @@ -148,6 +177,13 @@ def defRankId (id : KId m) : RecM m (Nat × Nat) := do | .abbrev => return (2, 0) | _ => return (0, 0) +/-- Read the reducibility rank of an optional head constant. The sentinel +rank is retained for the syntactically headless case. -/ +def rankDeltaHead (head : Option (KId m)) : RecM m (Nat × Nat) := + match head with + | some id => defRankId id + | none => pure (255, 4294967295) + mutual /-- Definitional equality entry point: fast paths, equiv-manager, caches @@ -161,8 +197,9 @@ def isDefEq (a b : KExpr m) : RecM m Bool := do -- structural alpha-equivalence fast path needed. return true let eqCtx ← TcM.defEqCtxKey a b - let aKey : EqKey := (a.addr, eqCtx) - let bKey : EqKey := (b.addr, eqCtx) + let eqLbr := max a.lbr b.lbr + let aKey : EqKey := ⟨a.addr, eqCtx, eqLbr, a.lbr⟩ + let bKey : EqKey := ⟨b.addr, eqCtx, eqLbr, b.lbr⟩ let isEq ← TcM.withEquiv (m := m) (·.isEquiv aKey bKey) if isEq then return true @@ -185,6 +222,14 @@ def isDefEq (a b : KExpr m) : RecM m Bool := do defEqCache := s.env.defEqCache.insert cacheKey true } equivManager := s.equivManager.addEquiv aKey bKey } return cached + isDefEqAfterDirectCacheMiss a b eqCtx aKey bKey cacheKey cheapMode + +/-- Guarded equivalence-root probe after both direct DefEq cache partitions +miss. Keeping this as a production seam lets verification cover the exact +remaining program without duplicating reducer control flow. -/ +def isDefEqAfterDirectCacheMiss (a b : KExpr m) (eqCtx : Address) + (aKey bKey : EqKey) (cacheKey : Address × Address × Address) + (cheapMode : Bool) : RecM m Bool := do -- Equiv-root second chance: probe (root a, root b). let (aRoot?, bRoot?) ← TcM.withEquiv (m := m) fun em => let (aRoot?, em) := em.findRootKey aKey @@ -192,36 +237,46 @@ def isDefEq (a b : KExpr m) : RecM m Bool := do ((aRoot?, bRoot?), em) if let (some aRoot, some bRoot) := (aRoot?, bRoot?) then if aRoot != aKey || bRoot != bKey then - -- EqKey is (exprAddr, ctxAddr); canonicalize the expr components. - let (rlo, rhi) := canonicalPair aRoot.fst bRoot.fst - let rootCacheKey := (rlo, rhi, eqCtx) - let cached? : Option (Bool × Bool) ← - match (← get).env.defEqCache[rootCacheKey]? with - | some v => pure (some (v, false)) - | none => - if cheapMode then - match (← get).env.defEqCheapCache[rootCacheKey]? with - | some v => pure (some (v, true)) - | none => pure none + -- A representative can have a different intrinsic radius from the + -- original expression. The root cache key reuses `eqCtx`, so probe it + -- only when both representatives retain that exact cache scope. + if aRoot.rootCacheScopeMatches bRoot eqCtx (max a.lbr b.lbr) then + let (rlo, rhi) := canonicalPair aRoot.exprAddr bRoot.exprAddr + let rootCacheKey := (rlo, rhi, eqCtx) + let cached? : Option (Bool × Bool) ← + match (← get).env.defEqCache[rootCacheKey]? with + | some v => pure (some (v, false)) + | none => + if cheapMode then + match (← get).env.defEqCheapCache[rootCacheKey]? with + | some v => pure (some (v, true)) + | none => pure none + else + pure none + if let some (cached, fromCheap) := cached? then + if fromCheap then + modify fun s => { s with env := { s.env with + defEqCheapCache := s.env.defEqCheapCache.insert cacheKey cached + defEqCache := if cached then + s.env.defEqCache.insert cacheKey true + else s.env.defEqCache } } else - pure none - if let some (cached, fromCheap) := cached? then - if fromCheap then - modify fun s => { s with env := { s.env with - defEqCheapCache := s.env.defEqCheapCache.insert cacheKey cached - defEqCache := if cached then - s.env.defEqCache.insert cacheKey true - else s.env.defEqCache } } - else - modify fun s => { s with env := { s.env with - defEqCache := s.env.defEqCache.insert cacheKey cached - defEqCheapCache := if cheapMode then - s.env.defEqCheapCache.insert cacheKey cached - else s.env.defEqCheapCache } } - if cached then - modify fun s => { s with - equivManager := s.equivManager.addEquiv aKey bKey } - return cached + modify fun s => { s with env := { s.env with + defEqCache := s.env.defEqCache.insert cacheKey cached + defEqCheapCache := if cheapMode then + s.env.defEqCheapCache.insert cacheKey cached + else s.env.defEqCheapCache } } + if cached then + modify fun s => { s with + equivManager := s.equivManager.addEquiv aKey bKey } + return cached + isDefEqAfterRootCacheMiss a b aKey bKey cacheKey cheapMode + +/-- Charged recursive DefEq tail after every O(1) equivalence/cache exit +misses. This owns depth restoration and the final cache/manager updates. -/ +def isDefEqAfterRootCacheMiss (a b : KExpr m) (aKey bKey : EqKey) + (cacheKey : Address × Address × Address) (cheapMode : Bool) : + RecM m Bool := do -- Charge fuel only after the O(1) exits. TcM.bumpStats (m := m) fun s => { s with deqMisses := s.deqMisses + 1 } TcM.tick (m := m) @@ -259,21 +314,43 @@ def isDefEqInner (a b : KExpr m) : RecM m Bool := do -- Tier 1: quick structural. if (← quickDefEq a b) then return true + isDefEqInnerAfterQuick a b + +/-- Remaining recursive DefEq tiers after the quick structural probe misses. +Keeping this as a production-owned seam lets verification compose the +constructor-exhaustive Tier-1 proof without duplicating or restating the +subsequent reducer. -/ +def isDefEqInnerAfterQuick (a b : KExpr m) : RecM m Bool := do -- Tier 1b: eager Bool.true reduction. - if (← isBoolTrue b) && (!a.hasFVars || (← get).eagerReduce) then - if (← isBoolTrue (← whnf a)) then + if (← isBoolTrue b) && (← boolTrueReductionAllowed a) then + if (← whnfIsBoolTrue a) then return true - else if (← isBoolTrue a) && (!b.hasFVars || (← get).eagerReduce) then - if (← isBoolTrue (← whnf b)) then + isDefEqInnerAfterBoolTrue a b + else + isDefEqInnerAfterFirstBoolGuardMiss a b + +/-- Symmetric eager-Boolean direction, reached only when the first +recognition/policy guard was unavailable. -/ +def isDefEqInnerAfterFirstBoolGuardMiss (a b : KExpr m) : RecM m Bool := do + if (← isBoolTrue a) && (← boolTrueReductionAllowed b) then + if (← whnfIsBoolTrue b) then return true + isDefEqInnerAfterBoolTrue a b + +/-- Remaining recursive DefEq tiers after the two eager `Bool.true` +directions both fail to accept. -/ +def isDefEqInnerAfterBoolTrue (a b : KExpr m) : RecM m Bool := do -- Tier 1c: string-literal expansion BEFORE any whnf. - let aIsStr := match a with | .str .. => true | _ => false - let bIsStr := match b with | .str .. => true | _ => false - if aIsStr || bIsStr then + if hasStringLiteralPair a b then if (← tryStringLitExpansion a b) then return true if (← tryStringLitExpansion b a) then return true + isDefEqInnerAfterStringExpansion a b + +/-- Remaining recursive DefEq tiers after literal String expansion fails to +accept in either direction. -/ +def isDefEqInnerAfterStringExpansion (a b : KExpr m) : RecM m Bool := do -- Tier 1d: cheap structural passes. let ca ← whnfCoreForDefEq a let cb ← whnfCoreForDefEq b @@ -281,134 +358,237 @@ def isDefEqInner (a b : KExpr m) : RecM m Bool := do return true if (← quickDefEq ca cb) then return true + isDefEqInnerAfterCorePass a b + +/-- Remaining recursive DefEq tiers after the cheap structural-core pass +fails to accept. -/ +def isDefEqInnerAfterCorePass (a b : KExpr m) : RecM m Bool := do let wa ← whnfNoDeltaForDefEq a let wb ← whnfNoDeltaForDefEq b if wa.addr == wb.addr then return true if (← quickDefEq wa wb) then return true + isDefEqInnerAfterNoDeltaPass wa wb + +/-- Remaining recursive DefEq tiers after the cheap no-delta pass fails to +accept. Inputs are the already normalized pair. -/ +def isDefEqInnerAfterNoDeltaPass (wa wb : KExpr m) : RecM m Bool := do -- Tier 3: proof irrelevance (before delta). if (← tryProofIrrel wa wb) then return true - -- Tier 4: iterative lazy delta. - let step (state : KExpr m × KExpr m) : - RecM m (BoundedStep (KExpr m × KExpr m) (LazyDeltaLoopResult m)) := do - let (wa0, wb0) := state - let mut wa := wa0 - let mut wb := wb0 - -- Nat offset comparison at the top of the loop. - if let some result ← tryDefEqOffset wa wb then - return .done (.answer result) - -- Nat primitives gated on closed terms (or eagerReduce). - let natOk := (!wa.hasFVars && !wb.hasFVars) || (← get).eagerReduce - if natOk then - if let some wa2 ← tryReduceNat wa then - return .done (.answer (← isDefEqCall wa2 wb)) - if let some wb2 ← tryReduceNat wb then - return .done (.answer (← isDefEqCall wa wb2)) - if let some wa2 ← tryReduceNative wa then - return .done (.answer (← isDefEqCall wa2 wb)) - if let some wb2 ← tryReduceNative wb then - return .done (.answer (← isDefEqCall wa wb2)) - if let some wa2 ← tryReduceDecidable wa then + isDefEqInnerAfterProofIrrelevance wa wb + +/-- One iteration of the bounded lazy-delta comparison. Nat-offset +comparison is isolated at the front because its shared-offset injectivity +argument is distinct from the ordinary reduction branches. -/ +def defEqLazyDeltaStep (state : KExpr m × KExpr m) : + RecM m (BoundedStep (KExpr m × KExpr m) (LazyDeltaLoopResult m)) := do + let (wa, wb) := state + if let some result ← tryDefEqOffset wa wb then + return .done (.answer result) + defEqLazyDeltaStepAfterOffsetMiss state + +/-- Remaining lazy-delta iteration after the Nat-offset probe returns +`none`. -/ +def defEqLazyDeltaStepAfterOffsetMiss (state : KExpr m × KExpr m) : + RecM m (BoundedStep (KExpr m × KExpr m) (LazyDeltaLoopResult m)) := do + let (wa0, wb0) := state + let mut wa := wa0 + let mut wb := wb0 + -- Nat primitives gated on closed terms (or eagerReduce). + let natOk := (!wa.hasFVars && !wb.hasFVars) || (← get).eagerReduce + if natOk then + if let some wa2 ← tryReduceNat wa then return .done (.answer (← isDefEqCall wa2 wb)) - if let some wb2 ← tryReduceDecidable wb then + if let some wb2 ← tryReduceNat wb then return .done (.answer (← isDefEqCall wa wb2)) - let aHead := headConstId wa - let bHead := headConstId wb - let aDelta ← match aHead with - | some h => isDelta h - | none => pure false - let bDelta ← match bHead with - | some h => isDelta h - | none => pure false - if !aDelta && !bDelta then - return .done (.stopped wa wb) - -- Before unfolding, try reducing projection apps on the other side. - if aDelta && !bDelta then - if let some wb2 ← tryUnfoldProjApp wb then - return .next (wa, wb2) - else if bDelta && !aDelta then - if let some wa2 ← tryUnfoldProjApp wa then - return .next (wa2, wb) - if aDelta && bDelta then - let waW ← match aHead with - | some h => defRankId h - | none => pure (255, 4294967295) - let wbW ← match bHead with - | some h => defRankId h - | none => pure (255, 4294967295) - if waW == wbW then - -- Same-head-spine attempt, guarded by the narrow negative cache. - if let (some ah, some bh) := (aHead, bHead) then - if ah.addr == bh.addr && (← isRegular ah) then - let (flo, fhi) := canonicalPair wa.addr wb.addr - let failureKey := (flo, fhi, ← TcM.defEqCtxKey wa wb) - if !(← get).env.defEqFailure.contains failureKey then - if let some result ← trySameHeadSpine wa wb then - return .done (.answer result) - -- Attempted and failed — record. - modify fun s => { s with env := { s.env with - defEqFailure := s.env.defEqFailure.insert failureKey } } - -- Equal rank: unfold BOTH sides. - let ua ← deltaUnfoldOne wa - let ub ← deltaUnfoldOne wb - match ua, ub with - | some ua, some ub => - wa ← whnfNoDeltaForDefEq ua - wb ← whnfNoDeltaForDefEq ub - | some ua, none => - wa ← whnfNoDeltaForDefEq ua - | none, some ub => - wb ← whnfNoDeltaForDefEq ub - | none, none => - return .done (.stopped wa wb) - else if compareRank waW wbW == .gt then - match (← deltaUnfoldOne wa) with - | some ua => wa ← whnfNoDeltaForDefEq ua - | none => - return .done (.stopped wa wb) - else - match (← deltaUnfoldOne wb) with - | some ub => wb ← whnfNoDeltaForDefEq ub - | none => - return .done (.stopped wa wb) - else if aDelta then - match (← deltaUnfoldOne wa) with - | some ua => wa ← whnfNoDeltaForDefEq ua - | none => - return .done (.stopped wa wb) + defEqLazyDeltaStepAfterNatMiss wa wb + +/-- Remaining lazy-delta iteration after the gated Nat reducers both miss or +are skipped. -/ +def defEqLazyDeltaStepAfterNatMiss (wa0 wb0 : KExpr m) : + RecM m (BoundedStep (KExpr m × KExpr m) (LazyDeltaLoopResult m)) := do + let mut wa := wa0 + let mut wb := wb0 + if let some wa2 ← tryReduceNative wa then + return .done (.answer (← isDefEqCall wa2 wb)) + if let some wb2 ← tryReduceNative wb then + return .done (.answer (← isDefEqCall wa wb2)) + if let some wa2 ← tryReduceDecidable wa then + return .done (.answer (← isDefEqCall wa2 wb)) + if let some wb2 ← tryReduceDecidable wb then + return .done (.answer (← isDefEqCall wa wb2)) + defEqLazyDeltaStepAfterAcceleratorMiss wa wb + +/-- Remaining lazy-delta iteration after native and Decidable acceleration +both miss. In the no-acceleration verification layer this is the exact tail +of `defEqLazyDeltaStepAfterNatMiss`. -/ +def defEqLazyDeltaStepAfterAcceleratorMiss (wa0 wb0 : KExpr m) : + RecM m (BoundedStep (KExpr m × KExpr m) (LazyDeltaLoopResult m)) := do + let mut wa := wa0 + let mut wb := wb0 + let aHead := headConstId wa + let bHead := headConstId wb + let aDelta ← classifyDeltaHead wa + let bDelta ← classifyDeltaHead wb + if !aDelta && !bDelta then + return .done (.stopped wa wb) + defEqLazyDeltaStepAfterDeltaClassification wa wb aHead bHead aDelta bDelta + +/-- Remaining lazy-delta iteration after at least one head has been +classified as delta-reducible. -/ +def defEqLazyDeltaStepAfterDeltaClassification (wa0 wb0 : KExpr m) + (aHead bHead : Option (KId m)) (aDelta bDelta : Bool) : + RecM m (BoundedStep (KExpr m × KExpr m) (LazyDeltaLoopResult m)) := do + let mut wa := wa0 + let mut wb := wb0 + -- Before unfolding, try reducing projection apps on the other side. + if aDelta && !bDelta then + if let some wb2 ← tryUnfoldProjApp wb then + return .next (wa, wb2) + else if bDelta && !aDelta then + if let some wa2 ← tryUnfoldProjApp wa then + return .next (wa2, wb) + defEqLazyDeltaStepAfterProjectionMiss wa wb aHead bHead aDelta bDelta + +/-- Remaining lazy-delta iteration after the asymmetric projection-app probe +is inapplicable or returns `none`. -/ +def defEqLazyDeltaStepAfterProjectionMiss (wa0 wb0 : KExpr m) + (aHead bHead : Option (KId m)) (aDelta bDelta : Bool) : + RecM m (BoundedStep (KExpr m × KExpr m) (LazyDeltaLoopResult m)) := do + let mut wa := wa0 + let mut wb := wb0 + if aDelta && bDelta then + let waW ← rankDeltaHead aHead + let wbW ← rankDeltaHead bHead + if waW == wbW then + defEqLazyDeltaStepWithEqualRank wa wb aHead bHead + else if compareRank waW wbW == .gt then + defEqLazyDeltaStepWithLeftDelta wa wb else - match (← deltaUnfoldOne wb) with - | some ub => wb ← whnfNoDeltaForDefEq ub - | none => - return .done (.stopped wa wb) - if wa.addr == wb.addr then - return .done (.answer true) - if (← quickDefEq wa wb) then - return .done (.answer true) - return .next (wa, wb) - match ← runBounded step maxWhnfFuel.toNat (wa, wb) with + defEqLazyDeltaStepWithRightDelta wa wb + else if aDelta then + defEqLazyDeltaStepWithLeftDelta wa wb + else + defEqLazyDeltaStepWithRightDelta wa wb + +/-- Run same-head spine comparison behind its narrow rejection-only cache. +A cache hit skips the attempt; a genuine miss records exactly the canonical +operand/context key. -/ +def trySameHeadSpineCached (left right : KExpr m) : + RecM m (Option Bool) := do + let failureKey := defEqFailureKey left right (← TcM.defEqCtxKey left right) + if (← get).env.defEqFailure.contains failureKey then + return none + match ← trySameHeadSpine left right with + | some result => return some result + | none => + modify fun state => { state with env := { state.env with + defEqFailure := state.env.defEqFailure.insert failureKey } } + return none + +/-- Equal-rank lazy delta: attempt the guarded same-head spine comparison, +then unfold both operands before the common finishing checks. -/ +def defEqLazyDeltaStepWithEqualRank (wa0 wb0 : KExpr m) + (aHead bHead : Option (KId m)) : + RecM m (BoundedStep (KExpr m × KExpr m) (LazyDeltaLoopResult m)) := do + let mut wa := wa0 + let mut wb := wb0 + -- Same-head-spine attempt, guarded by the narrow negative cache. + if let (some ah, some bh) := (aHead, bHead) then + if ah.addr == bh.addr && (← isRegular ah) then + if let some result ← trySameHeadSpineCached wa wb then + return .done (.answer result) + defEqLazyDeltaStepAfterSameHeadMiss wa wb + +/-- Equal-rank continuation after the guarded same-head attempt is skipped, +cached as a failure, or returns `none`. -/ +def defEqLazyDeltaStepAfterSameHeadMiss (wa0 wb0 : KExpr m) : + RecM m (BoundedStep (KExpr m × KExpr m) (LazyDeltaLoopResult m)) := do + let mut wa := wa0 + let mut wb := wb0 + -- Equal rank: unfold BOTH sides. + let ua ← deltaUnfoldOne wa + let ub ← deltaUnfoldOne wb + match ua, ub with + | some ua, some ub => + wa ← whnfNoDeltaForDefEq ua + wb ← whnfNoDeltaForDefEq ub + | some ua, none => + wa ← whnfNoDeltaForDefEq ua + | none, some ub => + wb ← whnfNoDeltaForDefEq ub + | none, none => + return .done (.stopped wa wb) + finishDefEqLazyDeltaStep wa wb + +/-- Unfold and no-delta-normalize only the left operand, then perform the +common finishing checks. -/ +def defEqLazyDeltaStepWithLeftDelta (wa wb : KExpr m) : + RecM m (BoundedStep (KExpr m × KExpr m) (LazyDeltaLoopResult m)) := do + match (← deltaUnfoldOne wa) with + | some unfolded => + let reduced ← whnfNoDeltaForDefEq unfolded + finishDefEqLazyDeltaStep reduced wb + | none => + return .done (.stopped wa wb) + +/-- Symmetric one-sided delta unfold for the right operand. -/ +def defEqLazyDeltaStepWithRightDelta (wa wb : KExpr m) : + RecM m (BoundedStep (KExpr m × KExpr m) (LazyDeltaLoopResult m)) := do + match (← deltaUnfoldOne wb) with + | some unfolded => + let reduced ← whnfNoDeltaForDefEq unfolded + finishDefEqLazyDeltaStep wa reduced + | none => + return .done (.stopped wa wb) + +/-- Finish one productive lazy-delta iteration with the two cheap equality +checks, otherwise expose the transformed pair to the bounded driver. -/ +def finishDefEqLazyDeltaStep (wa wb : KExpr m) : + RecM m (BoundedStep (KExpr m × KExpr m) (LazyDeltaLoopResult m)) := do + if wa.addr == wb.addr then + return .done (.answer true) + if (← quickDefEq wa wb) then + return .done (.answer true) + return .next (wa, wb) + +/-- Run the iterative lazy-delta comparison with the kernel's WHNF fuel +bound. -/ +def runDefEqLazyDelta (wa wb : KExpr m) : + RecM m (LazyDeltaLoopResult m) := + runBounded defEqLazyDeltaStep maxWhnfFuel.toNat (wa, wb) + +/-- Continue the recursive comparison after lazy delta can no longer make +progress. -/ +def isDefEqAfterLazyDeltaStopped (wa wb : KExpr m) : RecM m Bool := do + -- Tier 4b: post-delta structural congruence. + if (← tryStructuralCongruence wa wb) then + return true + -- Tier 4c: second structural pass — whnfCore, NOT full whnf. + let waCore ← whnfCore wa + let wbCore ← whnfCore wb + let waChanged := waCore.addr != wa.addr + let wbChanged := wbCore.addr != wb.addr + if waChanged || wbChanged then + return (← isDefEqCall waCore wbCore) + if waCore.addr == wbCore.addr then + return true + if (← quickDefEq waCore wbCore) then + return true + -- Tier 4d: app-spine comparison. + if (← tryDefEqApp waCore wbCore) then + return true + isDefEqWhnf waCore wbCore + +/-- Remaining recursive DefEq tiers after the pre-delta proof-irrelevance +attempt fails to accept. -/ +def isDefEqInnerAfterProofIrrelevance + (wa wb : KExpr m) : RecM m Bool := do + match ← runDefEqLazyDelta wa wb with | .answer result => return result - | .stopped wa wb => - -- Tier 4b: post-delta structural congruence. - if (← tryStructuralCongruence wa wb) then - return true - -- Tier 4c: second structural pass — whnfCore, NOT full whnf. - let waCore ← whnfCore wa - let wbCore ← whnfCore wb - let waChanged := waCore.addr != wa.addr - let wbChanged := wbCore.addr != wb.addr - if waChanged || wbChanged then - return (← isDefEqCall waCore wbCore) - if waCore.addr == wbCore.addr then - return true - if (← quickDefEq waCore wbCore) then - return true - -- Tier 4d: app-spine comparison. - if (← tryDefEqApp waCore wbCore) then - return true - isDefEqWhnf waCore wbCore + | .stopped wa wb => isDefEqAfterLazyDeltaStopped wa wb /-- Tier-1 quick structural: same ctor, same children (binders open both bodies with the SAME fresh fvar — the common-fvar trick). -/ @@ -425,22 +605,38 @@ def quickBinder (name : m.F Name) (bi : m.F Lean.BinderInfo) (ty1 body1 ty2 body2 : KExpr m) : RecM m Bool := do if !(← isDefEqCall ty1 ty2) then return false - let saved := (← get).lctx.size - let fvId ← TcM.freshFVarId (m := m) - let fv ← TcM.intern (.mkFVar fvId name) - modify fun s => { s with lctx := s.lctx.push fvId (.cdecl name bi ty1) } - let b1Open ← TcM.runIntern (instantiateRev body1 #[fv]) - let b2Open ← TcM.runIntern (instantiateRev body2 #[fv]) - let r ← - try - let r ← isDefEqCall b1Open b2Open - pure (Except.ok r) - catch e => - pure (Except.error e) - modify fun s => { s with lctx := s.lctx.truncate saved } - match r with - | .ok v => return v - | .error e => throw e + withLctxScope do + let (b1Open, fvId) ← TcM.openBinder name bi ty1 body1 + let fv ← TcM.intern (KExpr.mkFVar fvId name) + let b2Open ← TcM.runIntern (instantiateRev body2 #[fv]) + isDefEqCall b1Open b2Open + +/-- List recursion underlying application-spine argument comparison. -/ +def allDefEqSpineArgsList : List (KExpr m × KExpr m) → RecM m Bool + | [] => pure true + | (left, right) :: rest => do + if !(← isDefEqCall left right) then + return false + allDefEqSpineArgsList rest + +/-- Compare a finite array of expression pairs through the recursive DefEq +callback, stopping at the first rejection. Both same-head and general +application-spine comparison use this exact left-to-right loop. -/ +def allDefEqSpineArgs (pairs : Array (KExpr m × KExpr m)) : RecM m Bool := + allDefEqSpineArgsList pairs.toList + +/-- Pure recursive comparison of universe pairs used by constant-headed +spine checks. -/ +def allDefEqUniversesList : List (KUniv m × KUniv m) → Bool + | [] => true + | (left, right) :: rest => + univEq left right && allDefEqUniversesList rest + +/-- Exact constant-instance gate: equal arity and pairwise universe +equality in production order. -/ +def sameDefEqUniverses (left right : Array (KUniv m)) : Bool := + left.size == right.size && + allDefEqUniversesList (left.zip right).toList /-- Both are `C us args` with the same head: compare spines without unfolding. `none` means "not applicable / spine differs". -/ @@ -451,87 +647,157 @@ def trySameHeadSpine (a b : KExpr m) : RecM m (Option Bool) := do let .const bId bUs _ := bHead | return none if aId.addr != bId.addr || aArgs.size != bArgs.size then return none - if aUs.size != bUs.size then + if !sameDefEqUniverses aUs bUs then + return none + if !(← allDefEqSpineArgs (aArgs.zip bArgs)) then return none - for (u, v) in aUs.zip bUs do - if !univEq u v then - return none - for (ai, bi) in aArgs.zip bArgs do - if !(← isDefEqCall ai bi) then - return none return some true -/-- Tier 5: full structural + eta / struct-eta / unit / proof irrelevance. -/ -def isDefEqWhnf (a b : KExpr m) : RecM m Bool := do +/-- Short-circuiting application branch of the final structural comparison. -/ +def tryDefEqWhnfApp (f1 a1 f2 a2 : KExpr m) : + RecM m (Option Bool) := do + -- MUST short-circuit (Rust `&&` does; Lean's `(← _) && (← _)` runs + -- BOTH actions). For dependent apps the second component is often a + -- PROOF: comparing proof pairs whose value pair already failed forces + -- unbounded proof normalization. + if (← isDefEqCall f1 f2) then + if (← isDefEqCall a1 a2) then + return some true + return none + +/-- Let-declaration branch of the final structural comparison. -/ +def tryDefEqWhnfLet (name : m.F Name) + (ty1 v1 body1 ty2 v2 body2 : KExpr m) : + RecM m (Option Bool) := do + -- Normally zeta-reduced before reaching here; push LDecl in case. + if (← isDefEqCall ty1 ty2) then + if (← isDefEqCall v1 v2) then + let r ← withLctxScope do + let (b1Open, fv, _) ← TcM.openLetWithFV name ty1 v1 body1 + let b2Open ← TcM.runIntern (instantiateRev body2 #[fv]) + isDefEqCall b1Open b2Open + if r then + return some true + return none + +/-- Constructor-directed prefix of the final WHNF comparison. `some answer` +is a terminal verdict; `none` means that production must continue with the +Nat/eta/String/structural fallbacks. -/ +def tryDefEqWhnfStructural (a b : KExpr m) : RecM m (Option Bool) := do match a, b with - | .sort u1 _, .sort u2 _ => return univEq u1 u2 + | .sort u1 _, .sort u2 _ => return some (univEq u1 u2) | .var i _ _, .var j _ _ => if i == j then - return true + return some true | .const id1 us1 _, .const id2 us2 _ => - if id1.addr == id2.addr && us1.size == us2.size - && (us1.zip us2).all (fun (u, v) => univEq u v) then - return true + if id1.addr == id2.addr && sameDefEqUniverses us1 us2 then + return some true | .app f1 a1 _, .app f2 a2 _ => - -- MUST short-circuit (Rust `&&` does; Lean's `(← _) && (← _)` runs - -- BOTH actions). For dependent apps the second component is often a - -- PROOF: comparing proof pairs whose value pair already failed forces - -- unbounded proof normalization (e.g. materializing `Nat.le` - -- derivations — the `minEntry!_eq_get!_minEntry?` OOM). - if (← isDefEqCall f1 f2) then - if (← isDefEqCall a1 a2) then - return true + return (← tryDefEqWhnfApp f1 a1 f2 a2) | .lam name bi ty1 body1 _, .lam _ _ ty2 body2 _ => if (← quickBinder name bi ty1 body1 ty2 body2) then - return true + return some true | .all name bi ty1 body1 _, .all _ _ ty2 body2 _ => if (← quickBinder name bi ty1 body1 ty2 body2) then - return true + return some true | .letE name ty1 v1 body1 _ _, .letE _ ty2 v2 body2 _ _ => - -- Normally zeta-reduced before reaching here; push LDecl in case. - -- Short-circuit like the app case (Rust `&&` semantics). - if (← isDefEqCall ty1 ty2) then - if (← isDefEqCall v1 v2) then - let saved := (← get).lctx.size - let fvId ← TcM.freshFVarId (m := m) - let fv ← TcM.intern (.mkFVar fvId name) - modify fun s => { s with lctx := s.lctx.push fvId (.ldecl name ty1 v1) } - let b1Open ← TcM.runIntern (instantiateRev body1 #[fv]) - let b2Open ← TcM.runIntern (instantiateRev body2 #[fv]) - let r ← isDefEqCall b1Open b2Open - modify fun s => { s with lctx := s.lctx.truncate saved } - if r then - return true - | .nat v1 _ _, .nat v2 _ _ => return v1 == v2 - | .str v1 _ _, .str v2 _ _ => return v1 == v2 + return (← tryDefEqWhnfLet name ty1 v1 body1 ty2 v2 body2) + | .nat v1 _ _, .nat v2 _ _ => return some (v1 == v2) + | .str v1 _ _, .str v2 _ _ => return some (v1 == v2) | _, _ => pure () - -- Nat literal ↔ constructor bridging. + return none + +/-- Optional Nat literal/constructor bridge at the head of the final-WHNF +fallback chain. -/ +def tryDefEqWhnfNat (a b : KExpr m) : RecM m (Option Bool) := do if (← isNatLike a) && (← isNatLike b) then - return (← isDefEqNat a b) - -- Eta expansion, both directions. + return some (← isDefEqNat a b) + return none + +/-- Ordered bidirectional eta attempts after the outer syntax guard accepts. -/ +def tryDefEqWhnfEtaAfterGuard (a b : KExpr m) : RecM m (Option Bool) := do + if (← tryEtaExpansion a b) then + return some true + if (← tryEtaExpansion b a) then + return some true + return none + +/-- Optional lambda-eta phase in the final-WHNF fallback chain. The two +directions retain production's ordering and short-circuit behavior. -/ +def tryDefEqWhnfEta (a b : KExpr m) : RecM m (Option Bool) := do let aIsLam := match a with | .lam .. => true | _ => false let bIsLam := match b with | .lam .. => true | _ => false if aIsLam || bIsLam then - if (← tryEtaExpansion a b) then - return true - if (← tryEtaExpansion b a) then - return true - -- String literal expansion. - let aIsStr := match a with | .str .. => true | _ => false - let bIsStr := match b with | .str .. => true | _ => false - if aIsStr || bIsStr then - if (← tryStringLitExpansion a b) then - return true - if (← tryStringLitExpansion b a) then - return true - -- Struct eta + unit-like + proof irrelevance. + tryDefEqWhnfEtaAfterGuard a b + else + return none + +/-- Ordered bidirectional String-literal expansion attempts after the outer +syntax guard accepts. -/ +def tryDefEqWhnfStringAfterGuard (a b : KExpr m) : + RecM m (Option Bool) := do + if (← tryStringLitExpansion a b) then + return some true + if (← tryStringLitExpansion b a) then + return some true + return none + +/-- Optional String-literal expansion phase in the final-WHNF fallback +chain. -/ +def tryDefEqWhnfString (a b : KExpr m) : RecM m (Option Bool) := do + if hasStringLiteralPair a b then + tryDefEqWhnfStringAfterGuard a b + else + return none + +/-- Ordered bidirectional structure-eta attempts. -/ +def tryDefEqWhnfStructEta (a b : KExpr m) : RecM m (Option Bool) := do if (← tryEtaStruct a b) then - return true + return some true if (← tryEtaStruct b a) then - return true + return some true + return none + +/-- Final proof-irrelevance fallback after the unit-like probe misses. -/ +def isDefEqWhnfAfterUnit (a b : KExpr m) : RecM m Bool := + tryProofIrrel a b + +/-- Remaining final-WHNF fallbacks after structure eta misses. -/ +def isDefEqWhnfAfterStructEta (a b : KExpr m) : RecM m Bool := do if (← tryDefEqUnit a b) then return true - tryProofIrrel a b + isDefEqWhnfAfterUnit a b + +/-- Remaining final-WHNF fallbacks after String expansion misses. -/ +def isDefEqWhnfAfterString (a b : KExpr m) : RecM m Bool := do + match (← tryDefEqWhnfStructEta a b) with + | some answer => return answer + | none => isDefEqWhnfAfterStructEta a b + +/-- Remaining final-WHNF fallbacks after lambda eta misses. -/ +def isDefEqWhnfAfterEta (a b : KExpr m) : RecM m Bool := do + match (← tryDefEqWhnfString a b) with + | some answer => return answer + | none => isDefEqWhnfAfterString a b + +/-- Remaining final-WHNF fallbacks after the Nat bridge misses. -/ +def isDefEqWhnfAfterNat (a b : KExpr m) : RecM m Bool := do + match (← tryDefEqWhnfEta a b) with + | some answer => return answer + | none => isDefEqWhnfAfterEta a b + +/-- Remaining final-WHNF fallbacks after the constructor-directed prefix has +no terminal result. -/ +def isDefEqWhnfAfterStructural (a b : KExpr m) : RecM m Bool := do + match (← tryDefEqWhnfNat a b) with + | some answer => return answer + | none => isDefEqWhnfAfterNat a b + +/-- Tier 5: full structural + eta / struct-eta / unit / proof irrelevance. -/ +def isDefEqWhnf (a b : KExpr m) : RecM m Bool := do + match (← tryDefEqWhnfStructural a b) with + | some answer => return answer + | none => isDefEqWhnfAfterStructural a b /-- Proof irrelevance: both proofs of the same Prop. -/ def tryProofIrrel (a b : KExpr m) : RecM m Bool := do @@ -541,23 +807,40 @@ def tryProofIrrel (a b : KExpr m) : RecM m Bool := do let some bTy ← try? (inferOnlyCall b) | return false isDefEqCall aTy bTy +/-- Uncached proposition classification. Inner-chain errors and inferred +types that do not normalize to a sort are conservative negative results. -/ +def classifyPropTypeUncached (ty : KExpr m) : RecM m Bool := do + match (← try? (inferOnlyCall ty)) with + | none => pure false + | some sort => + match (← try? (whnf sort)) with + | some (.sort u _) => pure u.isZero + | _ => pure false + /-- Is `ty : Sort 0`? Memoized on `(tyAddr, ctxAddr)`; inner-chain errors treated as non-prop. -/ def isPropType (ty : KExpr m) : RecM m Bool := do let cacheKey := (ty.addr, ← TcM.ctxAddrForLbr (m := m) ty.lbr) if let some cached := (← get).env.isPropCache[cacheKey]? then return cached - let result ← (do - match (← try? (inferOnlyCall ty)) with - | none => pure false - | some sort => - match (← try? (whnf sort)) with - | some (.sort u _) => pure u.isZero - | _ => pure false) + let result ← classifyPropTypeUncached ty modify fun s => { s with env := { s.env with isPropCache := s.env.isPropCache.insert cacheKey result } } return result +/-- Classify one inductive declaration as unit-like: zero indices, exactly +one constructor, and no constructor fields. -/ +def isUnitLikeInductive (indId : KId m) : RecM m Bool := do + match (← TcM.tryGetConst indId) with + | some (.indc (indices := indices) (ctors := ctors) ..) => + if indices != 0 || ctors.size != 1 then + return false + else + match (← TcM.tryGetConst ctors[0]!) with + | some (.ctor (fields := fields) ..) => return fields == 0 + | _ => return false + | _ => return false + /-- Unit-like (non-recursive, 0 indices, 1 nullary ctor): any two inhabitants of the same unit-like type are def-eq. -/ def tryDefEqUnit (a b : KExpr m) : RecM m Bool := do @@ -565,31 +848,25 @@ def tryDefEqUnit (a b : KExpr m) : RecM m Bool := do let some aTyW ← try? (whnf aTy) | return false let (aHead, _) := aTyW.collectSpine let .const aInd _ _ := aHead | return false - let isUnit ← match (← TcM.tryGetConst aInd) with - | some (.indc (indices := indices) (ctors := ctors) ..) => - if indices != 0 || ctors.size != 1 then - pure false - else - match (← TcM.tryGetConst ctors[0]!) with - | some (.ctor (fields := fields) ..) => pure (fields == 0) - | _ => pure false - | _ => return false - if !isUnit then + if !(← isUnitLikeInductive aInd) then return false let some bTy ← try? (inferOnlyCall b) | return false isDefEqCall aTyW bTy -/-- Nat-like comparison: literal fast path, zero/succ peeling. -/ -def isDefEqNat (a b : KExpr m) : RecM m Bool := do - match a, b with - | .nat va _ _, .nat vb _ _ => return va == vb - | _, _ => pure () +/-- Nat-like comparison after the direct literal/literal case misses. -/ +def isDefEqNatAfterLiteral (a b : KExpr m) : RecM m Bool := do if (← isNatZero a) && (← isNatZero b) then return true match (← natSuccOf a), (← natSuccOf b) with | some aPred, some bPred => isDefEqCall aPred bPred | _, _ => return false +/-- Nat-like comparison: literal fast path, zero/succ peeling. -/ +def isDefEqNat (a b : KExpr m) : RecM m Bool := do + match a, b with + | .nat va _ _, .nat vb _ _ => return va == vb + | _, _ => isDefEqNatAfterLiteral a b + /-- Nat offset comparison in the lazy delta loop (`isDefEqOffset`), generalized to offset form: each side decomposes to `base + offset` (`Lit n`, `succ` layers, and the compact stuck `Nat.add base (Lit m)` @@ -604,14 +881,32 @@ def tryDefEqOffset (a b : KExpr m) : RecM m (Option Bool) := do match a, b with | .nat va _ _, .nat vb _ _ => return some (va == vb) | _, _ => pure () + tryDefEqOffsetAfterLiteral a b + +/-- Remaining Nat-offset comparison after the direct literal/literal case +does not apply. -/ +def tryDefEqOffsetAfterLiteral (a b : KExpr m) : + RecM m (Option Bool) := do if (← isNatZero a) && (← isNatZero b) then return some true + tryDefEqOffsetAfterZeroMiss a b + +/-- Remaining generalized offset path after neither the direct literal pair +nor the joint Nat-zero probe accepts. -/ +def tryDefEqOffsetAfterZeroMiss (a b : KExpr m) : + RecM m (Option Bool) := do -- Quick reject: decompose walks app spines, so only run it when both -- heads are plausibly offset-shaped (a one-succ peel rejects non-Nat -- shapes in O(1) off the head — keep that property). let p ← prims if !natOffsetCandidate p a || !natOffsetCandidate p b then return none + tryDefEqOffsetAfterCandidates a b + +/-- Remaining offset decomposition and rebuild after both allocation-free +candidate guards accept. -/ +def tryDefEqOffsetAfterCandidates (a b : KExpr m) : + RecM m (Option Bool) := do let some (baseA, ka) ← natOffsetDecompose a | return none let some (baseB, kb) ← natOffsetDecompose b | return none let k := min ka kb @@ -629,35 +924,63 @@ def tryStringLitExpansion (t s : KExpr m) : RecM m Bool := do let expanded ← strLitToConstructor strVal isDefEqCall expanded s +/-- Build and compare the concrete lambda used by eta after inference has +exposed the non-lambda operand's function domain. -/ +def compareEtaExpansion (t s : KExpr m) (name : m.F Name) + (bi : m.F Lean.BinderInfo) (ty : KExpr m) : RecM m Bool := do + let sLifted ← TcM.runIntern (lift s 1 0) + let v0 ← TcM.intern (.mkVar 0 anonN : KExpr m) + let body ← TcM.intern (KExpr.mkApp sLifted v0) + let sLam ← TcM.intern (.mkLam name bi ty body) + isDefEqCall t sLam + +/-- Lambda-eta construction after the syntactic lambda/non-lambda guard has +accepted. -/ +def tryEtaExpansionAfterGuard (t s : KExpr m) : RecM m Bool := do + let some sTy ← try? (inferOnlyCall s) | return false + let some sTyWhnf ← try? (whnf sTy) | return false + let .all name bi ty _ _ := sTyWhnf | return false + compareEtaExpansion t s name bi ty + /-- Lambda eta: `t` a lambda, `s` not — wrap `s` as `λ(ty). s #0`. -/ def tryEtaExpansion (t s : KExpr m) : RecM m Bool := do let tIsLam := match t with | .lam .. => true | _ => false let sIsLam := match s with | .lam .. => true | _ => false if !tIsLam || sIsLam then return false - let some sTy ← try? (inferOnlyCall s) | return false - let some sTyWhnf ← try? (whnf sTy) | return false - let .all name bi ty _ _ := sTyWhnf | return false - let sLifted ← TcM.runIntern (lift s 1 0) - let v0 ← TcM.intern (.mkVar 0 anonN : KExpr m) - let body ← TcM.intern (KExpr.mkApp sLifted v0) - let sLam ← TcM.intern (.mkLam name bi ty body) - isDefEqCall t sLam + tryEtaExpansionAfterGuard t s /-- Struct eta: `s` a fully-applied ctor of a struct-like type; compare `prj i t ≡ s.args[params+i]` per field (types def-eq first; no Prop guard here — equality checking, not term construction). -/ def tryEtaStruct (t s : KExpr m) : RecM m Bool := do - let tNorm ← (do - match (← try? (whnfNoDelta t)) with - | some w => pure w - | none => pure t) + let tNorm ← normalizeEtaStructSource t + tryEtaStructAfterNormalization tNorm s + +/-- Caught no-delta normalization used by structure eta. A reducer error +retains the original source exactly, matching production's non-backtracking +fallback. -/ +def normalizeEtaStructSource (t : KExpr m) : RecM m (KExpr m) := do + match (← try? (whnfNoDelta t)) with + | some w => pure w + | none => pure t + +/-- Constructor-head lookup and metadata selection after the left operand +has been normalized for structure eta. -/ +def tryEtaStructAfterNormalization (tNorm s : KExpr m) : RecM m Bool := do let (sHead, sArgs) := s.collectSpine let .const ctorId _ _ := sHead | return false let (inductId, numParams, numFields) ← match (← TcM.tryGetConst ctorId) with | some (.ctor (induct := induct) (params := params) (fields := fields) ..) => pure (induct, params.toNat, fields.toNat) | _ => return false + tryEtaStructAfterConstructor inductId numParams numFields tNorm s sArgs + +/-- Size, classifier, inference, and field-comparison tail for the exact +constructor metadata selected by `tryEtaStructAfterNormalization`. -/ +def tryEtaStructAfterConstructor (inductId : KId m) + (numParams numFields : Nat) (tNorm s : KExpr m) + (sArgs : Array (KExpr m)) : RecM m Bool := do if sArgs.size != numParams + numFields then return false if !(← isStructLike inductId) then @@ -666,35 +989,80 @@ def tryEtaStruct (t s : KExpr m) : RecM m Bool := do let some tTy ← try? (inferOnlyCall tNorm) | return false if !(← isDefEqCall tTy sTy) then return false + tryEtaStructAfterTypes inductId numParams numFields tNorm sArgs + +/-- Structure-eta tail after both operands have been shown to have +definitionally equal types. The common-base shortcut precedes the explicit +field loop exactly as in the original implementation. -/ +def tryEtaStructAfterTypes (inductId : KId m) (numParams numFields : Nat) + (tNorm : KExpr m) (sArgs : Array (KExpr m)) : RecM m Bool := do if let some base ← etaExpansionBase inductId numParams numFields sArgs then if (← isDefEqCall tNorm base) then return true - for i in [0:numFields] do - let proj ← TcM.intern (.mkPrj inductId i.toUInt64 tNorm) - if !(← isDefEqCall proj sArgs[numParams + i]!) then - return false - return true + tryEtaStructFields inductId numParams tNorm sArgs numFields 0 + +/-- Left-to-right structure-eta field comparison. `fuel` is the number of +remaining fields and `field` is the concrete projection index; naming this +loop exposes its exact generated projections and short-circuit behavior. -/ +def tryEtaStructFields (inductId : KId m) (numParams : Nat) + (tNorm : KExpr m) (sArgs : Array (KExpr m)) : + Nat → Nat → RecM m Bool + | 0, _ => pure true + | fuel + 1, field => do + let proj ← TcM.intern (.mkPrj inductId field.toUInt64 tNorm) + if !(← isDefEqCall proj sArgs[numParams + field]!) then + return false + tryEtaStructFields inductId numParams tNorm sArgs fuel (field + 1) /-- If every ctor field is `prj i base` of one common base, return it. -/ def etaExpansionBase (inductId : KId m) (numParams numFields : Nat) (args : Array (KExpr m)) : RecM m (Option (KExpr m)) := do - let mut base : Option (KExpr m) := none - for i in [0:numFields] do - let field := args[numParams + i]! - let field ← whnfNoDelta field - let .prj id idx val _ := field | return none - if id.addr != inductId.addr || idx.toNat != i then - return none - let val ← (do - match (← try? (whnfNoDelta val)) with - | some w => pure w - | none => pure val) - match base with - | some b => - if b.addr != val.addr then + etaExpansionBaseLoop inductId numParams args numFields 0 none + +/-- Left-to-right common-base scan used by the structure-eta shortcut. The +explicit accumulator and remaining-field count retain the original WHNF and +caught-error order while making partial exits available to verification. -/ +def etaExpansionBaseLoop (inductId : KId m) (numParams : Nat) + (args : Array (KExpr m)) : + Nat → Nat → Option (KExpr m) → RecM m (Option (KExpr m)) + | 0, _, base => pure base + | fuel + 1, fieldIdx, base => do + let field := args[numParams + fieldIdx]! + let field ← whnfNoDelta field + let .prj id idx val _ := field | return none + if id.addr != inductId.addr || idx.toNat != fieldIdx then + return none + etaExpansionBaseAfterProjection inductId numParams args fuel + fieldIdx base val + +/-- Caught optional normalization of one projection base in the common-base +scan. -/ +def etaExpansionBaseAfterProjection (inductId : KId m) (numParams : Nat) + (args : Array (KExpr m)) (fuel fieldIdx : Nat) + (base : Option (KExpr m)) (value : KExpr m) : + RecM m (Option (KExpr m)) := do + match (← try? (whnfNoDelta value)) with + | some normalized => + etaExpansionBaseAfterValue inductId numParams args fuel fieldIdx base + normalized + | none => + etaExpansionBaseAfterValue inductId numParams args fuel fieldIdx base + value + +/-- Accumulator check after one projection base has been selected. -/ +def etaExpansionBaseAfterValue (inductId : KId m) (numParams : Nat) + (args : Array (KExpr m)) (fuel fieldIdx : Nat) + (base : Option (KExpr m)) (value : KExpr m) : + RecM m (Option (KExpr m)) := + match base with + | some prior => do + if prior.addr != value.addr then return none - | none => base := some val - return base + etaExpansionBaseLoop inductId numParams args fuel + (fieldIdx + 1) base + | none => + etaExpansionBaseLoop inductId numParams args fuel + (fieldIdx + 1) (some value) /-- App-spine comparison (isDefEqApp). -/ def tryDefEqApp (a b : KExpr m) : RecM m Bool := do @@ -708,17 +1076,13 @@ def tryDefEqApp (a b : KExpr m) : RecM m Bool := do return false if !(← isDefEqCall aHead bHead) then return false - for (ai, bi) in aArgs.zip bArgs do - if !(← isDefEqCall ai bi) then - return false - return true + allDefEqSpineArgs (aArgs.zip bArgs) /-- Post-delta structural congruence (Const/Var/Prj). -/ def tryStructuralCongruence (a b : KExpr m) : RecM m Bool := do match a, b with | .const id1 us1 _, .const id2 us2 _ => - return id1.addr == id2.addr && us1.size == us2.size - && (us1.zip us2).all (fun (u, v) => univEq u v) + return id1.addr == id2.addr && sameDefEqUniverses us1 us2 | .var i _ _, .var j _ _ => return i == j | .prj id1 f1 v1 _, .prj id2 f2 v2 _ => if id1.addr != id2.addr || f1 != f2 then @@ -745,59 +1109,109 @@ def lazyDeltaProjReduction (structId : KId m) (field : UInt64) def lazyDeltaReductionStep (a0 b0 : KExpr m) : RecM m (LazyDeltaStep × KExpr m × KExpr m) := do + let aHead := headConstId a0 + let bHead := headConstId b0 + let aDelta ← classifyDeltaHead a0 + let bDelta ← classifyDeltaHead b0 + lazyDeltaReductionStepAfterClassification a0 b0 aHead bHead aDelta bDelta + +/-- Remaining projection-directed delta step after both head-classification +lookups. Naming this tail exposes lazy-ingress preservation independently +from the reduction/rank branches without changing their execution order. -/ +def lazyDeltaReductionStepAfterClassification (a0 b0 : KExpr m) + (aHead bHead : Option (KId m)) (aDelta bDelta : Bool) : + RecM m (LazyDeltaStep × KExpr m × KExpr m) := do let mut a := a0 let mut b := b0 - let aHead := headConstId a - let bHead := headConstId b - let aDelta ← match aHead with - | some h => isDelta h - | none => pure false - let bDelta ← match bHead with - | some h => isDelta h - | none => pure false if !aDelta && !bDelta then return (.unknown, a, b) + lazyDeltaReductionStepAfterActive a b aHead bHead aDelta bDelta + +/-- Active projection-directed delta branches after at least one operand has +been classified as reducible. -/ +def lazyDeltaReductionStepAfterActive (a0 b0 : KExpr m) + (aHead bHead : Option (KId m)) (aDelta bDelta : Bool) : + RecM m (LazyDeltaStep × KExpr m × KExpr m) := do if aDelta && !bDelta then - match (← tryUnfoldProjApp b) with - | some b2 => b := b2 - | none => - match (← deltaUnfoldOne a) with - | some a2 => a ← whnfCore a2 - | none => return (.unknown, a, b) + match (← tryUnfoldProjApp b0) with + | some b2 => finishLazyDeltaReductionStep a0 b2 + | none => lazyDeltaReductionStepWithLeftDelta a0 b0 else if !aDelta && bDelta then - match (← tryUnfoldProjApp a) with - | some a2 => a := a2 - | none => - match (← deltaUnfoldOne b) with - | some b2 => b ← whnfCore b2 - | none => return (.unknown, a, b) + match (← tryUnfoldProjApp a0) with + | some a2 => finishLazyDeltaReductionStep a2 b0 + | none => lazyDeltaReductionStepWithRightDelta a0 b0 else - let aId := aHead.get! - let bId := bHead.get! - let cmp := compareRank (← defRankId aId) (← defRankId bId) - if cmp == .gt then - match (← deltaUnfoldOne a) with - | some a2 => a ← whnfCore a2 - | none => return (.unknown, a, b) - else if cmp == .lt then - match (← deltaUnfoldOne b) with - | some b2 => b ← whnfCore b2 - | none => return (.unknown, a, b) - else - if aId.addr == bId.addr && (← isRegular aId) then - if let some true ← trySameHeadSpine a b then - return (.equal, a, b) - let a2 ← deltaUnfoldOne a - let b2 ← deltaUnfoldOne b - match a2, b2 with - | some a2, some b2 => - a ← whnfCore a2 - b ← whnfCore b2 - | some a2, none => - a ← whnfCore a2 - | none, some b2 => - b ← whnfCore b2 - | none, none => return (.unknown, a, b) + lazyDeltaReductionStepWithBothDelta a0 b0 aHead bHead + +/-- Unfold and structural-normalize the left operand in the compact +projection-directed delta step. -/ +def lazyDeltaReductionStepWithLeftDelta (a b : KExpr m) : + RecM m (LazyDeltaStep × KExpr m × KExpr m) := do + match (← deltaUnfoldOne a) with + | some unfolded => + let reduced ← whnfCore unfolded + finishLazyDeltaReductionStep reduced b + | none => return (.unknown, a, b) + +/-- Symmetric right-only branch of the compact projection-directed step. -/ +def lazyDeltaReductionStepWithRightDelta (a b : KExpr m) : + RecM m (LazyDeltaStep × KExpr m × KExpr m) := do + match (← deltaUnfoldOne b) with + | some unfolded => + let reduced ← whnfCore unfolded + finishLazyDeltaReductionStep a reduced + | none => return (.unknown, a, b) + +/-- Rank dispatch when the projection-directed step classified both heads as +delta-reducible. -/ +def lazyDeltaReductionStepWithBothDelta (a b : KExpr m) + (aHead bHead : Option (KId m)) : + RecM m (LazyDeltaStep × KExpr m × KExpr m) := do + let aId := aHead.get! + let bId := bHead.get! + let cmp := compareRank (← defRankId aId) (← defRankId bId) + if cmp == .gt then + lazyDeltaReductionStepWithLeftDelta a b + else if cmp == .lt then + lazyDeltaReductionStepWithRightDelta a b + else + lazyDeltaReductionStepWithEqualRank a b aId bId + +/-- Equal-rank branch: try same-head congruence, then unfold both operands +and structural-normalize every successful result. -/ +def lazyDeltaReductionStepWithEqualRank (a0 b0 : KExpr m) + (aId bId : KId m) : + RecM m (LazyDeltaStep × KExpr m × KExpr m) := do + let mut a := a0 + let mut b := b0 + if aId.addr == bId.addr && (← isRegular aId) then + if let some true ← trySameHeadSpine a b then + return (.equal, a, b) + lazyDeltaReductionStepAfterSameHeadMiss a b + +/-- Two-sided unfold/structural-normalization tail after the compact +same-head attempt does not prove equality. -/ +def lazyDeltaReductionStepAfterSameHeadMiss (a0 b0 : KExpr m) : + RecM m (LazyDeltaStep × KExpr m × KExpr m) := do + let mut a := a0 + let mut b := b0 + let a2 ← deltaUnfoldOne a + let b2 ← deltaUnfoldOne b + match a2, b2 with + | some a2, some b2 => + a ← whnfCore a2 + b ← whnfCore b2 + | some a2, none => + a ← whnfCore a2 + | none, some b2 => + b ← whnfCore b2 + | none, none => return (.unknown, a, b) + finishLazyDeltaReductionStep a b + +/-- Common address/quick-structural finish for a productive compact delta +step. -/ +def finishLazyDeltaReductionStep (a b : KExpr m) : + RecM m (LazyDeltaStep × KExpr m × KExpr m) := do if a.addr == b.addr || (← quickDefEq a b) then return (.equal, a, b) return (.continue', a, b) diff --git a/Ix/Tc/Equiv.lean b/Ix/Tc/Equiv.lean index 5048ec753..d8f2841f0 100644 --- a/Ix/Tc/Equiv.lean +++ b/Ix/Tc/Equiv.lean @@ -6,8 +6,9 @@ public import Ix.Address Mirror: crates/kernel/src/equiv.rs Union-find (disjoint set) for context-aware definitional-equality caching: -weighted quick-union with path halving, keyed by `(expr_hash, ctx_hash)` -content-address pairs. +weighted quick-union with path halving, keyed by expression hash, context +hash, the requested context-suffix radius, and the expression's intrinsic +local-binder radius. Pure port: operations return the updated manager (path halving mutates on reads). Do not reuse the `IO.Ref`-based `Ix.UnionFind`. @@ -18,11 +19,43 @@ public section namespace Ix.Tc -/-- Composite key: (expression content hash, context content hash). -/ -abbrev EqKey := Address × Address - -/-- Union-find for tracking definitional equality between - `(expr_hash, ctx_hash)` pairs. -/ +/-- Composite key for one expression in one context-suffix interpretation. + +The radius is semantically load-bearing even when two suffix calculations +emit the same digest: DefEq transport is only justified between executions +that requested the same radius. Retaining it here prevents union-find +transitivity from silently joining equality proofs made at different +context-suffix radii. -/ +structure EqKey where + exprAddr : Address + ctxAddr : Address + /-- Radius at which `ctxAddr` was computed for this comparison. -/ + lbr : UInt64 + /-- Intrinsic local-binder radius of the expression at `exprAddr`. -/ + exprLbr : UInt64 +deriving Inhabited + +instance : BEq EqKey where + beq left right := + left.exprAddr == right.exprAddr && + left.ctxAddr == right.ctxAddr && + left.lbr == right.lbr && + left.exprLbr == right.exprLbr + +instance : Hashable EqKey where + hash key := hash (key.exprAddr, key.ctxAddr, key.lbr, key.exprLbr) + +/-- Whether two union-find representatives can safely reuse a DefEq cache +context. Besides retaining the requested scope, their intrinsic expression +radii must reconstruct the radius at which that context digest was made. -/ +def EqKey.rootCacheScopeMatches (left right : EqKey) + (ctxAddr : Address) (lbr : UInt64) : Bool := + left.ctxAddr == ctxAddr && right.ctxAddr == ctxAddr && + left.lbr == lbr && right.lbr == lbr && + max left.exprLbr right.exprLbr == lbr + +/-- Union-find for tracking definitional equality between context-aware + expression keys. -/ structure EquivManager where /-- Map from composite key to union-find node index. -/ keyToNode : Std.HashMap EqKey Nat := {} diff --git a/Ix/Tc/Infer.lean b/Ix/Tc/Infer.lean index f7bbee838..f48831ef3 100644 --- a/Ix/Tc/Infer.lean +++ b/Ix/Tc/Infer.lean @@ -26,19 +26,27 @@ namespace Ix.Tc namespace RecM +/-- Store one successful inference result in the cache partition selected by +the validation policy captured at entry. Keeping this write separate from +the syntax dispatcher gives verification one exact state-update seam without +changing the full/infer-only separation. -/ +def cacheInferResult (inferOnly : Bool) (cacheKey : Address × Address) + (ty : KExpr m) : RecM m Unit := do + if !inferOnly then + modify fun s => { s with env := { s.env with + inferCache := s.env.inferCache.insert cacheKey ty } } + else + modify fun s => { s with env := { s.env with + inferOnlyCache := s.env.inferOnlyCache.insert cacheKey ty } } + mutual -def inferWith (inferRec : KExpr m → RecM m (KExpr m)) - (e : KExpr m) : RecM m (KExpr m) := do - let inferOnly := (← get).inferOnly - let cacheKey ← TcM.inferKey e - -- Full-mode results are validated; either mode may consume them. - if let some cached := (← get).env.inferCache[cacheKey]? then - return cached - if inferOnly then - if let some cached := (← get).env.inferOnlyCache[cacheKey]? then - return cached - let ty ← match e with +/-- Infer one expression after both policy-appropriate cache partitions have +missed. Recursive inference and DefEq calls still go through the smaller +method table supplied by the caller. -/ +def inferUncached (inferRec : KExpr m → RecM m (KExpr m)) + (inferOnly : Bool) (e : KExpr m) : RecM m (KExpr m) := do + match e with | .var i _ _ => -- Legacy de Bruijn lookup (inductive-validation paths still push via -- pushLocal/pushLet). @@ -75,31 +83,23 @@ def inferWith (inferRec : KExpr m → RecM m (KExpr m)) if !inferOnly then let t ← inferRec ty let _ ← ensureSortDirect t - -- Open the binder with a fresh fvar (lean4lean inferLambda). - let saved := (← get).lctx.size - let fvId ← TcM.freshFVarId (m := m) - let fv ← TcM.intern (.mkFVar fvId name) - modify fun s => { s with lctx := s.lctx.push fvId (.cdecl name bi ty) } - let bodyOpen ← TcM.runIntern (instantiateRev body #[fv]) - let bodyTy ← inferRec bodyOpen - -- Peephole-reduce App(λ…, …) shapes before wrapping in the Pi. - let bodyTy ← TcM.runIntern (cheapBetaReduce bodyTy) - let abstracted ← TcM.runIntern (abstractFVars bodyTy #[fvId]) - modify fun s => { s with lctx := s.lctx.truncate saved } - -- Anonymous binder metadata (hash-neutral; see module doc). - TcM.intern (.mkAll anonN anonBi ty abstracted) + withLctxScope do + -- Open the binder with a fresh fvar (lean4lean inferLambda). + let (bodyOpen, fvId) ← TcM.openBinder name bi ty body + let bodyTy ← inferRec bodyOpen + -- Peephole-reduce App(λ…, …) shapes before wrapping in the Pi. + let bodyTy ← TcM.runIntern (cheapBetaReduce bodyTy) + let abstracted ← TcM.runIntern (abstractFVars bodyTy #[fvId]) + -- Anonymous binder metadata (hash-neutral; see module doc). + TcM.intern (.mkAll anonN anonBi ty abstracted) | .all name bi ty body _ => do let tyTy ← inferRec ty let u1 ← ensureSortDirect tyTy - let saved := (← get).lctx.size - let fvId ← TcM.freshFVarId (m := m) - let fv ← TcM.intern (.mkFVar fvId name) - modify fun s => { s with lctx := s.lctx.push fvId (.cdecl name bi ty) } - let bodyOpen ← TcM.runIntern (instantiateRev body #[fv]) - let bodyTy ← inferRec bodyOpen - let u2 ← ensureSortDirect bodyTy - modify fun s => { s with lctx := s.lctx.truncate saved } - TcM.intern (.mkSort (.mkIMax u1 u2)) + withLctxScope do + let (bodyOpen, _) ← TcM.openBinder name bi ty body + let bodyTy ← inferRec bodyOpen + let u2 ← ensureSortDirect bodyTy + TcM.intern (.mkSort (.mkIMax u1 u2)) | .letE name ty val body _ _ => do if !inferOnly then let t ← inferRec ty @@ -109,28 +109,30 @@ def inferWith (inferRec : KExpr m → RecM m (KExpr m)) throw .declTypeMismatch -- Open with a let-bound fvar (lean4lean inferLet); eagerly substitute -- the value into the abstracted body type, then cheap-beta. - let saved := (← get).lctx.size - let fvId ← TcM.freshFVarId (m := m) - let fv ← TcM.intern (.mkFVar fvId name) - modify fun s => { s with lctx := s.lctx.push fvId (.ldecl name ty val) } - let bodyOpen ← TcM.runIntern (instantiateRev body #[fv]) - let bodyTy ← inferRec bodyOpen - let abstracted ← TcM.runIntern (abstractFVars bodyTy #[fvId]) - let r ← TcM.runIntern (subst abstracted val 0) - let r ← TcM.runIntern (cheapBetaReduce r) - modify fun s => { s with lctx := s.lctx.truncate saved } - pure r + withLctxScope do + let (bodyOpen, fvId) ← TcM.openLet name ty val body + let bodyTy ← inferRec bodyOpen + let abstracted ← TcM.runIntern (abstractFVars bodyTy #[fvId]) + let r ← TcM.runIntern (subst abstracted val 0) + TcM.runIntern (cheapBetaReduce r) | .prj structId field val _ => do let valTy ← inferRec val inferProj structId field val valTy | .nat .. => do TcM.intern (.mkConst (← prims).nat #[]) | .str .. => do TcM.intern (.mkConst (← prims).string #[]) - if !inferOnly then - modify fun s => { s with env := { s.env with - inferCache := s.env.inferCache.insert cacheKey ty } } - else - modify fun s => { s with env := { s.env with - inferOnlyCache := s.env.inferOnlyCache.insert cacheKey ty } } + +def inferWith (inferRec : KExpr m → RecM m (KExpr m)) + (e : KExpr m) : RecM m (KExpr m) := do + let inferOnly := (← get).inferOnly + let cacheKey ← TcM.inferKey e + -- Full-mode results are validated; either mode may consume them. + if let some cached := (← get).env.inferCache[cacheKey]? then + return cached + if inferOnly then + if let some cached := (← get).env.inferOnlyCache[cacheKey]? then + return cached + let ty ← inferUncached inferRec inferOnly e + cacheInferResult inferOnly cacheKey ty return ty /-- One recursive Infer edge through the indexed method table. -/ @@ -148,27 +150,113 @@ def inferWith (inferRec : KExpr m → RecM m (KExpr m)) def infer (e : KExpr m) : RecM m (KExpr m) := inferWith inferCall e +/-- WHNF fallback for sort exposure. Naming the fallback separately keeps +the syntactic fast path in `ensureSortDirect` while giving verification an +exact target for the reduction-dependent branch. -/ +def ensureSortWhnf (e : KExpr m) : RecM m (KUniv m) := do + match (← whnf e) with + | .sort u _ => return u + | _ => throw .typeExpected + /-- `ensureSort` against the direct whnf (no Methods indirection needed — infer imports whnf). -/ def ensureSortDirect (e : KExpr m) : RecM m (KUniv m) := do if let .sort u _ := e then return u - match (← whnf e) with - | .sort u _ => return u - | _ => throw .typeExpected + ensureSortWhnf e -def ensureForallDirect (e : KExpr m) : RecM m (KExpr m × KExpr m) := do - if let .all _ _ a b _ := e then - return (a, b) +def ensureForallWhnf (e : KExpr m) : RecM m (KExpr m × KExpr m) := do let w ← whnf e match w with | .all _ _ a b _ => return (a, b) | _ => throw (.funExpected e w) +/-- Syntactic Pi fast path with a separately named WHNF fallback. The seam +is operationally neutral and gives verification an exact target for the +non-syntactic branch. -/ +def ensureForallDirect (e : KExpr m) : RecM m (KExpr m × KExpr m) := do + if let .all _ _ a b _ := e then + return (a, b) + ensureForallWhnf e + /-- The isDefEq back-edge (tied in `Ix.Tc.Knot`). -/ def isDefEqCall (a b : KExpr m) : RecM m Bool := do (← read).isDefEq a b +/-- One constructor-parameter iteration. The explicit `ForInStep` result +makes the state threaded by the production range loop visible to proofs. -/ +def instantiateProjParamStep (args : Array (KExpr m)) (i : Nat) + (ctorTy : KExpr m) : RecM m (ForInStep (KExpr m)) := do + let (_, body) ← peelProjForall ctorTy + "projection: expected forall in ctor type" + if h : i < args.size then + let result ← TcM.runIntern (subst body args[i] 0) + return .yield result + else + throw (.other "projection: not enough params") + +/-- Instantiate the constructor telescope's inductive parameters with the +arguments recovered from the projected value's inferred type. Naming this +loop separately exposes its exact partial-error boundary to verification. -/ +def instantiateProjParams (args : Array (KExpr m)) (numParams : Nat) + (ctorTy : KExpr m) : RecM m (KExpr m) := + forIn [0:numParams] ctorTy (instantiateProjParamStep args) + +/-- One constructor-field iteration. A selected field stops the surrounding +range loop; an earlier field yields the telescope obtained by substituting +the concrete projection node. -/ +def inferProjFieldStep (structId : KId m) (field : UInt64) (val : KExpr m) + (isPropStruct : Bool) (i : Nat) (current : KExpr m) : + RecM m (ForInStep (KExpr m)) := do + let (dom, body) ← + peelProjForall current "projection: not enough fields" + if i == field.toNat then + -- Prop structures may only project Prop fields. + if isPropStruct then + let fieldSortTy ← inferCall dom + let fieldLevel ← ensureSortDirect fieldSortTy + if !univEq fieldLevel .mkZero then + throw (.other + "projection: cannot project data field from Prop structure") + return .done dom + if isPropStruct then + let fieldSortTy ← inferCall dom + let fieldLevel ← ensureSortDirect fieldSortTy + let isData := !univEq fieldLevel .mkZero + -- body.lbr > 0 ⇒ later fields depend on this one. + if isData && body.lbr > 0 then + throw (.other + "projection: forbidden after dependent data field in Prop structure") + let proj ← TcM.intern (.mkPrj structId i.toUInt64 val) + let result ← TcM.runIntern (subst body proj 0) + return .yield result + +/-- Lift a field step into the accumulator used by the projection range +loop. A selected field stores its result and stops; an earlier field stores +the substituted telescope and continues. -/ +def inferProjFieldsLoopStep (structId : KId m) (field : UInt64) + (val : KExpr m) (isPropStruct : Bool) (i : Nat) + (state : Option (KExpr m) × KExpr m) : + RecM m (ForInStep (Option (KExpr m) × KExpr m)) := do + match ← inferProjFieldStep structId field val isPropStruct i state.2 with + | .done result => + pure (.done (some result, state.2)) + | .yield next => + pure (.yield (none, next)) + +/-- Walk the instantiated constructor fields up to the requested projection. +Earlier dependent fields are substituted by concrete projection nodes; Prop +elimination checks are performed at the same points as the original inline +loop. -/ +def inferProjFields (structId : KId m) (field : UInt64) (val : KExpr m) + (isPropStruct : Bool) (ctorTy : KExpr m) : RecM m (KExpr m) := do + let state ← forIn [0:field.toNat + 1] + ((none : Option (KExpr m)), ctorTy) + (inferProjFieldsLoopStep structId field val isPropStruct) + match state.1 with + | none => throw (.other "projection: unreachable") + | some result => pure result + def inferProj (structId : KId m) (field : UInt64) (val : KExpr m) (valTy : KExpr m) : RecM m (KExpr m) := do let wty ← whnf valTy @@ -188,34 +276,10 @@ def inferProj (structId : KId m) (field : UInt64) (val : KExpr m) let ctorTy ← match (← TcM.tryGetConst ctors[0]!) with | some c => pure c.ty | none => throw (.other "projection: constructor not found") - let mut r ← TcM.instantiateUnivParams ctorTy iLevels - for i in [0:numParams] do - let (_, body) ← peelProjForall r "projection: expected forall in ctor type" - if h : i < args.size then - r ← TcM.runIntern (subst body args[i] 0) - else - throw (.other "projection: not enough params") - for i in [0:field.toNat + 1] do - let (dom, body) ← peelProjForall r "projection: not enough fields" - if i == field.toNat then - -- Prop structures may only project Prop fields. - if isPropStruct then - let fieldSortTy ← inferCall dom - let fieldLevel ← ensureSortDirect fieldSortTy - if !univEq fieldLevel .mkZero then - throw (.other "projection: cannot project data field from Prop structure") - return dom - if isPropStruct then - let fieldSortTy ← inferCall dom - let fieldLevel ← ensureSortDirect fieldSortTy - let isData := !univEq fieldLevel .mkZero - -- body.lbr > 0 ⇒ later fields depend on this one. - if isData && body.lbr > 0 then - throw (.other - "projection: forbidden after dependent data field in Prop structure") - let proj ← TcM.intern (.mkPrj structId i.toUInt64 val) - r ← TcM.runIntern (subst body proj 0) - throw (.other "projection: unreachable") + let instantiatedCtorTy ← TcM.instantiateUnivParams ctorTy iLevels + let parameterizedCtorTy ← + instantiateProjParams args numParams instantiatedCtorTy + inferProjFields structId field val isPropStruct parameterizedCtorTy /-- Peel a leading `Π`: syntactic fast path, whnf fallback. -/ def peelProjForall (e : KExpr m) (err : String) : @@ -226,20 +290,38 @@ def peelProjForall (e : KExpr m) (err : String) : | .all _ _ dom body _ => return (dom, body) | _ => throw (.other err) +/-- One declaration-binder scan used while classifying an inductive result +sort. The body is intentionally not instantiated: production only needs the +eventual sort and therefore carries the raw declaration telescope. -/ +def inductiveAppBinderStep (current : KExpr m) : + RecM m (ForInStep (KExpr m)) := do + let reduced ← whnf current + match reduced with + | .all _ _ _ body _ => pure (.yield body) + | _ => throw (.other "projection: expected forall in inductive type") + +/-- Strip the declared parameter and index prefix before inspecting an +inductive family's result sort. -/ +def inductiveAppBinders (binders : Nat) (indTy : KExpr m) : + RecM m (KExpr m) := + forIn [0:binders] indTy (fun _ current => + inductiveAppBinderStep current) + +/-- Classify the result remaining after the declaration telescope has been +stripped. -/ +def inductiveAppResultIsProp (resultTy : KExpr m) : RecM m Bool := do + let sortTy ← whnf resultTy + let level ← ensureSortDirect sortTy + return univEq level .mkZero + def inductiveAppIsProp (indId : KId m) (levels : Array (KUniv m)) (binders : Nat) : RecM m Bool := do let indTy ← match (← TcM.tryGetConst indId) with | some (.indc (ty := ty) ..) => pure ty | _ => throw (.other "projection: not an inductive type") - let mut r ← TcM.instantiateUnivParams indTy levels - for _ in [0:binders] do - let wr ← whnf r - match wr with - | .all _ _ _ body _ => r := body - | _ => throw (.other "projection: expected forall in inductive type") - let sortTy ← whnf r - let level ← ensureSortDirect sortTy - return univEq level .mkZero + let instantiated ← TcM.instantiateUnivParams indTy levels + let resultTy ← inductiveAppBinders binders instantiated + inductiveAppResultIsProp resultTy end diff --git a/Ix/Tc/Monad.lean b/Ix/Tc/Monad.lean index 9e06d68ca..aa78a3545 100644 --- a/Ix/Tc/Monad.lean +++ b/Ix/Tc/Monad.lean @@ -264,9 +264,15 @@ def addr8 (a : Address) : String := ((toString a).take 8).toString if (← get).stats then modify f +/-- Mint a checker-global free-variable id. Match Rust's checked counter: +the final counter value is reserved as the exhausted state, so allocation +fails instead of wrapping and reusing an id already present in caches. -/ def freshFVarId : TcM m FVarId := fun s => - let (id, env) := s.env.freshFVarId - .ok id { s with env } + if s.env.nextFVarId.toNat + 1 < UInt64.size then + let (id, env) := s.env.freshFVarId + .ok id { s with env } + else + .error (.other "free-variable id space exhausted") s /-- Fault `addr` through the lazy-ingress hook (if installed), deduplicated by `faultedAddrs`. Ingress errors surface as `TcError.other` with the @@ -349,12 +355,34 @@ def ctxSuffixNeed (s : TcState m) : Nat → Nat → Nat if nextNeed == need then need else ctxSuffixNeed s fuel nextNeed -/-- Suffix-aware context identity for a loose-bound-variable range. +/-- Fresh suffix-aware context identity for a loose-bound-variable range. + Runs a fixpoint closing the needed suffix over binder type/value + dependencies, then hashes the suffix—unless the whole context is needed, + in which case `ctxId` itself is the identity. This helper does not inspect + or mutate `ctxAddrCache`. -/ +def ctxAddrForLbrUncached (s : TcState m) (lbr : UInt64) : Address := + let n := s.ctx.size + let need := ctxSuffixNeed s (n + 1) (min lbr.toNat n) + if need == n then s.ctxId + else Id.run do + let mut h := Blake3.Rust.Hasher.init () + h := h.update "ctx.suffix".toUTF8 + h := h.update (need.toUInt64.toLEBytes) + for i in [n - need:n] do + match s.letVals[i]! with + | some val => + h := h.update "let".toUTF8 + h := h.update s.ctx[i]!.addr.hash + h := h.update val.addr.hash + | none => + h := h.update "local".toUTF8 + h := h.update s.ctx[i]!.addr.hash + return ⟨(h.finalizeWithLength 32).val⟩ - Pure in `(ctxId, lbr)` (memoized). Runs a fixpoint closing the needed - suffix over binder type/value dependencies, then hashes the suffix — - unless the whole context is needed, in which case `ctxId` itself is the - identity. Mirrors tc.rs `ctx_addr_for_lbr` exactly. -/ +/-- Memoized wrapper around `ctxAddrForLbrUncached`, mirroring tc.rs + `ctx_addr_for_lbr`. The pure helper is a verification seam as well as an + implementation boundary: memo coherence can state that every stored value + equals this exact computation. -/ def ctxAddrForLbr (lbr : UInt64) : TcM m Address := do let s ← get if lbr == 0 || s.ctx.isEmpty then @@ -362,24 +390,7 @@ def ctxAddrForLbr (lbr : UInt64) : TcM m Address := do let cacheKey := (s.ctxId, lbr) if let some cached := s.ctxAddrCache[cacheKey]? then return cached - let n := s.ctx.size - let need := ctxSuffixNeed s (n + 1) (min lbr.toNat n) - let result := - if need == n then s.ctxId - else Id.run do - let mut h := Blake3.Rust.Hasher.init () - h := h.update "ctx.suffix".toUTF8 - h := h.update (need.toUInt64.toLEBytes) - for i in [n - need:n] do - match s.letVals[i]! with - | some val => - h := h.update "let".toUTF8 - h := h.update s.ctx[i]!.addr.hash - h := h.update val.addr.hash - | none => - h := h.update "local".toUTF8 - h := h.update s.ctx[i]!.addr.hash - return ⟨(h.finalizeWithLength 32).val⟩ + let result := ctxAddrForLbrUncached s lbr modify fun s => { s with ctxAddrCache := s.ctxAddrCache.insert cacheKey result } return result @@ -533,6 +544,15 @@ def openLet (name : m.F Name) (ty val : KExpr m) (body : KExpr m) : let bodyOpen ← runIntern (instantiateRev body #[fv]) return (bodyOpen, fvId) +/-- Like `openLet` but also returns the fvar expression itself. -/ +def openLetWithFV (name : m.F Name) (ty val : KExpr m) + (body : KExpr m) : TcM m (KExpr m × KExpr m × FVarId) := do + let fvId ← freshFVarId + let fv ← intern (KExpr.mkFVar fvId name) + modify fun s => { s with lctx := s.lctx.push fvId (.ldecl name ty val) } + let bodyOpen ← runIntern (instantiateRev body #[fv]) + return (bodyOpen, fv, fvId) + /-- Push a fresh fvar declaration without a body to instantiate. -/ def pushFVarDeclAnon (ty : KExpr m) : TcM m (FVarId × KExpr m) := do let name : m.F Name := Mode.fieldWith fun _ => .mkAnon @@ -761,6 +781,16 @@ def maxDispatchDepth : UInt32 := 200_000 namespace RecM +/-- Run one computation in a free-variable local-context scope. Any +declarations pushed by `x` are discarded when it returns, including when it +returns a kernel error. Mutations to the rest of the checker state are +retained. -/ +def withLctxScope (x : RecM m α) : RecM m α := do + let saved := (← get).lctx.size + try x + finally + modify fun s => { s with lctx := s.lctx.truncate saved } + /-- One iteration of an explicitly bounded kernel loop. `next` consumes the current iteration and continues from a new state; `done` returns without consulting the remaining bound. -/ diff --git a/Ix/Tc/Subst.lean b/Ix/Tc/Subst.lean index ac9248488..5e8329e57 100644 --- a/Ix/Tc/Subst.lean +++ b/Ix/Tc/Subst.lean @@ -373,7 +373,7 @@ termination_by structural body (`Var(n-1)`), `fvars[n-1]` the innermost (`Var(0)`). -/ def abstractFVars (body : KExpr m) (fvars : Array FVarId) : InternM m (KExpr m) := - if fvars.isEmpty || !body.hasFVars then pure body + if fvars.isEmpty || (!body.hasFVars && body.lbr == 0) then pure body else let n : UInt64 := fvars.size.toUInt64 -- Innermost (last) fvar gets position 0; outermost (first) gets `n-1`, @@ -398,34 +398,77 @@ def peelLams (n : Nat) (head : KExpr m) (i : Nat) : KExpr m × Nat := | _ => (head, i) termination_by structural head +/-- Equivalent remaining-fuel presentation of lambda peeling. The returned +count is the number of binders removed, rather than an absolute loop index; +this form makes the structural verification trace direct. -/ +def peelLamsN : Nat → KExpr m → KExpr m × Nat + | 0, head => (head, 0) + | n + 1, .lam _ _ _ inner _ => + let (head, consumed) := peelLamsN n inner + (head, consumed + 1) + | _ + 1, head => (head, 0) +termination_by n => n + +/-- The deterministic rebuild selected by `cheapBetaReduce`: start from +`base` and intern applications of `trailing` from left to right. Naming this +pure plan gives verification an exact finite footprint without changing the +production algorithm. -/ +structure CheapBetaPlan (m : Mode) where + base : KExpr m + trailing : List (KExpr m) + +namespace CheapBetaPlan + +/-- Pure result of one cheap-beta rebuild plan. -/ +def result (plan : CheapBetaPlan m) : KExpr m := + plan.trailing.foldl KExpr.mkApp plan.base + +end CheapBetaPlan + +/-- Select the cheap-beta rebuild, if any, without touching the intern table. -/ +def cheapBetaPlan? (e : KExpr m) : Option (CheapBetaPlan m) := + match e with + | .app .. => + let (head₀, args) := e.collectSpine + match head₀ with + | .lam .. => + let (head, i) := peelLamsN args.size head₀ + let trailing := (args.extract i args.size).toList + if head.lbr == 0 then + some ⟨head, trailing⟩ + else + match head with + | .var k _ _ => + if k < i.toUInt64 then + some ⟨args[i - k.toNat - 1]!, trailing⟩ + else none + | _ => none + | _ => none + | _ => none + +/-- Pure result selected by `cheapBetaReduce`, before canonical interning of +the intermediate application chain. -/ +def KExpr.cheapBetaReduceResult (e : KExpr m) : KExpr m := + match cheapBetaPlan? e with + | none => e + | some plan => plan.result + +/-- Intern the left-associated application chain of a selected cheap-beta +plan. -/ +def internAppChain (base : KExpr m) : List (KExpr m) → InternM m (KExpr m) + | [] => pure base + | arg :: trailing => do + let next ← internExprM (KExpr.mkApp base arg) + internAppChain next trailing + /-- Cheap beta reduction: peephole-reduce `App(λ…λ. body, args)` without full `subst` in trivial cases (closed body, or single-bvar body). Otherwise returns the input unchanged (full WHNF handles it). Mirrors lean4lean's `Expr.cheapBetaReduce`. -/ def cheapBetaReduce (e : KExpr m) : InternM m (KExpr m) := do - match e with - | .app .. => pure () - | _ => return e - let (head₀, args) := e.collectSpine - match head₀ with - | .lam .. => pure () - | _ => return e - -- Peel up to `args.size` lambdas. - let (head, i) := peelLams args.size head₀ 0 - -- Case A: closed body — drop the peeled binders, apply remaining args. - if head.lbr == 0 then - let mut result := head - for arg in args.extract i args.size do - result ← internExprM (KExpr.mkApp result arg) - return result - -- Case B: body is Var(k) selecting a peeled arg. - if let .var k _ _ := head then - if k < i.toUInt64 then - let mut result := args[i - k.toNat - 1]! - for arg in args.extract i args.size do - result ← internExprM (KExpr.mkApp result arg) - return result - return e + match cheapBetaPlan? e with + | none => return e + | some plan => internAppChain plan.base plan.trailing end Ix.Tc diff --git a/Ix/Tc/Verify/Audit/Completed.lean b/Ix/Tc/Verify/Audit/Completed.lean index 0fa98ff38..66309d1b7 100644 --- a/Ix/Tc/Verify/Audit/Completed.lean +++ b/Ix/Tc/Verify/Audit/Completed.lean @@ -1,11 +1,61 @@ import Ix.Tc.Verify.Audit.Basic import Ix.Tc.Verify.Ctx import Ix.Tc.Verify.Decl +import Ix.Tc.Verify.DefEq +import Ix.Tc.Verify.DefEq.AcceleratorGates +import Ix.Tc.Verify.DefEq.ApplicationSpine +import Ix.Tc.Verify.DefEq.CacheShell +import Ix.Tc.Verify.DefEq.Closure +import Ix.Tc.Verify.DefEq.DeltaClassification +import Ix.Tc.Verify.DefEq.EqualRankCache +import Ix.Tc.Verify.DefEq.EqualRankPrefix +import Ix.Tc.Verify.DefEq.EqualRankReduction +import Ix.Tc.Verify.DefEq.FinalWhnf.Application +import Ix.Tc.Verify.DefEq.FinalWhnf.Closure +import Ix.Tc.Verify.DefEq.FinalWhnf.Contracts +import Ix.Tc.Verify.DefEq.FinalWhnf.EtaExpansion +import Ix.Tc.Verify.DefEq.FinalWhnf.LetDeclaration +import Ix.Tc.Verify.DefEq.FinalWhnf.NatBridge +import Ix.Tc.Verify.DefEq.FinalWhnf.ProofTail +import Ix.Tc.Verify.DefEq.FinalWhnf.StringExpansion +import Ix.Tc.Verify.DefEq.FinalWhnf.StructuralPrefix +import Ix.Tc.Verify.DefEq.FinalWhnf.StructureEta +import Ix.Tc.Verify.DefEq.FinalWhnf.UnitLike +import Ix.Tc.Verify.DefEq.LazyDelta +import Ix.Tc.Verify.DefEq.LazyDeltaClosure +import Ix.Tc.Verify.DefEq.LazyDeltaIteration +import Ix.Tc.Verify.DefEq.LoopFinish +import Ix.Tc.Verify.DefEq.NatOffset +import Ix.Tc.Verify.DefEq.NatOffsetDecomposition +import Ix.Tc.Verify.DefEq.NatReduction +import Ix.Tc.Verify.DefEq.OneSidedDelta +import Ix.Tc.Verify.DefEq.ProjectionDeltaActive +import Ix.Tc.Verify.DefEq.ProjectionDeltaClosure +import Ix.Tc.Verify.DefEq.ProjectionDeltaEqualRank +import Ix.Tc.Verify.DefEq.ProjectionDeltaFinish +import Ix.Tc.Verify.DefEq.ProjectionDeltaLoop +import Ix.Tc.Verify.DefEq.ProjectionDeltaRank +import Ix.Tc.Verify.DefEq.ProjectionDeltaStep +import Ix.Tc.Verify.DefEq.ProjectionDeltaUnfolding +import Ix.Tc.Verify.DefEq.ProjectionProbe +import Ix.Tc.Verify.DefEq.ProjectionReduction +import Ix.Tc.Verify.DefEq.PropositionClassifier +import Ix.Tc.Verify.DefEq.RankDispatch +import Ix.Tc.Verify.DefEq.SameHeadSpine +import Ix.Tc.Verify.DefEq.SpineArguments +import Ix.Tc.Verify.DefEq.StoppedContinuation +import Ix.Tc.Verify.DefEq.StoppedContinuationClosure +import Ix.Tc.Verify.DefEq.StructuralCongruence import Ix.Tc.Verify.Execution import Ix.Tc.Verify.Frame +import Ix.Tc.Verify.Infer.CacheSoundness +import Ix.Tc.Verify.InferDefEq.Closure import Ix.Tc.Verify.InstL +import Ix.Tc.Verify.Whnf.Closure +import Ix.Tc.Verify.Knot import Ix.Tc.Verify.NatFixture import Ix.Tc.Verify.Run +import Ix.Tc.Verify.RecursiveMethods.Closure import Ix.Tc.Verify.Support import Ix.Tc.Verify.Totalization import Ix.Tc.Verify.Whnf @@ -54,13 +104,69 @@ private def levelNative : Array Lean.Name := expressionNative.push (nativeAxiom `Ix.Tc.Level `Ix.Tc.KUniv.mkSucc._native.native_decide.ax_1) -private def contextNative : Array Lean.Name := expressionNative.push - (nativeAxiom `Ix.Tc.Monad - `Ix.Tc.TcM.ctxAddrForLbr._native.native_decide.ax_5) +private def univOnlyNative : Array Lean.Name := #[ + nativeAxiom `Ix.Tc.Level + `Ix.Tc.KUniv.mkSucc._native.native_decide.ax_1 +] + +private def nameDecideNative : Lean.Name := + nativeAxiom `Ix.Environment + `Ix.Name.mkStr._native.native_decide.ax_1 + +private def nameNative : Array Lean.Name := levelNative.push nameDecideNative + +private def expressionNameNative : Array Lean.Name := + expressionNative.push nameDecideNative + +private def canonicalPrimitivesNative : Array Lean.Name := + blake3Native.push nameDecideNative + +private def ctxAddrNative : Lean.Name := + nativeAxiom `Ix.Tc.Monad + `Ix.Tc.TcM.ctxAddrForLbrUncached._native.native_decide.ax_3 + +private def blake3ContextNative : Array Lean.Name := + blake3Native.push ctxAddrNative + +private def contextNative : Array Lean.Name := + expressionNative.push ctxAddrNative + +private def inferNative : Array Lean.Name := + levelNative.push ctxAddrNative + +private def nameContextNative : Array Lean.Name := + nameNative.push ctxAddrNative + +private def canonicalPrimitivesContextNative : Array Lean.Name := + canonicalPrimitivesNative.push ctxAddrNative + +private def natAddNeSuccNative : Lean.Name := + nativeAxiom `Ix.Tc.Verify.NatFixture + `Ix.Tc.AmbientNat.natAdd_ne_natSucc._native.native_decide.ax_1_1 + +private def natAddNeBeqNative : Lean.Name := + nativeAxiom `Ix.Tc.Verify.NatFixture + `Ix.Tc.AmbientNat.natAdd_ne_natBeq._native.native_decide.ax_1_1 + +private def natAddNeBleNative : Lean.Name := + nativeAxiom `Ix.Tc.Verify.NatFixture + `Ix.Tc.AmbientNat.natAdd_ne_natBle._native.native_decide.ax_1_1 + +private def natReductionNative : Array Lean.Name := + (((contextNative.push nameDecideNative).push natAddNeSuccNative).push + natAddNeBeqNative).push natAddNeBleNative + +private def natSuffixReductionNative : Array Lean.Name := + ((contextNative.push nameDecideNative).push natAddNeBeqNative).push + natAddNeBleNative -private def inferNative : Array Lean.Name := levelNative.push - (nativeAxiom `Ix.Tc.Monad - `Ix.Tc.TcM.ctxAddrForLbr._native.native_decide.ax_5) +private def natSuffixCertificateNative : Array Lean.Name := + ((expressionNative.push nameDecideNative).push natAddNeBeqNative).push + natAddNeBleNative + +private def natBranchOrderNative : Array Lean.Name := + (((inferNative.push nameDecideNative).push natAddNeSuccNative).push + natAddNeBeqNative).push natAddNeBleNative private def inductiveNative : Array Lean.Name := (inferNative.push (nativeAxiom `Ix.Environment @@ -76,6 +182,7 @@ private def addInductWF : Lean.Name := ``Lean4Lean.VEnv.addInduct_WF private def forallEInv : Lean.Name := ``Lean4Lean.VEnv.IsDefEqU.forallE_inv_stratified private def sortInv : Lean.Name := ``Lean4Lean.VEnv.IsDefEqU.sort_inv +private def trProjSorry : Lean.Name := ``Lean4Lean.TrProj private def typingDebt : Array Lean.Name := #[inductiveWF, addInduct, addInductWF, forallEInv, sortInv] @@ -90,6 +197,19 @@ private def legacyWholeEnv : Array Lean.Name := #[ ``Ix.Tc.TrKEnv ] +/- The pre-TrustedBody delta route admitted successful unfolding through a broad +reflection oracle and arbitrary cache-write authority. The final K1 closure +must use exact trusted declaration certificates instead. -/ +private def legacyDeltaAuthority : Array Lean.Name := #[ + ``Ix.Tc.UnfoldCacheWriteOracle, + ``Ix.Tc.DeltaUnfoldReflection, + ``Ix.Tc.RecM.DeltaUnfoldContext, + ``Ix.Tc.RecM.FullWhnfStepContext.ofDelta +] + +private def k1ForbiddenDependencies : Array Lean.Name := + legacyWholeEnv ++ legacyDeltaAuthority + private def roots : Array RootAllowance := #[ -- Level decision procedures. { root := ``Ix.Tc.univEq_sound, standardAxioms := standard }, @@ -260,7 +380,7 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RunAssumptions.instantiateUnivParams_wf, standardAxioms := standard, nativeAxioms := levelNative }, { root := ``Ix.Tc.RunAssumptions.runIntern_supported_wf, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RunAssumptions.lift_wf, standardAxioms := standard, nativeAxioms := levelNative, @@ -293,6 +413,10 @@ private def roots : Array RootAllowance := #[ sorryOrigins := typingDebt }, { root := ``Ix.Tc.TrKExprS.inst, standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.TrKExprS.inst_let, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.TrKExprS.inst_let_lbr, + standardAxioms := standard, nativeAxioms := expressionNative }, { root := ``Ix.Tc.TrKExprS.wf, standardAxioms := standard }, { root := ``Ix.Tc.TrKExpr.wf, standardAxioms := standard }, { root := ``Ix.Tc.TrKExprS.uniq, @@ -393,6 +517,18 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.TrustedCatalogRel.find, standardAxioms := standard, sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.TrustedCatalogEntry.recursorRule, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.TrustedCatalogRel.recursorRule, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.TrustedCatalogEntry.recursorPattern, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.TrustedCatalogRel.recursorPattern, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.TrustedDecl.lookup, standardAxioms := standard, sorryOrigins := #[inductiveWF, addInduct] }, @@ -445,8 +581,22 @@ private def roots : Array RootAllowance := #[ -- constructive Nat model and its adversarial loaded-state witness. { root := ``Ix.Tc.RawInductiveConstRel.mono, standardAxioms := standard }, + { root := ``Ix.Tc.TrKExprS.mono, + standardAxioms := standard }, + { root := ``Ix.Tc.RegisteredRecursorRuleRhsRel.mono, + standardAxioms := standard }, + { root := ``Ix.Tc.RegisteredRecursorRuleRhsRel.rhsTyped, + standardAxioms := standard }, + { root := ``Ix.Tc.RawRecursorRuleRel.registeredRhs, + standardAxioms := standard }, { root := ``Ix.Tc.RawRecursorRuleRel.mono, standardAxioms := standard }, + { root := ``Ix.Tc.HeadConstN.of_varN_matches }, + { root := ``Ix.Tc.RecursorIotaPattern.matches_shape }, + { root := ``Ix.Tc.KConst.RecursorRuleAt.hasRecursorRule, + standardAxioms := propextOnly }, + { root := ``Ix.Tc.RawRecursorRulePatternRel.mono, + standardAxioms := propextOnly }, { root := ``Ix.Tc.InductiveOracle.members, standardAxioms := standard, sorryOrigins := #[inductiveWF, addInduct] }, @@ -471,6 +621,9 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.InductiveOracle.recursorFacts, standardAxioms := standard, sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.InductiveOracle.recursorPatterns, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.InductiveOracle.catalogued, standardAxioms := standard, sorryOrigins := #[inductiveWF, addInduct] }, @@ -578,10 +731,10 @@ private def roots : Array RootAllowance := #[ nativeAxioms := #[nativeAxiom `Blake3 `Blake3.HasherOps.hash._native.native_decide.ax_1] }, { root := ``Ix.Tc.KernelStateWF.pendingCacheIsolation, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.KernelStateWF.restoreCheckCachesOnError, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.AmbientNat.warmCache_worldTransport, standardAxioms := standard, nativeAxioms := expressionNative, @@ -615,6 +768,22 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.WhnfCacheValid.expr, standardAxioms := standard, sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.CacheProvenance.isRec_of_trusted, + standardAxioms := standardWithoutChoice, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.IsRecCacheValid.mono, + standardAxioms := standardWithoutChoice, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.IsRecCacheValid.trusted, + standardAxioms := standardWithoutChoice, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.kernelCacheSemantics_isRec_valid, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.CacheProvenance.whnfMeaning, standardAxioms := standard, sorryOrigins := #[inductiveWF, addInduct] }, @@ -650,7 +819,7 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.TcM.whnfKey_closed, standardAxioms := standard, nativeAxioms := contextNative }, { root := ``Ix.Tc.ContextKeyFrame.whnfStateInv, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.TcM.ctxAddrForLbr_wf, standardAxioms := standard, nativeAxioms := contextNative }, @@ -660,16 +829,16 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.TcM.whnfKey_matches_wf, standardAxioms := standard, nativeAxioms := contextNative, sorryOrigins := #[inductiveWF, addInduct] }, - -- K1c: exact intern-only framing, execution-indexed simultaneous + -- interning frame: exact intern-only framing, execution-indexed simultaneous -- substitution, and the production one-argument beta path. { root := ``Ix.Tc.InternUpdateFrame.whnfStateInv, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.TcM.runIntern_whnf_wf, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.TcM.runIntern_whnf_eval, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RunAssumptions.simulSubst_whnf_wf, standardAxioms := standard, nativeAxioms := levelNative, @@ -680,25 +849,29 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.WhnfMeaning.beta, standardAxioms := standard, nativeAxioms := expressionNative, sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, + { root := ``Ix.Tc.WhnfMeaning.letE, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, { root := ``Ix.Tc.WhnfMeaning.betaSimul, standardAxioms := standard, nativeAxioms := expressionNative, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.WhnfCoreLeaf.eval, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_betaOne, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_leaf, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_betaOne, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_betaOne_wf, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.whnfCoreWithFlags_leaf_wf, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.AmbientNat.warmStateInvAccelerated, - standardAxioms := standard, nativeAxioms := inferNative, + standardAxioms := standard, + nativeAxioms := inferNative.push nameDecideNative, sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.warmKey_matches_wf, @@ -726,12 +899,12 @@ private def roots : Array RootAllowance := #[ sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.betaCoreUncached_eval, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.AmbientNat.betaCoreUncached_acceptance, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, - -- K1d: both production zeta branches, including the legacy lifting walk, + -- zeta reduction: both production zeta branches, including the legacy lifting walk, -- mixed-context semantic lookup, bounded driver, and inhabited fixtures. { root := ``Ix.Tc.CtxRecon.lctxFindLetVal, standardAxioms := standard, nativeAxioms := expressionNative }, @@ -750,20 +923,20 @@ private def roots : Array RootAllowance := #[ standardAxioms := standard, nativeAxioms := expressionNative, sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_varZeta, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_fvarZeta, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_nextLeaf, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_varZeta, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_fvarZeta, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_varZeta_acceptance, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_fvarZeta_acceptance, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, { root := ``Ix.Tc.AmbientNat.bvarZetaLiftSpec, standardAxioms := standardWithoutQuot, nativeAxioms := expressionNative }, @@ -774,9 +947,9 @@ private def roots : Array RootAllowance := #[ sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.bvarZetaCoreUncachedEval, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.AmbientNat.bvarZetaAcceptance, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fvarZetaMeaning, @@ -784,12 +957,12 @@ private def roots : Array RootAllowance := #[ sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fvarZetaCoreUncachedEval, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.AmbientNat.fvarZetaAcceptance, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, - -- K1e: exact projection/iota branches and bounded-driver composition. + -- projection/iota branch: exact projection/iota branches and bounded-driver composition. -- Semantic success is conditional on an explicit translated-source oracle; -- the two hostile fixtures prove that raw helper success cannot replace it. { root := ``Ix.Tc.WhnfMeaning.projection, @@ -799,37 +972,37 @@ private def roots : Array RootAllowance := #[ standardAxioms := standard, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.InductiveReductionOracle.projection, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.InductiveReductionOracle.iota, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_projection, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_iota, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_projection, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_iota, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_projection_acceptance, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_iota_acceptance, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.AmbientNat.projectionReduceEval, standardAxioms := standard, nativeAxioms := expressionNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.projectionCoreEval, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.projectionSource_not_translated, standardAxioms := standard, nativeAxioms := expressionNative, sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.projectionAdversarialWitness, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.iotaStateInv, @@ -837,43 +1010,43 @@ private def roots : Array RootAllowance := #[ sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.iotaTryEval, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.iotaCoreEval, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.iotaSource_not_translated, standardAxioms := standard, nativeAxioms := expressionNative, sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.iotaAdversarialWitness, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, - -- K1f: arbitrary-length structural traces compose exact production + -- structural trace: arbitrary-length structural traces compose exact production -- execution, fixed-world/context invariants, and local Theory meanings. -- The inhabited fixture takes two `.next` steps before its leaf; the -- hostile zero-fuel witness cannot be certified as a successful trace. { root := ``Ix.Tc.RecM.WhnfCoreTrace.no_zero, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.eval, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.initialInv, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.finalInv, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.meaning, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.uncached_eval, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.uncached_acceptance, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt }, { root := ``Ix.Tc.AmbientNat.structuralNatLit_type, standardAxioms := standard, @@ -896,24 +1069,24 @@ private def roots : Array RootAllowance := #[ sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralLoopFVarStep, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralLoopBetaStep, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralLoopTrace, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralLoopAcceptance, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralLoopZeroFuel, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, - -- K1g: the public structural entry point's keyed body has exact full, + -- structural cache: the public structural entry point's keyed body has exact full, -- cheap, miss, hit, and transient equations. Misses require both an -- execution-indexed trace and universal provenance before insertion; -- hits require the physical entry, semantic invariant, and executed key @@ -937,10 +1110,10 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RecM.whnfCoreWithFlagsNonLeaf_transient, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfCoreCacheUpdate.full_whnfStateInv, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.WhnfCoreCacheUpdate.cheap_whnfStateInv, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.whnfCoreWithFlags_fullHit_acceptance, standardAxioms := standard, nativeAxioms := inferNative, @@ -995,10 +1168,10 @@ private def roots : Array RootAllowance := #[ standardAxioms := standard, nativeAxioms := expressionNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.betaStep_state, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.coreCacheTrace, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullCoreColdAcceptance, @@ -1020,13 +1193,13 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.AmbientNat.coreCachePolicyIsolation, standardAxioms := standard, nativeAxioms := expressionNative, forbiddenDependencies := legacyWholeEnv }, - -- K1h: no-delta and full-WHNF now have execution-indexed bounded traces, + -- outer WHNF driver: no-delta and full-WHNF now have execution-indexed bounded traces, -- exact public-prefix/cache/fuel equations, provenance-checked insertion, -- and semantic hit/miss acceptance. The Nat fixture executes all nested -- cache layers, proves the cold call consumes exactly one fuel unit, and -- proves the warm public call preserves the entire state. { root := ``Ix.Tc.WhnfStateInv.of_semantic_fields_eq, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.TcM.stepTrace_disabled, standardAxioms := standardWithoutChoice }, @@ -1103,13 +1276,13 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RecM.whnfNoDeltaImplNonLeaf_nativeNoInsert, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfDriverCacheUpdate.noDelta_whnfStateInv, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.WhnfDriverCacheUpdate.noDeltaCheap_whnfStateInv, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.WhnfDriverCacheUpdate.full_whnfStateInv, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.whnfNoDeltaImpl_fullHit_acceptance, standardAxioms := standard, nativeAxioms := inferNative, @@ -1222,14 +1395,115 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.AmbientNat.fullWhnfCacheLayering, standardAxioms := standard, nativeAxioms := expressionNative, forbiddenDependencies := legacyWholeEnv }, + -- total-outcome boundary: local step contracts now construct success traces and classify + -- bounded exhaustion versus step errors. The public no-delta/full-WHNF + -- dispatchers close conditionally over suffix reconciliation, transient + -- lookup safety, collision-robust insertion provenance, and the local + -- semantic step contracts. Instrumentation and miss charging are proved. + { root := ``Ix.Tc.WhnfPost.transMeaning, + standardAxioms := standard, sorryOrigins := typingDebt }, + { root := ``Ix.Tc.WhnfPost.meaning, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.TcM.isLetVar_wf, + standardAxioms := standardWithoutChoice }, + { root := ``Ix.Tc.TcM.stepTrace_whnf_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.TcM.bumpStats_whnf_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.RecM.WF.liftTcM, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.RecM.WF.get, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.RecM.WF.modifyGet, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.RecM.WF.modify, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.RecM.WhnfCoreTrace.complete, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.RecM.WhnfCoreTrace.uncached_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt }, + { root := ``Ix.Tc.RecM.WhnfNoDeltaTrace.complete, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.RecM.WhnfNoDeltaTrace.uncached_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt }, + { root := ``Ix.Tc.RecM.WhnfFullTrace.complete, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.RecM.WhnfFullTrace.uncached_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt }, + { root := ``Ix.Tc.RecM.whnfNoDeltaImplNonLeaf_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNoDeltaImpl_nonLeaf_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfWithNatSuccModeNonLeaf_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfWithNatSuccMode_nonLeaf_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfWithNatSuccModePrefix_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.RecM.whnfWithNatSuccModeMissCharge_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct] }, + { root := ``Ix.Tc.RecM.whnfWithNatSuccMode_nonLeaf_semantic_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNoDeltaImpl_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfWithNatSuccMode_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNoDelta_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnf_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.noDeltaZeroFuel, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.fullWhnfZeroFuel, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.whnfLoopErrorSeparation, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.WhnfPost.refl, standardAxioms := standard, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.WF.bind, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.runBounded_wf, - standardAxioms := standard, + standardAxioms := standard, nativeAxioms := blake3Native, sorryOrigins := #[inductiveWF, addInduct] }, { root := ``Ix.Tc.RecM.WhnfLeaf.eval, standardAxioms := standard, nativeAxioms := inferNative }, @@ -1508,7 +1782,3814 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.exprMentionsAddr_go_app, standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.exprMentionsAddr_go_const, - standardAxioms := standardWithoutChoice } + standardAxioms := standardWithoutChoice }, + + -- RuntimeContracts: the repaired step source includes finite support plus an actual + -- translation; closed contexts derive both key representation and + -- collision-robust write validity. The transient Nat probe is proved + -- state-pure for eager states. General lazy execution is reduced to the + -- exact invariant contract of the driver-installed environment hook. + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_leaf_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_betaOne_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_projection_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_iota_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RunAssumptions.subst_whnf_wf, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RunAssumptions.subst_whnf_eval, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_letE, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_letE_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + + -- regular-binder fallback: both translated regular-binder forms take the state-pure `.done` + -- fallback and cannot be confused with their let-bound zeta siblings. + { root := ``Ix.Tc.TcM.lookupLetVal_none_state, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_varDone, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_fvarDone, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_varDone_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_fvarDone_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.bvarStuckAcceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.fvarStuckAcceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + + -- stuck-reduction fallback: projection misses and unchanged non-lambda application heads keep + -- their original syntax, distinguish helper errors from `none`, and are + -- inhabited by translated projection and constructor-application fixtures. + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_projectionDone, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_projectionWhnfError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_projectionReduceError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appUnchangedDone, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appHeadError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appUnchangedIotaError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_projectionDone_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appUnchangedDone_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.appStuckAcceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.ProjectionFallback.acceptance, + standardAxioms := standard, nativeAxioms := nameContextNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + + -- application rebuilding: both application rebuilding loops share one audited helper. A + -- finite certificate fixes suffix order, support, collision freedom, and + -- intern-only framing; general multi-beta and changed-head hit/miss/error + -- equations consume that helper boundary. The Nat fixtures make argument + -- reversal, a trailing argument, and physically changed heads observable. + { root := ``Ix.Tc.InternUpdateFrame.refl, + standardAxioms := standardWithoutChoice }, + { root := ``Ix.Tc.InternUpdateFrame.trans, + standardAxioms := standardWithoutChoice }, + { root := ``Ix.Tc.RunAssumptions.internExpr_whnf_eval, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.finishAppResult_eq_foldlM, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.RecM.finishAppResult_one, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.RecM.FinishAppRequests.result_eq_foldl, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative }, + { root := ``Ix.Tc.RecM.FinishAppRequests.support, + standardAxioms := standard, nativeAxioms := levelNative }, + { root := ``Ix.Tc.RecM.FinishAppRequests.foldlM_eval, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.FinishAppRequests.eval, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.FinishAppRequests.final_eq_spec, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_betaMany, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appChangedIota, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appChangedDone, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appChangedIotaError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_betaMany_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appChangedDone_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appChangedIota_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appChangedIotaError_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiBetaStep, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.changedHeadInternSpec, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.AmbientNat.changedHeadStep, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.WhnfKey.closed_represents, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.WhnfCacheWriteOracle.closed, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.tryGetConst_noLazy, + standardAxioms := standardWithoutChoice }, + { root := ``Ix.Tc.TcM.lazyIngressAddr_wf, + standardAxioms := standardWithoutChoice }, + { root := ``Ix.Tc.TcM.tryGetConst_wf, + standardAxioms := standardWithoutChoice }, + { root := ``Ix.Tc.KId.anon_eq_of_addr_eq }, + { root := ``Ix.Tc.TcM.tryGetConst_success_loaded, + standardAxioms := standardWithoutChoice }, + { root := ``Ix.Tc.RecM.NatRecLiteralPartsSuccessTrace.eval, + standardAxioms := standard }, + { root := ``Ix.Tc.RecM.NatRecLiteralPartsSuccessTrace.complete, + standardAxioms := standard }, + { root := ``Ix.Tc.RecM.NatRecLiteralPartsSuccessTrace.trusted, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrustedNatRecLiteralParts.patternAt, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.HeadConstN.matches_varN }, + { root := ``Ix.Tc.HeadConstN.natLit_zero }, + { root := ``Ix.Tc.HeadConstN.natLit_succ }, + { root := ``Ix.Tc.RecursorIotaPattern.matches_of_shapes }, + { root := ``Ix.Tc.RecursorIotaPattern.exists_matches_iff_shapes }, + { root := ``Ix.Tc.RecursorIotaPattern.matches_natZero }, + { root := ``Ix.Tc.RecursorIotaPattern.matches_natSucc }, + { root := ``Ix.Tc.NatRecIotaCase.major_shape }, + { root := ``Ix.Tc.RecursorRulePattern.matches_natLiteral }, + { root := ``Ix.Tc.RecM.TrAppSpine.headConstN, + standardAxioms := standard }, + { root := ``Ix.Tc.RecM.TrAppSpine.matches_natRecRulePrefix, + standardAxioms := standard }, + { root := ``Ix.Tc.RawRecursorRulePatternRel.matches_natLiteralPrefix, + standardAxioms := standard }, + { root := ``Ix.Tc.AmbientNat.linearRecTheoryPrefix_shape }, + { root := ``Ix.Tc.AmbientNat.linearRecZeroPatternMatch }, + { root := ``Ix.Tc.AmbientNat.linearRecSuccPatternMatch }, + { root := ``Ix.Tc.TrustedNatRecursorLayout.caseForMajor, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrAppSuffix.tr, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrAppSpine.splitAt, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatRecLiteralPartsDescriptor.patternMajor, + standardAxioms := standardWithoutChoice, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatRecLiteralPartsDescriptor.translatedSplit, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrustedNatRecLiteralParts.translatedCase, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrAppSuffix.startHasType, + standardAxioms := standard, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrAppSuffix.rebase, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RawRecursorRulePatternRel.checkedReduction, + standardAxioms := propextOnly, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatRecLiteralTranslationSplit.checkedRhsSuffix, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RegisteredRecursorRuleRhsRel.rhsRaw, + standardAxioms := standard, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RegisteredRecursorRuleRhsRel.rhsStructural, + standardAxioms := standard, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RegisteredRecursorRuleRhsRel.instUnivSpec, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RegisteredRecursorRuleRhsRel.instantiateUnivParams_nonempty, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RawRecursorRuleRel.registeredRhsTyped, + standardAxioms := standard, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrAppSuffix.rebaseQuot, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.NatRecLiteralTranslationSplit.checkedRhsSuffixQuot, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.KExpr.Constructed.liftNoIntern_eq_liftSpec, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.KExpr.Constructed.substNoIntern_eq_substSpec, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.applyIotaArg_true_lam_spec, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.applyIotaArg_true_lam_run, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfMeaning.betaNoIntern, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.betaIotaArgRun, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.betaNoInternMeaning, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.IotaArgNonLambda.applyIotaArg_true, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.IotaArgNonLambda.applyIotaArg_true_run, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfMeaning.appRebuild, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.applyIotaArg_true_nonlam_semantic, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.applyIotaArg_false_eval, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.applyIotaArg_false_semantic, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.appStuckIotaTransient, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.appStuckIotaInterned, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfMeaning.resultQuot, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfMeaning.ofStructuralQuot, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.KExpr.substNoIntern_of_lbr_le, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.KExpr.liftNoIntern_of_lbr_le, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.applyIotaArgs_eq_foldlM, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.singleton, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.append, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.three, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.ApplyIotaArgsTrace.transientNonLambdaSingleton, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.ApplyIotaArgsTrace.transientNonLambdaSingletonQuot, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.internedSingleton, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.transientLambdaSingleton, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.transientLambdaSingletonQuot, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.evalList, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.evalArray, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.sourceTr, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.finalQuot, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.finalInv, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.frame, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.finalSupport, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.acceptance, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.evalThreeArrays, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.threeArrayAcceptance, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfMeaning.ofQuot, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.sourceQuot, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.acceptanceQuot, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaArgsTrace.threeArrayAcceptanceQuot, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.instantiateUnivParams_whnf_of_run, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaRuleTrace.eval, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaRuleTrace.emptyInstantiation, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaRuleTrace.instantiatePost, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaRuleTrace.acceptance, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaRuleTrace.acceptance_empty, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.ApplyIotaRuleTrace.registeredStartQuot_empty, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.ApplyIotaRuleTrace.registeredAcceptance_empty, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.ApplyIotaRuleTrace.registeredStartQuot_nonempty, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.ApplyIotaRuleTrace.registeredAcceptance_nonempty, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaRuleTrace.checkedMeaning, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.ApplyIotaRuleTrace.checkedAcceptance_empty, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.ApplyIotaRuleTrace.checkedAcceptance_nonempty, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.KConst.recursorMajorIdx_of_iotaInfo, + standardAxioms := propextOnly, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.KConst.recursorRuleAt_of_iotaInfo, + standardAxioms := propextOnly, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryApplyIotaCtorSuccessTrace.eval, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaCtorTrace.operational, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaCtorTrace.eval, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaCtorTrace.recursorRuleAt, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaCtorTrace.acceptance_empty, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaCtorTrace.checkedAcceptance_empty, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ApplyIotaCtorTrace.checkedAcceptance_nonempty, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaCtorOrStructEta_regular, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaAfterMajorWhnf_regular, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaWithFlags_nonKPrefix, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaWithFlags_regularCtor, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryIotaWithFlags_regularCtor_checkedAcceptance_empty, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.natToConstructor_zero, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.natToConstructor_succ, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaAfterMajorWhnf_nat, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaWithFlags_natCtor, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryIotaWithFlags_natCtor_checkedAcceptance_empty, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.intern_success_frame, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.strLitListToConstructor_empty, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.strLitListToConstructor_success_frame, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.strLitToConstructor_success_frame, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.evalNatOffsetLiteral_str, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.natOffset_str, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.cleanupNatOffsetMajor_str, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaAfterMajorWhnf_str, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaWithFlags_strCtor, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryIotaWithFlags_strCtor_checkedAcceptance_empty, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaStringEmptyFold, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaStringExpand, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaStringCallback, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaStringCleanup, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaStringGetZeroOfFrame, + standardAxioms := standard, + nativeAxioms := canonicalPrimitivesNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaStringApplyRule, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaStringApplyCtor, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaStringAfterEval, + standardAxioms := standard, nativeAxioms := nameContextNative, + forbiddenDependencies := legacyWholeEnv }, + + -- ConstructorSynthesis: the positive K-like recursor branch. Optional probes retain + -- error-side state, candidate synthesis records the DefEq gate and counter + -- order, and the inhabited fixture reaches the real bounded WHNF driver. + { root := ``Ix.Tc.RecM.tryOptional_success, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryOptional_error, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.VerifyKSynthCandidateSuccessTrace.eval, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.VerifyKSynthCandidateRejectTrace.eval, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.SynthCtorWhenKSuccessTrace.eval, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaWithFlags_kPrefix, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaWithFlags_kFallback, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaWithFlags_kCtor, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryIotaWithFlags_kCtor_checkedAcceptance_empty, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaIntern, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaMajorInfer, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaMajorWhnf, + standardAxioms := standard, nativeAxioms := canonicalPrimitivesNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaGetRec, + standardAxioms := standard, nativeAxioms := canonicalPrimitivesNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaGetNat, + standardAxioms := standard, nativeAxioms := canonicalPrimitivesNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaMajorInductive, + standardAxioms := standard, nativeAxioms := canonicalPrimitivesContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaCtorInfer, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaAttemptStats, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaTypeDefEq, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaCandidate, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaSynth, + standardAxioms := standard, + nativeAxioms := inferNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaInternFrame, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaSynthCleanup, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaSynthWhnf, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaGetZeroAfter, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaApplyRule, + standardAxioms := standard, nativeAxioms := nameNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaApplyCtor, + standardAxioms := standard, nativeAxioms := nameNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaTryEval, + standardAxioms := standard, nativeAxioms := nameContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaStepEval, + standardAxioms := standard, nativeAxioms := nameContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kIotaCoreEval, + standardAxioms := standard, nativeAxioms := nameContextNative, + forbiddenDependencies := legacyWholeEnv }, + + -- ConstructorSynthesisFallback: exhaustive K-synthesis fallback and error branches. + { root := ``Ix.Tc.RecM.verifyKSynthCandidate_inferMiss, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.verifyKSynthCandidate_inferError, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.verifyKSynthCandidate_defEqError, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.selectKSynthCandidate_mismatch, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.selectKSynthCandidate_missing, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.selectKSynthCandidate_nonInductive, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.selectKSynthCandidate_empty, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.selectKSynthCandidate_selected, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.selectKSynthCandidate_selectedError, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.synthCtorWhenK_majorInferMiss, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.synthCtorWhenK_majorInferError, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.synthCtorWhenK_majorWhnfMiss, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.synthCtorWhenK_majorWhnfError, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.synthCtorWhenK_nonConstHead, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.synthCtorWhenK_recursorMissing, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.synthCtorWhenK_majorInductiveMiss, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.synthCtorWhenK_majorInductiveError, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.SynthCtorWhenKSelectionTrace.eval, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.SynthCtorWhenKSelectionTrace.mismatch, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.SynthCtorWhenKSelectionTrace.missing, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.SynthCtorWhenKSelectionTrace.nonInductive, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.SynthCtorWhenKSelectionTrace.empty, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.SynthCtorWhenKSelectionTrace.selected, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.SynthCtorWhenKSelectionTrace.selectedError, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kMajorInferRawError, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kMajorInferCaughtMiss, + standardAxioms := standard, + nativeAxioms := inferNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kCandidateInferRawError, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kCandidateInferCaughtMiss, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kDefEqRawError, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kDefEqCandidateError, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kDefEqSynthError, + standardAxioms := standard, + nativeAxioms := inferNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kEmptyGetRec, + standardAxioms := standard, nativeAxioms := canonicalPrimitivesNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kEmptyGetNat, + standardAxioms := standard, nativeAxioms := canonicalPrimitivesNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kEmptyMajorInductive, + standardAxioms := standard, nativeAxioms := canonicalPrimitivesContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.kEmptyInductiveMiss, + standardAxioms := standard, + nativeAxioms := inferNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + + -- StructEtaControl: exhaustive struct-eta classification, caught probes, rebuild, + -- single-rule selection, and final constructor fallthrough. Rebuilding is + -- proved total; only universe instantiation can produce a post-guard error. + { root := ``Ix.Tc.RecM.isStructLike_missing, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isStructLike_nonInductive, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isStructLike_lookupError, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isStructLike_badShape, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isStructLike_shapeQualified, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isStructLike_recError, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.finishStructEtaResult_empty, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.structEtaIntern_total, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.finishStructEtaFields_total, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.finishStructEtaResult_of_segments, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.finishStructEtaResult_total, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.finishStructEtaResult_ne_error, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.finishStructEtaAfterSort_prop, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.finishStructEtaAfterSort_success, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.finishStructEtaAfterSort_instantiateError, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.finishStructEtaAfterSort_finishError, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaAfterInductive_notStruct, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaAfterInductive_structError, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaAfterInductive_majorInferMiss, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaAfterInductive_majorInferError, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaAfterInductive_sortInferMiss, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaAfterInductive_sortInferError, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaAfterInductive_sortWhnfMiss, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaAfterInductive_sortWhnfError, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaProbeTrace.eval, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaProbeTrace.prop, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaProbeTrace.success, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaProbeTrace.finishError, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaIota_ruleCount, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaIota_recursorMissing, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaIota_recursorError, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaIota_majorInductiveMiss, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaIota_majorInductiveError, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaSelectionTrace.eval, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaIotaSuccessTrace.eval, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaIotaSuccessTrace.acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- Rebuild: the successful struct-eta rebuild derives its invariant, frame, + -- and finite support from the exact projection/application request list. + -- The registered Theory equation remains an explicit premise. + { root := ``Ix.Tc.RecM.StructEtaFieldRequests.support, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaFieldRequests.eval, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaBuildRequests.eval, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaIotaSuccessTrace.acceptance_of_requests, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- CallbackPrefix: the exact infer-only and optional-catch wrappers preserve the + -- complete fixed-world invariant while retaining callback mutations. + { root := ``Ix.Tc.TcM.withInferOnly_eq, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.withInferOnly_whnf_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.inferOnlyRec_run, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryOptional_run, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryOptional_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.inferOnlyRec_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryOptionalInferOnlyRec_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryOptionalWhnfRec_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- RecursionClassifier: recursion classification now owns its complete concrete state + -- transaction. Both physical writes require explicit provenance; the + -- final write is indexed by the exact classifier execution, and only + -- errors inside that classifier enter the erase-and-rethrow handler. + { root := ``Ix.Tc.CacheInvariant.insertIsRec, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheInvariant.eraseIsRec, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IsRecCacheUpdate.insert_whnfStateInv, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IsRecCacheUpdate.erase_whnfStateInv, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IsRecCacheWriteOracle.of_trusted, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.getConst_wf, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.tryGetBlock_wf, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.WhnfCallbackSupports.preserves, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.getMajorInductiveId_wf, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.collectSpine_const_references, + standardAxioms := propextOnly, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.getMajorInductiveId_trusted_wf, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.discoverBlockInductives_wf, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.computeIsRec_wf, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.cacheIsRec_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.eraseCachedIsRec_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.computedIsRecClassify_wf, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.computedIsRecMiss_wf, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.computedIsRec_wf, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- Classifier: compose the recursion classifier through `isStructLike`, then + -- exhaust the single-rule recursor lookup and all three caught struct-eta + -- probes. Only the explicitly parameterized cache-write, callback, and + -- successful universe/rebuild authorities remain outside these proofs. + { root := ``Ix.Tc.RecM.isStructLike_wf, + standardAxioms := standard, nativeAxioms := blake3ContextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryOptional_state_wf, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryOptional_fixed_wf, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaAfterInductive_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaIota_prefix_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaIota_trusted_prefix_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructEtaIota_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- RebuildTail: the universe-instantiation/rebuild tail now preserves the complete + -- invariant from the finite execution request census, including retained + -- intern-table updates on a non-backtracking walker error. + { root := ``Ix.Tc.TcM.instantiateUnivParams_whnf_wf, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaBuildRequests.wf, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.finishStructEtaAfterSort_wf_of_requests, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- CacheShell: both structural-core cache partitions now have explicit + -- collision-robust write authority, and the actual public dispatcher is + -- closed conditionally on the remaining exhaustive structural step. + { root := ``Ix.Tc.RecM.WhnfCoreCacheWriteOracle.closed, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfSuffixModel.coreCacheWriteOracle, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsNonLeaf_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlags_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- BasicStep: immediate leaves, the complete fvar split, and explicit-let + -- substitution now share one local structural-step contract. The fvar + -- theorem exposes the real unchanged-value safety invariant rather than + -- inferring closedness or arithmetic bounds from translation alone. + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_fvar_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_letE_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_basic_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + + -- VariableStep: legacy zeta now derives its semantic weakening from the exact + -- lift-walker bounds. The only additional safety fact is the real + -- UInt64 `idx + 1` no-wrap condition on an actual let-value hit. + { root := ``Ix.Tc.CtxRecon.lookupLetVal_liftBounds, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.lookupLetVal_noLet, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfMeaning.zetaVar_liftBounds, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_var_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_basicVar_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + + -- RecursiveCallbacks: projection values and application-spine children now have an + -- explicit finite-support boundary, and both recursive head callbacks are + -- instantiated directly from the predecessor method-table contract. + { root := ``Ix.Tc.RecM.whnfCoreFlagsRec_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrAppSpine.headTr, + standardAxioms := standard, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.projectionValueCallback_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.applicationHeadCallback_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.applicationArgument_support, + standardAxioms := propextOnly, + forbiddenDependencies := legacyWholeEnv }, + + -- ProjectionStep: all projection-step outcomes now satisfy the local structural + -- contract once the exact helper effect/result boundary is instantiated; + -- callback and helper errors retain their partial post-state. + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_projection_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_basicVarProjection_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + + -- ApplicationCongruence: the application-head callback is tied to the exact typed suffix, + -- and Theory application congruence transports head reduction across every + -- argument rebuilt by the finite production certificate. + { root := ``Ix.Tc.RecM.TrAppSpine.toSuffix, + standardAxioms := standard, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.applicationHeadCallbackWithSuffix_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.WhnfMeaning.appHeadRebuild, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- ApplicationRebuild: a finite census now executes each dynamic changed-head rebuild and + -- returns its exact intern frame, support, and transported Theory meaning. + { root := ``Ix.Tc.RecM.changedHeadFinish_acceptance, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- ApplicationTails: both non-beta application tails are exhaustive over iota hit, + -- miss, and error. Changed-head hits compose rebuild congruence with the + -- helper result; unchanged misses remain reflexive at the original source. + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appUnchangedIota, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appUnchanged_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_appChanged_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- NoAccelTail: the actual no-acceleration projection tail now forces the + -- Fin/Decidable probe to miss, preserves lazy constructor lookup state, + -- and derives selected-field support from the concrete collected spine. + -- Only String preprocessing and the installed lazy-ingress hook remain at + -- the public helper constructor. + { root := ``Ix.Tc.RecM.WhnfCoreInputSupport.spineArg, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryProjReduceTail_noAccel_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ProjectionPrelude.nonString, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ProjectionPrelude.ofString, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryProjReduce_noAccel_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ProjectionHelper.noAccel, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ProjectionStringPrelude.ofExpansion, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ProjectionHelper.noAccelOfExpansion, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + -- StringExpansion: the remaining String-expansion premise is reduced to a pure, + -- finite plan. The actual primitive read, seven prefix interns, recursive + -- character fold, and final intern preserve the complete K1 invariant and + -- return the exact structurally translated generated expression. + { root := ``Ix.Tc.RecM.strLitListToConstructor_plan_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.strLitToConstructorWithPrimitives_plan_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.strLitToConstructor_plan_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ProjectionStringExpansion.ofPlans, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ProjectionHelper.noAccelOfStringPlans, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + -- LazyIngress: instantiate the generic lazy-fault plumbing with production's + -- anonymous shallow-ingress callback. The outcome refinement explicitly + -- covers a successful load, an absent address, and an error-carried partial + -- environment; hook identity remains visible because `TcState.lazyFault` + -- otherwise stores an arbitrary function. + { root := ``Ix.Tc.LazyIngressEnvFrame.refl, + standardAxioms := standardWithoutChoice, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.LazyIngressEnvFrame.kernelStateWF, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.LazyIngressEnvFrame.ctxRecon, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.LazyIngressEnvFrame.whnfStateInv, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ingressAnonAddrShallow_absent, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AnonIngressRefinement.absentOfVerifiedMiss, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AnonIngressRefinement.error, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AnonIngressRefinement.lazyFaultPreserves, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AnonLazyIngressContext, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AnonLazyIngressContext.preserves, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.ProjectionHelper.noAccelOfAnonIngress, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + -- NatOffset: the actual post-major iota preprocessing path. Bounded Nat-offset + -- parsing, Nat constructor expansion, cleanup, lazy constructor lookup, + -- finite String expansion, the policy-selected recursive callback, and the + -- constructor/struct-eta dispatch all preserve the complete K1 invariant. + -- Only the ordinary-constructor and struct-eta tails remain named inputs. + { root := ``Ix.Tc.RecM.prims_state_wf, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isNatBinArithAddr_state_wf, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.natOffsetReaders_state_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.natOffset_state_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.evalNatOffsetLiteral_state_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.natToConstructor_state_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.mkNatSucc_state_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.mkNatAdd_state_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.WF.with_run_eq, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.OptionalGeneratedInput, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatOffsetCleanupInputOracle, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.cleanupNatOffsetMajor_state_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.cleanupNatOffsetMajor_input_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryApplyIotaCtorPreserves, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaIotaPreserves, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.SelectedStructEtaIotaPreserves, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaCtorOrStructEta_state_wf, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.strLitToConstructor_context_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaAfterCleanup_state_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaAfterMajorWhnf_state_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + -- ApplicationRequests--Ingress: finite ordinary-iota, struct-eta, and K-synthesis request + -- censuses close every generated-expression effect. Their composition + -- exhausts the actual tryIotaWithFlags state path through lazy lookup, + -- caught probes, both cleanup stages, policy-selected major callbacks, + -- statistics updates, and the final uncaught DefEq callback. + { root := ``Ix.Tc.RecM.IotaArgsInternRequests, + standardAxioms := standardWithoutQuot, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IotaArgsInternRequests.wfList, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IotaArgsInternRequests.wfArray, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.applyIotaArg_true_state_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.applyIotaArgs_true_state_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IotaRuleRequests, + standardAxioms := standardWithoutQuot, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IotaRuleRequestCensus, + standardAxioms := standardWithoutQuot, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.applyIotaRule_state_wf_of_requests, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryApplyIotaCtor_state_wf_of_requests, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryApplyIotaCtorPreserves.of_requests, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaFinishRequests, + standardAxioms := standardWithoutQuot, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaFinishRequestCensus, + standardAxioms := standardWithoutQuot, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaFinishPreserves.of_requests, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructEtaIotaPreserves.of_components, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaAfterMajorWhnf_state_wf_of_contexts, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IsDefEqCallbackPreserves, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.WF.tryFinally_const, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.enterDispatch_whnf_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.exitDispatch_whnf_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.callIsDefEq_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.KSynthCandidateRequests, + standardAxioms := standardWithoutQuot, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.KSynthCandidateRequestCensus, + standardAxioms := standardWithoutQuot, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.KSynthCandidateInputs, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.KSynthCandidateInputOracle, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.FinishAppRequests.state_wf, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.verifyKSynthCandidate_state_wf_of_requests, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.selectKSynthCandidate_state_wf_of_requests, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.synthCtorWhenK_state_wf_of_requests, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.verifyKSynthCandidate_state_wf_of_inputs, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.selectKSynthCandidate_state_wf_of_inputs, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.synthCtorWhenK_state_wf_of_inputs, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaWithFlags_state_wf_of_contexts, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + -- OptionalReduction: the exhaustive state proof and the direct admission-owned success + -- boundary assemble the ordinary optional-reduction contract. The success + -- boundary contributes support and Theory meaning only; it cannot hide an + -- error-side or miss-side state assumption. + { root := ``Ix.Tc.IotaCallbackFrameOracle, + standardAxioms := standardWithoutChoice, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.IotaSuccessOracle, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaWithFlags_optional_wf_of_contexts, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + -- Reducer: the structural contract is indexed by the actual universe/context + -- represented by the cache model. The assembled theorem feeds OptionalReduction into + -- the exhaustive syntax step and then through the bounded/cache driver. + { root := ``Ix.Tc.StructuralReduction.WF, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructuralCoreContext, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.StructuralCoreContext.wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + -- ProjectionApplication: projection-application reduction is exhaustive over empty and + -- non-projection misses, both callback/helper error seams, helper misses, + -- and successful projection followed by a certified complete-spine + -- rebuild. Head meaning is transported through the typed suffix rather + -- than inferred from expression-address equality. + { root := ``Ix.Tc.RecM.tryProjAppReduce_empty, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryProjAppReduce_notProjection, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryProjAppReduce_projectionWhnfError, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryProjAppReduce_projectionReduceError, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryProjAppReduce_projectionNone, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryProjAppReduce_projectionSome, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryProjAppReduceFinished_empty_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryProjAppReduceFinished_app_optional_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryProjAppReduceFinished_optional_wf_of_contexts, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + -- StringPrimitive: the production String primitive helper is exhaustive over every + -- classifier miss and all three hits. Its state proof derives finite + -- generated-node support at each intern; the reflection boundary owns + -- only Theory meaning for an observed successful run. + { root := ``Ix.Tc.StringReductionSupport, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.StringReductionReflection, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceString_inv_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceString_optional_wf_of_reflection, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + -- ProjectionDefinition: projection-wrapper reduction covers the real lazy constant lookup, + -- the generated projection, and every suffix intern. The request plan + -- exposes all intermediate support obligations instead of assuming that + -- support for the final node retroactively makes those interns safe. + { root := ``Ix.Tc.ProjectionDefinitionRequestCensus, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ProjectionDefinitionReflection, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.projectionDefinitionFinish_eq, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.FinishAppRequests.finishAppResult_wf, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceProjectionDefinition_inv_wf, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryReduceProjectionDefinition_optional_wf_of_contexts, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + -- Quotient: quotient reduction derives the selected major's support and + -- translation from its real application-spine position, executes the + -- predecessor WHNF callback, and covers the initial representative + -- application plus every trailing suffix intern. + { root := ``Ix.Tc.QuotientReductionRequestCensus, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.QuotientReductionReflection, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryQuotReduceSelected, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryQuotReduceSelected_inv_wf, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryQuotReduce_inv_wf, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryQuotReduce_optional_wf_of_contexts, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + -- BaseReductions: the five active no-acceleration reducers are assembled into the + -- exact production base oracle for either successor policy. Native and + -- BitVec remain independently discharged by the no-acceleration gate. + { root := ``Ix.Tc.RecM.NoDeltaBaseContext, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NoDeltaBaseContext.oracle, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := legacyWholeEnv }, + -- Reducer: Reducer's structural reducer and BaseReductions's active base oracle now feed + -- the real bounded, keyed, transient-aware, cache-writing public + -- `whnfNoDeltaImpl` shell for every flag and successor policy. + { root := ``Ix.Tc.RecM.NoDeltaDriverContext, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NoDeltaDriverContext.wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := legacyWholeEnv }, + -- FullStep--Closure: the exhaustive full-WHNF step is connected to exact + -- definition/theorem certificates. Stable unfold-cache provenance covers + -- warm and cold paths, typed suffix rebuilding covers applied heads, and + -- the bare fallback closes `deltaUnfoldOne`. The final cache composition + -- and method knot are indexed by the active universe count; concrete lazy + -- ingress is carried by `AnonLazyIngressContext`, not a free callback. + { root := ``Ix.Tc.OptionalReduction.WFAt, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TrustedDeltaBody.meaning, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.StableWhnfTheory, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TrustedDeltaBody.unfoldCacheProvenance, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.unfoldConstValue_trusted_wf, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TrustedDeltaCensus, + standardAxioms := standard, nativeAxioms := univOnlyNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryDeltaUnfold_trusted_wf, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.deltaUnfoldOne_trusted_wf, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrustedDeltaContext, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrustedDeltaContext.wfAt, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.FullWhnfStepContext.ofTrustedDelta, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.Methods.WhnfClosedAt, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.Methods.methodsN_wfAt, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.K1ClosureContext, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.K1ClosureContext.closedAt, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.AmbientNat.structEtaInferOnlyRun, + standardAxioms := standard, nativeAxioms := expressionNameNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.structEtaOptionalInferOnlyRun, + standardAxioms := standard, nativeAxioms := expressionNameNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaCtorOrStructEta_nonConst, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaCtorOrStructEta_missing, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaCtorOrStructEta_notConstructor, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaCtorOrStructEta_lookupError, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryIotaCtorOrStructEta_constructor, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.structEtaIotaSuccess, + standardAxioms := standard, nativeAxioms := nameContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.structEtaBuildRequests, + standardAxioms := standardWithoutQuot, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.structEtaDispatchSuccess, + standardAxioms := standard, nativeAxioms := nameContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.structEtaIotaAbsent, + standardAxioms := standard, nativeAxioms := nameContextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.structEtaIotaCaughtInferError, + standardAxioms := standard, nativeAxioms := nameContextNative, + forbiddenDependencies := legacyWholeEnv }, + + { root := ``Ix.Tc.AmbientNat.iotaCleanupOfNatValue, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaNatCleanup, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaNatCtorCleanup, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaNatMajorWhnf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaNatZeroExpand, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaNatSuccExpand, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaNatApplyRule, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaNatApplyCtor, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaNatTryEval, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaNatStepEval, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaNatCoreEval, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaApplyRule, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaApplyCtor, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.support_le_iotaArgsSupport, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaArgsStateInv, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaArgsSupport_head, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.iotaArgsSupport_source, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.appStuckIotaTransientThreeSegments, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaFirstResult, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaSecondResult, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.appStuckHead_constructed, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiBetaInner_constructed, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaIntermediate_constructed, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.appStuckHead_tr_ctx, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.appStuckHead_type_ctx, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaIntermediate_tr, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.support_le_multiIotaSupport, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaStateInv, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaSupport_start, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaSupport_intermediate, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaSupport_head, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaSupport_result, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaFirstTrace, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaSecondTrace, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaThirdTrace, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaTransientThreeSegments, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaPrefixSlice, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaFieldSlice, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaTrailingSlice, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaRuleEval, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaRuleAcceptance, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaCtorEval, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiIotaCtorAcceptance, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.missingRuleDescriptor, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.AmbientNat.missingRuleDescriptor_noZeroRule, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.AmbientNat.multiBetaMiddleSplit, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.multiBetaMiddleRebase, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.linearRecPartsRun, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.AmbientNat.linearRecPartsTrace, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.TcM.LazyFaultPreserves.of_none, + standardAxioms := standardWithoutChoice }, + { root := ``Ix.Tc.RecM.natRecLiteralParts_wf, + standardAxioms := standardWithoutChoice }, + { root := ``Ix.Tc.RecM.NatRecLiteralPartsPreserves.of_lazy, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatRecLiteralPartsPreserves.eager, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isNatLiteralRecursorApp_wf, + standardAxioms := standardWithoutChoice }, + { root := ``Ix.Tc.RecM.isTransientNatLiteralWork_wf, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.RecM.TransientNatWork.preserving, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isTransientNatLiteralWork_noLazy, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.RecM.TransientNatWork.eager, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- ordered no-delta reduction: the production no-delta tail has an explicit seam. Exact equations + -- pin projection-app completion, every ordered success/fallback branch, and + -- every partial error state. The semantic package composes structural and + -- reducer meanings, while the closed Nat.add fixture makes precedence + -- executable and records its three canonical-address decisions explicitly. + { root := ``Ix.Tc.RecM.tryProjAppReduceFinished_some, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.RecM.tryProjAppReduceFinished_none, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.RecM.tryProjAppReduceFinished_projError, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.RecM.tryProjAppReduceFinished_finishError, + standardAxioms := standard, nativeAxioms := expressionNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_projApp, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_bitvec, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_nat, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_native, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_string, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_projectionDef, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_quotFull, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_quotCheap, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_doneFull, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_doneCheap, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_projError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_bitvecError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_natError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_nativeError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_stringError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_projectionDefError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_quotFullError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_quotCheapError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaImplStep_ofCore, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaImplStep_coreError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaImplStep_reducerError, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.RecM.whnfNoDeltaImplStep_next_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNoDeltaImplStep_done_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNoDeltaImplStep_error_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.noDeltaNatAddReduction, + standardAxioms := standard, nativeAxioms := natReductionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.noDeltaNatBranchOrder, + standardAxioms := standard, nativeAxioms := natBranchOrderNative, + forbiddenDependencies := legacyWholeEnv }, + + -- primitive reduction: `.noAccel` concretely discharges the native and BitVec optional + -- reducers. The five active helpers remain an explicit base oracle, which + -- now feeds the exhaustive tail, outer step, and public no-delta shell. + { root := ``Ix.Tc.RecM.tryReduceNative_noAccel_optional_wf, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceBitvec_noAccel_optional_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.NoDeltaBaseOracle.toNoAccel, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNoDeltaReducersStep_noAccel_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNoDeltaImplStep_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNoDeltaImplStep_noAccel_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNoDeltaImpl_noAccel_wf_of_base, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + -- WHNF layer policy: production WHNF layers bind every observable primitive-table + -- address to `PrimAddrs.canonical`; the separate structural layer retains + -- table-parametric syntax tests without being eligible for production + -- reducer closure. The world/context interface then binds the active Nat, + -- String, projection, and quotient IDs to trusted Theory names and scopes + -- generated results to actual successful helper executions. + { root := ``Ix.Tc.Primitives.ofAnonAddrs_canonical, + standardAxioms := standard, nativeAxioms := canonicalPrimitivesNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfStateInv.noAccel_primitives, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfStateInv.accelerated_primitives, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.PrimitiveIdAgrees.contains, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.PrimitiveIdAgrees.mono, + standardAxioms := standardWithoutChoice, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.NoDeltaPrimitiveTableAgrees.mono, + standardAxioms := standardWithoutChoice, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.NoDeltaPrimitiveContext.stateTable, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + -- Nat reducer callback: the Nat reducer's shared callback/fuel boundary and exact binary + -- arithmetic hit. The primitive computation is derived from the bound + -- canonical table and Lean4Lean reflection laws; no raw address equality + -- is treated as semantic authority. + { root := ``Ix.Tc.WhnfStateInv.set_recFuel, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.WF.tryCatch, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfRec_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNatReducerArg_post_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNatReducerArg_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.NoDeltaPrimitiveContext.computeNatBin_defeq, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TrKExprS.of_extractNatLit, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TrKExprS.natExprFromValue, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TrKExprS.natBinExact_inv, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfPost.of_extractNatLit, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfMeaning.natBinExact, + standardAxioms := standard, sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binArithExact, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binArithExact_acceptance, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + -- Nat primitive classification: canonical classifier derivation and exact Bool-predicate hits. The + -- generic proof uses trusted-name separation instead of native hash + -- inequalities, and the finite Bool intern is checked against explicit run + -- collision freedom and generated-node support. + { root := ``Ix.Tc.TcM.intern_whnf_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.intern_whnf_eval, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.PrimitiveIdAgrees.addr_ne, + standardAxioms := standardWithoutChoice, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.NoDeltaPrimitiveContext.computeNatBin_classifiers, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.NoDeltaPrimitiveContext.natPredicate_classifiers, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.NoDeltaPrimitiveContext.natPredicate_defeq, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TrKExprS.boolExprFromDecision, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatPredicate_exact, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binPredExact, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binPredExact_acceptance, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + -- binary Nat early-out: exhaustive early-out traces and state closure for exact binary Nat + -- reduction. Callback errors retain their partial state, arithmetic and + -- predicate extraction order is pinned, and the complete two-argument + -- dispatcher preserves the invariant on every outcome. + { root := ``Ix.Tc.RecM.WF.withInv, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.prims_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isNatBinArithAddr_inv_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isNatBinPredAddr_inv_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNatReducerArg_ok_inv, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.whnfNatReducerArg_error_inv, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatPredicate_bin_inv_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_bin_inv_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatPredicate_argAMiss, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatPredicate_argAError, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatPredicate_extractAMiss, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatPredicate_argBMiss, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatPredicate_argBError, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatPredicate_extractBMiss, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binPredMiss, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binPredError, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binArithArgAMiss, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binArithArgAError, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binArithArgBMiss, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binArithArgBError, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binArithExtractAMiss, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binArithExtractBMiss, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binArithComputeMiss, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + -- binary Nat success: every successful exact-binary Nat run is inverted into its actual + -- callback/extraction/computation-or-intern trace, then folded into a + -- semantic optional-reduction Hoare slice. Predicate precedence remains + -- operationally exhaustive even before canonical classifier separation. + { root := ``Ix.Tc.RecM.isNatBinArithAddr_eval, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isNatBinPredAddr_eval, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isNatBinPredAddr_true, + standardAxioms := standard, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binPredAnyExact, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatPredicateSuccessTrace.eval, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatPredicateSuccessTrace.complete, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatBinSuccessTrace.eval, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatBinSuccessTrace.complete, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatBinSuccessTrace.acceptance, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_bin_optional_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.structuralInvariant_does_not_bind_primitives, + standardAxioms := standard, nativeAxioms := levelNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.productionNoAccelStateInv, + standardAxioms := standard, nativeAxioms := nameNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.noAccelInvariant_rejects_mismatched_primitives, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- Nat suffix reduction: production `collectSpine` is reconciled with a typed structural + -- spine, exact Nat equations are transported over arbitrary unchanged + -- argument suffixes, and finite rebuild certificates preserve state and + -- support. Successful general-spine executions are inverted exhaustively. + { root := ``Ix.Tc.RecM.appSpineView_go, + standardAxioms := standardWithoutChoice }, + { root := ``Ix.Tc.RecM.appSpineView_collectSpine, + standardAxioms := standardWithoutChoice }, + { root := ``Ix.Tc.RecM.trAppSpine_of_tr, + standardAxioms := standard, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrAppSpine.argument, + standardAxioms := standard, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrAppSpine.tr, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.trAppSpine_of_collectSpine, + standardAxioms := standard, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TrKExprS.foldlMkApp_initial, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfMeaning.appSameArg, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfMeaning.foldlMkApp, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfMeaning.mkAppN, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfMeaning.ofSharedSourceTranslation, + standardAxioms := standard, sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatPredicate_suffixExact, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binPredSuffixExact, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binArithSuffixExact, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binArithSuffix_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryReduceNatWithSuccMode_binPredSuffix_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatPredicateSuffixSuccessTrace.eval, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatPredicateSuffixSuccessTrace.complete, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatSpineSuccessTrace.eval, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatSpineSuccessTrace.complete, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.noDeltaNatAddSuffixSpine, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.noDeltaNatAddSuffixFinishRequests, + standardAxioms := standardWithoutQuot, + nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.noDeltaNatAddSuffixReduction, + standardAxioms := standard, nativeAxioms := natSuffixReductionNative, + forbiddenDependencies := legacyWholeEnv }, + + -- Nat suffix closure: all general-spine misses and callback errors preserve the full + -- invariant without suffix assumptions. A successful trace is enriched + -- with only its observed finite rebuild requests, then interpreted as the + -- fixed-state optional-reduction Hoare contract. The over-applied Nat.add + -- fixture inhabits that execution-indexed coverage boundary. + { root := ``Ix.Tc.RecM.finishAppResult_total, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.natBinSpine_inputs, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatPredicate_spine_nonhit_inv, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_spine_nonhit_inv, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatSpineCertifiedSuccess.trace, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatSpineCertifiedSuccess.acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_spine_optional_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.noDeltaNatAddSuffixCertifiedSuccess, + standardAxioms := standard, nativeAxioms := natSuffixCertificateNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.noDeltaNatAddSuffixFinishCoverage, + standardAxioms := standard, nativeAxioms := natSuffixReductionNative, + forbiddenDependencies := legacyWholeEnv }, + + -- successor-collapse loop: the production successor-collapse loop is split into named seams + -- whose entry, callback, literal, peel, memo-hit, memo-miss, and partial- + -- error equations are exhaustive. Stuck-marker writes preserve the full + -- cache/state invariant only under explicit per-key provenance. The + -- closed Nat.succ fixture runs through the actual dispatcher and bounded + -- driver without mutating the state. + { root := ``Ix.Tc.CacheInvariant.insertNatSuccStuck, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheInvariant.insertNatSuccStuckList, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheInvariant.insertNatSuccStuckArray, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatSuccStuckCacheUpdate.fold_whnfStateInv, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccIter_entryHit, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccIter_entryKeyError, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccIter_entryMiss, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccIterStep_linearHit, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccIterStep_linearError, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccIterStep_whnfError, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccIterStep_afterWhnf, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccAfterWhnf_literal, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccAfterWhnf_stuck, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.recordNatSuccStuck_eval, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.recordNatSuccStuck_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccPeel_keyError, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccPeel_afterKey, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccPeelAfterKey_hit, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccPeelAfterKey_miss, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccPeelMiss_keyError, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccPeelMiss_next, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccAfterWhnf_succ, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_succ_stuck, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_succ_collapse, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.succCollapseSpine, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.succCollapseLinearMiss, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.succCollapseWhnf, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.succCollapseExtract, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.succCollapseStep, + standardAxioms := standard, + nativeAxioms := contextNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.succCollapseKey, + standardAxioms := standard, + nativeAxioms := contextNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.succCollapseMemoMiss, + standardAxioms := standard, + nativeAxioms := expressionNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.succCollapseIter, + standardAxioms := standard, + nativeAxioms := contextNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.succCollapseReduction, + standardAxioms := standard, + nativeAxioms := contextNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + + -- successor-collapse semantics: semantic closure of the actual successor-collapse loop. Negative + -- memo markers are semantically inert but retain exact source/reference + -- provenance; the ghost loop state tracks Nat typing, arbitrary successor + -- offsets, and every pending marker. Linear Nat.rec recognition remains + -- behind its explicit oracle until inductive iota semantics instantiate it. + { root := ``Ix.Tc.WhnfCacheValid.natSuccStuck, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheProvenance.whnfNatSuccStuck, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatSuccStuckWriteOracle.forWhnfCache, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.natSucc_hasType, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.natSuccSpine_tr, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccPeel_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccAfterWhnf_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccIterStep_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccIter_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- Outer Nat integration: attach the semantic successor loop to the actual + -- outer Nat + -- dispatcher, recover successful generated support from that execution, + -- and exhaustively assemble short, successor, and general-spine branches + -- in both successor policies. The general branch consumes only a finite + -- request census; descriptor safety is derived from the lazy-hook contract, + -- while successful callback meaning reduces the former exact-arity + -- assumption to canonical Nat/Bool result-shape separation. Nat.rec + -- reflection and that Theory shape fact remain explicit. + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_succ_optional_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.NatCollapseRequestCensus.suffix_eq_empty_of_result_shape, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatCollapseRequestCensus.of_no_suffix, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatCollapseRequestCensus.of_result_shape, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatCollapseRequestCensus.certify, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isNatSuccIhStep_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatSuccLinearRec_effect_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatSuccLinearOracle.of_reflection, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_collapse_optional_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryReduceNatWithSuccMode_collapse_optional_wf_of_boundaries, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_stuck_short, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryReduceNatWithSuccMode_stuck_optional_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryReduceNatWithSuccMode_stuck_optional_wf_of_boundary, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryReduceNatWithSuccMode_optional_wf_of_boundaries, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.tryReduceNatWithSuccMode_optional_wf_of_lazy_boundaries, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.AmbientNat.succStuckReduction, + standardAxioms := standard, + nativeAxioms := contextNative.push nameDecideNative, + forbiddenDependencies := legacyWholeEnv }, + + -- K2a: suffix semantics reduce open-context cache validity to one explicit + -- operational model. The recursive method table closes by induction from + -- an exact one-layer contract split between WHNF and Infer/DefEq ownership. + { root := ``Ix.Tc.WhnfSuffixModel.keyRepresents, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfSuffixModel.cacheWriteOracle, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.Methods.LayerWF.of_parts, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.Methods.Closed.of_parts, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.Methods.methodsOut_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.Methods.methodsN_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.runRec_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- K2a also assigns exact meanings to the remaining cache families. A + -- positive DefEq result carries Theory equality; negative results are + -- intentionally vacuous for the one-way soundness claim. + { root := ``Ix.Tc.InferMeaning.mono, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.InferMeaning.post, + standardAxioms := standard, sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.InferCacheValid.mono, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheInvariant.inferHitOfMatches, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.DefEqMeaning.mono, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.DefEqMeaning.of_translations, + standardAxioms := standard, sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.DefEqCacheValid.mono, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheProvenance.kernelWhnfMeaningOfMatches, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheProvenance.kernelInferMeaningOfMatches, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheProvenance.kernelDefEqMeaning, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- K2b: production key executions now generate the canonical operational + -- context witnesses. Physical inference/DefEq writes preserve every + -- cache partition, including the rejection-only same-head failure set. + { root := ``Ix.Tc.CacheInvariant.insertInfer, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheInvariant.insertInferOnly, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheInvariant.insertDefEq, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheInvariant.insertDefEqCheap, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheInvariant.insertDefEqFailure, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.ctxAddrForLbr_empty, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.whnfKey_ctx, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.operationalWhnfContextKeys.represents, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.operationalWhnfContextKeys.representsCtx, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ContextDigestSpec.execution, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ContextDigestSpec.StateValid, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ContextDigestSpec.memoValid, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ContextDigestSpec.preserves, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.ctxAddrForLbr_trivial, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.ctxAddrForLbr_cacheHit, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.ctxAddrForLbr_cacheMiss, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.ctxAddrForLbr_replay, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.ContextAddrMemoValid, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.ctxAddrForLbr_memoValid, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.scopedOperationalWhnfContextKeys.represents, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.scopedOperationalWhnfContextKeys.representsCtx, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.scopedOperationalWhnfContextKeys.digest_eq, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.scopedOperationalWhnfContextKeys.mem, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.WhnfSuffixModel.operational, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.inferKey_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.inferKey_operational_matches_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.inferWith_fullHit, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.inferWith_inferOnlyHit, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.InferCacheUpdate.full_whnfStateInv, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.InferCacheUpdate.inferOnly_whnfStateInv, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- The union-find frame and joint suffix model keep composite context-hash + -- transport explicit for WHNF, inference, and DefEq. Collision-robust + -- provenance constructors quantify over every supported address peer. + { root := ``Ix.Tc.TcM.withEquiv_eq, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.withEquiv_whnf_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.defEqCtxKey_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.defEqCtxKey_operational_matches_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.DefEqMeaning.of_addr_beq, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.DefEqMeaning.symm, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.KernelSuffixModel.toWhnfSuffixModel, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.KernelSuffixModel.operational, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ContextSuffixSemantics.whnf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ContextSuffixSemantics.infer, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ContextSuffixSemantics.defEq, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ScopedKernelSuffixModel.represents, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ScopedKernelSuffixModel.StateInScope, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ScopedKernelSuffixModel.whnfTransport, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ScopedKernelSuffixModel.inferTransport, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ScopedKernelSuffixModel.defEqTransport, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ScopedKernelSuffixModel.finiteOperational, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.ScopedKernelSuffixModel.toKernelSuffixModel, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.KernelSuffixModel.finiteOperational, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheProvenance.kernelDefEqMeaningCanonical, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.KernelSuffixModel.inferProvenance, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.KernelSuffixModel.defEqProvenance, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.KernelSuffixModel.defEqFailureProvenance, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqCacheUpdate.full_whnfStateInv, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqCacheUpdate.cheap_whnfStateInv, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqCacheUpdate.failure_whnfStateInv, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- First production K2 branches: both inference hit partitions, collision- + -- safe DefEq address reflexivity, and a positive full DefEq hit including + -- canonical ordering and its final union-find mutation. + { root := ``Ix.Tc.RecM.isDefEq_fullHit_true, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isDefEq_fullHit_true_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isDefEq_addrEq_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.inferWith_fullHit_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.inferWith_inferOnlyHit_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- The memoized proposition classifier closes proof irrelevance's sole + -- auxiliary cache family. Positive hits and writes are tied to `Sort 0` + -- through expression collision freedom and the explicit suffix model. + { root := ``Ix.Tc.RecM.isPropType_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryProofIrrel_classifier_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- Lazy delta is a bounded semantic state machine. These roots expose the + -- pair invariant, the fuel-bounded closure, and the exact remaining + -- obligations for one iteration and the stopped continuation. + { root := ``Ix.Tc.RecM.DefEqPairInvariant.refl, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqPairInvariant.conclude, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.runDefEqLazyDelta_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isDefEqInnerAfterProofIrrelevance_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqAfterProofIrrelevance.ofLazyDelta, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + + -- The front of each lazy-delta iteration now closes the actual Nat-offset + -- literal/zero guards and both ordinary Nat-reduction attempts. Structural + -- offset decomposition and the post-Nat reducer tiers remain explicit + -- continuation contracts; negative recognizer results carry no semantics. + { root := ``Ix.Tc.RecM.isNatZero_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IsNatZero.ofContext, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryDefEqOffset_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryDefEqOffset.ofContext, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.defEqLazyDeltaStepAfterOffsetMiss_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqLazyDeltaAfterOffsetMiss.ofNat, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.defEqLazyDeltaStepAfterNatMiss_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqLazyDeltaAfterNatMiss.ofNoAccel, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.classifyDeltaHead_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.defEqLazyDeltaStepAfterAcceleratorMiss_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.DefEqLazyDeltaAfterAcceleratorMiss.ofClassification, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryUnfoldProjApp_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.defEqLazyDeltaStepAfterDeltaClassification_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.DefEqLazyDeltaAfterDeltaClassification.ofProjection, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.finishDefEqLazyDeltaStep_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.defEqLazyDeltaStepWithLeftDelta_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.defEqLazyDeltaStepWithRightDelta_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.rankDeltaHead_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.defEqLazyDeltaStepAfterProjectionMiss_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqLazyDeltaAfterProjectionMiss.ofRankDispatch, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.defEqLazyDeltaStepAfterSameHeadMiss_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqLazyDeltaAfterSameHeadMiss.ofReduction, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- Equal-rank closure: recursive spine arguments, constant-universe + -- congruence, and the rejection-only failure-cache shell. A cache hit can + -- only skip the comparison; every positive result still comes from the + -- semantic same-head proof. + { root := ``Ix.Tc.RecM.allDefEqSpineArgs_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrAppSpine.defEq_of_zip, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.sameDefEqUniverses_sound, + standardAxioms := standard, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.constantHeadsDefEq, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.trySameHeadSpine_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrySameHeadSpine.ofResources, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.CacheEntry.defEqFailureReferencesAuthorized, + standardAxioms := standardWithoutChoice, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.DefEqFailureCacheResources.ofKernelSuffixModel, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isRegular_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.trySameHeadSpineCached_wf, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TrySameHeadSpineCached.ofResources, + standardAxioms := standard, nativeAxioms := contextNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.defEqLazyDeltaStepWithEqualRank_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqLazyDeltaEqualRank.ofPrefix, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqLazyDeltaEqualRank.ofKernelResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- The Nat-offset candidate branch is state-safe on every parser and rebuild + -- path. Its only semantic input is an exact successful-run reflection; + -- recursive equality is transported forward through the common successor + -- suffix, without assuming offset injectivity or completeness. + { root := ``Ix.Tc.TcM.WF.withInvRunEq, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.natOffsetDecompose_state_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.natOffsetRebuild_state_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryDefEqOffsetAfterCandidates_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryDefEqOffsetAfterCandidates.ofContext, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- The stopped continuation now closes its exact outer control flow. The + -- general app probe reconstructs equality through both typed spines; + -- structural congruence proves constants and variables directly and + -- delegates matching projections to one execution-indexed helper contract. + { root := ``Ix.Tc.RecM.tryDefEqApp_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryDefEqApp.ofResources, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryStructuralCongruence_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryStructuralCongruence.ofResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isDefEqAfterLazyDeltaStopped_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqAfterLazyDeltaStopped.ofResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqLazyDeltaContext.ofKernelResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.DefEqAfterProofIrrelevance.ofKernelResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- The structural projection callback's bounded lazy-delta driver preserves + -- the original projected semantics across delta steps, direct projection + -- reduction, recursive comparison, and normal depth exhaustion. + { root := ``Ix.Tc.RecM.lazyDeltaProjReduction_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.LazyDeltaProjReduction.ofResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- Direct projection reduction gets state/support closure from the proved + -- no-acceleration helper and consults semantic reflection only for the + -- exact successful execution that occurred. + { root := ``Ix.Tc.RecM.tryProjReduce_direct_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryProjReduce.ofDirectResources, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- The compact projection-loop delta step exposes its two lazy declaration + -- classifications as a proved prefix; the exact branch continuation sees + -- only their concrete results. + { root := ``Ix.Tc.RecM.lazyDeltaReductionStep_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.LazyDeltaReductionStep.ofClassification, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.lazyDeltaReductionStepAfterClassification_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.LazyDeltaReductionAfterClassification.ofActive, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.LazyDeltaReductionStep.ofActive, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- Once classification reports an active delta head, the compact step is + -- exhaustive: projection hits enter the productive finish, misses select + -- one- or two-sided unfolding, and equal ranks try same-head congruence + -- before normalizing both sides. The final two roots assemble that branch + -- proof with the already-audited classifier prefix. + { root := ``Ix.Tc.RecM.finishLazyDeltaReductionStep_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.lazyDeltaReductionStepWithLeftDelta_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.lazyDeltaReductionStepWithRightDelta_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.lazyDeltaReductionStepAfterSameHeadMiss_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.lazyDeltaReductionStepWithEqualRank_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.defRankId_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.lazyDeltaReductionStepWithBothDelta_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.lazyDeltaReductionStepAfterActive_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.LazyDeltaReductionAfterActive.ofResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.LazyDeltaReductionStep.ofResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- Concrete projection-loop assembly derives the compact step, bounded + -- projection comparison, and structural-congruence projection branch from + -- named lower reducers. The exact-run direct projection reflection is the + -- remaining semantic boundary; the outer loop itself is no longer one. + { root := ``Ix.Tc.RecM.ProjectionDeltaClosureResources.loop, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.LazyDeltaProjReduction.ofClosureResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.TryStructuralCongruence.ofProjectionDeltaResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- The stopped continuation now derives its structural field from the + -- concrete projection loop and reuses that record's core/quick resources; + -- only application-spine and final-WHNF contracts remain as sibling inputs. + { root := + ``Ix.Tc.RecM.StoppedContinuationClosureResources.stopped, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := + ``Ix.Tc.RecM.DefEqAfterLazyDeltaStopped.ofClosureResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- The final-WHNF comparator is split at a production seam: an optional + -- constructor-directed prefix followed by the fallback chain. Application + -- comparison and every constructor in the prefix are now exhaustive + -- concrete proofs. The let roots include exact allocation, common-fvar + -- body opening, context transport, and local-scope restoration. + { root := ``Ix.Tc.RecM.isDefEqWhnf_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IsDefEqWhnf.ofPhases, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryDefEqWhnfApp_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryDefEqWhnfApp.ofResources, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.TcM.openLetWithFV_scope, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.withLctxScope_openLetWithFV_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryDefEqWhnfLet_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryDefEqWhnfLet.ofResources, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isNatLike_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.natSuccOf_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.NatSuccOf.ofResources, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isDefEqNatAfterLiteral_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isDefEqNat_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryDefEqWhnfNat_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryDefEqWhnfNat.ofResources, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isDefEqWhnfAfterStructural_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IsDefEqWhnfAfterStructural.ofNat, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryDefEqWhnfStructural_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryDefEqWhnfStructural.ofResources, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- Lambda eta is split into a syntactic guard, caught infer/WHNF probes, and + -- an explicit term builder. The builder's lifted source and generated #0 + -- application are translated structurally before the recursive comparison + -- is composed with Theory eta; the ordered reverse attempt uses symmetry. + { root := ``Ix.Tc.TcM.lift_whnf_wf_of_resources, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.compareEtaExpansion_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryEtaExpansionAfterGuard_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryEtaExpansion_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryDefEqWhnfEtaAfterGuard_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryDefEqWhnfEta_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryDefEqWhnfEta.ofResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isDefEqWhnfAfterNat_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IsDefEqWhnfAfterNat.ofEta, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- The final-WHNF String phase reuses the exact expansion plans proved for + -- the earlier DefEq tier. Its optional result preserves the original + -- two-way short-circuit order; reverse success is justified by symmetry. + { root := ``Ix.Tc.RecM.tryDefEqWhnfStringAfterGuard_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryDefEqWhnfString_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryDefEqWhnfString.ofContext, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isDefEqWhnfAfterEta_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IsDefEqWhnfAfterEta.ofString, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- The terminal final-WHNF chain is split at the two inductive boundaries. + -- Proof irrelevance is concrete through the memoized proposition + -- classifier; unit-like and structure-eta soundness remain separately + -- named contracts until their exact inductive laws are supplied. + { root := ``Ix.Tc.RecM.isDefEqWhnfAfterUnit_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IsDefEqWhnfAfterUnit.ofClassifier, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isDefEqWhnfAfterStructEta_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IsDefEqWhnfAfterStructEta.ofUnitAndProof, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.isDefEqWhnfAfterString_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.IsDefEqWhnfAfterString.ofStructEta, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + + -- The unit-like classifier is tied to the exact immutable-catalog entries + -- returned by both lazy lookups. The shortcut then consumes only the + -- narrow unique-inhabitant law for that trusted zero-index, one-nullary- + -- constructor shape; it does not recover the legacy whole-environment + -- inductive oracle. + { root := ``Ix.Tc.RecM.isUnitLikeInductive_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.tryDefEqUnit_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + { root := ``Ix.Tc.RecM.TryDefEqUnit.ofResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + { root := ``Ix.Tc.RecM.DefEqLazyDeltaStep.ofKernelResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := legacyWholeEnv }, + + -- Structure eta is proved from the exact normalized source, immutable + -- constructor lookup, typed field spine, and generated projection law. + -- The positive structure classifier cannot manufacture semantic eta on + -- its own, and every exported root remains quarantined from both legacy + -- whole-environment and broad delta-authority paths. + { root := ``Ix.Tc.TrKExprS.prj_components, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.tryEtaStructFields_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.etaExpansionBaseLoop_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.etaExpansionBase_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.tryEtaStructAfterTypes_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.normalizeEtaStructSource_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct, addInductWF], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.tryEtaStructAfterConstructor_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.tryEtaStructAfterNormalization_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.tryEtaStruct_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.tryDefEqWhnfStructEta_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.TryDefEqWhnfStructEta.ofResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + + -- The final-WHNF phases are now assembled in exact production order. + { root := ``Ix.Tc.RecM.FinalWhnfClosureResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.FinalWhnfClosureResources.afterStructural, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.FinalWhnfClosureResources.finalWhnf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + + -- Recursive DefEq closure: trusted finite expression references authorize + -- only the two direct roots of an ordinary result entry. The complete + -- inner tier then feeds the guarded public cache shell. + { root := ``Ix.Tc.CacheEntry.defEqReferencesAuthorized, + standardAxioms := standardWithoutChoice, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.DefEqInner.WF, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.isDefEq_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.DefEqClosureResources, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.DefEqClosureResources.stopped, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.DefEqClosureResources.lazyDelta, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.DefEqClosureResources.inner, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.DefEqClosureResources.entryPoint, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.DefEqClosureResources.nextDefEq_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + + -- Inference and DefEq consume the same predecessor table and suffix model; + -- their fixed-universe pair closes before it is joined to the four WHNF + -- fields. `TrProj` remains a separately named upstream debt origin. + { root := ``Ix.Tc.UncachedInference.Context.nextInfer_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.Methods.InferDefEqClosedAt, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.InferDefEqClosureContext, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.InferDefEqClosureContext.layer, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.InferDefEqClosureContext.closedAt, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + + -- Final six-field knot assembly under the canonical production cache + -- stack. These roots prove every finite `methodsN` approximation and the + -- fixed-universe runner interface without importing a headline checker + -- `sorry`. + { root := ``Ix.Tc.kernelCacheFallback, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.kernelCacheSemantics_eq_k1, + standardAxioms := standard, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.Methods.ClosedAt, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.Methods.ClosedAt.of_parts, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.runRec_wfAt, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecursiveMethodClosureContext, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[inductiveWF, addInduct], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecursiveMethodClosureContext.closedAt, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecursiveMethodClosureContext.methodsN, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies } ] run_cmd Ix.Tc.Verify.Audit.check roots diff --git a/Ix/Tc/Verify/Audit/Statements.lean b/Ix/Tc/Verify/Audit/Statements.lean index b432c1bd8..cc0d4071c 100644 --- a/Ix/Tc/Verify/Audit/Statements.lean +++ b/Ix/Tc/Verify/Audit/Statements.lean @@ -29,7 +29,7 @@ private def runNative : Array Lean.Name := #[ nativeAxiom `Ix.Tc.Level `Ix.Tc.KUniv.mkSucc._native.native_decide.ax_1, nativeAxiom `Ix.Tc.Monad - `Ix.Tc.TcM.ctxAddrForLbr._native.native_decide.ax_5 + `Ix.Tc.TcM.ctxAddrForLbrUncached._native.native_decide.ax_3 ] private def checkConstNative : Array Lean.Name := #[ @@ -40,7 +40,7 @@ private def checkConstNative : Array Lean.Name := #[ nativeAxiom `Ix.Tc.Level `Ix.Tc.KUniv.mkSucc._native.native_decide.ax_1, nativeAxiom `Ix.Tc.Monad - `Ix.Tc.TcM.ctxAddrForLbr._native.native_decide.ax_5, + `Ix.Tc.TcM.ctxAddrForLbrUncached._native.native_decide.ax_3, nativeAxiom `Ix.Environment `Ix.Name.mkStr._native.native_decide.ax_1, nativeAxiom `Ix.Tc.Inductive diff --git a/Ix/Tc/Verify/Cache.lean b/Ix/Tc/Verify/Cache.lean index 748f52b59..e44941e20 100644 --- a/Ix/Tc/Verify/Cache.lean +++ b/Ix/Tc/Verify/Cache.lean @@ -363,6 +363,13 @@ structure CacheSemantics where mono : ∀ {before after : CacheAuthority} {support : RunSupport} {entry : CacheEntry}, before ≤ after → Valid before support entry → Valid after support entry + /-- Semantic relation represented by the per-check DefEq union-find. -/ + Equiv : CacheAuthority → RunSupport → EqKey → EqKey → Prop + equivEquivalence : ∀ authority support, + Equivalence (Equiv authority support) + equivMono : ∀ {before after : CacheAuthority} {support : RunSupport} + {left right : EqKey}, before ≤ after → + Equiv before support left right → Equiv after support left right blockError : ∀ (authority : CacheAuthority) (support : RunSupport) (block : KId .anon) (err : TcError .anon), Valid authority support (.blockResult block (.error err)) @@ -373,6 +380,9 @@ stubs be declared `opaque`. -/ instance : Inhabited CacheSemantics := ⟨{ Valid := fun _ _ _ => True mono := fun _ h => h + Equiv := fun _ _ => Eq + equivEquivalence := fun _ _ => ⟨fun _ => rfl, Eq.symm, Eq.trans⟩ + equivMono := fun _ h => h blockError := fun _ _ _ _ => trivial }⟩ /-- Full ghost certificate attached to one physical entry. -/ @@ -395,6 +405,35 @@ theorem blockError (semantics : CacheSemantics) (authority : CacheAuthority) intro id href exact False.elim href +/-- Build provenance for an operational recursion-classifier entry once the +queried anonymous identifier is trusted and the selected cache semantics +accepts this exact Boolean. + +The Boolean itself deliberately carries no Theory claim here. A cached +`true` may be production's conservative re-entrancy marker, while a cached +`false` merely allows the struct-eta code to continue to its separately +checked semantic-success boundary. Trust of the queried identifier is still +mandatory because `.isRec` is a subject-scoped cache family and stable +boundaries have no active-block authority. -/ +theorem isRec_of_trusted {semantics : CacheSemantics} + {world : VerifyWorld} {support : RunSupport} + {ind : KId .anon} {value : Bool} + (htrusted : world.trusted ind) + (hvalid : semantics.Valid (CacheAuthority.stable world) support + (.isRec ind.addr value)) : + CacheProvenance semantics (CacheAuthority.stable world) support + (.isRec ind.addr value) := by + refine ⟨trivial, ?_, hvalid⟩ + intro id href + apply Or.inl + have hid : id = ind := by + rcases id with ⟨idAddr, ⟨⟩⟩ + rcases ind with ⟨indAddr, ⟨⟩⟩ + change idAddr = indAddr at href + cases href + rfl + simpa [hid] using htrusted + theorem mono {semantics : CacheSemantics} {before after : CacheAuthority} {support : RunSupport} {entry : CacheEntry} (hauth : before ≤ after) @@ -607,6 +646,46 @@ theorem insertWhnf {semantics : CacheSemantics} | blockPeer hmem => exact .inr (.blockPeer hmem) | blockResult hget => exact .inr (.blockResult hget) +/-- Insert one certified universe-instantiated definition body while +retaining provenance for every other physical cache entry. -/ +theorem insertUnfold {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {key : Address} {value : KExpr .anon} + (hbefore : CacheInvariant semantics authority support env) + (hnew : CacheProvenance semantics authority support + (.unfold key value)) : + CacheInvariant semantics authority support + { env with unfoldCache := env.unfoldCache.insert key value } := by + apply update hbefore hnew + intro entry hentry + cases hentry with + | whnf hget => exact .inr (.whnf hget) + | whnfNoDelta hget => exact .inr (.whnfNoDelta hget) + | whnfNoDeltaCheap hget => exact .inr (.whnfNoDeltaCheap hget) + | whnfCore hget => exact .inr (.whnfCore hget) + | whnfCoreCheap hget => exact .inr (.whnfCoreCheap hget) + | infer hget => exact .inr (.infer hget) + | inferOnly hget => exact .inr (.inferOnly hget) + | defEq hget => exact .inr (.defEq hget) + | defEqCheap hget => exact .inr (.defEqCheap hget) + | defEqFailure hmem => exact .inr (.defEqFailure hmem) + | @unfold foundKey foundValue hget => + rw [Std.HashMap.getElem?_insert] at hget + split at hget + · next heq => + cases hget + have hkey : key = foundKey := eq_of_beq heq + subst foundKey + exact .inl rfl + · exact .inr (.unfold hget) + | natSuccStuck hmem => exact .inr (.natSuccStuck hmem) + | isProp hget => exact .inr (.isProp hget) + | isRec hget => exact .inr (.isRec hget) + | recursor hget => exact .inr (.recursor hget) + | recMajors hget => exact .inr (.recMajors hget) + | blockPeer hmem => exact .inr (.blockPeer hmem) + | blockResult hget => exact .inr (.blockResult hget) + /-- Insert one certified full-policy no-delta result. -/ theorem insertWhnfNoDelta {semantics : CacheSemantics} {authority : CacheAuthority} {support : RunSupport} @@ -769,6 +848,401 @@ theorem insertWhnfCoreCheap {semantics : CacheSemantics} | blockPeer hmem => exact .inr (.blockPeer hmem) | blockResult hget => exact .inr (.blockResult hget) +/-- Insert one certified full-mode inference result. Full inference entries +may later be consumed in either inference policy, so this update targets only +the validated `inferCache` partition. -/ +theorem insertInfer {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {key : Address × Address} {value : KExpr .anon} + (hbefore : CacheInvariant semantics authority support env) + (hnew : CacheProvenance semantics authority support + (.expr .infer key value)) : + CacheInvariant semantics authority support + { env with inferCache := env.inferCache.insert key value } := by + apply update hbefore hnew + intro entry hentry + cases hentry with + | whnf hget => exact .inr (.whnf hget) + | whnfNoDelta hget => exact .inr (.whnfNoDelta hget) + | whnfNoDeltaCheap hget => exact .inr (.whnfNoDeltaCheap hget) + | whnfCore hget => exact .inr (.whnfCore hget) + | whnfCoreCheap hget => exact .inr (.whnfCoreCheap hget) + | @infer foundKey foundValue hget => + rw [Std.HashMap.getElem?_insert] at hget + split at hget + · next heq => + cases hget + have hkey : key = foundKey := eq_of_beq heq + subst foundKey + exact .inl rfl + · exact .inr (.infer hget) + | inferOnly hget => exact .inr (.inferOnly hget) + | defEq hget => exact .inr (.defEq hget) + | defEqCheap hget => exact .inr (.defEqCheap hget) + | defEqFailure hmem => exact .inr (.defEqFailure hmem) + | unfold hget => exact .inr (.unfold hget) + | natSuccStuck hmem => exact .inr (.natSuccStuck hmem) + | isProp hget => exact .inr (.isProp hget) + | isRec hget => exact .inr (.isRec hget) + | recursor hget => exact .inr (.recursor hget) + | recMajors hget => exact .inr (.recMajors hget) + | blockPeer hmem => exact .inr (.blockPeer hmem) + | blockResult hget => exact .inr (.blockResult hget) + +/-- Insert one certified infer-only result without widening it into the full +validated inference partition. -/ +theorem insertInferOnly {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {key : Address × Address} {value : KExpr .anon} + (hbefore : CacheInvariant semantics authority support env) + (hnew : CacheProvenance semantics authority support + (.expr .inferOnly key value)) : + CacheInvariant semantics authority support + { env with inferOnlyCache := env.inferOnlyCache.insert key value } := by + apply update hbefore hnew + intro entry hentry + cases hentry with + | whnf hget => exact .inr (.whnf hget) + | whnfNoDelta hget => exact .inr (.whnfNoDelta hget) + | whnfNoDeltaCheap hget => exact .inr (.whnfNoDeltaCheap hget) + | whnfCore hget => exact .inr (.whnfCore hget) + | whnfCoreCheap hget => exact .inr (.whnfCoreCheap hget) + | infer hget => exact .inr (.infer hget) + | @inferOnly foundKey foundValue hget => + rw [Std.HashMap.getElem?_insert] at hget + split at hget + · next heq => + cases hget + have hkey : key = foundKey := eq_of_beq heq + subst foundKey + exact .inl rfl + · exact .inr (.inferOnly hget) + | defEq hget => exact .inr (.defEq hget) + | defEqCheap hget => exact .inr (.defEqCheap hget) + | defEqFailure hmem => exact .inr (.defEqFailure hmem) + | unfold hget => exact .inr (.unfold hget) + | natSuccStuck hmem => exact .inr (.natSuccStuck hmem) + | isProp hget => exact .inr (.isProp hget) + | isRec hget => exact .inr (.isRec hget) + | recursor hget => exact .inr (.recursor hget) + | recMajors hget => exact .inr (.recMajors hget) + | blockPeer hmem => exact .inr (.blockPeer hmem) + | blockResult hget => exact .inr (.blockResult hget) + +/-- Insert one certified full definitional-equality result. -/ +theorem insertDefEq {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {key : Address × Address × Address} {value : Bool} + (hbefore : CacheInvariant semantics authority support env) + (hnew : CacheProvenance semantics authority support + (.defEq .full key value)) : + CacheInvariant semantics authority support + { env with defEqCache := env.defEqCache.insert key value } := by + apply update hbefore hnew + intro entry hentry + cases hentry with + | whnf hget => exact .inr (.whnf hget) + | whnfNoDelta hget => exact .inr (.whnfNoDelta hget) + | whnfNoDeltaCheap hget => exact .inr (.whnfNoDeltaCheap hget) + | whnfCore hget => exact .inr (.whnfCore hget) + | whnfCoreCheap hget => exact .inr (.whnfCoreCheap hget) + | infer hget => exact .inr (.infer hget) + | inferOnly hget => exact .inr (.inferOnly hget) + | @defEq foundKey foundValue hget => + rw [Std.HashMap.getElem?_insert] at hget + split at hget + · next heq => + cases hget + have hkey : key = foundKey := eq_of_beq heq + subst foundKey + exact .inl rfl + · exact .inr (.defEq hget) + | defEqCheap hget => exact .inr (.defEqCheap hget) + | defEqFailure hmem => exact .inr (.defEqFailure hmem) + | unfold hget => exact .inr (.unfold hget) + | natSuccStuck hmem => exact .inr (.natSuccStuck hmem) + | isProp hget => exact .inr (.isProp hget) + | isRec hget => exact .inr (.isRec hget) + | recursor hget => exact .inr (.recursor hget) + | recMajors hget => exact .inr (.recMajors hget) + | blockPeer hmem => exact .inr (.blockPeer hmem) + | blockResult hget => exact .inr (.blockResult hget) + +/-- Insert one certified cheap definitional-equality result. Sound `true` +promotion into the full cache is a separate update and cannot be obtained by +retagging this entry. -/ +theorem insertDefEqCheap {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {key : Address × Address × Address} {value : Bool} + (hbefore : CacheInvariant semantics authority support env) + (hnew : CacheProvenance semantics authority support + (.defEq .cheap key value)) : + CacheInvariant semantics authority support + { env with defEqCheapCache := env.defEqCheapCache.insert key value } := by + apply update hbefore hnew + intro entry hentry + cases hentry with + | whnf hget => exact .inr (.whnf hget) + | whnfNoDelta hget => exact .inr (.whnfNoDelta hget) + | whnfNoDeltaCheap hget => exact .inr (.whnfNoDeltaCheap hget) + | whnfCore hget => exact .inr (.whnfCore hget) + | whnfCoreCheap hget => exact .inr (.whnfCoreCheap hget) + | infer hget => exact .inr (.infer hget) + | inferOnly hget => exact .inr (.inferOnly hget) + | defEq hget => exact .inr (.defEq hget) + | @defEqCheap foundKey foundValue hget => + rw [Std.HashMap.getElem?_insert] at hget + split at hget + · next heq => + cases hget + have hkey : key = foundKey := eq_of_beq heq + subst foundKey + exact .inl rfl + · exact .inr (.defEqCheap hget) + | defEqFailure hmem => exact .inr (.defEqFailure hmem) + | unfold hget => exact .inr (.unfold hget) + | natSuccStuck hmem => exact .inr (.natSuccStuck hmem) + | isProp hget => exact .inr (.isProp hget) + | isRec hget => exact .inr (.isRec hget) + | recursor hget => exact .inr (.recursor hget) + | recMajors hget => exact .inr (.recMajors hget) + | blockPeer hmem => exact .inr (.blockPeer hmem) + | blockResult hget => exact .inr (.blockResult hget) + +/-- Insert one certified narrow DefEq failure marker. The marker has no +acceptance consequence, but its source addresses and authorization still +belong to the physical cache invariant. -/ +theorem insertDefEqFailure {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {key : Address × Address × Address} + (hbefore : CacheInvariant semantics authority support env) + (hnew : CacheProvenance semantics authority support + (.defEqFailure key)) : + CacheInvariant semantics authority support + { env with defEqFailure := env.defEqFailure.insert key } := by + apply update hbefore hnew + intro entry hentry + cases hentry with + | whnf hget => exact .inr (.whnf hget) + | whnfNoDelta hget => exact .inr (.whnfNoDelta hget) + | whnfNoDeltaCheap hget => exact .inr (.whnfNoDeltaCheap hget) + | whnfCore hget => exact .inr (.whnfCore hget) + | whnfCoreCheap hget => exact .inr (.whnfCoreCheap hget) + | infer hget => exact .inr (.infer hget) + | inferOnly hget => exact .inr (.inferOnly hget) + | defEq hget => exact .inr (.defEq hget) + | defEqCheap hget => exact .inr (.defEqCheap hget) + | @defEqFailure foundKey hmem => + rw [Std.HashSet.contains_insert, Bool.or_eq_true] at hmem + rcases hmem with hsame | hold + · have hkey : key = foundKey := eq_of_beq hsame + subst foundKey + exact .inl rfl + · exact .inr (.defEqFailure hold) + | unfold hget => exact .inr (.unfold hget) + | natSuccStuck hmem => exact .inr (.natSuccStuck hmem) + | isProp hget => exact .inr (.isProp hget) + | isRec hget => exact .inr (.isRec hget) + | recursor hget => exact .inr (.recursor hget) + | recMajors hget => exact .inr (.recMajors hget) + | blockPeer hmem => exact .inr (.blockPeer hmem) + | blockResult hget => exact .inr (.blockResult hget) + +/-- Insert one provenance-certified stuck-successor marker. The certificate +is deliberately explicit: a marker changes future reduction behavior even +though it stores no reduced expression, so physical set membership alone is +not enough to preserve the kernel cache invariant. -/ +theorem insertNatSuccStuck {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {key : Address × Address} + (hbefore : CacheInvariant semantics authority support env) + (hnew : CacheProvenance semantics authority support + (.natSuccStuck key)) : + CacheInvariant semantics authority support + { env with natSuccStuck := env.natSuccStuck.insert key } := by + apply update hbefore hnew + intro entry hentry + cases hentry with + | whnf hget => exact .inr (.whnf hget) + | whnfNoDelta hget => exact .inr (.whnfNoDelta hget) + | whnfNoDeltaCheap hget => exact .inr (.whnfNoDeltaCheap hget) + | whnfCore hget => exact .inr (.whnfCore hget) + | whnfCoreCheap hget => exact .inr (.whnfCoreCheap hget) + | infer hget => exact .inr (.infer hget) + | inferOnly hget => exact .inr (.inferOnly hget) + | defEq hget => exact .inr (.defEq hget) + | defEqCheap hget => exact .inr (.defEqCheap hget) + | defEqFailure hmem => exact .inr (.defEqFailure hmem) + | unfold hget => exact .inr (.unfold hget) + | @natSuccStuck foundKey hmem => + rw [Std.HashSet.contains_insert, Bool.or_eq_true] at hmem + rcases hmem with hsame | hold + · have hkey : key = foundKey := eq_of_beq hsame + subst foundKey + exact .inl rfl + · exact .inr (.natSuccStuck hold) + | isProp hget => exact .inr (.isProp hget) + | isRec hget => exact .inr (.isRec hget) + | recursor hget => exact .inr (.recursor hget) + | recMajors hget => exact .inr (.recMajors hget) + | blockPeer hmem => exact .inr (.blockPeer hmem) + | blockResult hget => exact .inr (.blockResult hget) + +/-- Insert or overwrite one provenance-certified proposition-classification +entry. A cached `true` participates directly in proof-irrelevance +acceptance, so the semantic certificate is mandatory. -/ +theorem insertIsProp {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {key : Address × Address} {value : Bool} + (hbefore : CacheInvariant semantics authority support env) + (hnew : CacheProvenance semantics authority support + (.isProp key value)) : + CacheInvariant semantics authority support + { env with isPropCache := env.isPropCache.insert key value } := by + apply update hbefore hnew + intro entry hentry + cases hentry with + | whnf hget => exact .inr (.whnf hget) + | whnfNoDelta hget => exact .inr (.whnfNoDelta hget) + | whnfNoDeltaCheap hget => exact .inr (.whnfNoDeltaCheap hget) + | whnfCore hget => exact .inr (.whnfCore hget) + | whnfCoreCheap hget => exact .inr (.whnfCoreCheap hget) + | infer hget => exact .inr (.infer hget) + | inferOnly hget => exact .inr (.inferOnly hget) + | defEq hget => exact .inr (.defEq hget) + | defEqCheap hget => exact .inr (.defEqCheap hget) + | defEqFailure hmem => exact .inr (.defEqFailure hmem) + | unfold hget => exact .inr (.unfold hget) + | natSuccStuck hmem => exact .inr (.natSuccStuck hmem) + | @isProp foundKey foundValue hget => + rw [Std.HashMap.getElem?_insert] at hget + split at hget + · next heq => + cases hget + have hkey : key = foundKey := eq_of_beq heq + subst foundKey + exact .inl rfl + · exact .inr (.isProp hget) + | isRec hget => exact .inr (.isRec hget) + | recursor hget => exact .inr (.recursor hget) + | recMajors hget => exact .inr (.recMajors hget) + | blockPeer hmem => exact .inr (.blockPeer hmem) + | blockResult hget => exact .inr (.blockResult hget) + +/-- Insert or overwrite one provenance-certified recursion-classification +entry. The certificate is explicit because `false` enables struct-eta +reduction, while the provisional `true` marker controls re-entrancy. -/ +theorem insertIsRec {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {ind : Address} {value : Bool} + (hbefore : CacheInvariant semantics authority support env) + (hnew : CacheProvenance semantics authority support + (.isRec ind value)) : + CacheInvariant semantics authority support + { env with isRecCache := env.isRecCache.insert ind value } := by + apply update hbefore hnew + intro entry hentry + cases hentry with + | whnf hget => exact .inr (.whnf hget) + | whnfNoDelta hget => exact .inr (.whnfNoDelta hget) + | whnfNoDeltaCheap hget => exact .inr (.whnfNoDeltaCheap hget) + | whnfCore hget => exact .inr (.whnfCore hget) + | whnfCoreCheap hget => exact .inr (.whnfCoreCheap hget) + | infer hget => exact .inr (.infer hget) + | inferOnly hget => exact .inr (.inferOnly hget) + | defEq hget => exact .inr (.defEq hget) + | defEqCheap hget => exact .inr (.defEqCheap hget) + | defEqFailure hmem => exact .inr (.defEqFailure hmem) + | unfold hget => exact .inr (.unfold hget) + | natSuccStuck hmem => exact .inr (.natSuccStuck hmem) + | isProp hget => exact .inr (.isProp hget) + | @isRec foundInd foundValue hget => + rw [Std.HashMap.getElem?_insert] at hget + split at hget + · next heq => + cases hget + have hind : ind = foundInd := eq_of_beq heq + subst foundInd + exact .inl rfl + · exact .inr (.isRec hget) + | recursor hget => exact .inr (.recursor hget) + | recMajors hget => exact .inr (.recMajors hget) + | blockPeer hmem => exact .inr (.blockPeer hmem) + | blockResult hget => exact .inr (.blockResult hget) + +/-- Erasing one recursion-classification entry preserves every remaining +cache certificate. This is the error-cleanup half of `computedIsRec`. -/ +theorem eraseIsRec {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {ind : Address} + (hbefore : CacheInvariant semantics authority support env) : + CacheInvariant semantics authority support + { env with isRecCache := env.isRecCache.erase ind } := by + intro entry hentry + apply hbefore + cases hentry with + | whnf hget => exact .whnf hget + | whnfNoDelta hget => exact .whnfNoDelta hget + | whnfNoDeltaCheap hget => exact .whnfNoDeltaCheap hget + | whnfCore hget => exact .whnfCore hget + | whnfCoreCheap hget => exact .whnfCoreCheap hget + | infer hget => exact .infer hget + | inferOnly hget => exact .inferOnly hget + | defEq hget => exact .defEq hget + | defEqCheap hget => exact .defEqCheap hget + | defEqFailure hmem => exact .defEqFailure hmem + | unfold hget => exact .unfold hget + | natSuccStuck hmem => exact .natSuccStuck hmem + | isProp hget => exact .isProp hget + | @isRec foundInd foundValue hget => + rw [Std.HashMap.getElem?_erase] at hget + split at hget + · simp at hget + · exact .isRec hget + | recursor hget => exact .recursor hget + | recMajors hget => exact .recMajors hget + | blockPeer hmem => exact .blockPeer hmem + | blockResult hget => exact .blockResult hget + +/-- Fold the single-marker rule over a finite list. Every physical marker +written by the fold must have its own provenance; duplicate keys are harmless +because set insertion is idempotent. -/ +theorem insertNatSuccStuckList {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} (keys : List (Address × Address)) + (hbefore : CacheInvariant semantics authority support env) + (hnew : ∀ key ∈ keys, + CacheProvenance semantics authority support (.natSuccStuck key)) : + CacheInvariant semantics authority support + { env with natSuccStuck := + keys.foldl (fun set key => set.insert key) env.natSuccStuck } := by + induction keys generalizing env with + | nil => simpa using hbefore + | cons key rest ih => + rw [List.foldl_cons] + have hhead := insertNatSuccStuck hbefore (hnew key (by simp)) + have htail := ih (env := { env with + natSuccStuck := env.natSuccStuck.insert key }) hhead (by + intro found hfound + exact hnew found (by simp [hfound])) + simpa using htail + +/-- Array form matching the production successor loop's `visited.foldl` +write. This is the exact invariant rule consumed by both stuck exits. -/ +theorem insertNatSuccStuckArray {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} (keys : Array (Address × Address)) + (hbefore : CacheInvariant semantics authority support env) + (hnew : ∀ key ∈ keys, + CacheProvenance semantics authority support (.natSuccStuck key)) : + CacheInvariant semantics authority support + { env with natSuccStuck := + keys.foldl (fun set key => set.insert key) env.natSuccStuck } := by + rw [← Array.foldl_toList] + apply insertNatSuccStuckList keys.toList hbefore + intro key hkey + exact hnew key (by simpa using hkey) + /-- Exact environment equality preserves all cache provenance. -/ theorem of_env_eq {semantics : CacheSemantics} {authority : CacheAuthority} {support : RunSupport} diff --git a/Ix/Tc/Verify/Ctx.lean b/Ix/Tc/Verify/Ctx.lean index 271409750..f86b63090 100644 --- a/Ix/Tc/Verify/Ctx.lean +++ b/Ix/Tc/Verify/Ctx.lean @@ -113,78 +113,114 @@ def KVLCtx.bvarLets : KVLCtx → Nat /-! ### Concrete `LocalContext` well-formedness -Upstream `LocalContext.WF` (Verify/LocalContext.lean:119) re-keyed -over our production `push`: each pushed id is absent from the index. -Only the `mem_of_index` inversion is needed this slice (it discharges -mint-freshness); the full `find?`-correspondence kit is next. -/ - -inductive LocalContext.WF {m : Mode} : LocalContext m → Prop - | empty : WF {} - | push {lctx : LocalContext m} {fv : FVarId} {d : LocalDecl m} : - WF lctx → lctx.index[fv]? = none → WF (lctx.push fv d) +The invariant is deliberately extensional in the hash-map representation: +every successful index lookup must point to a declaration carrying the same +id. An earlier push-history inductive was too strong for production +`truncate`: `erase (insert map key value) key` is lookup-equivalent to `map` +when the key was absent, but `Std.HashMap` does not promise representation +equality after that mutation pair. -/ + +structure LocalContext.WF {m : Mode} (lctx : LocalContext m) : Prop where + sound : ∀ {fv : FVarId} {i : Nat}, lctx.index[fv]? = some i → + ∃ d, lctx.decls[i]? = some (fv, d) + +protected theorem LocalContext.WF.empty : + LocalContext.WF ({} : LocalContext m) where + sound := by simp + +protected theorem LocalContext.WF.push {m : Mode} + {lctx : LocalContext m} {fv : FVarId} {d : LocalDecl m} + (h : lctx.WF) (hfree : lctx.index[fv]? = none) : + (lctx.push fv d).WF where + sound := by + have _hfree := hfree + intro queried i hi + simp only [LocalContext.push] at hi ⊢ + rw [Std.HashMap.getElem?_insert] at hi + split at hi + · next heq => + cases hi + have hid : fv = queried := eq_of_beq heq + subst queried + refine ⟨d, ?_⟩ + rw [Array.getElem?_push] + simp + · obtain ⟨decl, hd⟩ := h.sound hi + refine ⟨decl, ?_⟩ + rw [Array.getElem?_push, if_neg] + · exact hd + · intro hieq + subst i + obtain ⟨hlt, _⟩ := Array.getElem?_eq_some_iff.mp hd + omega theorem LocalContext.WF.mem_of_index {m : Mode} {lctx : LocalContext m} (h : lctx.WF) {fv : FVarId} {i : Nat} (hi : lctx.index[fv]? = some i) : ∃ p ∈ lctx.decls.toList, p.1 = fv := by - induction h with - | empty => simp at hi - | @push lctx fv' d _ h2 ih => - simp only [LocalContext.push] at hi ⊢ - rw [Std.HashMap.getElem?_insert] at hi - split at hi - · next heq => - have h3 : fv' = fv := eq_of_beq heq - subst h3 - exact ⟨(fv', d), by simp [Array.toList_push], rfl⟩ - · obtain ⟨p, hp, hfst⟩ := ih hi - have hp' : p ∈ (lctx.decls.push (fv', d)).toList := by - rw [Array.toList_push] - exact List.mem_append.mpr (.inl hp) - exact ⟨p, hp', hfst⟩ + obtain ⟨d, hd⟩ := h.sound hi + refine ⟨(fv, d), ?_, rfl⟩ + apply List.mem_of_getElem? + rw [Array.getElem?_toList] + exact hd theorem LocalContext.WF.index_lt {m : Mode} {lctx : LocalContext m} (h : lctx.WF) {fv : FVarId} {i : Nat} (hi : lctx.index[fv]? = some i) : i < lctx.decls.size := by - induction h with - | empty => simp at hi - | @push lctx fv' d _ h2 ih => - simp only [LocalContext.push] at hi ⊢ - rw [Std.HashMap.getElem?_insert] at hi - split at hi - · cases hi - rw [Array.size_push] - omega - · have := ih hi - rw [Array.size_push] - omega + obtain ⟨d, hd⟩ := h.sound hi + exact (Array.getElem?_eq_some_iff.mp hd).choose /-- The index is positionally coherent: a hit points at an entry carrying exactly the queried id. -/ theorem LocalContext.WF.getElem?_of_index {m : Mode} {lctx : LocalContext m} (h : lctx.WF) {fv : FVarId} {i : Nat} (hi : lctx.index[fv]? = some i) : - ∃ d, lctx.decls[i]? = some (fv, d) := by - induction h with - | empty => simp at hi - | @push lctx fv' d hwf h2 ih => - simp only [LocalContext.push] at hi ⊢ - rw [Std.HashMap.getElem?_insert] at hi - split at hi - · next heq => - cases hi - have h3 : fv' = fv := eq_of_beq heq - subst h3 - refine ⟨d, ?_⟩ - rw [← Array.getElem?_toList, Array.toList_push, - ← Array.length_toList, List.getElem?_concat_length] - · obtain ⟨d', hd⟩ := ih hi - have hlt : i < lctx.decls.size := hwf.index_lt hi - refine ⟨d', ?_⟩ - rw [← Array.getElem?_toList, Array.toList_push, - List.getElem?_append_left (by simpa using hlt), - Array.getElem?_toList] + ∃ d, lctx.decls[i]? = some (fv, d) := + h.sound hi + +/-- Truncating a one-entry extension produces the exact declaration-array +prefix and an index whose remaining hits are still sound. The index is not +claimed equal to any earlier hash-map value. -/ +theorem LocalContext.truncate_pred_eval {m : Mode} + {lctx : LocalContext m} {len : Nat} + (hsize : lctx.decls.size = len + 1) : + lctx.truncate len = + { decls := lctx.decls.pop + index := lctx.index.erase lctx.decls.back!.1 } := by + unfold LocalContext.truncate + simp [hsize, LocalContext.truncate.go] + +theorem LocalContext.WF.truncate_pred {m : Mode} + {lctx : LocalContext m} {len : Nat} + (h : lctx.WF) (hsize : lctx.decls.size = len + 1) : + (lctx.truncate len).WF := by + rw [LocalContext.truncate_pred_eval hsize] + constructor + intro fv i hi + change (lctx.index.erase lctx.decls.back!.1)[fv]? = some i at hi + rw [Std.HashMap.getElem?_erase] at hi + split at hi + · contradiction + · next hne => + obtain ⟨d, hd⟩ := h.sound hi + by_cases hlt : i < lctx.decls.pop.size + · refine ⟨d, ?_⟩ + rw [Array.getElem?_pop, if_pos (by simpa using hlt)] exact hd + · have hiOld : i < lctx.decls.size := + (Array.getElem?_eq_some_iff.mp hd).choose + have hiLast : i = lctx.decls.size - 1 := by + simp only [Array.size_pop] at hlt + omega + subst i + obtain ⟨hiBound, hget⟩ := Array.getElem?_eq_some_iff.mp hd + have hback : lctx.decls.back! = (fv, d) := by + simp only [Array.back!] + rw [getElem!_pos lctx.decls (lctx.decls.size - 1) hiBound] + exact hget + exfalso + rw [hback] at hne + simp at hne /-- Unpack the concrete `find?` read into a positional hit. -/ theorem LocalContext.WF.find?_pos {m : Mode} {lctx : LocalContext m} @@ -325,6 +361,19 @@ theorem bvar_let_inv {bs' : List (KExpr .anon × Option (KExpr .anon))} match H with | .bvar_let H1 _ _ _ => ⟨_, _, _, rfl, H1⟩ +/-- Head inversion at a tagged fvar entry: the concrete declaration list +has the same id at its head and its tail reconciles with the outer ghost +context. -/ +theorem fvar_inv {bs : List (KExpr .anon × Option (KExpr .anon))} + {fs : List (FVarId × LocalDecl .anon)} {Δ : KVLCtx} + {fv : FVarId} {deps : List FVarId} {vd : VLocalDecl} + (H : CtxRecon' env uvars nameOf trProj bs fs + ((some (fv, deps), vd) :: Δ)) : + ∃ d fs', fs = (fv, d) :: fs' ∧ + CtxRecon' env uvars nameOf trProj bs fs' Δ := + match H with + | .fvar H1 _ _ => ⟨_, _, rfl, H1⟩ + theorem bvars_eq {bs : List (KExpr .anon × Option (KExpr .anon))} {fs : List (FVarId × LocalDecl .anon)} {Δ : KVLCtx} (H : CtxRecon' env uvars nameOf trProj bs fs Δ) : @@ -573,6 +622,20 @@ theorem index_fresh (h : CtxRecon env uvars nameOf trProj s Δ) : rw [hfst] at h2 exact absurd h2 (Nat.lt_irrefl _) +/-- The next concrete mint id is also absent from the reconciled ghost +context. This is the freshness premise needed when an untagged binder is +opened into a tagged fvar entry. -/ +theorem nextFVarId_fresh (h : CtxRecon env uvars nameOf trProj s Δ) : + (⟨s.env.nextFVarId⟩ : FVarId) ∉ Δ.fvars := by + rw [h.recon.fvars_eq] + intro hmem + obtain ⟨p, hp, hpeq⟩ := List.mem_map.mp hmem + have hp' : p ∈ s.lctx.decls.toList := by + simpa using hp + have hlt := h.fresh p hp' + rw [hpeq] at hlt + exact Nat.lt_irrefl _ hlt + /-- Distinctness of the declared fvar ids, from `incr`. -/ theorem fvars_nodup (h : CtxRecon env uvars nameOf trProj s Δ) : ((s.lctx.decls.toList.reverse).map (·.1)).Nodup := by @@ -691,6 +754,35 @@ theorem lookupLetVal {idx : UInt64} {ty val : KExpr .anon} simpa [Lean4Lean.VLocalDecl.value, Lean4Lean.VLocalDecl.depth] using hw +/-- Walker-tight sibling of `lookupLetVal`. The older theorem asks for the +coarse ambient bound `Δ.bvars + val.size`; the production lift walker records +the strictly smaller obligations it actually needs: construction, cutoff +space, and `val.lbr + val.size + (idx + 1)` space. Using those exact request +bounds avoids inventing a run-global context-size assumption for legacy +zeta. -/ +theorem lookupLetVal_liftBounds {idx : UInt64} {ty val : KExpr .anon} + (h : CtxRecon env uvars nameOf trProj s Δ) + (henv : env.Ordered) (htp : TrProjOK env uvars trProj) + (hidx : idx.toNat < s.ctx.size) + (hshift : (idx + 1).toNat = idx.toNat + 1) + (hty : s.ctx[s.ctx.size - 1 - idx.toNat]? = some ty) + (hov : s.letVals[s.ctx.size - 1 - idx.toNat]? = some (some val)) + (hcon : KExpr.Constructed val) + (hcut : (0 : UInt64).toNat + val.size < UInt64.size) + (hlift : val.lbr.toNat + val.size + (idx + 1).toNat < UInt64.size) : + ∃ e A, KVLCtx.find? Δ (.inl idx.toNat) = some (e, A) ∧ + TrKExprS env uvars nameOf trProj Δ + (KExpr.liftSpec val (idx + 1) 0) e := by + obtain ⟨Δ₀, vd, m, W, hf, hsub, htr⟩ := + h.frame_of_read hidx hty hov + cases htr with + | vlet h1 h2 h3 => + refine ⟨_, _, hf, ?_⟩ + have hw := h2.weakBV_lbr henv htp.weakN hcon W hshift + (show (0 : UInt64).toNat = 0 from rfl) hcut hlift + simpa [Lean4Lean.VLocalDecl.value, Lean4Lean.VLocalDecl.depth] + using hw + /-- The fvar-side lookup bridge at the concrete state: a successful `lctx.find?` resolves in the ghost `Δ` with translated payloads at the declaration's tail suffix — `TrKExprS.fvar`'s premise plus the @@ -716,6 +808,63 @@ theorem lctxFind? {fv : FVarId} {d : LocalDecl .anon} exact hd exact h.recon.fvar_frame h.fvars_nodup hj +/-- A free-variable lookup yields a translation of its stored declaration +type at the current mixed context when that type is closed with respect to +the legacy de Bruijn stack. This is the inference-side analogue of +`lctxFindLetVal`: production returns `d.ty` unchanged, so closure is the +precise condition under which the ghost context's accumulated lift is +definitionally unnecessary. -/ +theorem lctxFindType {fv : FVarId} {d : LocalDecl .anon} + (h : CtxRecon env uvars nameOf trProj s Δ) + (henv : env.Ordered) (htp : TrProjOK env uvars trProj) + (hf : s.lctx.find? fv = some d) + (hcon : KExpr.Constructed d.ty) (hclosed : d.ty.lbr = 0) + (hbig : Δ.bvars + d.ty.size < UInt64.size) : + ∃ e A, KVLCtx.find? Δ (.inr fv) = some (e, A) ∧ + TrKExprS env uvars nameOf trProj Δ d.ty A := by + obtain ⟨Δ₀, vd, dn, m, W, hfind, hsub, htr⟩ := h.lctxFind? hf + refine ⟨vd.value.liftN m 0, vd.type.liftN m 0, hfind, ?_⟩ + have hdn : dn < UInt64.size := by + have hb := W.bvars_eq + omega + have hshift : dn.toUInt64.toNat = dn := by + rw [Nat.toUInt64_eq] + exact UInt64.toNat_ofNat_of_lt' hdn + cases htr with + | @vlam nm bi ty ty' hty htyType => + have hcon' : KExpr.Constructed ty := by + simpa [LocalDecl.ty] using hcon + have hclosed' : ty.lbr = 0 := by + simpa [LocalDecl.ty] using hclosed + have hbig' : Δ.bvars + ty.size < UInt64.size := by + simpa [LocalDecl.ty] using hbig + have hw := hty.weakBV henv htp.weakN + (shift := dn.toUInt64) (cutoff := 0) W hshift rfl hbig' + have hid : KExpr.liftSpec ty dn.toUInt64 0 = ty := by + apply KExpr.liftSpec_id hcon' + (by simpa using (show ty.size < UInt64.size by omega)) + simp [hclosed'] + rw [hid] at hw + simpa [LocalDecl.ty, Lean4Lean.VLocalDecl.type, + Lean4Lean.VLocalDecl.depth, Lean4Lean.VExpr.liftN_liftN, + Nat.add_comm] using hw + | @vlet nm ty val ty' val' hty hval hvalType => + have hcon' : KExpr.Constructed ty := by + simpa [LocalDecl.ty] using hcon + have hclosed' : ty.lbr = 0 := by + simpa [LocalDecl.ty] using hclosed + have hbig' : Δ.bvars + ty.size < UInt64.size := by + simpa [LocalDecl.ty] using hbig + have hw := hty.weakBV henv htp.weakN + (shift := dn.toUInt64) (cutoff := 0) W hshift rfl hbig' + have hid : KExpr.liftSpec ty dn.toUInt64 0 = ty := by + apply KExpr.liftSpec_id hcon' + (by simpa using (show ty.size < UInt64.size by omega)) + simp [hclosed'] + rw [hid] at hw + simpa [LocalDecl.ty, Lean4Lean.VLocalDecl.type, + Lean4Lean.VLocalDecl.depth] using hw + /-- A let-valued fvar lookup yields a translation of the concrete stored value at the current mixed context, provided that value is closed with respect to the legacy de Bruijn stack. This premise is operationally @@ -952,6 +1101,56 @@ theorem openFVar {d : LocalDecl .anon} {vd : VLocalDecl} exact hnext lets := by rw [hnum, h.lets]; rfl +/-- Close exactly one tagged fvar scope. The saved length is tied to the +outer ghost context, so `truncate` removes the concrete head exposed by +`fvar_inv`; no representation equality for the hash-map index is needed. -/ +theorem closeFVar {fv : FVarId} {deps : List FVarId} {vd : VLocalDecl} + {saved : Nat} + (h : CtxRecon env uvars nameOf trProj s + ((some (fv, deps), vd) :: Δ)) + (hsaved : saved = Δ.fvars.length) : + CtxRecon env uvars nameOf trProj + {s with lctx := s.lctx.truncate saved} Δ := by + have hsizeExt := h.fvars_length + simp only [KVLCtx.fvars_cons_some, List.length_cons] at hsizeExt + have hsize : s.lctx.decls.size = saved + 1 := by omega + obtain ⟨d, fs, hfs, htail⟩ := h.recon.fvar_inv + have hlist : s.lctx.decls.toList = fs.reverse ++ [(fv, d)] := by + have hreversed := congrArg List.reverse hfs + simpa using hreversed + have htruncate := LocalContext.truncate_pred_eval hsize + have htruncList : + (s.lctx.truncate saved).decls.toList = fs.reverse := by + rw [htruncate, Array.toList_pop, hlist] + simp + refine { + size_eq := h.size_eq + recon := ?_ + lwf := h.lwf.truncate_pred hsize + incr := ?_ + fresh := ?_ + lets := ?_ } + · change CtxRecon' env uvars nameOf trProj + ((s.ctx.toList.zip s.letVals.toList).reverse) + ((s.lctx.truncate saved).decls.toList.reverse) Δ + rw [htruncList, List.reverse_reverse] + exact htail + · change List.Pairwise + (fun p q : FVarId × LocalDecl .anon => + p.1.id.toNat < q.1.id.toNat) + (s.lctx.truncate saved).decls.toList + rw [htruncList] + have hincr := h.incr + rw [hlist] at hincr + exact (List.pairwise_append.mp hincr).1 + · intro p hp + change p ∈ (s.lctx.truncate saved).decls.toList at hp + rw [htruncList] at hp + apply h.fresh p + rw [hlist] + exact List.mem_append.mpr (.inl hp) + · simpa using h.lets + end CtxRecon end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq.lean b/Ix/Tc/Verify/DefEq.lean new file mode 100644 index 000000000..75669c8b3 --- /dev/null +++ b/Ix/Tc/Verify/DefEq.lean @@ -0,0 +1,2498 @@ +import Ix.Tc.Verify.Infer +import Ix.Tc.Verify.Whnf.Closure +import Batteries.Data.UInt + +/-! +# K2 definitional-equality cache semantics + +For checker soundness, a cached `true` must denote Theory definitional +equality. A cached `false` (including the narrow failure set) can only reject +an otherwise valid declaration, so it carries no acceptance claim here. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +private theorem uint64_max_comm (a b : UInt64) : max a b = max b a := by + apply UInt64.toNat_inj.mp + simp only [UInt64.toNat_max, Nat.max_comm] + +namespace EqKey + +/-- Propositional contract for the runtime guard on root-derived DefEq cache +lookups. This is the exact scope information consumed by the semantic branch +proof below. -/ +theorem rootCacheScopeMatches_iff (left right : EqKey) + (ctxAddr : Address) (lbr : UInt64) : + left.rootCacheScopeMatches right ctxAddr lbr = true ↔ + left.ctxAddr = ctxAddr ∧ right.ctxAddr = ctxAddr ∧ + left.lbr = lbr ∧ right.lbr = lbr ∧ + max left.exprLbr right.exprLbr = lbr := by + simp [EqKey.rootCacheScopeMatches, and_assoc] + +end EqKey + +/-- A represented context address tied to the actual DefEq key computation. +The expression-address pair is canonicalized separately after this run. -/ +def DefEqContextKeys.Matches (keys : WhnfContextKeys) + (trProj : RawProjRel) (world : VerifyWorld) (s : TcState .anon) + (Delta : KVLCtx) (a b : KExpr .anon) (ctxAddr : Address) : Prop := + CtxRecon world.venv keys.uvars world.nameOf trProj s Delta ∧ + keys.Represents (max a.lbr b.lbr) ctxAddr Delta ∧ + exists s', TcM.defEqCtxKey a b s = .ok ctxAddr s' + +namespace TcM + +/-- `withEquiv` is state-pure outside the union-find manager. Naming its +exact result keeps path-halving updates from being treated as semantic cache +or context changes. -/ +theorem withEquiv_eq (f : EquivManager → α × EquivManager) + (s : TcState .anon) : + TcM.withEquiv f s = .ok (f s.equivManager).1 + {s with equivManager := (f s.equivManager).2} := by + unfold TcM.withEquiv + rcases hresult : f s.equivManager with ⟨a, em⟩ + change EStateM.bind + (fun st : TcState .anon => + .ok st.equivManager {st with equivManager := {}}) _ s = _ + unfold EStateM.bind + simp only + rw [hresult] + rfl + +/-- A union-find operation preserves the fixed-world checker invariant once +its updated manager has been proved valid. The preservation premise is +deliberately explicit: arbitrary mutation of the manager is not semantic +bookkeeping. -/ +theorem withEquiv_whnf_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + (f : EquivManager → α × EquivManager) + (hf : ∀ em, EquivManager.WF + (semantics.Equiv (CacheAuthority.stable world) support) em → + EquivManager.WF + (semantics.Equiv (CacheAuthority.stable world) support) (f em).2) + (s : TcState .anon) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.withEquiv f) (fun _ _ => True) := by + intro hI + rw [TcM.withEquiv_eq] + exact ⟨hI.setEquivManager _ (hf _ hI.1.equivalences), trivial⟩ + +/-- The production equivalence query performs only verified path compression; +a positive Boolean additionally exposes the semantic relation represented by +the manager. -/ +theorem withEquiv_isEquiv_whnf_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} (left right : EqKey) + (s : TcState .anon) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.withEquiv (·.isEquiv left right)) + (fun answer _ => answer = true → + semantics.Equiv (CacheAuthority.stable world) support left right) := by + intro hI + rw [TcM.withEquiv_eq] + have hquery := hI.1.equivalences.isEquiv + (semantics.equivEquivalence (CacheAuthority.stable world) support) + left right + rcases hresult : s.equivManager.isEquiv left right with ⟨answer, manager⟩ + rw [hresult] at hquery + exact ⟨hI.setEquivManager manager hquery.1, hquery.2⟩ + +/-- DefEq's two-root second-chance query preserves the manager and returns a +semantic relation from each original key to any representative it exposes. -/ +theorem withEquiv_findRootKeys_whnf_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} (left right : EqKey) + (s : TcState .anon) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.withEquiv fun em => + let (leftRoot, em) := em.findRootKey left + let (rightRoot, em) := em.findRootKey right + ((leftRoot, rightRoot), em)) + (fun roots _ => + (∀ root, roots.1 = some root → + semantics.Equiv (CacheAuthority.stable world) support left root) ∧ + (∀ root, roots.2 = some root → + semantics.Equiv (CacheAuthority.stable world) support right root)) := by + intro hI + rw [TcM.withEquiv_eq] + have hroots := hI.1.equivalences.findRootKeys + (semantics.equivEquivalence (CacheAuthority.stable world) support) + left right + rcases hleft : s.equivManager.findRootKey left with ⟨leftRoot, manager₁⟩ + rcases hright : manager₁.findRootKey right with ⟨rightRoot, manager₂⟩ + simp only [hleft, hright] at hroots ⊢ + exact ⟨hI.setEquivManager manager₂ hroots.1, hroots.2⟩ + +/-- DefEq's shared context key permits only the suffix-memo state frame. -/ +theorem defEqCtxKey_wf {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {a b : KExpr .anon} + {s : TcState .anon} : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.defEqCtxKey a b) (fun _ s' => ContextKeyFrame s s') := by + unfold TcM.defEqCtxKey + exact TcM.ctxAddrForLbr_wf + (fun hI hframe => hframe.whnfStateInv hI) (max a.lbr b.lbr) s + +/-- The canonical operational interpretation constructs DefEq context +membership directly from the real `ctxAddrForLbr (max a.lbr b.lbr)` run. -/ +theorem defEqCtxKey_operational_matches_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {a b : KExpr .anon} + {s : TcState .anon} : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.defEqCtxKey a b) + (fun ctxAddr s' => + DefEqContextKeys.Matches + (operationalWhnfContextKeys trProj world uvars) trProj world s + Delta a b ctxAddr ∧ ContextKeyFrame s s') := by + intro hI + have hwf := TcM.defEqCtxKey_wf (layer := layer) + (semantics := semantics) (trProj := trProj) (world := world) + (support := support) (uvars := uvars) (Delta := Delta) + (a := a) (b := b) (s := s) hI + match hrun : TcM.defEqCtxKey a b s with + | .ok ctxAddr s' => + rw [hrun] at hwf + exact ⟨hwf.1, + ⟨⟨hI.2.1, + operationalWhnfContextKeys.representsCtx hI.2.1 hrun, + ⟨s', hrun⟩⟩, hwf.2⟩⟩ + | .error err s' => + rw [hrun] at hwf + exact hwf + +end TcM + +namespace WhnfStateInv + +/-- Record one already-proved semantic equality in the concrete manager. -/ +theorem addEquiv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {left right : EqKey} + (h : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hrel : semantics.Equiv (CacheAuthority.stable world) support left right) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with equivManager := s.equivManager.addEquiv left right} := + h.setEquivManager _ <| + h.1.equivalences.addEquiv + (semantics.equivEquivalence (CacheAuthority.stable world) support) hrel + +end WhnfStateInv + +/-- Soundness meaning of one concrete boolean def-eq result. -/ +def DefEqMeaning (trProj : RawProjRel) (world : VerifyWorld) + (uvars : Nat) (Delta : KVLCtx) (a b : KExpr .anon) + (answer : Bool) : Prop := + answer = true → + ∃ va vb, + TrKExprS world.venv uvars world.nameOf trProj Delta a va ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta b vb ∧ + world.venv.IsDefEqU uvars Delta.toCtx va vb + +namespace DefEqMeaning + +theorem false {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {a b : KExpr .anon} : + DefEqMeaning trProj world uvars Delta a b false := by + intro h + contradiction + +/-- The production address-equality fast path is sound on the finite run +support. In anonymous mode collision freedom turns equal Blake3 addresses +into literal expression equality; Theory reflexivity then supplies the +semantic result. -/ +theorem of_addr_beq {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {uvars : Nat} {Delta : KVLCtx} + {s : TcState .anon} {a b : KExpr .anon} {va : VExpr} + (theory : WhnfTheory trProj world uvars) + (hctx : CtxRecon world.venv uvars world.nameOf trProj s Delta) + (hcollision : support.CollisionFree) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv uvars world.nameOf trProj Delta a va) + (haddr : (a.addr == b.addr) = true) : + DefEqMeaning trProj world uvars Delta a b true := by + have herase := hcollision.expr haSupport hbSupport (eq_of_beq haddr) + have hab : a = b := by + simpa only [KExpr.eraseMeta_anon] using herase + subst b + intro _ + exact ⟨va, va, ha, ha, + Lean4Lean.VEnv.IsDefEqU.refl (theory.exprWF hctx ha)⟩ + +theorem symm {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {a b : KExpr .anon} {answer : Bool} + (h : DefEqMeaning trProj world uvars Delta a b answer) : + DefEqMeaning trProj world uvars Delta b a answer := by + intro htrue + obtain ⟨va, vb, ha, hb, hab⟩ := h htrue + exact ⟨vb, va, hb, ha, hab.symm⟩ + +theorem mono {trProj : RawProjRel} {before after : VerifyWorld} + (hle : before ≤ after) {uvars : Nat} {Delta : KVLCtx} + {a b : KExpr .anon} {answer : Bool} + (h : DefEqMeaning trProj before uvars Delta a b answer) : + DefEqMeaning trProj after uvars Delta a b answer := by + intro htrue + obtain ⟨va, vb, ha, hb, hab⟩ := h htrue + refine ⟨va, vb, ?_, ?_, hab.mono hle.venv⟩ + · simpa only [← hle.nameOf] using ha.mono hle.venv + · simpa only [← hle.nameOf] using hb.mono hle.venv + +/-- Convert cache meaning to the exact caller translations used by +`Methods.WF.isDefEq`. -/ +theorem of_translations {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} (theory : WhnfTheory trProj world uvars) + {Delta : KVLCtx} (hDelta : KVLCtx.WF world.venv uvars Delta) + {a b : KExpr .anon} {va vb : VExpr} {answer : Bool} + (ha : TrKExprS world.venv uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv uvars world.nameOf trProj Delta b vb) + (h : DefEqMeaning trProj world uvars Delta a b answer) + (htrue : answer = true) : + world.venv.IsDefEqU uvars Delta.toCtx va vb := by + obtain ⟨cachedA, cachedB, hcachedA, hcachedB, hcached⟩ := h htrue + have hctx := KVLCtx.IsDefEq.refl world.venvWF hDelta + have haEq := hcachedA.uniq world.venvWF theory.literalWF + theory.projections hctx ha + have hbEq := hcachedB.uniq world.venvWF theory.literalWF + theory.projections hctx hb + exact haEq.symm.trans world.venvWF hDelta <| + hcached.trans world.venvWF hDelta hbEq + +end DefEqMeaning + +/-- Soundness meaning of one memoized proposition classifier result. The +classifier is conservative on `false`; a `true` result retains a structural +translation of the concrete type with type `Sort 0`. -/ +def IsPropMeaning (trProj : RawProjRel) (world : VerifyWorld) + (uvars : Nat) (Delta : KVLCtx) (source : KExpr .anon) + (answer : Bool) : Prop := + answer = true → + ∃ sourceV, + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV ∧ + world.venv.HasType uvars Delta.toCtx sourceV (.sort .zero) + +namespace IsPropMeaning + +theorem false {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {source : KExpr .anon} : + IsPropMeaning trProj world uvars Delta source false := by + intro htrue + contradiction + +theorem mono {trProj : RawProjRel} {before after : VerifyWorld} + (hle : before ≤ after) {uvars : Nat} {Delta : KVLCtx} + {source : KExpr .anon} {answer : Bool} + (h : IsPropMeaning trProj before uvars Delta source answer) : + IsPropMeaning trProj after uvars Delta source answer := by + intro htrue + obtain ⟨sourceV, hsource, htype⟩ := h htrue + refine ⟨sourceV, ?_, htype.mono hle.venv⟩ + simpa only [← hle.nameOf] using hsource.mono hle.venv + +/-- Reconcile cached proposition meaning with the caller's particular +structural translation. -/ +theorem of_translation {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} (theory : WhnfTheory trProj world uvars) + {Delta : KVLCtx} (hDelta : KVLCtx.WF world.venv uvars Delta) + {source : KExpr .anon} {sourceV : VExpr} {answer : Bool} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (h : IsPropMeaning trProj world uvars Delta source answer) + (htrue : answer = true) : + world.venv.HasType uvars Delta.toCtx sourceV (.sort .zero) := by + obtain ⟨cachedV, hcached, htype⟩ := h htrue + have hctx := KVLCtx.IsDefEq.refl world.venvWF hDelta + have heq := hcached.uniq world.venvWF theory.literalWF + theory.projections hctx hsource + exact htype.defeqU_l world.venvWF hDelta heq + +end IsPropMeaning + +/-! ## Semantic relation represented by the equivalence manager -/ + +/-- One directed, semantically justified union-find edge. Besides the +context/radius agreement, both endpoint keys retain concrete finite-support +witnesses. That witness retention is what makes a chain of manager edges +semantically composable: the intermediate address is never interpreted as an +expression merely because a hash happens to exist. -/ +structure DefEqKeyEdge (keys : WhnfContextKeys) (trProj : RawProjRel) + (authority : CacheAuthority) (support : RunSupport) + (left right : EqKey) : Prop where + context_eq : left.ctxAddr = right.ctxAddr + radius_eq : left.lbr = right.lbr + leftWitness : ∃ a, support a ∧ a.addr = left.exprAddr ∧ + a.lbr = left.exprLbr + rightWitness : ∃ b, support b ∧ b.addr = right.exprAddr ∧ + b.lbr = right.exprLbr + meaning : ∀ a, support a → a.addr = left.exprAddr → + ∀ b, support b → b.addr = right.exprAddr → + ∀ Delta, keys.Represents left.lbr left.ctxAddr Delta → + DefEqMeaning trProj authority.world keys.uvars Delta a b true + +namespace DefEqKeyEdge + +/-- Edge validity is monotone in the trusted Theory world. -/ +theorem mono {keys : WhnfContextKeys} {trProj : RawProjRel} + {before after : CacheAuthority} {support : RunSupport} + {left right : EqKey} (hle : before ≤ after) + (h : DefEqKeyEdge keys trProj before support left right) : + DefEqKeyEdge keys trProj after support left right where + context_eq := h.context_eq + radius_eq := h.radius_eq + leftWitness := h.leftWitness + rightWitness := h.rightWitness + meaning a ha haddrA b hb haddrB Delta hrepresented := + (h.meaning a ha haddrA b hb haddrB Delta hrepresented).mono hle.world + +end DefEqKeyEdge + +/-- One undirected semantic step. Union-find parent edges may choose either +orientation, so symmetry belongs at this structural layer rather than being +silently assumed of a raw insertion certificate. -/ +inductive DefEqKeyStep (keys : WhnfContextKeys) (trProj : RawProjRel) + (authority : CacheAuthority) (support : RunSupport) : + EqKey → EqKey → Prop where + | forward : DefEqKeyEdge keys trProj authority support left right → + DefEqKeyStep keys trProj authority support left right + | backward : DefEqKeyEdge keys trProj authority support right left → + DefEqKeyStep keys trProj authority support left right + +namespace DefEqKeyStep + +theorem symm {keys : WhnfContextKeys} {trProj : RawProjRel} + {authority : CacheAuthority} {support : RunSupport} {left right : EqKey} + (h : DefEqKeyStep keys trProj authority support left right) : + DefEqKeyStep keys trProj authority support right left := by + cases h with + | forward hedge => exact .backward hedge + | backward hedge => exact .forward hedge + +theorem mono {keys : WhnfContextKeys} {trProj : RawProjRel} + {before after : CacheAuthority} {support : RunSupport} + {left right : EqKey} (hle : before ≤ after) + (h : DefEqKeyStep keys trProj before support left right) : + DefEqKeyStep keys trProj after support left right := by + cases h with + | forward hedge => exact .forward (hedge.mono hle) + | backward hedge => exact .backward (hedge.mono hle) + +theorem context_eq {keys : WhnfContextKeys} {trProj : RawProjRel} + {authority : CacheAuthority} {support : RunSupport} {left right : EqKey} + (h : DefEqKeyStep keys trProj authority support left right) : + left.ctxAddr = right.ctxAddr := by + cases h with + | forward hedge => exact hedge.context_eq + | backward hedge => exact hedge.context_eq.symm + +theorem radius_eq {keys : WhnfContextKeys} {trProj : RawProjRel} + {authority : CacheAuthority} {support : RunSupport} {left right : EqKey} + (h : DefEqKeyStep keys trProj authority support left right) : + left.lbr = right.lbr := by + cases h with + | forward hedge => exact hedge.radius_eq + | backward hedge => exact hedge.radius_eq.symm + +/-- Every step provides a supported expression for its target key. -/ +theorem targetWitness {keys : WhnfContextKeys} {trProj : RawProjRel} + {authority : CacheAuthority} {support : RunSupport} {left right : EqKey} + (h : DefEqKeyStep keys trProj authority support left right) : + ∃ b, support b ∧ b.addr = right.exprAddr ∧ b.lbr = right.exprLbr := by + cases h with + | forward hedge => exact hedge.rightWitness + | backward hedge => exact hedge.leftWitness + +/-- Interpret one undirected step at a represented source context. -/ +theorem meaning {keys : WhnfContextKeys} {trProj : RawProjRel} + {authority : CacheAuthority} {support : RunSupport} {left right : EqKey} + (h : DefEqKeyStep keys trProj authority support left right) + {a b : KExpr .anon} (ha : support a) (haddrA : a.addr = left.exprAddr) + (hb : support b) (haddrB : b.addr = right.exprAddr) + {Delta : KVLCtx} (hrepresented : + keys.Represents left.lbr left.ctxAddr Delta) : + DefEqMeaning trProj authority.world keys.uvars Delta a b true := by + cases h with + | forward hedge => + exact hedge.meaning a ha haddrA b hb haddrB Delta hrepresented + | backward hedge => + have hrepresented' : + keys.Represents right.lbr right.ctxAddr Delta := by + simpa only [hedge.radius_eq, hedge.context_eq] using hrepresented + exact (hedge.meaning b hb haddrB a ha haddrA Delta hrepresented').symm + +end DefEqKeyStep + +/-- A finite path of justified manager edges. Its constructors make +reflexivity and transitivity structural; no unproved transitivity of context +digests or expression addresses enters the relation. -/ +inductive DefEqKeyEquiv (keys : WhnfContextKeys) (trProj : RawProjRel) + (authority : CacheAuthority) (support : RunSupport) : + EqKey → EqKey → Prop where + | refl (key : EqKey) : DefEqKeyEquiv keys trProj authority support key key + | cons : DefEqKeyStep keys trProj authority support left middle → + DefEqKeyEquiv keys trProj authority support middle right → + DefEqKeyEquiv keys trProj authority support left right + +namespace DefEqKeyEquiv + +theorem trans {keys : WhnfContextKeys} {trProj : RawProjRel} + {authority : CacheAuthority} {support : RunSupport} {left middle right : EqKey} + (h₁ : DefEqKeyEquiv keys trProj authority support left middle) + (h₂ : DefEqKeyEquiv keys trProj authority support middle right) : + DefEqKeyEquiv keys trProj authority support left right := by + induction h₁ with + | refl => exact h₂ + | cons hstep htail ih => exact .cons hstep (ih h₂) + +theorem symm {keys : WhnfContextKeys} {trProj : RawProjRel} + {authority : CacheAuthority} {support : RunSupport} {left right : EqKey} + (h : DefEqKeyEquiv keys trProj authority support left right) : + DefEqKeyEquiv keys trProj authority support right left := by + induction h with + | refl => exact .refl _ + | @cons left middle right hstep htail ih => + exact trans ih (.cons hstep.symm (.refl _)) + +theorem equivalence (keys : WhnfContextKeys) (trProj : RawProjRel) + (authority : CacheAuthority) (support : RunSupport) : + Equivalence (DefEqKeyEquiv keys trProj authority support) := + ⟨.refl, symm, trans⟩ + +theorem mono {keys : WhnfContextKeys} {trProj : RawProjRel} + {before after : CacheAuthority} {support : RunSupport} + {left right : EqKey} (hle : before ≤ after) + (h : DefEqKeyEquiv keys trProj before support left right) : + DefEqKeyEquiv keys trProj after support left right := by + induction h with + | refl => exact .refl _ + | cons hstep htail ih => exact .cons (hstep.mono hle) ih + +theorem context_eq {keys : WhnfContextKeys} {trProj : RawProjRel} + {authority : CacheAuthority} {support : RunSupport} {left right : EqKey} + (h : DefEqKeyEquiv keys trProj authority support left right) : + left.ctxAddr = right.ctxAddr := by + induction h with + | refl => rfl + | cons hstep htail ih => exact hstep.context_eq.trans ih + +theorem radius_eq {keys : WhnfContextKeys} {trProj : RawProjRel} + {authority : CacheAuthority} {support : RunSupport} {left right : EqKey} + (h : DefEqKeyEquiv keys trProj authority support left right) : + left.lbr = right.lbr := by + induction h with + | refl => rfl + | cons hstep htail ih => exact hstep.radius_eq.trans ih + +/-- A manager path exposes a concrete supported witness for its target once +the queried source key has one. The intrinsic-radius equality is retained so +root-derived cache probes can reconstruct the exact context radius used by +their expression pair. -/ +theorem targetWitness {keys : WhnfContextKeys} {trProj : RawProjRel} + {authority : CacheAuthority} {support : RunSupport} {left right : EqKey} + (h : DefEqKeyEquiv keys trProj authority support left right) + {a : KExpr .anon} (ha : support a) (haddr : a.addr = left.exprAddr) + (hlbr : a.lbr = left.exprLbr) : + ∃ b, support b ∧ b.addr = right.exprAddr ∧ b.lbr = right.exprLbr := by + induction h generalizing a with + | refl => exact ⟨a, ha, haddr, hlbr⟩ + | cons hstep htail ih => + obtain ⟨middle, hmiddle, hmiddleAddr, hmiddleLbr⟩ := + hstep.targetWitness + exact ih hmiddle hmiddleAddr hmiddleLbr + +/-- A manager path is sound for concrete translated endpoints. Intermediate +expressions and translations come from the edge certificates themselves; +they are never reconstructed from hashes. -/ +theorem sound {keys : WhnfContextKeys} {trProj : RawProjRel} + {authority : CacheAuthority} {support : RunSupport} + (theory : WhnfTheory trProj authority.world keys.uvars) + {Delta : KVLCtx} (hDelta : KVLCtx.WF authority.world.venv keys.uvars Delta) + (hcollision : support.CollisionFree) + {left right : EqKey} + (h : DefEqKeyEquiv keys trProj authority support left right) + {a b : KExpr .anon} {va vb : VExpr} + (haSupport : support a) (haddrA : a.addr = left.exprAddr) + (hbSupport : support b) (haddrB : b.addr = right.exprAddr) + (hrepresented : keys.Represents left.lbr left.ctxAddr Delta) + (ha : TrKExprS authority.world.venv keys.uvars authority.world.nameOf + trProj Delta a va) + (hb : TrKExprS authority.world.venv keys.uvars authority.world.nameOf + trProj Delta b vb) : + authority.world.venv.IsDefEqU keys.uvars Delta.toCtx va vb := by + induction h generalizing a va with + | refl => + have habAddr : a.addr = b.addr := haddrA.trans haddrB.symm + have hab : a = b := by + have herase := hcollision.expr haSupport hbSupport habAddr + simpa only [KExpr.eraseMeta_anon] using herase + subst b + exact ha.uniq authority.world.venvWF theory.literalWF + theory.projections (KVLCtx.IsDefEq.refl authority.world.venvWF hDelta) hb + | @cons left middle right hstep htail ih => + obtain ⟨mid, hmidSupport, hmidAddr, _hmidLbr⟩ := hstep.targetWitness + have hstepMeaning := hstep.meaning haSupport haddrA hmidSupport hmidAddr + hrepresented + obtain ⟨stepA, midV, hstepA, hmid, hstepEq⟩ := hstepMeaning rfl + have hleftMid : authority.world.venv.IsDefEqU keys.uvars Delta.toCtx + va midV := + DefEqMeaning.of_translations theory hDelta ha hmid hstepMeaning rfl + have hrepresentedTail : + keys.Represents middle.lbr middle.ctxAddr Delta := by + simpa only [hstep.radius_eq, hstep.context_eq] using hrepresented + have hmidRight := ih hmidSupport hmidAddr haddrB + hrepresentedTail hmid + exact hleftMid.trans authority.world.venvWF hDelta hmidRight + +end DefEqKeyEquiv + +/-! ## Joint suffix semantics + +The production context key is itself a Blake3 digest. Expression-address +collision freedom does not imply injectivity of this second, composite hash. +Consequently the four semantic transports below remain an explicit boundary: +they may later be proved from a finite context-digest collision hypothesis and +the declarative suffix-closure theorem, but must not be inferred from a bare +address equality. -/ + +/-- One context-key interpretation sufficient for every K1/K2 semantic cache +family. Operational representation is shared, while WHNF, inference, DefEq, +and the auxiliary proposition classifier each state their own +context-transport consequence. -/ +structure KernelSuffixModel (trProj : RawProjRel) (world : VerifyWorld) where + keys : WhnfContextKeys + representsCtx : ∀ {before after : TcState .anon} {lbr : UInt64} + {ctxAddr : Address} {Delta : KVLCtx}, + CtxRecon world.venv keys.uvars world.nameOf trProj before Delta → + TcM.ctxAddrForLbr lbr before = .ok ctxAddr after → + keys.Represents lbr ctxAddr Delta + represents : ∀ {before after : TcState .anon} {key : Address × Address} + {Delta : KVLCtx} {source : KExpr .anon}, + CtxRecon world.venv keys.uvars world.nameOf trProj before Delta → + TcM.whnfKey source before = .ok key after → + keys.Represents source.lbr key.2 Delta + whnfTransport : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {source result : KExpr .anon}, + keys.Represents source.lbr ctxAddr Delta → + keys.Represents source.lbr ctxAddr Delta' → + WhnfMeaning trProj world keys.uvars Delta source result → + WhnfMeaning trProj world keys.uvars Delta' source result + inferTransport : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {source ty : KExpr .anon}, + keys.Represents source.lbr ctxAddr Delta → + keys.Represents source.lbr ctxAddr Delta' → + InferMeaning trProj world keys.uvars Delta source ty → + InferMeaning trProj world keys.uvars Delta' source ty + defEqTransport : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {a b : KExpr .anon} {answer : Bool}, + keys.Represents (max a.lbr b.lbr) ctxAddr Delta → + keys.Represents (max a.lbr b.lbr) ctxAddr Delta' → + DefEqMeaning trProj world keys.uvars Delta a b answer → + DefEqMeaning trProj world keys.uvars Delta' a b answer + isPropTransport : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {source : KExpr .anon} {answer : Bool}, + keys.Represents source.lbr ctxAddr Delta → + keys.Represents source.lbr ctxAddr Delta' → + IsPropMeaning trProj world keys.uvars Delta source answer → + IsPropMeaning trProj world keys.uvars Delta' source answer + +namespace TcM + +/-- A joint suffix model interprets a direct context-address execution at an +arbitrary expression's local-binding radius. -/ +theorem ctxAddrForLbr_model_matches_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : KernelSuffixModel trProj world) + {Delta : KVLCtx} {source : KExpr .anon} {s : TcState .anon} : + TcM.WF + (WhnfStateInv layer semantics trProj world support model.keys.uvars + Delta) s + (TcM.ctxAddrForLbr source.lbr) + (fun ctxAddr s' => + model.keys.Represents source.lbr ctxAddr Delta ∧ + ContextKeyFrame s s') := by + intro hI + have hwf := + (TcM.ctxAddrForLbr_wf + (fun hInv hframe => hframe.whnfStateInv hInv) source.lbr s) hI + match hrun : TcM.ctxAddrForLbr source.lbr s with + | .ok ctxAddr s' => + rw [hrun] at hwf + exact ⟨hwf.1, model.representsCtx hI.2.1 hrun, hwf.2⟩ + | .error err s' => + rw [hrun] at hwf + exact hwf + +/-- A joint suffix model supplies the same direct representation theorem for +DefEq's bare context-key execution that it supplies for WHNF/inference keys. +Keeping this field explicit prevents a model of expression-key runs from +being silently assumed to cover `ctxAddrForLbr` in isolation. -/ +theorem defEqCtxKey_model_matches_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : KernelSuffixModel trProj world) + {Delta : KVLCtx} {a b : KExpr .anon} {s : TcState .anon} : + TcM.WF + (WhnfStateInv layer semantics trProj world support model.keys.uvars + Delta) s + (TcM.defEqCtxKey a b) + (fun ctxAddr s' => + DefEqContextKeys.Matches model.keys trProj world s Delta a b + ctxAddr /\ ContextKeyFrame s s') := by + intro hI + have hwf := + (TcM.defEqCtxKey_wf + (layer := layer) (semantics := semantics) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) (a := a) (b := b) + (s := s)) hI + match hrun : TcM.defEqCtxKey a b s with + | .ok ctxAddr s' => + rw [hrun] at hwf + have hctxRun : TcM.ctxAddrForLbr (max a.lbr b.lbr) s = + .ok ctxAddr s' := by + simpa [TcM.defEqCtxKey] using hrun + exact ⟨hwf.1, + ⟨⟨hI.2.1, model.representsCtx hI.2.1 hctxRun, ⟨s', hrun⟩⟩, + hwf.2⟩⟩ + | .error err s' => + rw [hrun] at hwf + exact hwf + +end TcM + +/-- Declarative sufficiency of one normalized context-digest input. This is +the semantic half of K2's suffix theorem: equality of the exact input—not +equality of its Blake3 output—must preserve each judgment family at the +radius that production requested. -/ +structure ContextSuffixSemantics {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} (spec : ContextDigestSpec trProj world uvars) : Prop where + whnf : ∀ {Delta Delta' : KVLCtx} {source result : KExpr .anon}, + spec.inputOf source.lbr Delta = spec.inputOf source.lbr Delta' → + WhnfMeaning trProj world uvars Delta source result → + WhnfMeaning trProj world uvars Delta' source result + infer : ∀ {Delta Delta' : KVLCtx} {source ty : KExpr .anon}, + spec.inputOf source.lbr Delta = spec.inputOf source.lbr Delta' → + InferMeaning trProj world uvars Delta source ty → + InferMeaning trProj world uvars Delta' source ty + defEq : ∀ {Delta Delta' : KVLCtx} {a b : KExpr .anon} {answer : Bool}, + spec.inputOf (max a.lbr b.lbr) Delta = + spec.inputOf (max a.lbr b.lbr) Delta' → + DefEqMeaning trProj world uvars Delta a b answer → + DefEqMeaning trProj world uvars Delta' a b answer + isProp : ∀ {Delta Delta' : KVLCtx} {source : KExpr .anon} + {answer : Bool}, + spec.inputOf source.lbr Delta = spec.inputOf source.lbr Delta' → + IsPropMeaning trProj world uvars Delta source answer → + IsPropMeaning trProj world uvars Delta' source answer + +/-- Joint suffix model whose representation theorem is restricted to states +in one explicit domain. This is the correct shape for a finite execution +scope: unlike `KernelSuffixModel`, it does not quantify key construction over +every context-reconciled state in existence. -/ +structure ScopedKernelSuffixModel (trProj : RawProjRel) + (world : VerifyWorld) where + keys : WhnfContextKeys + StateInScope : TcState .anon → Prop + representsCtx : ∀ {before after : TcState .anon} {lbr : UInt64} + {ctxAddr : Address} {Delta : KVLCtx}, + StateInScope before → + CtxRecon world.venv keys.uvars world.nameOf trProj before Delta → + TcM.ctxAddrForLbr lbr before = .ok ctxAddr after → + keys.Represents lbr ctxAddr Delta + represents : ∀ {before after : TcState .anon} {key : Address × Address} + {Delta : KVLCtx} {source : KExpr .anon}, + StateInScope before → + CtxRecon world.venv keys.uvars world.nameOf trProj before Delta → + TcM.whnfKey source before = .ok key after → + keys.Represents source.lbr key.2 Delta + whnfTransport : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {source result : KExpr .anon}, + keys.Represents source.lbr ctxAddr Delta → + keys.Represents source.lbr ctxAddr Delta' → + WhnfMeaning trProj world keys.uvars Delta source result → + WhnfMeaning trProj world keys.uvars Delta' source result + inferTransport : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {source ty : KExpr .anon}, + keys.Represents source.lbr ctxAddr Delta → + keys.Represents source.lbr ctxAddr Delta' → + InferMeaning trProj world keys.uvars Delta source ty → + InferMeaning trProj world keys.uvars Delta' source ty + defEqTransport : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {a b : KExpr .anon} {answer : Bool}, + keys.Represents (max a.lbr b.lbr) ctxAddr Delta → + keys.Represents (max a.lbr b.lbr) ctxAddr Delta' → + DefEqMeaning trProj world keys.uvars Delta a b answer → + DefEqMeaning trProj world keys.uvars Delta' a b answer + isPropTransport : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {source : KExpr .anon} {answer : Bool}, + keys.Represents source.lbr ctxAddr Delta → + keys.Represents source.lbr ctxAddr Delta' → + IsPropMeaning trProj world keys.uvars Delta source answer → + IsPropMeaning trProj world keys.uvars Delta' source answer + +namespace ScopedKernelSuffixModel + +/-- Construct the genuinely run-scoped joint model. State membership is +exactly finite-scope capture for that state; no universal reachability claim +is smuggled into the constructor. -/ +def finiteOperational {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} (spec : ContextDigestSpec trProj world uvars) + (scope : ContextDigestScope spec) (hcollision : scope.CollisionFree) + (hsemantics : ContextSuffixSemantics spec) : + ScopedKernelSuffixModel trProj world where + keys := scopedOperationalWhnfContextKeys spec scope + StateInScope before := spec.StateValid before ∧ scope.Captures before + representsCtx hscope hctx hrun := + scopedOperationalWhnfContextKeys.representsCtx hscope.1 hscope.2 hctx hrun + represents hscope hctx hrun := + scopedOperationalWhnfContextKeys.represents hscope.1 hscope.2 hctx hrun + whnfTransport hDelta hDelta' hmeaning := by + apply hsemantics.whnf _ hmeaning + apply hcollision + · exact scopedOperationalWhnfContextKeys.mem hDelta + · exact scopedOperationalWhnfContextKeys.mem hDelta' + · exact (scopedOperationalWhnfContextKeys.digest_eq hDelta).trans + (scopedOperationalWhnfContextKeys.digest_eq hDelta').symm + inferTransport hDelta hDelta' hmeaning := by + apply hsemantics.infer _ hmeaning + apply hcollision + · exact scopedOperationalWhnfContextKeys.mem hDelta + · exact scopedOperationalWhnfContextKeys.mem hDelta' + · exact (scopedOperationalWhnfContextKeys.digest_eq hDelta).trans + (scopedOperationalWhnfContextKeys.digest_eq hDelta').symm + defEqTransport hDelta hDelta' hmeaning := by + apply hsemantics.defEq _ hmeaning + apply hcollision + · exact scopedOperationalWhnfContextKeys.mem hDelta + · exact scopedOperationalWhnfContextKeys.mem hDelta' + · exact (scopedOperationalWhnfContextKeys.digest_eq hDelta).trans + (scopedOperationalWhnfContextKeys.digest_eq hDelta').symm + isPropTransport hDelta hDelta' hmeaning := by + apply hsemantics.isProp _ hmeaning + apply hcollision + · exact scopedOperationalWhnfContextKeys.mem hDelta + · exact scopedOperationalWhnfContextKeys.mem hDelta' + · exact (scopedOperationalWhnfContextKeys.digest_eq hDelta).trans + (scopedOperationalWhnfContextKeys.digest_eq hDelta').symm + +/-- Forget the state domain only after proving that it contains every state +quantified by the legacy universal interface. Finite run proofs should use +the scoped model directly; this conversion is intentionally stronger. -/ +def toKernelSuffixModel {trProj : RawProjRel} {world : VerifyWorld} + (model : ScopedKernelSuffixModel trProj world) + (hcomplete : ∀ before, model.StateInScope before) : + KernelSuffixModel trProj world where + keys := model.keys + representsCtx hctx hrun := model.representsCtx (hcomplete _) hctx hrun + represents hctx hrun := model.represents (hcomplete _) hctx hrun + whnfTransport := model.whnfTransport + inferTransport := model.inferTransport + defEqTransport := model.defEqTransport + isPropTransport := model.isPropTransport + +end ScopedKernelSuffixModel + +namespace KernelSuffixModel + +/-- Forget the K2 transports and recover exactly the K1 suffix model. -/ +def toWhnfSuffixModel {trProj : RawProjRel} {world : VerifyWorld} + (model : KernelSuffixModel trProj world) : + WhnfSuffixModel trProj world where + keys := model.keys + represents := model.represents + transport := model.whnfTransport + +/-- Build the joint model over the canonical operational representation. +Only the four semantic same-digest transports remain as assumptions; actual +key membership is derived from production executions. -/ +def operational {trProj : RawProjRel} {world : VerifyWorld} (uvars : Nat) + (hwhnf : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {source result : KExpr .anon}, + (operationalWhnfContextKeys trProj world uvars).Represents + source.lbr ctxAddr Delta → + (operationalWhnfContextKeys trProj world uvars).Represents + source.lbr ctxAddr Delta' → + WhnfMeaning trProj world uvars Delta source result → + WhnfMeaning trProj world uvars Delta' source result) + (hinfer : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {source ty : KExpr .anon}, + (operationalWhnfContextKeys trProj world uvars).Represents + source.lbr ctxAddr Delta → + (operationalWhnfContextKeys trProj world uvars).Represents + source.lbr ctxAddr Delta' → + InferMeaning trProj world uvars Delta source ty → + InferMeaning trProj world uvars Delta' source ty) + (hdefeq : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {a b : KExpr .anon} {answer : Bool}, + (operationalWhnfContextKeys trProj world uvars).Represents + (max a.lbr b.lbr) ctxAddr Delta → + (operationalWhnfContextKeys trProj world uvars).Represents + (max a.lbr b.lbr) ctxAddr Delta' → + DefEqMeaning trProj world uvars Delta a b answer → + DefEqMeaning trProj world uvars Delta' a b answer) + (hisProp : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {source : KExpr .anon} {answer : Bool}, + (operationalWhnfContextKeys trProj world uvars).Represents + source.lbr ctxAddr Delta → + (operationalWhnfContextKeys trProj world uvars).Represents + source.lbr ctxAddr Delta' → + IsPropMeaning trProj world uvars Delta source answer → + IsPropMeaning trProj world uvars Delta' source answer) : + KernelSuffixModel trProj world where + keys := operationalWhnfContextKeys trProj world uvars + representsCtx hctx hrun := + operationalWhnfContextKeys.representsCtx hctx hrun + represents hctx hrun := + operationalWhnfContextKeys.represents hctx hrun + whnfTransport hDelta hDelta' hmeaning := + hwhnf hDelta hDelta' hmeaning + inferTransport hDelta hDelta' hmeaning := + hinfer hDelta hDelta' hmeaning + defEqTransport hDelta hDelta' hmeaning := + hdefeq hDelta hDelta' hmeaning + isPropTransport hDelta hDelta' hmeaning := + hisProp hDelta hDelta' hmeaning + +/-- Universal corollary of the finite scoped construction. It is available +only when every state quantified by `KernelSuffixModel` satisfies both the +digest state invariant and finite-scope capture. The proof uses separately +named facts: + +* `ContextDigestSpec.StateValid` and `execution` connect real key computation + (including memo hits) to the exact normalized digest input; +* `ContextDigestScope.Captures` keeps every admitted execution inside the + finite list; +* `ContextDigestScope.CollisionFree` turns equal composite digests into + equal normalized inputs only on that list; and +* `ContextSuffixSemantics` transports the four declarative meanings across + equal inputs. + +No expression-address collision theorem appears in this construction. -/ +def finiteOperational {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} (spec : ContextDigestSpec trProj world uvars) + (scope : ContextDigestScope spec) + (hstates : ∀ before, spec.StateValid before ∧ scope.Captures before) + (hcollision : scope.CollisionFree) + (hsemantics : ContextSuffixSemantics spec) : + KernelSuffixModel trProj world := + (ScopedKernelSuffixModel.finiteOperational + spec scope hcollision hsemantics).toKernelSuffixModel hstates + +end KernelSuffixModel + +/-- Exact validity of the memoized proposition classifier. A key is +interpreted only through a finite-support expression witness and a represented +suffix context; the fallback owns every other cache family. -/ +def IsPropCacheValid (keys : WhnfContextKeys) (trProj : RawProjRel) + (fallback : CacheSemantics) (authority : CacheAuthority) + (support : RunSupport) : CacheEntry → Prop + | .isProp key answer => + ∀ source, support source → source.addr = key.1 → + ∀ Delta, keys.Represents source.lbr key.2 Delta → + IsPropMeaning trProj authority.world keys.uvars Delta source answer + | entry => fallback.Valid authority support entry + +namespace IsPropCacheValid + +theorem mono {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {before after : CacheAuthority} + {support : RunSupport} {entry : CacheEntry} (hle : before ≤ after) + (h : IsPropCacheValid keys trProj fallback before support entry) : + IsPropCacheValid keys trProj fallback after support entry := by + cases entry with + | isProp key answer => + intro source hsource haddr Delta hrepresented + exact (h source hsource haddr Delta hrepresented).mono hle.world + | expr | defEq | defEqFailure | unfold | natSuccStuck | isRec | + recursor | recMajors | blockPeer | blockResult => + exact fallback.mono hle h + +theorem result {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {key : Address × Address} {answer : Bool} + {source : KExpr .anon} + (h : IsPropCacheValid keys trProj fallback authority support + (.isProp key answer)) + (hsource : support source) (haddr : source.addr = key.1) + {Delta : KVLCtx} + (hrepresented : keys.Represents source.lbr key.2 Delta) : + IsPropMeaning trProj authority.world keys.uvars Delta source answer := + h source hsource haddr Delta hrepresented + +end IsPropCacheValid + +/-- Overlay the proposition-classifier meaning on an arbitrary fallback +cache semantics. -/ +def isPropCacheSemantics (keys : WhnfContextKeys) (trProj : RawProjRel) + (fallback : CacheSemantics) : CacheSemantics where + Valid := IsPropCacheValid keys trProj fallback + mono := IsPropCacheValid.mono + Equiv := fallback.Equiv + equivEquivalence := fallback.equivEquivalence + equivMono := fallback.equivMono + blockError := by + intro authority support block err + exact fallback.blockError authority support block err + +/-- Exact validity for full/cheap def-eq maps and the negative failure set. -/ +def DefEqCacheValid (keys : WhnfContextKeys) (trProj : RawProjRel) + (fallback : CacheSemantics) (authority : CacheAuthority) + (support : RunSupport) : CacheEntry → Prop + | .defEq _ key answer => + ∀ a, support a → a.addr = key.1 → + ∀ b, support b → b.addr = key.2.1 → + ∀ Delta, keys.Represents (max a.lbr b.lbr) key.2.2 Delta → + DefEqMeaning trProj authority.world keys.uvars Delta a b answer + | .defEqFailure _ => True + | entry => fallback.Valid authority support entry + +namespace DefEqCacheValid + +theorem mono {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {before after : CacheAuthority} + {support : RunSupport} {entry : CacheEntry} (hle : before ≤ after) + (h : DefEqCacheValid keys trProj fallback before support entry) : + DefEqCacheValid keys trProj fallback after support entry := by + cases entry with + | defEq kind key answer => + intro a ha haddrA b hb haddrB Delta hctx + exact (h a ha haddrA b hb haddrB Delta hctx).mono hle.world + | defEqFailure => trivial + | expr | unfold | natSuccStuck | isProp | isRec | recursor | recMajors | + blockPeer | blockResult => + exact fallback.mono hle h + +theorem result {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {kind : DefEqCacheKind} + {key : Address × Address × Address} {answer : Bool} + {a b : KExpr .anon} + (h : DefEqCacheValid keys trProj fallback authority support + (.defEq kind key answer)) + (ha : support a) (haddrA : a.addr = key.1) + (hb : support b) (haddrB : b.addr = key.2.1) + {Delta : KVLCtx} + (hctx : keys.Represents (max a.lbr b.lbr) key.2.2 Delta) : + DefEqMeaning trProj authority.world keys.uvars Delta a b answer := + h a ha haddrA b hb haddrB Delta hctx + +end DefEqCacheValid + +/-- Overlay K2 def-eq meanings on K1+inference cache semantics. -/ +def defEqCacheSemantics (keys : WhnfContextKeys) (trProj : RawProjRel) + (fallback : CacheSemantics) : CacheSemantics where + Valid := DefEqCacheValid keys trProj fallback + mono := DefEqCacheValid.mono + Equiv := DefEqKeyEquiv keys trProj + equivEquivalence := DefEqKeyEquiv.equivalence keys trProj + equivMono := DefEqKeyEquiv.mono + blockError := by + intro authority support block err + exact fallback.blockError authority support block err + +/-- Canonical K1+K2 semantic stack. K1's WHNF and fixed-universe unfold +layers stay outermost; inference and def-eq occupy precisely the fallback +families they own. -/ +def kernelCacheSemantics (keys : WhnfContextKeys) (trProj : RawProjRel) : + CacheSemantics := + k1CacheSemantics keys trProj <| + inferCacheSemantics keys trProj <| + defEqCacheSemantics keys trProj <| + isPropCacheSemantics keys trProj <| + isRecCacheSemantics CacheSemantics.blockErrorsOnly + +/-- The canonical cache stack owns both final and conservative/provisional +recursion-classifier entries for every trusted anonymous identifier. -/ +theorem kernelCacheSemantics_isRec_valid + {keys : WhnfContextKeys} {trProj : RawProjRel} + {authority : CacheAuthority} {support : RunSupport} + {ind : KId .anon} {value : Bool} + (htrusted : authority.world.trusted ind) : + (kernelCacheSemantics keys trProj).Valid authority support + (.isRec ind.addr value) := by + change IsRecCacheValid CacheSemantics.blockErrorsOnly authority support + (.isRec ind.addr value) + exact IsRecCacheValid.trusted + (fallback := CacheSemantics.blockErrorsOnly) (support := support) + (value := value) htrusted + +namespace CacheProvenance + +/-- Read one proposition-classifier entry from the canonical cache stack. -/ +theorem kernelIsPropMeaning {keys : WhnfContextKeys} + {trProj : RawProjRel} {authority : CacheAuthority} + {support : RunSupport} {key : Address × Address} {answer : Bool} + {source : KExpr .anon} + (h : CacheProvenance (kernelCacheSemantics keys trProj) + authority support (.isProp key answer)) + (hsource : support source) (haddr : source.addr = key.1) + {Delta : KVLCtx} + (hrepresented : keys.Represents source.lbr key.2 Delta) : + IsPropMeaning trProj authority.world keys.uvars Delta source answer := + IsPropCacheValid.result + (fallback := isRecCacheSemantics CacheSemantics.blockErrorsOnly) + h.valid hsource haddr hrepresented + +/-- Full and cheap DefEq partitions have identical semantic validity; only +their lookup policy differs. A certified entry can therefore be copied +between partitions without re-proving its witnesses, references, or result. -/ +theorem kernelDefEqRekind {keys : WhnfContextKeys} + {trProj : RawProjRel} {authority : CacheAuthority} + {support : RunSupport} {source target : DefEqCacheKind} + {key : Address × Address × Address} {answer : Bool} + (h : CacheProvenance (kernelCacheSemantics keys trProj) + authority support (.defEq source key answer)) : + CacheProvenance (kernelCacheSemantics keys trProj) + authority support (.defEq target key answer) := by + refine ⟨h.supported, h.references, ?_⟩ + simpa [kernelCacheSemantics, k1CacheSemantics, whnfCacheSemantics, + WhnfCacheValid, unfoldCacheSemantics, UnfoldCacheValid, + inferCacheSemantics, InferCacheValid, defEqCacheSemantics, + DefEqCacheValid] using h.valid + +theorem kernelWhnfMeaningOfMatches {keys : WhnfContextKeys} + {trProj : RawProjRel} {authority : CacheAuthority} + {support : RunSupport} {kind : ExprCacheKind} + {key : Address × Address} {value source : KExpr .anon} + {s : TcState .anon} {Delta : KVLCtx} + (h : CacheProvenance (kernelCacheSemantics keys trProj) + authority support (.expr kind key value)) + (hkind : kind.IsWhnf) (hsource : support source) + (hmatch : keys.Matches trProj authority.world s Delta source key) : + WhnfMeaning trProj authority.world keys.uvars Delta source value := + WhnfCacheValid.expr hkind h.valid hsource hmatch.sourceAddr hmatch.2.1 + +theorem kernelInferMeaningOfMatches {keys : WhnfContextKeys} + {trProj : RawProjRel} {authority : CacheAuthority} + {support : RunSupport} {kind : ExprCacheKind} + {key : Address × Address} {ty source : KExpr .anon} + {s : TcState .anon} {Delta : KVLCtx} + (h : CacheProvenance (kernelCacheSemantics keys trProj) + authority support (.expr kind key ty)) + (hkind : kind.IsInfer) (hsource : support source) + (hmatch : keys.Matches trProj authority.world s Delta source key) : + InferMeaning trProj authority.world keys.uvars Delta source ty := by + cases hkind with + | infer => + apply InferCacheValid.expr + (fallback := defEqCacheSemantics keys trProj + CacheSemantics.blockErrorsOnly) .infer (hsource := hsource) + (haddr := hmatch.sourceAddr) (hctx := hmatch.2.1) + simpa [kernelCacheSemantics, k1CacheSemantics, whnfCacheSemantics, + WhnfCacheValid, unfoldCacheSemantics, UnfoldCacheValid] using + h.valid + | inferOnly => + apply InferCacheValid.expr + (fallback := defEqCacheSemantics keys trProj + CacheSemantics.blockErrorsOnly) .inferOnly (hsource := hsource) + (haddr := hmatch.sourceAddr) (hctx := hmatch.2.1) + simpa [kernelCacheSemantics, k1CacheSemantics, whnfCacheSemantics, + WhnfCacheValid, unfoldCacheSemantics, UnfoldCacheValid] using + h.valid + +theorem kernelDefEqMeaning {keys : WhnfContextKeys} + {trProj : RawProjRel} {authority : CacheAuthority} + {support : RunSupport} {kind : DefEqCacheKind} + {key : Address × Address × Address} {answer : Bool} + {a b : KExpr .anon} + (h : CacheProvenance (kernelCacheSemantics keys trProj) + authority support (.defEq kind key answer)) + (ha : support a) (haddrA : a.addr = key.1) + (hb : support b) (haddrB : b.addr = key.2.1) + {Delta : KVLCtx} + (hctx : keys.Represents (max a.lbr b.lbr) key.2.2 Delta) : + DefEqMeaning trProj authority.world keys.uvars Delta a b answer := by + apply DefEqCacheValid.result (keys := keys) (trProj := trProj) + (fallback := CacheSemantics.blockErrorsOnly) (kind := kind) + (ha := ha) (haddrA := haddrA) (hb := hb) (haddrB := haddrB) + (hctx := hctx) + simpa [kernelCacheSemantics, k1CacheSemantics, whnfCacheSemantics, + WhnfCacheValid, unfoldCacheSemantics, UnfoldCacheValid, + inferCacheSemantics, InferCacheValid] using h.valid + +/-- Eliminate a physical DefEq cache entry in the caller's original order. +The production key stores the canonical address order, so the swapped branch +uses semantic symmetry explicitly rather than silently identifying operands. -/ +theorem kernelDefEqMeaningCanonical {keys : WhnfContextKeys} + {trProj : RawProjRel} {authority : CacheAuthority} + {support : RunSupport} {kind : DefEqCacheKind} + {ctxAddr : Address} {answer : Bool} {a b : KExpr .anon} + (h : CacheProvenance (kernelCacheSemantics keys trProj) + authority support + (.defEq kind + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer)) + (ha : support a) (hb : support b) + {Delta : KVLCtx} + (hctx : keys.Represents (max a.lbr b.lbr) ctxAddr Delta) : + DefEqMeaning trProj authority.world keys.uvars Delta a b answer := by + by_cases horder : a.addr.cmpBytes b.addr != .gt + · have hpair : canonicalPair a.addr b.addr = (a.addr, b.addr) := by + simp [canonicalPair, horder] + rw [hpair] at h + exact h.kernelDefEqMeaning ha rfl hb rfl hctx + · have hpair : canonicalPair a.addr b.addr = (b.addr, a.addr) := by + simp [canonicalPair, horder] + rw [hpair] at h + have hctx' : keys.Represents (max b.lbr a.lbr) ctxAddr Delta := by + simpa [uint64_max_comm] using hctx + exact (h.kernelDefEqMeaning hb rfl ha rfl hctx').symm + +/-- A positive canonical cache entry is also a justified manager edge in the +caller's original operand order. Collision freedom is used only to recover +the concrete supported expressions quantified by the edge contract. -/ +theorem kernelDefEqEdgeCanonical {keys : WhnfContextKeys} + {trProj : RawProjRel} {authority : CacheAuthority} + {support : RunSupport} {kind : DefEqCacheKind} + {ctxAddr : Address} {a b : KExpr .anon} + (h : CacheProvenance (kernelCacheSemantics keys trProj) + authority support + (.defEq kind + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true)) + (hcollision : support.CollisionFree) + (ha : support a) (hb : support b) : + DefEqKeyEdge keys trProj authority support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ where + context_eq := rfl + radius_eq := rfl + leftWitness := ⟨a, ha, rfl, rfl⟩ + rightWitness := ⟨b, hb, rfl, rfl⟩ + meaning otherA hotherA haddrA otherB hotherB haddrB Delta hrepresented := by + have heqA : a = otherA := by + have herase := hcollision.expr ha hotherA haddrA.symm + simpa only [KExpr.eraseMeta_anon] using herase + have heqB : b = otherB := by + have herase := hcollision.expr hb hotherB haddrB.symm + simpa only [KExpr.eraseMeta_anon] using herase + subst otherA + subst otherB + exact h.kernelDefEqMeaningCanonical ha hb hrepresented + +/-- Package a positive canonical cache entry as the equivalence relation +consumed by `EquivManager.WF.addEquiv`. -/ +theorem kernelDefEqEquivCanonical {keys : WhnfContextKeys} + {trProj : RawProjRel} {authority : CacheAuthority} + {support : RunSupport} {kind : DefEqCacheKind} + {ctxAddr : Address} {a b : KExpr .anon} + (h : CacheProvenance (kernelCacheSemantics keys trProj) + authority support + (.defEq kind + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true)) + (hcollision : support.CollisionFree) + (ha : support a) (hb : support b) : + DefEqKeyEquiv keys trProj authority support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ := + .cons (.forward (h.kernelDefEqEdgeCanonical hcollision ha hb)) (.refl _) + +/-- Interpret a positive root-derived cache hit without treating a root +address as an expression. Each manager path supplies a supported endpoint +witness; the runtime scope guard proves that those endpoints reconstruct the +same represented suffix radius as the caller. The result is the composition +`a ≃ root(a) ≃ root(b) ≃ b`. -/ +theorem kernelDefEqRootAcceptance {keys : WhnfContextKeys} + {trProj : RawProjRel} {authority : CacheAuthority} + {support : RunSupport} {kind : DefEqCacheKind} + {ctxAddr : Address} {lbr : UInt64} + {a b : KExpr .anon} {aRoot bRoot : EqKey} + {Delta : KVLCtx} {va vb : VExpr} + (h : CacheProvenance (kernelCacheSemantics keys trProj) + authority support + (.defEq kind + ((canonicalPair aRoot.exprAddr bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr bRoot.exprAddr).2, ctxAddr) true)) + (theory : WhnfTheory trProj authority.world keys.uvars) + (hDelta : KVLCtx.WF authority.world.venv keys.uvars Delta) + (hcollision : support.CollisionFree) + (haPath : DefEqKeyEquiv keys trProj authority support + ⟨a.addr, ctxAddr, lbr, a.lbr⟩ aRoot) + (hbPath : DefEqKeyEquiv keys trProj authority support + ⟨b.addr, ctxAddr, lbr, b.lbr⟩ bRoot) + (hscope : aRoot.rootCacheScopeMatches bRoot ctxAddr lbr = true) + (hrepresented : keys.Represents lbr ctxAddr Delta) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS authority.world.venv keys.uvars authority.world.nameOf + trProj Delta a va) + (hb : TrKExprS authority.world.venv keys.uvars authority.world.nameOf + trProj Delta b vb) : + authority.world.venv.IsDefEqU keys.uvars Delta.toCtx va vb := by + obtain ⟨rootA, hrootASupport, hrootAAddr, hrootALbr⟩ := + haPath.targetWitness haSupport rfl rfl + obtain ⟨rootB, hrootBSupport, hrootBAddr, hrootBLbr⟩ := + hbPath.targetWitness hbSupport rfl rfl + have hscopeFields := + (EqKey.rootCacheScopeMatches_iff aRoot bRoot ctxAddr lbr).mp hscope + have hrootRepresented : + keys.Represents (max rootA.lbr rootB.lbr) ctxAddr Delta := by + rw [hrootALbr, hrootBLbr, hscopeFields.2.2.2.2] + exact hrepresented + have hrootCache : + CacheProvenance (kernelCacheSemantics keys trProj) authority support + (.defEq kind + ((canonicalPair rootA.addr rootB.addr).1, + (canonicalPair rootA.addr rootB.addr).2, ctxAddr) true) := by + simpa only [hrootAAddr, hrootBAddr] using h + have hrootMeaning : + DefEqMeaning trProj authority.world keys.uvars Delta rootA rootB true := + hrootCache.kernelDefEqMeaningCanonical + hrootASupport hrootBSupport hrootRepresented + obtain ⟨rootVA, rootVB, hrootATr, hrootBTr, hrootEq⟩ := hrootMeaning rfl + have haRootEq : authority.world.venv.IsDefEqU keys.uvars Delta.toCtx + va rootVA := + haPath.sound theory hDelta hcollision + haSupport rfl hrootASupport hrootAAddr hrepresented ha hrootATr + have hbRootEq : authority.world.venv.IsDefEqU keys.uvars Delta.toCtx + vb rootVB := + hbPath.sound theory hDelta hcollision + hbSupport rfl hrootBSupport hrootBAddr hrepresented hb hrootBTr + exact (haRootEq.trans authority.world.venvWF hDelta hrootEq).trans + authority.world.venvWF hDelta hbRootEq.symm + +theorem defEqMeaning {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {kind : DefEqCacheKind} + {key : Address × Address × Address} {answer : Bool} + {a b : KExpr .anon} + (h : CacheProvenance (defEqCacheSemantics keys trProj fallback) + authority support (.defEq kind key answer)) + (ha : support a) (haddrA : a.addr = key.1) + (hb : support b) (haddrB : b.addr = key.2.1) + {Delta : KVLCtx} + (hctx : keys.Represents (max a.lbr b.lbr) key.2.2 Delta) : + DefEqMeaning trProj authority.world keys.uvars Delta a b answer := + DefEqCacheValid.result (keys := keys) (trProj := trProj) + (fallback := fallback) (kind := kind) h.valid ha haddrA hb haddrB hctx + +end CacheProvenance + +namespace KernelSuffixModel + +/-- Turn one executed proposition-classifier result into collision-robust +provenance for the memo table. -/ +theorem isPropProvenance {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : KernelSuffixModel trProj world) + (hcollision : support.CollisionFree) + {Delta : KVLCtx} {source : KExpr .anon} {answer : Bool} + {ctxAddr : Address} + (hsource : support source) + (hctx : model.keys.Represents source.lbr ctxAddr Delta) + (hmeaning : IsPropMeaning trProj world model.keys.uvars Delta source + answer) + (hreferences : + (CacheEntry.isProp (source.addr, ctxAddr) answer).ReferencesAuthorized + (CacheAuthority.stable world) support) : + CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.isProp (source.addr, ctxAddr) answer) := by + refine ⟨⟨source, hsource, rfl⟩, hreferences, ?_⟩ + have hvalid : IsPropCacheValid model.keys trProj + (isRecCacheSemantics CacheSemantics.blockErrorsOnly) + (CacheAuthority.stable world) support + (.isProp (source.addr, ctxAddr) answer) := by + intro other hother haddr Delta' hrepresented + have heq : source = other := by + have herase := hcollision.expr hsource hother haddr.symm + simpa only [KExpr.eraseMeta_anon] using herase + subst other + exact model.isPropTransport hctx hrepresented hmeaning + simpa [kernelCacheSemantics, k1CacheSemantics, whnfCacheSemantics, + WhnfCacheValid, unfoldCacheSemantics, UnfoldCacheValid, + inferCacheSemantics, InferCacheValid, defEqCacheSemantics, + DefEqCacheValid, isPropCacheSemantics] using hvalid + +/-- Turn one executed inference result into collision-robust provenance for +either inference cache. Validity quantifies over every supported expression +sharing the source address and every context sharing the suffix digest. -/ +theorem inferProvenance {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : KernelSuffixModel trProj world) + (hcollision : support.CollisionFree) + {kind : ExprCacheKind} (hkind : kind.IsInfer) + {Delta : KVLCtx} {source ty : KExpr .anon} + {key : Address × Address} {s : TcState .anon} + (hsource : support source) (hty : support ty) + (hmatch : model.keys.Matches trProj world s Delta source key) + (hmeaning : InferMeaning trProj world model.keys.uvars Delta source ty) + (hreferences : (CacheEntry.expr kind key ty).ReferencesAuthorized + (CacheAuthority.stable world) support) : + CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support (.expr kind key ty) := by + have hall : ∀ other, support other → other.addr = key.1 → + ∀ Delta', model.keys.Represents other.lbr key.2 Delta' → + InferMeaning trProj world model.keys.uvars Delta' other ty := by + intro other hother haddr Delta' hrepresented + have heq : source = other := by + have herase := hcollision.expr hsource hother + (hmatch.sourceAddr.trans haddr.symm) + simpa only [KExpr.eraseMeta_anon] using herase + subst other + exact model.inferTransport hmatch.2.1 hrepresented hmeaning + refine ⟨⟨⟨source, hsource, hmatch.sourceAddr⟩, hty⟩, + hreferences, ?_⟩ + cases hkind with + | infer => + have hvalid : InferCacheValid model.keys trProj + (defEqCacheSemantics model.keys trProj + CacheSemantics.blockErrorsOnly) + (CacheAuthority.stable world) support + (.expr .infer key ty) := hall + simpa [kernelCacheSemantics, k1CacheSemantics, whnfCacheSemantics, + WhnfCacheValid, unfoldCacheSemantics, UnfoldCacheValid] using + hvalid + | inferOnly => + have hvalid : InferCacheValid model.keys trProj + (defEqCacheSemantics model.keys trProj + CacheSemantics.blockErrorsOnly) + (CacheAuthority.stable world) support + (.expr .inferOnly key ty) := hall + simpa [kernelCacheSemantics, k1CacheSemantics, whnfCacheSemantics, + WhnfCacheValid, unfoldCacheSemantics, UnfoldCacheValid] using + hvalid + +/-- Turn one executed DefEq result into collision-robust provenance for the +canonicalized production key. The swapped canonical-pair branch transports +the semantic result through symmetry explicitly. -/ +theorem defEqProvenance {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : KernelSuffixModel trProj world) + (hcollision : support.CollisionFree) (kind : DefEqCacheKind) + {Delta : KVLCtx} {a b : KExpr .anon} {answer : Bool} + {ctxAddr : Address} + (ha : support a) (hb : support b) + (hctx : model.keys.Represents (max a.lbr b.lbr) ctxAddr Delta) + (hmeaning : DefEqMeaning trProj world model.keys.uvars Delta a b answer) + (hreferences : + (CacheEntry.defEq kind + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer).ReferencesAuthorized + (CacheAuthority.stable world) support) : + CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq kind + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer) := by + by_cases horder : a.addr.cmpBytes b.addr != .gt + · have hpair : canonicalPair a.addr b.addr = (a.addr, b.addr) := by + simp [canonicalPair, horder] + rw [hpair] at hreferences ⊢ + refine ⟨⟨⟨a, ha, rfl⟩, ⟨b, hb, rfl⟩⟩, hreferences, ?_⟩ + have hvalid : DefEqCacheValid model.keys trProj + CacheSemantics.blockErrorsOnly (CacheAuthority.stable world) support + (.defEq kind (a.addr, b.addr, ctxAddr) answer) := by + intro otherA hotherA haddrA otherB hotherB haddrB Delta' hrepresented + have heqA : a = otherA := by + have herase := hcollision.expr ha hotherA haddrA.symm + simpa only [KExpr.eraseMeta_anon] using herase + have heqB : b = otherB := by + have herase := hcollision.expr hb hotherB haddrB.symm + simpa only [KExpr.eraseMeta_anon] using herase + subst otherA + subst otherB + exact model.defEqTransport hctx hrepresented hmeaning + simpa [kernelCacheSemantics, k1CacheSemantics, whnfCacheSemantics, + WhnfCacheValid, unfoldCacheSemantics, UnfoldCacheValid, + inferCacheSemantics, InferCacheValid] using hvalid + · have hpair : canonicalPair a.addr b.addr = (b.addr, a.addr) := by + simp [canonicalPair, horder] + rw [hpair] at hreferences ⊢ + refine ⟨⟨⟨b, hb, rfl⟩, ⟨a, ha, rfl⟩⟩, hreferences, ?_⟩ + have hvalid : DefEqCacheValid model.keys trProj + CacheSemantics.blockErrorsOnly (CacheAuthority.stable world) support + (.defEq kind (b.addr, a.addr, ctxAddr) answer) := by + intro otherA hotherA haddrA otherB hotherB haddrB Delta' hrepresented + have heqA : b = otherA := by + have herase := hcollision.expr hb hotherA haddrA.symm + simpa only [KExpr.eraseMeta_anon] using herase + have heqB : a = otherB := by + have herase := hcollision.expr ha hotherB haddrB.symm + simpa only [KExpr.eraseMeta_anon] using herase + subst otherA + subst otherB + have hctx' : model.keys.Represents + (max b.lbr a.lbr) ctxAddr Delta := by + simpa [uint64_max_comm] using hctx + exact model.defEqTransport hctx' hrepresented hmeaning.symm + simpa [kernelCacheSemantics, k1CacheSemantics, whnfCacheSemantics, + WhnfCacheValid, unfoldCacheSemantics, UnfoldCacheValid, + inferCacheSemantics, InferCacheValid] using hvalid + +/-- A narrow same-head failure marker is rejection-only, so it needs no +semantic transport. It still records finite source witnesses and explicit +reference authorization for the canonical operand pair. -/ +theorem defEqFailureProvenance {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : KernelSuffixModel trProj world) + {a b : KExpr .anon} {ctxAddr : Address} + (ha : support a) (hb : support b) + (hreferences : + (CacheEntry.defEqFailure + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)).ReferencesAuthorized + (CacheAuthority.stable world) support) : + CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEqFailure + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)) := by + by_cases horder : a.addr.cmpBytes b.addr != .gt + · have hpair : canonicalPair a.addr b.addr = (a.addr, b.addr) := by + simp [canonicalPair, horder] + rw [hpair] at hreferences ⊢ + refine ⟨⟨⟨a, ha, rfl⟩, ⟨b, hb, rfl⟩⟩, hreferences, ?_⟩ + have hvalid : DefEqCacheValid model.keys trProj + CacheSemantics.blockErrorsOnly (CacheAuthority.stable world) support + (.defEqFailure (a.addr, b.addr, ctxAddr)) := trivial + simpa [kernelCacheSemantics, k1CacheSemantics, whnfCacheSemantics, + WhnfCacheValid, unfoldCacheSemantics, UnfoldCacheValid, + inferCacheSemantics, InferCacheValid] using hvalid + · have hpair : canonicalPair a.addr b.addr = (b.addr, a.addr) := by + simp [canonicalPair, horder] + rw [hpair] at hreferences ⊢ + refine ⟨⟨⟨b, hb, rfl⟩, ⟨a, ha, rfl⟩⟩, hreferences, ?_⟩ + have hvalid : DefEqCacheValid model.keys trProj + CacheSemantics.blockErrorsOnly (CacheAuthority.stable world) support + (.defEqFailure (b.addr, a.addr, ctxAddr)) := trivial + simpa [kernelCacheSemantics, k1CacheSemantics, whnfCacheSemantics, + WhnfCacheValid, unfoldCacheSemantics, UnfoldCacheValid, + inferCacheSemantics, InferCacheValid] using hvalid + +end KernelSuffixModel + +namespace RecM + +namespace IsPropCacheUpdate + +/-- Installing one certified proposition classification changes only its +dedicated memo map and preserves the complete checker invariant. -/ +theorem whnfStateInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {key : Address × Address} {answer : Bool} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hnew : CacheProvenance semantics (CacheAuthority.stable world) support + (.isProp key answer)) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with env := {s.env with + isPropCache := s.env.isPropCache.insert key answer}} := by + rcases hI with ⟨hkernel, hctx, hlayer⟩ + refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ + · exact hkernel.core.of_consts_eq rfl (by + simpa using hkernel.core.intern) + · simpa using hkernel.internSupport + · exact hkernel.caches.insertIsProp hnew + · exact hkernel.equivalences + · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer + +end IsPropCacheUpdate + +namespace DefEqCacheUpdate + +/-- Installing a certified full DefEq answer changes only the full result +partition and preserves the complete checker invariant. -/ +theorem full_whnfStateInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {key : Address × Address × Address} {answer : Bool} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hnew : CacheProvenance semantics (CacheAuthority.stable world) support + (.defEq .full key answer)) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with env := {s.env with + defEqCache := s.env.defEqCache.insert key answer}} := by + rcases hI with ⟨hkernel, hctx, hlayer⟩ + refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ + · exact hkernel.core.of_consts_eq rfl (by + simpa using hkernel.core.intern) + · simpa using hkernel.internSupport + · exact hkernel.caches.insertDefEq hnew + · exact hkernel.equivalences + · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer + +/-- Installing a certified cheap DefEq answer preserves partition separation; +promotion of a sound `true` into the full map is a distinct update. -/ +theorem cheap_whnfStateInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {key : Address × Address × Address} {answer : Bool} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hnew : CacheProvenance semantics (CacheAuthority.stable world) support + (.defEq .cheap key answer)) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with env := {s.env with + defEqCheapCache := s.env.defEqCheapCache.insert key answer}} := by + rcases hI with ⟨hkernel, hctx, hlayer⟩ + refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ + · exact hkernel.core.of_consts_eq rfl (by + simpa using hkernel.core.intern) + · simpa using hkernel.internSupport + · exact hkernel.caches.insertDefEqCheap hnew + · exact hkernel.equivalences + · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer + +/-- Recording a certified narrow failure marker preserves the checker +invariant. This write cannot contribute to an acceptance proof. -/ +theorem failure_whnfStateInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {key : Address × Address × Address} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hnew : CacheProvenance semantics (CacheAuthority.stable world) support + (.defEqFailure key)) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with env := {s.env with + defEqFailure := s.env.defEqFailure.insert key}} := by + rcases hI with ⟨hkernel, hctx, hlayer⟩ + refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ + · exact hkernel.core.of_consts_eq rfl (by + simpa using hkernel.core.intern) + · simpa using hkernel.internSupport + · exact hkernel.caches.insertDefEqFailure hnew + · exact hkernel.equivalences + · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer + +end DefEqCacheUpdate + +/-- Exact production execution for a positive equivalence-manager hit. The +query may path-compress the manager, but no semantic cache is consulted or +written on this branch. -/ +theorem isDefEq_equivHit_true + {methods : Methods .anon} {a b : KExpr .anon} + {ctxAddr : Address} {s s1 s2 s3 s4 : TcState .anon} + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok true s4) : + (isDefEq a b).run methods s = .ok true s4 := by + unfold isDefEq + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}")) _ s = _ + unfold EStateM.bind + rw [htrace] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1})) + _ s1 = _ + unfold EStateM.bind + rw [hstats] + simp only [haddr, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.defEqCtxKey a b) _ s2 = _ + unfold EStateM.bind + rw [hctx] + simp only + change ReaderT.run + ((liftM (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) : + RecM .anon Bool) >>= _) + methods s3 = _ + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) _ s3 = _ + unfold EStateM.bind + rw [hequiv] + simp + +/-- A positive manager hit is a Theory equality, not merely an optimization +claim. The manager path is interpreted through its supported edge chain at +the exact executed context/radius key. -/ +theorem isDefEq_equivHit_true_acceptance + {methods : Methods .anon} {layer : WhnfLayer} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {a b : KExpr .anon} {va vb : VExpr} + {ctxAddr : Address} {s s1 s2 s3 s4 : TcState .anon} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok true s4) + (hI : WhnfStateInv layer + (kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + trProj world support uvars Delta s) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv uvars world.nameOf trProj Delta b vb) : + (isDefEq a b).run methods s = .ok true s4 ∧ + WhnfStateInv layer + (kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + trProj world support uvars Delta s4 ∧ + world.venv.IsDefEqU uvars Delta.toCtx va vb := by + have htraceWf := + (TcM.stepTrace_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Delta := Delta) "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s) hI + rw [htrace] at htraceWf + have hstatsWf := + (TcM.bumpStats_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Delta := Delta) + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) s1) + htraceWf.1 + rw [hstats] at hstatsWf + have hctxWf := + (TcM.defEqCtxKey_wf (layer := layer) + (semantics := kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Delta := Delta) (a := a) (b := b) (s := s2)) + hstatsWf.1 + rw [hctx] at hctxWf + have hequivWf := + (TcM.withEquiv_isEquiv_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Delta := Delta) + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ s3) hctxWf.1 + rw [hequiv] at hequivWf + have hctxRun : + TcM.ctxAddrForLbr (max a.lbr b.lbr) s2 = .ok ctxAddr s3 := by + simpa [TcM.defEqCtxKey] using hctx + have hrepresented := operationalWhnfContextKeys.representsCtx + hstatsWf.1.2.1 hctxRun + have hrel := hequivWf.2 rfl + change DefEqKeyEquiv (operationalWhnfContextKeys trProj world uvars) + trProj (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ at hrel + have hsemantic := hrel.sound theory hequivWf.1.2.1.wf hcollision + haSupport rfl hbSupport rfl hrepresented ha hb + exact ⟨isDefEq_equivHit_true htrace hstats haddr hctx hequiv, + hequivWf.1, hsemantic⟩ + +/-- Exact production execution for the first positive full DefEq cache hit in +non-cheap mode. The only post-hit mutation is union-find insertion; the +semantic cache maps are unchanged. -/ +theorem isDefEq_fullHit_true + {methods : Methods .anon} {a b : KExpr .anon} + {ctxAddr : Address} {s s1 s2 s3 s4 : TcState .anon} + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = false) + (hhit : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = some true) : + (isDefEq a b).run methods s = .ok true + {s4 with equivManager := (s4.equivManager.addEquiv + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)} := by + unfold isDefEq + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}")) _ s = _ + unfold EStateM.bind + rw [htrace] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1})) + _ s1 = _ + unfold EStateM.bind + rw [hstats] + simp only [haddr, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.defEqCtxKey a b) _ s2 = _ + unfold EStateM.bind + rw [hctx] + simp only + change ReaderT.run + ((liftM (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) : + RecM .anon Bool) >>= _) + methods s3 = _ + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) _ s3 = _ + unfold EStateM.bind + rw [hequiv] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hcheap] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hhit, if_true] + rfl + +/-- A positive non-cheap full-cache hit is accepted by the real DefEq entry +point. Context membership comes from the executed `defEqCtxKey`; canonical +operand ordering is eliminated through cache provenance, and the union-find +write is proved semantically inert. -/ +theorem isDefEq_fullHit_true_acceptance + {methods : Methods .anon} {layer : WhnfLayer} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {a b : KExpr .anon} {va vb : VExpr} + {ctxAddr : Address} {s s1 s2 s3 s4 : TcState .anon} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = false) + (hhit : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = some true) + (hI : WhnfStateInv layer + (kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + trProj world support uvars Delta s) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv uvars world.nameOf trProj Delta b vb) : + let final := {s4 with equivManager := (s4.equivManager.addEquiv + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)} + (isDefEq a b).run methods s = .ok true final ∧ + WhnfStateInv layer + (kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + trProj world support uvars Delta final ∧ + world.venv.IsDefEqU uvars Delta.toCtx va vb := by + dsimp only + have htraceWf := + (TcM.stepTrace_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Delta := Delta) "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s) hI + rw [htrace] at htraceWf + have hI1 := htraceWf.1 + have hstatsWf := + (TcM.bumpStats_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Delta := Delta) + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) s1) hI1 + rw [hstats] at hstatsWf + have hI2 := hstatsWf.1 + have hctxWf := + (TcM.defEqCtxKey_wf (layer := layer) + (semantics := kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Delta := Delta) (a := a) (b := b) (s := s2)) hI2 + rw [hctx] at hctxWf + have hI3 := hctxWf.1 + have hequivWf := + (TcM.withEquiv_isEquiv_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Delta := Delta) + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ s3) hI3 + rw [hequiv] at hequivWf + have hI4 := hequivWf.1 + have hctxRun : + TcM.ctxAddrForLbr (max a.lbr b.lbr) s2 = .ok ctxAddr s3 := by + simpa [TcM.defEqCtxKey] using hctx + have hrepresented := operationalWhnfContextKeys.representsCtx + hI2.2.1 hctxRun + have hprovenance := hI4.1.caches.hit (.defEq hhit) + have hmeaning := hprovenance.kernelDefEqMeaningCanonical + haSupport hbSupport hrepresented + have hsemantic := DefEqMeaning.of_translations theory hI4.2.1.wf + ha hb hmeaning rfl + have hrel : + (kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj).Equiv + (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ := by + change DefEqKeyEquiv (operationalWhnfContextKeys trProj world uvars) + trProj (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + exact hprovenance.kernelDefEqEquivCanonical hcollision + haSupport hbSupport + have hfinal : WhnfStateInv layer + (kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + trProj world support uvars Delta + {s4 with equivManager := (s4.equivManager.addEquiv + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)} := + hI4.addEquiv hrel + exact ⟨isDefEq_fullHit_true htrace hstats haddr hctx hequiv hcheap hhit, + hfinal, hsemantic⟩ + +/-- Exact production execution for a positive non-cheap full-cache hit found +through the guarded equivalence-root second chance. The hit is copied to the +original pair and the original keys are then joined in the manager. -/ +theorem isDefEq_rootFullHit_true + {methods : Methods .anon} {a b : KExpr .anon} + {ctxAddr : Address} {aRoot bRoot : EqKey} + {s s1 s2 s3 s4 s5 : TcState .anon} + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = false) + (hmiss : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hroots : TcM.withEquiv (fun em => + let (aRoot?, em) := em.findRootKey + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let (bRoot?, em) := em.findRootKey + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((aRoot?, bRoot?), em)) s4 = .ok (some aRoot, some bRoot) s5) + (hchanged : (aRoot != + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ || + bRoot != ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) = true) + (hscope : aRoot.rootCacheScopeMatches bRoot ctxAddr + (max a.lbr b.lbr) = true) + (hhit : s5.env.defEqCache[ + ((canonicalPair aRoot.exprAddr bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr bRoot.exprAddr).2, ctxAddr)]? = some true) : + let cacheKey := + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) + let aKey : EqKey := + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let bKey : EqKey := + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + let cachedState := {s5 with env := {s5.env with + defEqCache := s5.env.defEqCache.insert cacheKey true}} + let final := {cachedState with + equivManager := cachedState.equivManager.addEquiv aKey bKey} + (isDefEq a b).run methods s = .ok true final := by + dsimp only + unfold isDefEq + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}")) _ s = _ + unfold EStateM.bind + rw [htrace] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1})) + _ s1 = _ + unfold EStateM.bind + rw [hstats] + simp only [haddr, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.defEqCtxKey a b) _ s2 = _ + unfold EStateM.bind + rw [hctx] + simp only + change ReaderT.run + ((liftM (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) : + RecM .anon Bool) >>= _) + methods s3 = _ + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) _ s3 = _ + unfold EStateM.bind + rw [hequiv] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hcheap] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hmiss] + change ReaderT.run + ((liftM (TcM.withEquiv (fun em => + let (aRoot?, em) := em.findRootKey + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let (bRoot?, em) := em.findRootKey + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((aRoot?, bRoot?), em))) : + RecM .anon (Option EqKey × Option EqKey)) >>= _) + methods s4 = _ + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.withEquiv (fun em => + let (aRoot?, em) := em.findRootKey + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let (bRoot?, em) := em.findRootKey + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((aRoot?, bRoot?), em))) _ s4 = _ + unfold EStateM.bind + rw [hroots] + simp only [hchanged, hscope, if_true] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s5 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s5 = .ok s5 s5 from rfl] + simp only [hhit] + rfl + +/-- Semantic acceptance and invariant preservation for the guarded positive +root/full-cache branch. The copied original-pair entry receives fresh +provenance from the joint suffix model; the final union is justified by that +same positive entry rather than treated as bookkeeping. -/ +theorem isDefEq_rootFullHit_true_acceptance + {methods : Methods .anon} {layer : WhnfLayer} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (model : KernelSuffixModel trProj world) + {Delta : KVLCtx} {a b : KExpr .anon} {va vb : VExpr} + {ctxAddr : Address} {aRoot bRoot : EqKey} + {s s1 s2 s3 s4 s5 : TcState .anon} + (theory : WhnfTheory trProj world model.keys.uvars) + (hcollision : support.CollisionFree) + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = false) + (hmiss : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hroots : TcM.withEquiv (fun em => + let (aRoot?, em) := em.findRootKey + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let (bRoot?, em) := em.findRootKey + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((aRoot?, bRoot?), em)) s4 = .ok (some aRoot, some bRoot) s5) + (hchanged : (aRoot != + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ || + bRoot != ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) = true) + (hscope : aRoot.rootCacheScopeMatches bRoot ctxAddr + (max a.lbr b.lbr) = true) + (hhit : s5.env.defEqCache[ + ((canonicalPair aRoot.exprAddr bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr bRoot.exprAddr).2, ctxAddr)]? = some true) + (hI : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta s) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta b vb) + (hreferences : + (CacheEntry.defEq .full + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true).ReferencesAuthorized + (CacheAuthority.stable world) support) : + let cacheKey := + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) + let aKey : EqKey := + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let bKey : EqKey := + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + let cachedState := {s5 with env := {s5.env with + defEqCache := s5.env.defEqCache.insert cacheKey true}} + let final := {cachedState with + equivManager := cachedState.equivManager.addEquiv aKey bKey} + (isDefEq a b).run methods s = .ok true final ∧ + WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta final ∧ + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb := by + dsimp only + have htraceWf := + (TcM.stepTrace_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s) hI + rw [htrace] at htraceWf + have hI1 := htraceWf.1 + have hstatsWf := + (TcM.bumpStats_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) s1) hI1 + rw [hstats] at hstatsWf + have hI2 := hstatsWf.1 + have hctxWf := + (TcM.defEqCtxKey_model_matches_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (support := support) model (Delta := Delta) (a := a) (b := b) + (s := s2)) hI2 + rw [hctx] at hctxWf + have hI3 := hctxWf.1 + have hrepresented := hctxWf.2.1.2.1 + have hequivWf := + (TcM.withEquiv_isEquiv_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ s3) hI3 + rw [hequiv] at hequivWf + have hI4 := hequivWf.1 + have hrootsWf := + (TcM.withEquiv_findRootKeys_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ s4) hI4 + rw [hroots] at hrootsWf + have hI5 := hrootsWf.1 + have haPath := hrootsWf.2.1 aRoot rfl + have hbPath := hrootsWf.2.2 bRoot rfl + change DefEqKeyEquiv model.keys trProj (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ aRoot at haPath + change DefEqKeyEquiv model.keys trProj (CacheAuthority.stable world) support + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ bRoot at hbPath + have hrootProvenance := hI5.1.caches.hit (.defEq hhit) + have hsemantic := hrootProvenance.kernelDefEqRootAcceptance + theory hI5.2.1.wf hcollision haPath hbPath hscope hrepresented + haSupport hbSupport ha hb + have horiginalMeaning : + DefEqMeaning trProj world model.keys.uvars Delta a b true := by + intro _ + exact ⟨va, vb, ha, hb, hsemantic⟩ + have hnew := model.defEqProvenance hcollision .full + haSupport hbSupport hrepresented horiginalMeaning hreferences + have hcached : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta + {s5 with env := {s5.env with + defEqCache := s5.env.defEqCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true}} := + DefEqCacheUpdate.full_whnfStateInv hI5 hnew + have hrel : DefEqKeyEquiv model.keys trProj + (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ := + hnew.kernelDefEqEquivCanonical hcollision haSupport hbSupport + have hfinal := hcached.addEquiv hrel + exact ⟨isDefEq_rootFullHit_true htrace hstats haddr hctx hequiv hcheap + hmiss hroots hchanged hscope hhit, hfinal, hsemantic⟩ + +/-- Exact production execution for a positive direct cheap-cache hit. Cheap +`true` is promoted to the full partition and recorded in the manager before +returning. -/ +theorem isDefEq_cheapHit_true + {methods : Methods .anon} {a b : KExpr .anon} + {ctxAddr : Address} {s s1 s2 s3 s4 : TcState .anon} + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = true) + (hfullMiss : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hhit : s4.env.defEqCheapCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = some true) : + let cacheKey := + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) + let aKey : EqKey := + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let bKey : EqKey := + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + let final := {s4 with + env := {s4.env with + defEqCache := s4.env.defEqCache.insert cacheKey true} + equivManager := s4.equivManager.addEquiv aKey bKey} + (isDefEq a b).run methods s = .ok true final := by + dsimp only + unfold isDefEq + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}")) _ s = _ + unfold EStateM.bind + rw [htrace] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1})) + _ s1 = _ + unfold EStateM.bind + rw [hstats] + simp only [haddr, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.defEqCtxKey a b) _ s2 = _ + unfold EStateM.bind + rw [hctx] + simp only + change ReaderT.run + ((liftM (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) : + RecM .anon Bool) >>= _) + methods s3 = _ + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) _ s3 = _ + unfold EStateM.bind + rw [hequiv] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hcheap] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hfullMiss, if_true] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hhit, if_true] + rfl + +/-- A positive cheap hit is semantically accepted, promoted with the same +provenance into the full partition, and safely joined in the manager. -/ +theorem isDefEq_cheapHit_true_acceptance + {methods : Methods .anon} {layer : WhnfLayer} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (model : KernelSuffixModel trProj world) + {Delta : KVLCtx} {a b : KExpr .anon} {va vb : VExpr} + {ctxAddr : Address} {s s1 s2 s3 s4 : TcState .anon} + (theory : WhnfTheory trProj world model.keys.uvars) + (hcollision : support.CollisionFree) + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = true) + (hfullMiss : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hhit : s4.env.defEqCheapCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = some true) + (hI : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta s) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta b vb) : + let cacheKey := + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) + let aKey : EqKey := + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let bKey : EqKey := + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + let final := {s4 with + env := {s4.env with + defEqCache := s4.env.defEqCache.insert cacheKey true} + equivManager := s4.equivManager.addEquiv aKey bKey} + (isDefEq a b).run methods s = .ok true final ∧ + WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta final ∧ + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb := by + dsimp only + have htraceWf := + (TcM.stepTrace_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s) hI + rw [htrace] at htraceWf + have hstatsWf := + (TcM.bumpStats_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) s1) + htraceWf.1 + rw [hstats] at hstatsWf + have hctxWf := + (TcM.defEqCtxKey_model_matches_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (support := support) model (Delta := Delta) (a := a) (b := b) + (s := s2)) hstatsWf.1 + rw [hctx] at hctxWf + have hrepresented := hctxWf.2.1.2.1 + have hequivWf := + (TcM.withEquiv_isEquiv_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ s3) hctxWf.1 + rw [hequiv] at hequivWf + have hcheapProvenance := hequivWf.1.1.caches.hit (.defEqCheap hhit) + have hmeaning := hcheapProvenance.kernelDefEqMeaningCanonical + haSupport hbSupport hrepresented + have hsemantic := DefEqMeaning.of_translations theory hequivWf.1.2.1.wf + ha hb hmeaning rfl + have hfullProvenance : + CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .full + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true) := + hcheapProvenance.kernelDefEqRekind + have hcached : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta + {s4 with env := {s4.env with + defEqCache := s4.env.defEqCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true}} := + DefEqCacheUpdate.full_whnfStateInv hequivWf.1 hfullProvenance + have hrel : DefEqKeyEquiv model.keys trProj + (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ := + hfullProvenance.kernelDefEqEquivCanonical hcollision + haSupport hbSupport + have hfinal := hcached.addEquiv hrel + exact ⟨isDefEq_cheapHit_true htrace hstats haddr hctx hequiv hcheap + hfullMiss hhit, hfinal, hsemantic⟩ + +/-- The first production DefEq branch is sound under the run-scoped collision +hypothesis. Trace and statistics instrumentation preserve the semantic +state, and an address hit is discharged by `DefEqMeaning.of_addr_beq`. -/ +theorem isDefEq_addrEq_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {a b : KExpr .anon} {va vb : VExpr} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv uvars world.nameOf trProj Delta b vb) + (haddr : (a.addr == b.addr) = true) : + RecM.WF layer semantics trProj world support uvars Delta s + (isDefEq a b) + (fun answer _ => answer = true -> + world.venv.IsDefEqU uvars Delta.toCtx va vb) := by + unfold isDefEq + apply RecM.WF.bind + · apply RecM.WF.liftTcM + exact TcM.stepTrace_whnf_wf "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s + · intro _ s1 _ + apply RecM.WF.bind + · apply RecM.WF.liftTcM + exact TcM.bumpStats_whnf_wf + (fun st => {st with deqCalls := st.deqCalls + 1}) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) s1 + · intro _ s2 _ + simp only [haddr, if_true] + apply RecM.WF.pure + intro hI htrue + exact DefEqMeaning.of_translations theory hI.2.1.wf ha hb + (DefEqMeaning.of_addr_beq theory hI.2.1 hcollision + haSupport hbSupport ha haddr) htrue + +/-- A production full inference-cache hit is semantically accepted from the +canonical operational context-key interpretation. Provenance is read from +the post-key invariant, while the actual key run supplies context membership. -/ +theorem inferWith_fullHit_acceptance + {inferRec : KExpr .anon -> RecM .anon (KExpr .anon)} + {methods : Methods .anon} {layer : WhnfLayer} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {source cached : KExpr .anon} + {sourceV : VExpr} {key : Address × Address} + {s s' : TcState .anon} + (theory : WhnfTheory trProj world uvars) + (hkey : TcM.inferKey source s = .ok key s') + (hhit : s'.env.inferCache[key]? = some cached) + (hI : WhnfStateInv layer + (kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + trProj world support uvars Delta s) + (hsupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + (inferWith inferRec source).run methods s = .ok cached s' ∧ + WhnfStateInv layer + (kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + trProj world support uvars Delta s' ∧ + support cached ∧ + InferPost trProj world uvars Delta sourceV cached := by + have hwf := + (TcM.inferKey_wf (layer := layer) + (semantics := kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Delta := Delta) (source := source) (s := s)) hI + rw [hkey] at hwf + have hrun : TcM.whnfKey source s = .ok key s' := by + simpa using hkey + have hmatch : + (operationalWhnfContextKeys trProj world uvars).Matches trProj world + s Delta source key := + ⟨hI.2.1, + operationalWhnfContextKeys.represents hI.2.1 hrun, + ⟨s', hrun⟩⟩ + have hprovenance := hwf.1.1.caches.hit (.infer hhit) + have hmeaning := hprovenance.kernelInferMeaningOfMatches + .infer hsupport hmatch + exact ⟨inferWith_fullHit hkey hhit, hwf.1, + hprovenance.supported.2, + hmeaning.post theory hI.2.1.wf hsource⟩ + +/-- The infer-only partition has the same semantic acceptance theorem. Its +policy guard is captured before key computation; the key frame cannot alter +that guard. -/ +theorem inferWith_inferOnlyHit_acceptance + {inferRec : KExpr .anon -> RecM .anon (KExpr .anon)} + {methods : Methods .anon} {layer : WhnfLayer} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {source cached : KExpr .anon} + {sourceV : VExpr} {key : Address × Address} + {s s' : TcState .anon} + (theory : WhnfTheory trProj world uvars) + (hpolicy : s.inferOnly = true) + (hkey : TcM.inferKey source s = .ok key s') + (hfullMiss : s'.env.inferCache[key]? = none) + (hhit : s'.env.inferOnlyCache[key]? = some cached) + (hI : WhnfStateInv layer + (kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + trProj world support uvars Delta s) + (hsupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + (inferWith inferRec source).run methods s = .ok cached s' ∧ + WhnfStateInv layer + (kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + trProj world support uvars Delta s' ∧ + support cached ∧ + InferPost trProj world uvars Delta sourceV cached := by + have hwf := + (TcM.inferKey_wf (layer := layer) + (semantics := kernelCacheSemantics + (operationalWhnfContextKeys trProj world uvars) trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Delta := Delta) (source := source) (s := s)) hI + rw [hkey] at hwf + have hrun : TcM.whnfKey source s = .ok key s' := by + simpa using hkey + have hmatch : + (operationalWhnfContextKeys trProj world uvars).Matches trProj world + s Delta source key := + ⟨hI.2.1, + operationalWhnfContextKeys.represents hI.2.1 hrun, + ⟨s', hrun⟩⟩ + have hprovenance := hwf.1.1.caches.hit (.inferOnly hhit) + have hmeaning := hprovenance.kernelInferMeaningOfMatches + .inferOnly hsupport hmatch + exact ⟨inferWith_inferOnlyHit hpolicy hkey hfullMiss hhit, hwf.1, + hprovenance.supported.2, + hmeaning.post theory hI.2.1.wf hsource⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/AcceleratorGates.lean b/Ix/Tc/Verify/DefEq/AcceleratorGates.lean new file mode 100644 index 000000000..0e59621d3 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/AcceleratorGates.lean @@ -0,0 +1,161 @@ +import Ix.Tc.Verify.DefEq.NatReduction +import Ix.Tc.Verify.Whnf.Driver.FullStep + +/-! +# Lazy-delta accelerator gates + +The verification stack closes the recursive kernel in the `.noAccel` layer. +In that layer both native evaluation and Decidable synthesis return `none` +before inspecting their operands or invoking callbacks. This module removes +those four operationally unreachable hit branches from lazy delta and exposes +the first substantive remaining tail: delta-head classification. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Exact remaining one-step contract after both native and both Decidable +acceleration probes miss. -/ +def DefEqLazyDeltaAfterAcceleratorMiss.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftSource rightSource left right}, + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right) → + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepAfterAcceleratorMiss left right) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) + +/-- In `.noAccel`, the native and Decidable prefix is definitionally a chain +of four misses, so it delegates to the post-accelerator tail without any new +semantic premise. -/ +theorem defEqLazyDeltaStepAfterNatMiss_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : Lean4Lean.VExpr} + {left right : KExpr .anon} + (theory : WhnfTheory trProj world uvars) + (hafter : DefEqLazyDeltaAfterAcceleratorMiss.WFAt .noAccel semantics + trProj world support uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF .noAccel semantics trProj world support uvars Delta state + (defEqLazyDeltaStepAfterNatMiss left right) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold defEqLazyDeltaStepAfterNatMiss + apply RecM.WF.bind + (RecM.WF.withInv <| + tryReduceNative_noAccel_optional_wf hpair.leftSupport hleft) + intro leftNative afterLeftNative hleftNative + rcases hleftNative with ⟨hILeftNative, hleftNative⟩ + cases leftNative with + | some reducedLeft => + rcases hleftNative with ⟨hreducedSupport, hreducedMeaning⟩ + have hleftReduced := WhnfPost.transMeaning theory hDelta + ⟨leftV, hleft, hleftEq⟩ hreducedMeaning + obtain ⟨reducedV, hreduced, hleftReducedEq⟩ := hleftReduced + apply RecM.WF.bind <| + RecM.isDefEqCall_wf hreducedSupport hpair.rightSupport + hreduced hright + intro answer afterEq hanswer + exact RecM.WF.pure fun _ htrue => + hleftReducedEq.trans world.venvWF hDelta <| + (hanswer htrue).trans world.venvWF hDelta hrightEq.symm + | none => + apply RecM.WF.bind + (RecM.WF.withInv <| + tryReduceNative_noAccel_optional_wf hpair.rightSupport hright) + intro rightNative afterRightNative hrightNative + rcases hrightNative with ⟨hIRightNative, hrightNative⟩ + cases rightNative with + | some reducedRight => + rcases hrightNative with ⟨hreducedSupport, hreducedMeaning⟩ + have hrightReduced := WhnfPost.transMeaning theory hDelta + ⟨rightV, hright, hrightEq⟩ hreducedMeaning + obtain ⟨reducedV, hreduced, hrightReducedEq⟩ := hrightReduced + apply RecM.WF.bind <| + RecM.isDefEqCall_wf hpair.leftSupport hreducedSupport + hleft hreduced + intro answer afterEq hanswer + exact RecM.WF.pure fun _ htrue => + hleftEq.trans world.venvWF hDelta <| + (hanswer htrue).trans world.venvWF hDelta + hrightReducedEq.symm + | none => + apply RecM.WF.bind + (RecM.WF.withInv <| + tryReduceDecidable_noAccel_optional_wf + hpair.leftSupport hleft) + intro leftDecidable afterLeftDecidable hleftDecidable + rcases hleftDecidable with ⟨hILeftDecidable, hleftDecidable⟩ + cases leftDecidable with + | some reducedLeft => + rcases hleftDecidable with + ⟨hreducedSupport, hreducedMeaning⟩ + have hleftReduced := WhnfPost.transMeaning theory hDelta + ⟨leftV, hleft, hleftEq⟩ hreducedMeaning + obtain ⟨reducedV, hreduced, hleftReducedEq⟩ := hleftReduced + apply RecM.WF.bind <| + RecM.isDefEqCall_wf hreducedSupport hpair.rightSupport + hreduced hright + intro answer afterEq hanswer + exact RecM.WF.pure fun _ htrue => + hleftReducedEq.trans world.venvWF hDelta <| + (hanswer htrue).trans world.venvWF hDelta hrightEq.symm + | none => + apply RecM.WF.bind + (RecM.WF.withInv <| + tryReduceDecidable_noAccel_optional_wf + hpair.rightSupport hright) + intro rightDecidable afterRightDecidable hrightDecidable + rcases hrightDecidable with + ⟨hIRightDecidable, hrightDecidable⟩ + cases rightDecidable with + | some reducedRight => + rcases hrightDecidable with + ⟨hreducedSupport, hreducedMeaning⟩ + have hrightReduced := WhnfPost.transMeaning theory hDelta + ⟨rightV, hright, hrightEq⟩ hreducedMeaning + obtain ⟨reducedV, hreduced, hrightReducedEq⟩ := + hrightReduced + apply RecM.WF.bind <| + RecM.isDefEqCall_wf hpair.leftSupport hreducedSupport + hleft hreduced + intro answer afterEq hanswer + exact RecM.WF.pure fun _ htrue => + hleftEq.trans world.venvWF hDelta <| + (hanswer htrue).trans world.venvWF hDelta + hrightReducedEq.symm + | none => + exact hafter hpair + +namespace DefEqLazyDeltaAfterNatMiss + +/-- Package the no-acceleration gate proof as the complete post-Nat +contract. -/ +theorem ofNoAccel + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hafter : DefEqLazyDeltaAfterAcceleratorMiss.WFAt .noAccel semantics + trProj world support uvars) : + DefEqLazyDeltaAfterNatMiss.WFAt .noAccel semantics trProj world support + uvars := by + intro Delta state leftSource rightSource left right hpair + intro methods hmethods hI + exact (defEqLazyDeltaStepAfterNatMiss_wf theory hafter hI.2.1.wf hpair) + methods hmethods hI + +end DefEqLazyDeltaAfterNatMiss + +end RecM + + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/ApplicationSpine.lean b/Ix/Tc/Verify/DefEq/ApplicationSpine.lean new file mode 100644 index 000000000..7c0704617 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/ApplicationSpine.lean @@ -0,0 +1,148 @@ +import Ix.Tc.Verify.DefEq.SpineArguments + +/-! +# General application-spine comparison + +The post-delta application tier compares two nonempty application spines. It +first compares the collected heads, then reuses the common left-to-right +argument loop. A positive result is reconstructed through the complete typed +spines; constructor misses and unequal arities carry no semantic claim. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Finite support coverage for the head and arguments selected by the exact +production `collectSpine` executions. -/ +structure ApplicationSpineResources (support : RunSupport) : Prop where + components : ∀ {f arg : KExpr .anon} {info : ExprInfo .anon} + {head : KExpr .anon} {args : Array (KExpr .anon)}, + support (.app f arg info) → + (.app f arg info : KExpr .anon).collectSpine = (head, args) → + support head ∧ ∀ child, child ∈ args.toList → support child + +namespace RecM + +/-- Exact positive-result contract for the production application-spine +probe. A negative result is deliberately unconstrained. -/ +def TryDefEqApp.WFAt (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqApp left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Complete execution proof of `tryDefEqApp`. -/ +theorem tryDefEqApp_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (resources : ApplicationSpineResources support) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqApp left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + cases left <;> cases right <;> + simp only [tryDefEqApp, Bool.not_false, Bool.not_true] + all_goals + first + | exact RecM.WF.pure fun _ h => by contradiction + | skip + case app fLeft argLeft infoLeft fRight argRight infoRight => + let left : KExpr .anon := .app fLeft argLeft infoLeft + let right : KExpr .anon := .app fRight argRight infoRight + rcases hleftCollect : left.collectSpine with ⟨leftHead, leftArgs⟩ + rcases hrightCollect : right.collectSpine with ⟨rightHead, rightArgs⟩ + cases hsize : leftArgs.size != rightArgs.size with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ h => by contradiction + | false => + simp only [Bool.false_or, Bool.false_eq_true, if_false] + have hlength : leftArgs.toList.length = rightArgs.toList.length := by + simpa only [Array.length_toList] using + eq_of_beq (show (leftArgs.size == rightArgs.size) = true by + simpa using hsize) + have hleftSpine := trAppSpine_of_collectSpine hleft hleftCollect + have hrightSpine := trAppSpine_of_collectSpine hright hrightCollect + obtain ⟨leftHeadV, hleftHead⟩ := hleftSpine.headTr + obtain ⟨rightHeadV, hrightHead⟩ := hrightSpine.headTr + have hleftComponents := resources.components hleftSupport hleftCollect + have hrightComponents := + resources.components hrightSupport hrightCollect + apply RecM.WF.bind <| + RecM.isDefEqCall_wf hleftComponents.1 hrightComponents.1 + hleftHead hrightHead + intro headsEqual afterHead hheadsEqual + cases headsEqual with + | false => + simp only [Bool.not_false, if_true] + exact RecM.WF.pure fun _ h => by contradiction + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false, + pure_bind] + apply RecM.WF.mono (RecM.WF.withInv <| + allDefEqSpineArgs_wf _ (by + intro pair hmem + have hmem' : pair ∈ + leftArgs.toList.zip rightArgs.toList := by + simpa only [Array.toList_zip] using hmem + have hleftMem := left_mem_of_pair_mem_zip hmem' + have hrightMem := right_mem_of_pair_mem_zip hmem' + obtain ⟨pairLeftV, pairLeftTy, hpairLeftTyped, hpairLeft⟩ := + hleftSpine.argument hleftMem + obtain ⟨pairRightV, pairRightTy, hpairRightTyped, hpairRight⟩ := + hrightSpine.argument hrightMem + exact ⟨hleftComponents.2 _ hleftMem, + hrightComponents.2 _ hrightMem, + pairLeftV, pairRightV, hpairLeft, hpairRight⟩)) + · intro argsEqual final hpost htrue + rcases hpost with ⟨hI, hargsEqual⟩ + have hDelta : KVLCtx.WF world.venv uvars Delta := + hI.2.1.wf + apply TrAppSpine.defEq_of_zip theory hDelta hleftSpine + hrightSpine hlength + · intro arbitraryLeftV arbitraryRightV arbitraryLeft + arbitraryRight + exact TrAppSpine.argumentDefEq theory hDelta + ⟨leftHeadV, rightHeadV, hleftHead, hrightHead, + hheadsEqual rfl⟩ arbitraryLeft arbitraryRight + · intro pair hmem + exact hargsEqual htrue pair (by + simpa only [Array.toList_zip] using hmem) + · intro _ _ _ + trivial + +namespace TryDefEqApp + +/-- Package the concrete spine proof as the helper contract consumed by the +stopped lazy-delta continuation. -/ +theorem ofResources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (resources : ApplicationSpineResources support) : + TryDefEqApp.WFAt layer semantics trProj world support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact tryDefEqApp_wf theory resources hleftSupport hrightSupport hleft + hright + +end TryDefEqApp + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/BoolTrue.lean b/Ix/Tc/Verify/DefEq/BoolTrue.lean new file mode 100644 index 000000000..6ac0fc3ec --- /dev/null +++ b/Ix/Tc/Verify/DefEq/BoolTrue.lean @@ -0,0 +1,319 @@ +import Ix.Tc.Verify.DefEq.Structural + +/-! +# Eager Bool.true definitional equality + +The second recursive tier recognizes the trusted `Bool.true` constant on one +side, normalizes the other side, and recognizes the same constant again. +Acceptance is sound only when the runtime primitive address is tied to the +trusted Theory name; address equality by itself is not authority. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Minimal trusted binding for the one primitive read by the eager Boolean +tier. -/ +structure BoolTruePrimitiveContext (world : VerifyWorld) : Prop where + table : ∀ prims : Primitives .anon, prims.CanonicalAnon → + PrimitiveIdAgrees world prims.boolTrue ``Bool.true + +/-- The selected verification layer guarantees that every invariant state +uses the canonical anonymous primitive table. Both production reduction +layers satisfy this; the weaker structural-only layer deliberately does not. +-/ +def CanonicalPrimitiveStates (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta s}, + WhnfStateInv layer semantics trProj world support uvars Delta s → + s.prims.CanonicalAnon + +theorem canonicalPrimitiveStates_noAccel + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} : + CanonicalPrimitiveStates .noAccel semantics trProj world support + uvars := + fun hI => hI.noAccel_primitives + +theorem canonicalPrimitiveStates_accelerated + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} : + CanonicalPrimitiveStates .accelerated semantics trProj world support + uvars := + fun hI => hI.accelerated_primitives + +namespace RecM + +/-- The primitive classifier is state-transparent. A positive answer pins +the structural translation to the exact Theory constant `Bool.true`; the +proof uses the trusted `nameOf` binding after the runtime table has been +shown canonical. -/ +theorem isBoolTrue_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr} + (context : BoolTruePrimitiveContext world) + (hcanonical : CanonicalPrimitiveStates layer semantics trProj world + support uvars) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (isBoolTrue source) + (fun answer after => after = s ∧ + (answer = true → sourceV = VExpr.boolTrue)) := by + cases hsource <;> simp only [isBoolTrue] + all_goals + first + | exact RecM.WF.pure fun _ => ⟨rfl, fun h => by contradiction⟩ + | skip + rename_i id us info name ci hname hlookup hlevels harity + apply RecM.WF.bind (prims_wf (s := s)) + intro runtimePrims after hread + rcases hread with ⟨hprims, hafter⟩ + subst after + exact RecM.WF.pure fun hI => ⟨rfl, fun hanswer => by + obtain ⟨hempty, haddr⟩ := Bool.and_eq_true_iff.mp hanswer + have hus : us = #[] := Array.empty_of_isEmpty hempty + subst us + have hnameEq : name = ``Bool.true := by + apply Option.some.inj + calc + some name = world.nameOf id.addr := hname.symm + _ = world.nameOf runtimePrims.boolTrue.addr := + congrArg world.nameOf (eq_of_beq haddr) + _ = some ``Bool.true := + (context.table runtimePrims (by + rw [hprims] + exact hcanonical hI)).2 + subst name + simp [VExpr.boolTrue]⟩ + +/-- The closed/eager policy check is a pure state observation. -/ +theorem boolTrueReductionAllowed_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + (source : KExpr .anon) : + RecM.WF layer semantics trProj world support uvars Delta s + (boolTrueReductionAllowed source) (fun _ after => after = s) := by + unfold boolTrueReductionAllowed + cases hfv : source.hasFVars with + | false => + simp only [Bool.not_false, if_true] + exact RecM.WF.pure fun _ => rfl + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s ∧ after = s) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨rfl, rfl⟩ + exact RecM.WF.pure (E := fun _ _ => True) fun _ => rfl + +/-- Direct WHNF contract used by the eager Boolean tier. K1 supplies this +for the current unfolded layer; keeping it generic avoids confusing the +current reducer with the predecessor-table callback. -/ +def DefEqDirectWhnf.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta s source sourceV}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + RecM.WF layer semantics trProj world support uvars Delta s + (whnf source) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + +/-- Normalize one side and recognize its result as trusted `Bool.true`. +A positive answer therefore denotes equality between the original Theory +term and the canonical Boolean literal. -/ +theorem whnfThenIsBoolTrue_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr} + (context : BoolTruePrimitiveContext world) + (hcanonical : CanonicalPrimitiveStates layer semantics trProj world + support uvars) + (hwhnf : DefEqDirectWhnf.WFAt layer semantics trProj world support + uvars) + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (whnfIsBoolTrue source) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx sourceV VExpr.boolTrue) := by + unfold whnfIsBoolTrue + apply RecM.WF.bind + (RecM.WF.withInv <| hwhnf hsourceSupport hsource) + intro reduced afterWhnf hwhnfPost + rcases hwhnfPost with + ⟨hIWhnf, hreducedSupport, reducedV, hreducedTr, hsourceReduced⟩ + apply RecM.WF.mono + (isBoolTrue_wf context hcanonical hreducedTr) + · intro answer final hrecognized hanswer + exact hrecognized.2 hanswer ▸ hsourceReduced + · intro _ _ _ + trivial + +namespace DefEqAfterBoolTrue + +/-- Semantic contract for the tiers following eager Boolean reduction. -/ +def WF (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ {Delta s a b aV bV}, + support a → support b → + TrKExprS world.venv uvars world.nameOf trProj Delta a aV → + TrKExprS world.venv uvars world.nameOf trProj Delta b bV → + RecM.WF layer semantics trProj world support uvars Delta s + (isDefEqInnerAfterBoolTrue a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx aV bV) + +end DefEqAfterBoolTrue + +/-- Soundness of the symmetric eager-Boolean direction. This helper is +entered only when the first direction's recognition/policy guard was +unavailable. -/ +theorem isDefEqInnerAfterFirstBoolGuardMiss_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {a b : KExpr .anon} {aV bV : VExpr} + (context : BoolTruePrimitiveContext world) + (hcanonical : CanonicalPrimitiveStates layer semantics trProj world + support uvars) + (hwhnf : DefEqDirectWhnf.WFAt layer semantics trProj world support + uvars) + (htail : DefEqAfterBoolTrue.WF layer semantics trProj world support + uvars) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv uvars world.nameOf trProj Delta a aV) + (hb : TrKExprS world.venv uvars world.nameOf trProj Delta b bV) : + RecM.WF layer semantics trProj world support uvars Delta s + (isDefEqInnerAfterFirstBoolGuardMiss a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx aV bV) := by + unfold isDefEqInnerAfterFirstBoolGuardMiss + apply RecM.WF.bind (isBoolTrue_wf context hcanonical ha) + intro aIsTrue afterA hclassifyA + rcases hclassifyA with ⟨hafterA, haTrue⟩ + subst afterA + apply RecM.WF.bind (boolTrueReductionAllowed_wf b) + intro allowed afterPolicy hafterPolicy + subst afterPolicy + cases aIsTrue with + | false => + cases allowed <;> + simp only [Bool.false_and, Bool.false_eq_true, if_false] <;> + exact htail haSupport hbSupport ha hb + | true => + cases allowed with + | false => + simp only [Bool.true_and, Bool.false_eq_true, if_false] + exact htail haSupport hbSupport ha hb + | true => + simp only [Bool.true_and, if_true] + apply RecM.WF.bind + (whnfThenIsBoolTrue_wf context hcanonical hwhnf hbSupport hb) + intro normalizedTrue afterNormalize hnormalized + cases normalizedTrue with + | false => + simp only [Bool.false_eq_true, if_false] + exact htail haSupport hbSupport ha hb + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => by + have haEq := haTrue rfl + simpa [haEq] using (hnormalized rfl).symm + +/-- Discharge the complete eager-Boolean prefix. If the first guard is +unavailable, production delegates to the symmetric helper above. If that +guard is available but normalization does not recognize `Bool.true`, the +algorithm intentionally skips the symmetric attempt and continues directly +to the later tiers. -/ +theorem DefEqAfterBoolTrue.closesAfterQuick + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (context : BoolTruePrimitiveContext world) + (hcanonical : CanonicalPrimitiveStates layer semantics trProj world + support uvars) + (hwhnf : DefEqDirectWhnf.WFAt layer semantics trProj world support + uvars) + (htail : DefEqAfterBoolTrue.WF layer semantics trProj world support + uvars) : + DefEqAfterQuick.WF layer semantics trProj world support uvars := by + intro Delta s a b aV bV haSupport hbSupport ha hb + unfold isDefEqInnerAfterQuick + apply RecM.WF.bind (isBoolTrue_wf context hcanonical hb) + intro bIsTrue afterB hclassifyB + rcases hclassifyB with ⟨hafterB, hbTrue⟩ + subst afterB + apply RecM.WF.bind (boolTrueReductionAllowed_wf a) + intro allowed afterPolicy hafterPolicy + subst afterPolicy + cases bIsTrue with + | false => + cases allowed <;> + simp only [Bool.false_and, Bool.false_eq_true, if_false] <;> + exact isDefEqInnerAfterFirstBoolGuardMiss_wf + context hcanonical hwhnf htail haSupport hbSupport ha hb + | true => + cases allowed with + | false => + simp only [Bool.true_and, Bool.false_eq_true, if_false] + exact isDefEqInnerAfterFirstBoolGuardMiss_wf + context hcanonical hwhnf htail haSupport hbSupport ha hb + | true => + simp only [Bool.true_and, if_true] + apply RecM.WF.bind + (whnfThenIsBoolTrue_wf context hcanonical hwhnf haSupport ha) + intro normalizedTrue afterNormalize hnormalized + cases normalizedTrue with + | false => + simp only [Bool.false_eq_true, if_false] + exact htail haSupport hbSupport ha hb + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => by + have hbEq := hbTrue rfl + simpa [hbEq] using hnormalized rfl + +/-- Assemble Tier 1 structural comparison and Tier 1b eager Boolean +reduction into the recursive-inner contract, leaving only the post-Boolean +tail as an explicit obligation. -/ +theorem DefEqAfterBoolTrue.closesInner + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hsorts : SortComponentResources support) + (hstructural : QuickDefEqResources support) + (context : BoolTruePrimitiveContext world) + (hcanonical : CanonicalPrimitiveStates layer semantics trProj world + support uvars) + (hwhnf : DefEqDirectWhnf.WFAt layer semantics trProj world support + uvars) + (htail : DefEqAfterBoolTrue.WF layer semantics trProj world support + uvars) : + ∀ {Delta s a b aV bV}, + support a → support b → + TrKExprS world.venv uvars world.nameOf trProj Delta a aV → + TrKExprS world.venv uvars world.nameOf trProj Delta b bV → + RecM.WF layer semantics trProj world support uvars Delta s + (isDefEqInner a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx aV bV) := + DefEqAfterQuick.closesInner theory hcollision hsorts hstructural + (DefEqAfterBoolTrue.closesAfterQuick context hcanonical hwhnf htail) + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/CacheBranches.lean b/Ix/Tc/Verify/DefEq/CacheBranches.lean new file mode 100644 index 000000000..f200f3670 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/CacheBranches.lean @@ -0,0 +1,847 @@ +import Ix.Tc.Verify.DefEq + +/-! +# DefEq cache-policy branches + +This module verifies cache exits whose state effects depend on cheap mode. +The semantic manager and guarded root-cache foundations live in +`Ix.Tc.Verify.DefEq`; the exhaustive cache shell will assemble these branches +before entering recursive comparison. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Exact positive full-cache hit while cheap mode is active. Production +copies the validated result into the cheap partition, then joins the original +keys in the equivalence manager. -/ +theorem isDefEq_fullHitCheapMode_true + {methods : Methods .anon} {a b : KExpr .anon} + {ctxAddr : Address} {s s1 s2 s3 s4 : TcState .anon} + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = true) + (hhit : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = some true) : + let cacheKey := + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) + let aKey : EqKey := + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let bKey : EqKey := + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + let cachedState := {s4 with env := {s4.env with + defEqCheapCache := s4.env.defEqCheapCache.insert cacheKey true}} + let final := {cachedState with + equivManager := cachedState.equivManager.addEquiv aKey bKey} + (isDefEq a b).run methods s = .ok true final := by + dsimp only + unfold isDefEq + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}")) _ s = _ + unfold EStateM.bind + rw [htrace] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1})) + _ s1 = _ + unfold EStateM.bind + rw [hstats] + simp only [haddr, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.defEqCtxKey a b) _ s2 = _ + unfold EStateM.bind + rw [hctx] + simp only + change ReaderT.run + ((liftM (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) : + RecM .anon Bool) >>= _) + methods s3 = _ + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) _ s3 = _ + unfold EStateM.bind + rw [hequiv] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hcheap] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hhit, if_true] + rfl + +/-- The cheap-mode copy of a positive full entry is justified by re-kinding +the same provenance. Both the copied entry and final manager union preserve +the checker invariant. -/ +theorem isDefEq_fullHitCheapMode_true_acceptance + {methods : Methods .anon} {layer : WhnfLayer} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (model : KernelSuffixModel trProj world) + {Delta : KVLCtx} {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} + {ctxAddr : Address} {s s1 s2 s3 s4 : TcState .anon} + (theory : WhnfTheory trProj world model.keys.uvars) + (hcollision : support.CollisionFree) + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = true) + (hhit : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = some true) + (hI : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta s) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta b vb) : + let cacheKey := + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) + let aKey : EqKey := + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let bKey : EqKey := + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + let cachedState := {s4 with env := {s4.env with + defEqCheapCache := s4.env.defEqCheapCache.insert cacheKey true}} + let final := {cachedState with + equivManager := cachedState.equivManager.addEquiv aKey bKey} + (isDefEq a b).run methods s = .ok true final ∧ + WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta final ∧ + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb := by + dsimp only + have htraceWf := + (TcM.stepTrace_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s) hI + rw [htrace] at htraceWf + have hstatsWf := + (TcM.bumpStats_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) s1) + htraceWf.1 + rw [hstats] at hstatsWf + have hctxWf := + (TcM.defEqCtxKey_model_matches_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (support := support) model (Delta := Delta) (a := a) (b := b) + (s := s2)) hstatsWf.1 + rw [hctx] at hctxWf + have hrepresented := hctxWf.2.1.2.1 + have hequivWf := + (TcM.withEquiv_isEquiv_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ s3) hctxWf.1 + rw [hequiv] at hequivWf + have hfullProvenance := hequivWf.1.1.caches.hit (.defEq hhit) + have hmeaning := hfullProvenance.kernelDefEqMeaningCanonical + haSupport hbSupport hrepresented + have hsemantic := DefEqMeaning.of_translations theory hequivWf.1.2.1.wf + ha hb hmeaning rfl + have hcheapProvenance : + CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .cheap + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true) := + hfullProvenance.kernelDefEqRekind + have hcached : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta + {s4 with env := {s4.env with + defEqCheapCache := s4.env.defEqCheapCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true}} := + DefEqCacheUpdate.cheap_whnfStateInv hequivWf.1 hcheapProvenance + have hrel : DefEqKeyEquiv model.keys trProj + (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ := + hfullProvenance.kernelDefEqEquivCanonical hcollision + haSupport hbSupport + have hfinal := hcached.addEquiv hrel + exact ⟨isDefEq_fullHitCheapMode_true htrace hstats haddr hctx hequiv + hcheap hhit, hfinal, hsemantic⟩ + +/-- Exact positive root/cheap-cache second-chance hit. Both original +partitions are populated because cheap `true` is sound in full mode, then the +original keys are joined. -/ +theorem isDefEq_rootCheapHit_true + {methods : Methods .anon} {a b : KExpr .anon} + {ctxAddr : Address} {aRoot bRoot : EqKey} + {s s1 s2 s3 s4 s5 : TcState .anon} + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = true) + (hfullMiss : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hcheapMiss : s4.env.defEqCheapCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hroots : TcM.withEquiv (fun em => + let (aRoot?, em) := em.findRootKey + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let (bRoot?, em) := em.findRootKey + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((aRoot?, bRoot?), em)) s4 = .ok (some aRoot, some bRoot) s5) + (hchanged : (aRoot != + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ || + bRoot != ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) = true) + (hscope : aRoot.rootCacheScopeMatches bRoot ctxAddr + (max a.lbr b.lbr) = true) + (hrootFullMiss : s5.env.defEqCache[ + ((canonicalPair aRoot.exprAddr bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr bRoot.exprAddr).2, ctxAddr)]? = none) + (hhit : s5.env.defEqCheapCache[ + ((canonicalPair aRoot.exprAddr bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr bRoot.exprAddr).2, ctxAddr)]? = + some true) : + let cacheKey := + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) + let aKey : EqKey := + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let bKey : EqKey := + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + let cachedState := {s5 with env := {s5.env with + defEqCheapCache := s5.env.defEqCheapCache.insert cacheKey true + defEqCache := s5.env.defEqCache.insert cacheKey true}} + let final := {cachedState with + equivManager := cachedState.equivManager.addEquiv aKey bKey} + (isDefEq a b).run methods s = .ok true final := by + dsimp only + unfold isDefEq + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}")) _ s = _ + unfold EStateM.bind + rw [htrace] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1})) + _ s1 = _ + unfold EStateM.bind + rw [hstats] + simp only [haddr, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.defEqCtxKey a b) _ s2 = _ + unfold EStateM.bind + rw [hctx] + simp only + change ReaderT.run + ((liftM (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) : + RecM .anon Bool) >>= _) + methods s3 = _ + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) _ s3 = _ + unfold EStateM.bind + rw [hequiv] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hcheap] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hfullMiss, if_true] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hcheapMiss] + change ReaderT.run + ((liftM (TcM.withEquiv (fun em => + let (aRoot?, em) := em.findRootKey + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let (bRoot?, em) := em.findRootKey + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((aRoot?, bRoot?), em))) : + RecM .anon (Option EqKey × Option EqKey)) >>= _) + methods s4 = _ + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.withEquiv (fun em => + let (aRoot?, em) := em.findRootKey + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let (bRoot?, em) := em.findRootKey + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((aRoot?, bRoot?), em))) _ s4 = _ + unfold EStateM.bind + rw [hroots] + simp only [hchanged, hscope, if_true] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s5 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s5 = .ok s5 s5 from rfl] + simp [hrootFullMiss] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s5 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s5 = .ok s5 s5 from rfl] + simp only [hhit, if_true] + rfl + +/-- Soundness of the guarded positive root/cheap branch. Root paths and the +scope guard justify the hit; the copied cheap/full entries are constructed +from the resulting original-pair meaning before the manager is updated. -/ +theorem isDefEq_rootCheapHit_true_acceptance + {methods : Methods .anon} {layer : WhnfLayer} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (model : KernelSuffixModel trProj world) + {Delta : KVLCtx} {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} + {ctxAddr : Address} {aRoot bRoot : EqKey} + {s s1 s2 s3 s4 s5 : TcState .anon} + (theory : WhnfTheory trProj world model.keys.uvars) + (hcollision : support.CollisionFree) + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = true) + (hfullMiss : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hcheapMiss : s4.env.defEqCheapCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hroots : TcM.withEquiv (fun em => + let (aRoot?, em) := em.findRootKey + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let (bRoot?, em) := em.findRootKey + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((aRoot?, bRoot?), em)) s4 = .ok (some aRoot, some bRoot) s5) + (hchanged : (aRoot != + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ || + bRoot != ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) = true) + (hscope : aRoot.rootCacheScopeMatches bRoot ctxAddr + (max a.lbr b.lbr) = true) + (hrootFullMiss : s5.env.defEqCache[ + ((canonicalPair aRoot.exprAddr bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr bRoot.exprAddr).2, ctxAddr)]? = none) + (hhit : s5.env.defEqCheapCache[ + ((canonicalPair aRoot.exprAddr bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr bRoot.exprAddr).2, ctxAddr)]? = + some true) + (hI : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta s) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta b vb) + (hreferences : + (CacheEntry.defEq .full + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true).ReferencesAuthorized + (CacheAuthority.stable world) support) : + let cacheKey := + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) + let aKey : EqKey := + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let bKey : EqKey := + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + let cachedState := {s5 with env := {s5.env with + defEqCheapCache := s5.env.defEqCheapCache.insert cacheKey true + defEqCache := s5.env.defEqCache.insert cacheKey true}} + let final := {cachedState with + equivManager := cachedState.equivManager.addEquiv aKey bKey} + (isDefEq a b).run methods s = .ok true final ∧ + WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta final ∧ + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb := by + dsimp only + have htraceWf := + (TcM.stepTrace_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s) hI + rw [htrace] at htraceWf + have hstatsWf := + (TcM.bumpStats_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) s1) + htraceWf.1 + rw [hstats] at hstatsWf + have hctxWf := + (TcM.defEqCtxKey_model_matches_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (support := support) model (Delta := Delta) (a := a) (b := b) + (s := s2)) hstatsWf.1 + rw [hctx] at hctxWf + have hrepresented := hctxWf.2.1.2.1 + have hequivWf := + (TcM.withEquiv_isEquiv_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ s3) hctxWf.1 + rw [hequiv] at hequivWf + have hrootsWf := + (TcM.withEquiv_findRootKeys_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ s4) hequivWf.1 + rw [hroots] at hrootsWf + have haPath := hrootsWf.2.1 aRoot rfl + have hbPath := hrootsWf.2.2 bRoot rfl + change DefEqKeyEquiv model.keys trProj (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ aRoot at haPath + change DefEqKeyEquiv model.keys trProj (CacheAuthority.stable world) support + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ bRoot at hbPath + have hrootProvenance := hrootsWf.1.1.caches.hit (.defEqCheap hhit) + have hsemantic := hrootProvenance.kernelDefEqRootAcceptance + theory hrootsWf.1.2.1.wf hcollision haPath hbPath hscope hrepresented + haSupport hbSupport ha hb + have horiginalMeaning : + DefEqMeaning trProj world model.keys.uvars Delta a b true := by + intro _ + exact ⟨va, vb, ha, hb, hsemantic⟩ + have hfullProvenance := model.defEqProvenance hcollision .full + haSupport hbSupport hrepresented horiginalMeaning hreferences + have hcheapProvenance : + CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .cheap + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true) := + hfullProvenance.kernelDefEqRekind + have hcheapState := + DefEqCacheUpdate.cheap_whnfStateInv hrootsWf.1 hcheapProvenance + have hbothStateRaw := + DefEqCacheUpdate.full_whnfStateInv hcheapState hfullProvenance + have hbothState : + WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta + {s5 with env := {s5.env with + defEqCheapCache := s5.env.defEqCheapCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true + defEqCache := s5.env.defEqCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true}} := by + simpa using hbothStateRaw + have hrel : DefEqKeyEquiv model.keys trProj + (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ := + hfullProvenance.kernelDefEqEquivCanonical hcollision + haSupport hbSupport + have hfinal := hbothState.addEquiv hrel + exact ⟨isDefEq_rootCheapHit_true htrace hstats haddr hctx hequiv hcheap + hfullMiss hcheapMiss hroots hchanged hscope hrootFullMiss hhit, + hfinal, hsemantic⟩ + +/-- Common semantic state transition for a positive guarded root hit when +cheap mode requires copying the answer into both original-key partitions. -/ +theorem guardedRootHit_copyBoth + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : KernelSuffixModel trProj world) + {kind : DefEqCacheKind} {Delta : KVLCtx} + {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} + {ctxAddr : Address} {aRoot bRoot : EqKey} {s : TcState .anon} + (theory : WhnfTheory trProj world model.keys.uvars) + (hcollision : support.CollisionFree) + (hI : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta s) + (haPath : DefEqKeyEquiv model.keys trProj + (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ aRoot) + (hbPath : DefEqKeyEquiv model.keys trProj + (CacheAuthority.stable world) support + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ bRoot) + (hscope : aRoot.rootCacheScopeMatches bRoot ctxAddr + (max a.lbr b.lbr) = true) + (hrepresented : model.keys.Represents (max a.lbr b.lbr) ctxAddr Delta) + (hroot : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq kind + ((canonicalPair aRoot.exprAddr bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr bRoot.exprAddr).2, ctxAddr) true)) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta b vb) + (hreferences : + (CacheEntry.defEq .full + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true).ReferencesAuthorized + (CacheAuthority.stable world) support) : + let cacheKey := + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) + let aKey : EqKey := + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let bKey : EqKey := + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + let cachedState := {s with env := {s.env with + defEqCheapCache := s.env.defEqCheapCache.insert cacheKey true + defEqCache := s.env.defEqCache.insert cacheKey true}} + let final := {cachedState with + equivManager := cachedState.equivManager.addEquiv aKey bKey} + WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta final ∧ + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb := by + dsimp only + have hsemantic := hroot.kernelDefEqRootAcceptance + theory hI.2.1.wf hcollision haPath hbPath hscope hrepresented + haSupport hbSupport ha hb + have horiginalMeaning : + DefEqMeaning trProj world model.keys.uvars Delta a b true := by + intro _ + exact ⟨va, vb, ha, hb, hsemantic⟩ + have hfullProvenance := model.defEqProvenance hcollision .full + haSupport hbSupport hrepresented horiginalMeaning hreferences + have hcheapProvenance : + CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .cheap + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true) := + hfullProvenance.kernelDefEqRekind + have hcheapState := + DefEqCacheUpdate.cheap_whnfStateInv hI hcheapProvenance + have hbothStateRaw := + DefEqCacheUpdate.full_whnfStateInv hcheapState hfullProvenance + have hbothState : + WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta + {s with env := {s.env with + defEqCheapCache := s.env.defEqCheapCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true + defEqCache := s.env.defEqCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true}} := by + simpa using hbothStateRaw + have hrel : DefEqKeyEquiv model.keys trProj + (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ := + hfullProvenance.kernelDefEqEquivCanonical hcollision + haSupport hbSupport + exact ⟨hbothState.addEquiv hrel, hsemantic⟩ + +/-- Exact positive root/full-cache hit observed in cheap mode. As for a +root/cheap hit, production copies the positive answer into both original-key +partitions before joining the keys. -/ +theorem isDefEq_rootFullHitCheapMode_true + {methods : Methods .anon} {a b : KExpr .anon} + {ctxAddr : Address} {aRoot bRoot : EqKey} + {s s1 s2 s3 s4 s5 : TcState .anon} + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = true) + (hfullMiss : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hcheapMiss : s4.env.defEqCheapCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hroots : TcM.withEquiv (fun em => + let (aRoot?, em) := em.findRootKey + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let (bRoot?, em) := em.findRootKey + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((aRoot?, bRoot?), em)) s4 = .ok (some aRoot, some bRoot) s5) + (hchanged : (aRoot != + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ || + bRoot != ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) = true) + (hscope : aRoot.rootCacheScopeMatches bRoot ctxAddr + (max a.lbr b.lbr) = true) + (hhit : s5.env.defEqCache[ + ((canonicalPair aRoot.exprAddr bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr bRoot.exprAddr).2, ctxAddr)]? = + some true) : + let cacheKey := + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) + let aKey : EqKey := + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let bKey : EqKey := + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + let cachedState := {s5 with env := {s5.env with + defEqCheapCache := s5.env.defEqCheapCache.insert cacheKey true + defEqCache := s5.env.defEqCache.insert cacheKey true}} + let final := {cachedState with + equivManager := cachedState.equivManager.addEquiv aKey bKey} + (isDefEq a b).run methods s = .ok true final := by + dsimp only + unfold isDefEq + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}")) _ s = _ + unfold EStateM.bind + rw [htrace] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1})) + _ s1 = _ + unfold EStateM.bind + rw [hstats] + simp only [haddr, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.defEqCtxKey a b) _ s2 = _ + unfold EStateM.bind + rw [hctx] + simp only + change ReaderT.run + ((liftM (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) : + RecM .anon Bool) >>= _) + methods s3 = _ + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) _ s3 = _ + unfold EStateM.bind + rw [hequiv] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hcheap] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hfullMiss, if_true] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hcheapMiss] + change ReaderT.run + ((liftM (TcM.withEquiv (fun em => + let (aRoot?, em) := em.findRootKey + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let (bRoot?, em) := em.findRootKey + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((aRoot?, bRoot?), em))) : + RecM .anon (Option EqKey × Option EqKey)) >>= _) + methods s4 = _ + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.withEquiv (fun em => + let (aRoot?, em) := em.findRootKey + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let (bRoot?, em) := em.findRootKey + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((aRoot?, bRoot?), em))) _ s4 = _ + unfold EStateM.bind + rw [hroots] + simp only [hchanged, hscope, if_true] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s5 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s5 = .ok s5 s5 from rfl] + simp only [hhit, if_true] + rfl + +/-- Semantic acceptance of the positive root/full hit in cheap mode. -/ +theorem isDefEq_rootFullHitCheapMode_true_acceptance + {methods : Methods .anon} {layer : WhnfLayer} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (model : KernelSuffixModel trProj world) + {Delta : KVLCtx} {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} + {ctxAddr : Address} {aRoot bRoot : EqKey} + {s s1 s2 s3 s4 s5 : TcState .anon} + (theory : WhnfTheory trProj world model.keys.uvars) + (hcollision : support.CollisionFree) + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = true) + (hfullMiss : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hcheapMiss : s4.env.defEqCheapCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hroots : TcM.withEquiv (fun em => + let (aRoot?, em) := em.findRootKey + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let (bRoot?, em) := em.findRootKey + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((aRoot?, bRoot?), em)) s4 = .ok (some aRoot, some bRoot) s5) + (hchanged : (aRoot != + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ || + bRoot != ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) = true) + (hscope : aRoot.rootCacheScopeMatches bRoot ctxAddr + (max a.lbr b.lbr) = true) + (hhit : s5.env.defEqCache[ + ((canonicalPair aRoot.exprAddr bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr bRoot.exprAddr).2, ctxAddr)]? = + some true) + (hI : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta s) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta b vb) + (hreferences : + (CacheEntry.defEq .full + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true).ReferencesAuthorized + (CacheAuthority.stable world) support) : + let cacheKey := + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) + let aKey : EqKey := + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + let bKey : EqKey := + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + let cachedState := {s5 with env := {s5.env with + defEqCheapCache := s5.env.defEqCheapCache.insert cacheKey true + defEqCache := s5.env.defEqCache.insert cacheKey true}} + let final := {cachedState with + equivManager := cachedState.equivManager.addEquiv aKey bKey} + (isDefEq a b).run methods s = .ok true final ∧ + WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta final ∧ + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb := by + dsimp only + have htraceWf := + (TcM.stepTrace_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s) hI + rw [htrace] at htraceWf + have hstatsWf := + (TcM.bumpStats_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) s1) + htraceWf.1 + rw [hstats] at hstatsWf + have hctxWf := + (TcM.defEqCtxKey_model_matches_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (support := support) model (Delta := Delta) (a := a) (b := b) + (s := s2)) hstatsWf.1 + rw [hctx] at hctxWf + have hrepresented := hctxWf.2.1.2.1 + have hequivWf := + (TcM.withEquiv_isEquiv_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ s3) hctxWf.1 + rw [hequiv] at hequivWf + have hrootsWf := + (TcM.withEquiv_findRootKeys_whnf_wf (layer := layer) + (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (uvars := model.keys.uvars) (Delta := Delta) + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ s4) hequivWf.1 + rw [hroots] at hrootsWf + have haPath := hrootsWf.2.1 aRoot rfl + have hbPath := hrootsWf.2.2 bRoot rfl + change DefEqKeyEquiv model.keys trProj (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ aRoot at haPath + change DefEqKeyEquiv model.keys trProj (CacheAuthority.stable world) support + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ bRoot at hbPath + have hrootProvenance := hrootsWf.1.1.caches.hit (.defEq hhit) + have htail := guardedRootHit_copyBoth model theory hcollision hrootsWf.1 + haPath hbPath hscope hrepresented hrootProvenance haSupport hbSupport + ha hb hreferences + exact ⟨isDefEq_rootFullHitCheapMode_true htrace hstats haddr hctx hequiv + hcheap hfullMiss hcheapMiss hroots hchanged hscope hhit, + htail.1, htail.2⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/CacheShell.lean b/Ix/Tc/Verify/DefEq/CacheShell.lean new file mode 100644 index 000000000..b6f72ddd9 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/CacheShell.lean @@ -0,0 +1,1049 @@ +import Ix.Tc.Verify.DefEq.CacheBranches + +/-! +# DefEq cache shell + +The production entry point exposes two exact control-flow seams. +`isDefEqAfterDirectCacheMiss` contains the guarded equivalence-root probe; +`isDefEqAfterRootCacheMiss` contains the charged recursive comparison and +final cache write. The bridge theorems below connect the entry-point prefix +to those production-owned functions. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Once the full partition misses outside cheap mode, the remaining concrete +entry-point program is exactly `isDefEqAfterDirectCacheMiss`. -/ +theorem isDefEq_directMiss_noncheap + {methods : Methods .anon} {a b : KExpr .anon} + {ctxAddr : Address} {s s1 s2 s3 s4 : TcState .anon} + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = false) + (hfullMiss : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) : + (isDefEq a b).run methods s = + (isDefEqAfterDirectCacheMiss a b ctxAddr + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) false).run methods s4 := by + unfold isDefEq + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}")) _ s = _ + unfold EStateM.bind + rw [htrace] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1})) + _ s1 = _ + unfold EStateM.bind + rw [hstats] + simp only [haddr, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.defEqCtxKey a b) _ s2 = _ + unfold EStateM.bind + rw [hctx] + simp only + change ReaderT.run + ((liftM (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) : + RecM .anon Bool) >>= _) + methods s3 = _ + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) _ s3 = _ + unfold EStateM.bind + rw [hequiv] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hcheap] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hfullMiss, Bool.false_eq_true, if_false] + rfl + +/-- In cheap mode, once both direct partitions miss, the same exact root +probe remains with the captured cheap policy bit set. -/ +theorem isDefEq_directMiss_cheap + {methods : Methods .anon} {a b : KExpr .anon} + {ctxAddr : Address} {s s1 s2 s3 s4 : TcState .anon} + (htrace : TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s = .ok () s1) + (hstats : TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1}) s1 = + .ok () s2) + (haddr : (a.addr == b.addr) = false) + (hctx : TcM.defEqCtxKey a b s2 = .ok ctxAddr s3) + (hequiv : TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) s3 = .ok false s4) + (hcheap : (s4.cheapRecursionDepth > 0) = true) + (hfullMiss : s4.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) + (hcheapMiss : s4.env.defEqCheapCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]? = none) : + (isDefEq a b).run methods s = + (isDefEqAfterDirectCacheMiss a b ctxAddr + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true).run methods s4 := by + unfold isDefEq + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.stepTrace "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}")) _ s = _ + unfold EStateM.bind + rw [htrace] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.bumpStats + (fun st : TcState .anon => {st with deqCalls := st.deqCalls + 1})) + _ s1 = _ + unfold EStateM.bind + rw [hstats] + simp only [haddr, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.defEqCtxKey a b) _ s2 = _ + unfold EStateM.bind + rw [hctx] + simp only + change ReaderT.run + ((liftM (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) : + RecM .anon Bool) >>= _) + methods s3 = _ + rw [ReaderT.run_bind] + change EStateM.bind + (TcM.withEquiv + (·.isEquiv ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩)) _ s3 = _ + unfold EStateM.bind + rw [hequiv] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hcheap] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hfullMiss, if_true] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s4 = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s4 = .ok s4 s4 from rfl] + simp only [hcheapMiss] + rfl + +namespace DefEqInner + +/-- Semantic contract still owed by the recursive DefEq tiers. Separating +it from the cache shell keeps the latter independent of branch order inside +`isDefEqInner`. -/ +def WF (layer : WhnfLayer) (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (model : KernelSuffixModel trProj world) : Prop := + ∀ {Delta s a b va vb}, + support a → support b → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta a va → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta b vb → + RecM.WF layer (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s (isDefEqInner a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) + +end DefEqInner + +/-- The simultaneous cheap-result write used by production is the +composition of the already-certified cheap write and, only for `true`, its +sound promotion to the full partition. -/ +private theorem cheapResult_whnfStateInv + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {model : KernelSuffixModel trProj world} + {Delta : KVLCtx} {s : TcState .anon} + {key : Address × Address × Address} {answer : Bool} + (hI : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta s) + (hcheap : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support (.defEq .cheap key answer)) + (hfull : answer = true → + CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support (.defEq .full key true)) : + WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta + {s with env := {s.env with + defEqCheapCache := s.env.defEqCheapCache.insert key answer + defEqCache := if answer then s.env.defEqCache.insert key true + else s.env.defEqCache}} := by + cases answer with + | false => + simpa using DefEqCacheUpdate.cheap_whnfStateInv hI hcheap + | true => + have hcheapState := DefEqCacheUpdate.cheap_whnfStateInv hI hcheap + have hboth := DefEqCacheUpdate.full_whnfStateInv hcheapState (hfull rfl) + simpa using hboth + +/-- A full root-cache result is always copied to the original full key and, +when the caller is already in cheap mode, to the cheap partition as well. -/ +private theorem fullResult_whnfStateInv + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {model : KernelSuffixModel trProj world} + {Delta : KVLCtx} {s : TcState .anon} + {key : Address × Address × Address} {answer cheapMode : Bool} + (hI : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta s) + (hfull : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support (.defEq .full key answer)) : + WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta + {s with env := {s.env with + defEqCache := s.env.defEqCache.insert key answer + defEqCheapCache := if cheapMode then + s.env.defEqCheapCache.insert key answer + else s.env.defEqCheapCache}} := by + cases cheapMode with + | false => + simpa using DefEqCacheUpdate.full_whnfStateInv hI hfull + | true => + have hfullState := DefEqCacheUpdate.full_whnfStateInv hI hfull + have hcheap : CacheProvenance + (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support (.defEq .cheap key answer) := + hfull.kernelDefEqRekind + have hboth := DefEqCacheUpdate.cheap_whnfStateInv hfullState hcheap + simpa using hboth + +/-- Interpret one guarded root-cache answer at the caller's original pair. +Negative answers need only rejection-safe provenance; positive answers must +compose both manager paths with the cached root equality. -/ +private theorem guardedRootResult + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : KernelSuffixModel trProj world) + (theory : WhnfTheory trProj world model.keys.uvars) + (hcollision : support.CollisionFree) + {kind : DefEqCacheKind} {answer : Bool} {Delta : KVLCtx} + {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} + {ctxAddr : Address} {aRoot bRoot : EqKey} {s : TcState .anon} + (hI : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta s) + (haPath : DefEqKeyEquiv model.keys trProj + (CacheAuthority.stable world) support + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ aRoot) + (hbPath : DefEqKeyEquiv model.keys trProj + (CacheAuthority.stable world) support + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ bRoot) + (hscope : aRoot.rootCacheScopeMatches bRoot ctxAddr + (max a.lbr b.lbr) = true) + (hctx : model.keys.Represents (max a.lbr b.lbr) ctxAddr Delta) + (hroot : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq kind + ((canonicalPair aRoot.exprAddr bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr bRoot.exprAddr).2, ctxAddr) answer)) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta b vb) + (hreferences : + (CacheEntry.defEq .full + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer).ReferencesAuthorized + (CacheAuthority.stable world) support) : + CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .full + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer) ∧ + (answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) := by + cases answer with + | false => + refine ⟨model.defEqProvenance hcollision .full haSupport hbSupport + hctx DefEqMeaning.false hreferences, ?_⟩ + intro h + contradiction + | true => + have hsemantic := hroot.kernelDefEqRootAcceptance theory hI.2.1.wf + hcollision haPath hbPath hscope hctx haSupport hbSupport ha hb + have hmeaning : DefEqMeaning trProj world model.keys.uvars + Delta a b true := by + intro _ + exact ⟨va, vb, ha, hb, hsemantic⟩ + exact ⟨model.defEqProvenance hcollision .full haSupport hbSupport + hctx hmeaning hreferences, fun _ => hsemantic⟩ + +/-- State and semantic contract for a root result sourced from the full +partition. -/ +private theorem applyFullRootResult_wf + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {model : KernelSuffixModel trProj world} + {Delta : KVLCtx} {s : TcState .anon} + {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} {ctxAddr : Address} + {answer cheapMode : Bool} + (hcollision : support.CollisionFree) + (haSupport : support a) (hbSupport : support b) + (hfull : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .full + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer)) + (hsemantic : answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) : + RecM.WF layer (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s + (do + modify fun st => {st with env := {st.env with + defEqCache := st.env.defEqCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer + defEqCheapCache := if cheapMode then + st.env.defEqCheapCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer + else st.env.defEqCheapCache}} + if answer then + modify fun st => {st with + equivManager := st.equivManager.addEquiv + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩} + return answer) + (fun result _ => result = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) := by + cases answer with + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => fullResult_whnfStateInv hI hfull) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.pure fun _ h => by contradiction + | true => + simp only [if_true] + have hrel := hfull.kernelDefEqEquivCanonical hcollision + haSupport hbSupport + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => fullResult_whnfStateInv hI hfull) + (fun _ => trivial) + · intro _ _ _ + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => hI.addEquiv hrel) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.pure fun _ _ => hsemantic rfl + +/-- State and semantic contract for a root result sourced from the cheap +partition. A positive cheap answer is promoted to full before union. -/ +private theorem applyCheapRootResult_wf + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {model : KernelSuffixModel trProj world} + {Delta : KVLCtx} {s : TcState .anon} + {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} {ctxAddr : Address} + {answer : Bool} + (hcollision : support.CollisionFree) + (haSupport : support a) (hbSupport : support b) + (hfull : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .full + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer)) + (hsemantic : answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) : + RecM.WF layer (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s + (do + modify fun st => {st with env := {st.env with + defEqCheapCache := st.env.defEqCheapCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer + defEqCache := if answer then + st.env.defEqCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true + else st.env.defEqCache}} + if answer then + modify fun st => {st with + equivManager := st.equivManager.addEquiv + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩} + return answer) + (fun result _ => result = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) := by + have hcheap : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .cheap + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer) := + hfull.kernelDefEqRekind + cases answer with + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => cheapResult_whnfStateInv hI hcheap + (fun h => by contradiction)) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.pure fun _ h => by contradiction + | true => + simp only [if_true] + have hrel := hfull.kernelDefEqEquivCanonical hcollision + haSupport hbSupport + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => cheapResult_whnfStateInv hI hcheap (fun _ => hfull)) + (fun _ => trivial) + · intro _ _ _ + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => hI.addEquiv hrel) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.pure fun _ _ => hsemantic rfl + +section DirectFullHit + +set_option maxHeartbeats 800000 + +/-- A direct full-cache hit optionally copies into the cheap partition, then +joins the original keys only when the cached answer is positive. -/ +private theorem applyDirectFullHit_wf + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {model : KernelSuffixModel trProj world} + {Delta : KVLCtx} {s : TcState .anon} + {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} {ctxAddr : Address} + {answer cheapMode : Bool} + (hcollision : support.CollisionFree) + (haSupport : support a) (hbSupport : support b) + (hfull : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .full + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer)) + (hsemantic : answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) : + RecM.WF layer (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s + (do + if cheapMode then + modify fun st => {st with env := {st.env with + defEqCheapCache := st.env.defEqCheapCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer}} + if answer then + modify fun st => {st with + equivManager := st.equivManager.addEquiv + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩} + return answer) + (fun result _ => result = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) := by + have hcheap : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .cheap + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer) := + hfull.kernelDefEqRekind + cases cheapMode with + | false => + cases answer with + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + exact RecM.WF.pure fun _ h => by contradiction + | true => + simp only [Bool.false_eq_true, if_false, if_true, pure_bind] + have hrel := hfull.kernelDefEqEquivCanonical hcollision + haSupport hbSupport + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (Q := fun _ _ => True) + (f := fun st : TcState .anon => {st with + equivManager := st.equivManager.addEquiv + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩}) + (fun (hI : WhnfStateInv layer + (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s) => + hI.addEquiv hrel) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.pure fun _ _ => hsemantic rfl + | true => + cases answer with + | false => + simp only [Bool.false_eq_true, if_false, if_true, pure_bind] + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => DefEqCacheUpdate.cheap_whnfStateInv hI hcheap) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.pure fun _ h => by contradiction + | true => + simp only [if_true] + have hrel := hfull.kernelDefEqEquivCanonical hcollision + haSupport hbSupport + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => DefEqCacheUpdate.cheap_whnfStateInv hI hcheap) + (fun _ => trivial) + · intro _ _ _ + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (f := fun st : TcState .anon => {st with + equivManager := st.equivManager.addEquiv + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩}) + (fun hI => hI.addEquiv hrel) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.pure fun _ _ => hsemantic rfl + +end DirectFullHit + +/-- A direct cheap-cache hit promotes only a positive answer, combining the +full-cache write and justified union in the production record update. -/ +private theorem applyDirectCheapHit_wf + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {model : KernelSuffixModel trProj world} + {Delta : KVLCtx} {s : TcState .anon} + {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} {ctxAddr : Address} + {answer : Bool} + (hcollision : support.CollisionFree) + (haSupport : support a) (hbSupport : support b) + (hcheap : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .cheap + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer)) + (hsemantic : answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) : + RecM.WF layer (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s + (do + if answer then + modify fun st => {st with + env := {st.env with + defEqCache := st.env.defEqCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true} + equivManager := st.equivManager.addEquiv + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩} + return answer) + (fun result _ => result = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) := by + cases answer with + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + exact RecM.WF.pure fun _ h => by contradiction + | true => + simp only [if_true] + have hfull : CacheProvenance + (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .full + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true) := + hcheap.kernelDefEqRekind + have hrel := hfull.kernelDefEqEquivCanonical hcollision + haSupport hbSupport + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (f := fun st : TcState .anon => {st with + env := {st.env with + defEqCache := st.env.defEqCache.insert + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) true} + equivManager := st.equivManager.addEquiv + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩}) + (fun (hI : WhnfStateInv layer + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars Delta s) => by + have hfullState := + DefEqCacheUpdate.full_whnfStateInv hI hfull + have hfinal := hfullState.addEquiv hrel + simpa using hfinal) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.pure fun _ _ => hsemantic rfl + +/-- Conditional closure of the charged recursive tail. All bookkeeping +errors preserve the checker invariant; successful results are cached with +collision-robust provenance, and only a semantically justified `true` joins +the original equivalence keys. -/ +theorem isDefEqAfterRootCacheMiss_wf + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : KernelSuffixModel trProj world) + (hcollision : support.CollisionFree) + (hinner : DefEqInner.WF layer trProj world support model) + {Delta : KVLCtx} {s : TcState .anon} + {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} {ctxAddr : Address} + {cheapMode : Bool} + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta b vb) + (hctx : model.keys.Represents (max a.lbr b.lbr) ctxAddr Delta) + (hreferences : ∀ (kind : DefEqCacheKind) (answer : Bool), + (CacheEntry.defEq kind + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer).ReferencesAuthorized + (CacheAuthority.stable world) support) : + RecM.WF layer (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s + (isDefEqAfterRootCacheMiss a b + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) cheapMode) + (fun answer _ => answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) := by + unfold isDefEqAfterRootCacheMiss + apply RecM.WF.bind + · apply RecM.WF.liftTcM + exact TcM.bumpStats_whnf_wf + (fun st => {st with deqMisses := st.deqMisses + 1}) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) s + · intro _ s₁ _ + apply RecM.WF.bind + · apply RecM.WF.liftTcM + exact TcM.WF.mono + (TcM.tick.wf (fun _ hI => hI.of_semantic_fields_eq + rfl rfl rfl rfl rfl rfl rfl rfl)) + (fun _ _ _ => trivial) (fun _ _ _ => trivial) + · intro _ s₂ _ + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => hI.of_semantic_fields_eq + rfl rfl rfl rfl rfl rfl rfl rfl) + (fun _ => trivial) + · intro _ s₃ _ + apply RecM.WF.bind + (Q₁ := fun read after => read = after) + (RecM.WF.get fun _ => rfl) + intro read s₄ hread + subst read + by_cases hdepth : s₄.defEqDepth > maxDefEqDepth + · simp only [hdepth, if_true] + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => hI.of_semantic_fields_eq + rfl rfl rfl rfl rfl rfl rfl rfl) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.throw fun _ => trivial + · simp only [hdepth, if_false, pure_bind] + apply RecM.WF.bind + (Q₁ := fun result _ => match result with + | .ok answer => answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb + | .error _ => True) + · apply RecM.WF.tryCatch + · apply RecM.WF.bind + (hinner haSupport hbSupport ha hb) + intro answer _ hanswer + exact RecM.WF.pure fun _ => hanswer + · intro _ _ _ + exact RecM.WF.pure fun _ => trivial + · intro result s₅ hresult + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => hI.of_semantic_fields_eq + rfl rfl rfl rfl rfl rfl rfl rfl) + (fun _ => trivial) + · intro _ s₆ _ + cases result with + | error err => + exact RecM.WF.throw fun _ => trivial + | ok answer => + cases answer with + | false => + have hmeaning : DefEqMeaning trProj world + model.keys.uvars Delta a b false := + DefEqMeaning.false + cases cheapMode with + | false => + have hfull := model.defEqProvenance hcollision .full + haSupport hbSupport hctx hmeaning + (hreferences .full false) + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => + DefEqCacheUpdate.full_whnfStateInv hI hfull) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.pure fun _ htrue => by + contradiction + | true => + have hcheap := model.defEqProvenance hcollision .cheap + haSupport hbSupport hctx hmeaning + (hreferences .cheap false) + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => cheapResult_whnfStateInv hI hcheap + (fun h => by contradiction)) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.pure fun _ htrue => by + contradiction + | true => + have hsemantic := hresult rfl + have hmeaning : DefEqMeaning trProj world + model.keys.uvars Delta a b true := by + intro _ + exact ⟨va, vb, ha, hb, hsemantic⟩ + have hfull := model.defEqProvenance hcollision .full + haSupport hbSupport hctx hmeaning + (hreferences .full true) + have hrel := hfull.kernelDefEqEquivCanonical hcollision + haSupport hbSupport + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => hI.addEquiv hrel) + (fun _ => trivial) + · intro _ s₇ _ + cases cheapMode with + | false => + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => + DefEqCacheUpdate.full_whnfStateInv hI hfull) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.pure fun _ _ => hsemantic + | true => + have hcheap : CacheProvenance + (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) support + (.defEq .cheap + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, + ctxAddr) true) := + hfull.kernelDefEqRekind + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => cheapResult_whnfStateInv hI hcheap + (fun _ => hfull)) + (fun _ => trivial) + · intro _ _ _ + exact RecM.WF.pure fun _ _ => hsemantic + +/-- Conditional closure of the guarded representative probe. Every miss or +scope rejection falls through to the charged tail; every hit is interpreted +from cache provenance before its answer is copied to the caller's key. -/ +theorem isDefEqAfterDirectCacheMiss_wf + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : KernelSuffixModel trProj world) + (theory : WhnfTheory trProj world model.keys.uvars) + (hcollision : support.CollisionFree) + (hinner : DefEqInner.WF layer trProj world support model) + {Delta : KVLCtx} {s : TcState .anon} + {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} {ctxAddr : Address} + {cheapMode : Bool} + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta b vb) + (hctx : model.keys.Represents (max a.lbr b.lbr) ctxAddr Delta) + (hreferences : ∀ (kind : DefEqCacheKind) (answer : Bool), + (CacheEntry.defEq kind + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer).ReferencesAuthorized + (CacheAuthority.stable world) support) : + RecM.WF layer (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s + (isDefEqAfterDirectCacheMiss a b ctxAddr + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) cheapMode) + (fun answer _ => answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) := by + unfold isDefEqAfterDirectCacheMiss + apply RecM.WF.bind + · apply RecM.WF.withInv + apply RecM.WF.liftTcM + exact TcM.withEquiv_findRootKeys_whnf_wf + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ s + · intro roots s₁ hroots + rcases roots with ⟨aRootOpt, bRootOpt⟩ + rcases hroots with ⟨hI₁, haPaths, hbPaths⟩ + cases aRootOpt with + | none => + simpa using isDefEqAfterRootCacheMiss_wf model hcollision hinner + haSupport hbSupport ha hb hctx hreferences (s := s₁) + (cheapMode := cheapMode) + | some aRoot => + cases bRootOpt with + | none => + simpa using isDefEqAfterRootCacheMiss_wf model hcollision hinner + haSupport hbSupport ha hb hctx hreferences (s := s₁) + (cheapMode := cheapMode) + | some bRoot => + have haPath := haPaths aRoot rfl + have hbPath := hbPaths bRoot rfl + cases hchanged : (aRoot != + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ || + bRoot != ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩) with + | false => + simp only [hchanged, Bool.false_eq_true, if_false] + exact isDefEqAfterRootCacheMiss_wf model hcollision hinner + haSupport hbSupport ha hb hctx hreferences + (s := s₁) (cheapMode := cheapMode) + | true => + simp only [hchanged, if_true] + cases hscope : aRoot.rootCacheScopeMatches bRoot ctxAddr + (max a.lbr b.lbr) with + | false => + simp only [Bool.false_eq_true, if_false] + exact isDefEqAfterRootCacheMiss_wf model hcollision hinner + haSupport hbSupport ha hb hctx hreferences + (s := s₁) (cheapMode := cheapMode) + | true => + simp only [if_true] + apply RecM.WF.bind + (Q₁ := fun read after => read = after ∧ + WhnfStateInv layer + (kernelCacheSemantics model.keys trProj) trProj + world support model.keys.uvars Delta after) + (RecM.WF.get fun hI => ⟨rfl, hI⟩) + intro read s₂ hread + rcases hread with ⟨hreadEq, hI₂⟩ + subst read + cases hfullHit : (s₂.env.defEqCache[ + ((canonicalPair aRoot.exprAddr bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr bRoot.exprAddr).2, + ctxAddr)]?) with + | some answer => + have hroot := hI₂.1.caches.hit (.defEq hfullHit) + have horiginal := guardedRootResult model theory + hcollision hI₂ haPath hbPath hscope hctx hroot + haSupport hbSupport ha hb (hreferences .full answer) + simp only [pure_bind, Bool.false_eq_true, + if_false] + exact applyFullRootResult_wf hcollision + haSupport hbSupport horiginal.1 horiginal.2 + (cheapMode := cheapMode) + | none => + cases cheapMode with + | false => + simp only [Bool.false_eq_true, if_false, + pure_bind] + exact isDefEqAfterRootCacheMiss_wf model hcollision + hinner haSupport hbSupport ha hb hctx hreferences + (s := s₂) (cheapMode := false) + | true => + simp only [if_true, pure_bind] + apply RecM.WF.bind + (Q₁ := fun read after => read = after ∧ + WhnfStateInv layer + (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta + after) + (RecM.WF.get fun hI => ⟨rfl, hI⟩) + intro read s₃ hread + rcases hread with ⟨hreadEq, hI₃⟩ + subst read + cases hcheapHit : (s₃.env.defEqCheapCache[ + ((canonicalPair aRoot.exprAddr + bRoot.exprAddr).1, + (canonicalPair aRoot.exprAddr + bRoot.exprAddr).2, ctxAddr)]?) with + | some answer => + have hroot := hI₃.1.caches.hit + (.defEqCheap hcheapHit) + have horiginal := guardedRootResult model theory + hcollision hI₃ haPath hbPath hscope hctx + hroot haSupport hbSupport ha hb + (hreferences .full answer) + exact applyCheapRootResult_wf hcollision + haSupport hbSupport horiginal.1 horiginal.2 + | none => + exact isDefEqAfterRootCacheMiss_wf model + hcollision hinner haSupport hbSupport ha hb + hctx hreferences (s := s₃) + (cheapMode := true) + +/-- Conditional semantic closure of the complete public DefEq entry point. +The only remaining assumption is the recursive tier contract; every fast +path, manager query, direct-cache branch, and guarded representative fallback +is discharged here against the concrete production program. -/ +theorem isDefEq_wf + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : KernelSuffixModel trProj world) + (theory : WhnfTheory trProj world model.keys.uvars) + (hcollision : support.CollisionFree) + (hinner : DefEqInner.WF layer trProj world support model) + {Delta : KVLCtx} {s : TcState .anon} + {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta b vb) + (hreferences : ∀ (ctxAddr : Address) (kind : DefEqCacheKind) + (answer : Bool), + (CacheEntry.defEq kind + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr) answer).ReferencesAuthorized + (CacheAuthority.stable world) support) : + RecM.WF layer (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s (isDefEq a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb) := by + unfold isDefEq + apply RecM.WF.bind + · apply RecM.WF.liftTcM + exact TcM.stepTrace_whnf_wf "deq" + (fun _ => s!"{TcM.addr8 a.addr} ~ {TcM.addr8 b.addr}") s + · intro _ s₁ _ + apply RecM.WF.bind + · apply RecM.WF.liftTcM + exact TcM.bumpStats_whnf_wf + (fun st => {st with deqCalls := st.deqCalls + 1}) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) s₁ + · intro _ s₂ _ + cases haddr : (a.addr == b.addr) with + | true => + simp only [if_true] + exact RecM.WF.pure fun hI _ => + DefEqMeaning.of_translations theory hI.2.1.wf ha hb + (DefEqMeaning.of_addr_beq theory hI.2.1 hcollision + haSupport hbSupport ha haddr) rfl + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + apply RecM.WF.bind + · apply RecM.WF.withInv + apply RecM.WF.liftTcM + exact TcM.defEqCtxKey_model_matches_wf + (semantics := kernelCacheSemantics model.keys trProj) + (support := support) model (Delta := Delta) (a := a) (b := b) + (s := s₂) + · intro ctxAddr s₃ hctxPost + rcases hctxPost with ⟨hI₃, hmatches, _hframe⟩ + have hrepresented := hmatches.2.1 + apply RecM.WF.bind + · apply RecM.WF.withInv + apply RecM.WF.liftTcM + exact TcM.withEquiv_isEquiv_whnf_wf + ⟨a.addr, ctxAddr, max a.lbr b.lbr, a.lbr⟩ + ⟨b.addr, ctxAddr, max a.lbr b.lbr, b.lbr⟩ s₃ + · intro isEq s₄ hequivPost + rcases hequivPost with ⟨hI₄, hequiv⟩ + cases isEq with + | true => + simp only [if_true] + have hsemantic := (hequiv rfl).sound theory hI₄.2.1.wf + hcollision haSupport rfl hbSupport rfl hrepresented ha hb + exact RecM.WF.pure fun _ _ => hsemantic + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind + (Q₁ := fun read after => read = after ∧ + WhnfStateInv layer + (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta after) + (RecM.WF.get fun hI => ⟨rfl, hI⟩) + intro read s₅ hread + rcases hread with ⟨hread, hI₅⟩ + subst read + apply RecM.WF.bind + (Q₁ := fun read after => read = after ∧ + WhnfStateInv layer + (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta after) + (RecM.WF.get fun hI => ⟨rfl, hI⟩) + intro read s₆ hread + rcases hread with ⟨hread, hI₆⟩ + subst read + cases hfullHit : (s₆.env.defEqCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]?) with + | some answer => + have hfull := hI₆.1.caches.hit (.defEq hfullHit) + have hmeaning := hfull.kernelDefEqMeaningCanonical + haSupport hbSupport hrepresented + have hsemantic : answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx va vb := + fun htrue => DefEqMeaning.of_translations theory + hI₆.2.1.wf ha hb hmeaning htrue + by_cases hcheapMode : s₅.cheapRecursionDepth > 0 + · simp only [hcheapMode, if_true] + exact applyDirectFullHit_wf hcollision haSupport + hbSupport hfull hsemantic (cheapMode := true) + · simp only [hcheapMode, if_false] + exact applyDirectFullHit_wf hcollision haSupport + hbSupport hfull hsemantic (cheapMode := false) + | none => + by_cases hcheapMode : s₅.cheapRecursionDepth > 0 + · simp only [hcheapMode, if_true, decide_true] + apply RecM.WF.bind + (Q₁ := fun read after => read = after ∧ + WhnfStateInv layer + (kernelCacheSemantics model.keys trProj) trProj + world support model.keys.uvars Delta after) + (RecM.WF.get fun hI => ⟨rfl, hI⟩) + intro read s₇ hread + rcases hread with ⟨hread, hI₇⟩ + subst read + cases hcheapHit : (s₇.env.defEqCheapCache[ + ((canonicalPair a.addr b.addr).1, + (canonicalPair a.addr b.addr).2, ctxAddr)]?) with + | some answer => + have hcheap := hI₇.1.caches.hit + (.defEqCheap hcheapHit) + have hmeaning := + hcheap.kernelDefEqMeaningCanonical + haSupport hbSupport hrepresented + have hsemantic : answer = true → + world.venv.IsDefEqU model.keys.uvars + Delta.toCtx va vb := + fun htrue => DefEqMeaning.of_translations theory + hI₇.2.1.wf ha hb hmeaning htrue + exact applyDirectCheapHit_wf hcollision haSupport + hbSupport hcheap hsemantic + | none => + exact isDefEqAfterDirectCacheMiss_wf model theory + hcollision hinner haSupport hbSupport ha hb + hrepresented (hreferences ctxAddr) + (s := s₇) (cheapMode := true) + · simp only [hcheapMode, if_false, decide_false] + exact isDefEqAfterDirectCacheMiss_wf model theory + hcollision hinner haSupport hbSupport ha hb + hrepresented (hreferences ctxAddr) + (s := s₆) (cheapMode := false) + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/CheapReduction.lean b/Ix/Tc/Verify/DefEq/CheapReduction.lean new file mode 100644 index 000000000..7b68bcd85 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/CheapReduction.lean @@ -0,0 +1,335 @@ +import Ix.Tc.Verify.DefEq.StringLiteral +import Ix.Tc.Verify.Whnf.NoDelta.Reducer + +/-! +# Cheap DefEq reduction prefix + +DefEq performs two cheap-projection normalization passes before lazy delta: +structural core reduction and then no-delta WHNF. This module verifies the +cheap-depth scope itself and composes both passes with address collision +freedom and the already verified structural comparison. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Common semantic contract for a direct production reducer used by DefEq. -/ +def DefEqReduction.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) + (reduce : KExpr .anon → RecM .anon (KExpr .anon)) : Prop := + ∀ {Delta state source sourceV}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + RecM.WF layer semantics trProj world support uvars Delta state + (reduce source) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + +/-- Incrementing the cheap-recursion counter changes only operational +bookkeeping and preserves the complete verification invariant. -/ +theorem cheapRecursionDepth_enter_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) state + (modify (fun s : TcState .anon => + {s with cheapRecursionDepth := s.cheapRecursionDepth + 1})) + (fun _ _ => True) := by + unfold modify + exact TcM.WF.modifyGet + (fun hI => hI.of_semantic_fields_eq rfl rfl rfl rfl rfl rfl rfl rfl) + (fun _ => trivial) + +/-- Decrementing the cheap-recursion counter is the matching invariant-safe +finalizer operation. -/ +theorem cheapRecursionDepth_exit_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) state + (modify (fun s : TcState .anon => + {s with cheapRecursionDepth := s.cheapRecursionDepth - 1})) + (fun _ _ => True) := by + unfold modify + exact TcM.WF.modifyGet + (fun hI => hI.of_semantic_fields_eq rfl rfl rfl rfl rfl rfl rfl rfl) + (fun _ => trivial) + +/-- Any state-independent semantic result survives the production cheap-depth +scope. The finalizer runs after both successful and failed body executions. -/ +theorem withCheapRecursionDepth_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {x : RecM .anon α} {P : α → Prop} + (hbody : ∀ {bodyState}, + RecM.WF layer semantics trProj world support uvars Delta bodyState x + (fun result _ => P result)) : + RecM.WF layer semantics trProj world support uvars Delta state + (withCheapRecursionDepth x) (fun result _ => P result) := by + intro methods hmethods + unfold withCheapRecursionDepth + rw [ReaderT.run_bind] + change TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) state + (do + (modify (fun s : TcState .anon => + {s with cheapRecursionDepth := s.cheapRecursionDepth + 1}) : + TcM .anon Unit) + tryFinally (x.run methods) + (modify (fun s : TcState .anon => + {s with cheapRecursionDepth := s.cheapRecursionDepth - 1}))) + (fun result _ => P result) + apply TcM.WF.bind cheapRecursionDepth_enter_wf + intro _ afterEnter _ + change TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) + afterEnter + (tryFinally (x.run methods) + (modify (fun s : TcState .anon => + {s with cheapRecursionDepth := s.cheapRecursionDepth - 1}))) + (fun result _ => P result) + apply TcM.WF.tryFinally_const + · exact hbody methods hmethods + · intro afterBody + exact cheapRecursionDepth_exit_wf + +/-- Lift a verified `.DEF_EQ_CORE` structural reducer through the concrete +cheap-depth wrapper. -/ +theorem whnfCoreForDefEq_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hbody : DefEqReduction.WFAt layer semantics trProj world support uvars + (fun source => whnfCoreWithFlags source .DEF_EQ_CORE)) : + DefEqReduction.WFAt layer semantics trProj world support uvars + whnfCoreForDefEq := by + intro Delta state source sourceV hsourceSupport hsource + unfold whnfCoreForDefEq + apply withCheapRecursionDepth_wf + intro bodyState + exact hbody hsourceSupport hsource + +/-- Lift a verified cheap no-delta reducer through the concrete cheap-depth +wrapper. -/ +theorem whnfNoDeltaForDefEq_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hbody : DefEqReduction.WFAt layer semantics trProj world support uvars + (fun source => whnfNoDeltaImpl source .DEF_EQ_CORE .collapse)) : + DefEqReduction.WFAt layer semantics trProj world support uvars + whnfNoDeltaForDefEq := by + intro Delta state source sourceV hsourceSupport hsource + unfold whnfNoDeltaForDefEq + apply withCheapRecursionDepth_wf + intro bodyState + exact hbody hsourceSupport hsource + +/-- The two direct cheap reducers used by the pre-delta DefEq prefix. -/ +structure DefEqCheapReductionContext + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop where + core : DefEqReduction.WFAt layer semantics trProj world support uvars + whnfCoreForDefEq + noDelta : DefEqReduction.WFAt layer semantics trProj world support uvars + whnfNoDeltaForDefEq + +namespace DefEqCheapReductionContext + +/-- Construct the public cheap reducers from their unwrapped K1/K2 body +contracts. -/ +theorem ofBodies + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hcore : DefEqReduction.WFAt layer semantics trProj world support uvars + (fun source => whnfCoreWithFlags source .DEF_EQ_CORE)) + (hnoDelta : DefEqReduction.WFAt layer semantics trProj world support uvars + (fun source => whnfNoDeltaImpl source .DEF_EQ_CORE .collapse)) : + DefEqCheapReductionContext layer semantics trProj world support uvars := + ⟨whnfCoreForDefEq_wf hcore, whnfNoDeltaForDefEq_wf hnoDelta⟩ + +end DefEqCheapReductionContext + +namespace DefEqAfterCorePass + +/-- Semantic contract for the tiers following the cheap structural-core +comparison. -/ +def WF (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ {Delta state a b aV bV}, + support a → support b → + TrKExprS world.venv uvars world.nameOf trProj Delta a aV → + TrKExprS world.venv uvars world.nameOf trProj Delta b bV → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqInnerAfterCorePass a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx aV bV) + +/-- Close the first cheap normalization pass. Address equality is interpreted +only through finite-run expression collision freedom; equal digests alone are +never treated as semantic equality. -/ +theorem closesAfterStringExpansion + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hsorts : SortComponentResources support) + (hstructural : QuickDefEqResources support) + (hreduction : DefEqCheapReductionContext layer semantics trProj world + support uvars) + (htail : WF layer semantics trProj world support uvars) : + DefEqAfterStringExpansion.WF layer semantics trProj world support + uvars := by + intro Delta state a b aV bV haSupport hbSupport ha hb + unfold isDefEqInnerAfterStringExpansion + apply RecM.WF.bind (RecM.WF.withInv <| + hreduction.core haSupport ha) + intro ca afterA hca + rcases hca with ⟨hIA, hcaSupport, caV, hcaTr, haCa⟩ + apply RecM.WF.bind (RecM.WF.withInv <| + hreduction.core hbSupport hb) + intro cb afterB hcb + rcases hcb with ⟨hIB, hcbSupport, cbV, hcbTr, hbCb⟩ + cases haddr : ca.addr == cb.addr with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => by + have herase := + hcollision.expr hcaSupport hcbSupport (eq_of_beq haddr) + have hsame : ca = cb := by + simpa only [KExpr.eraseMeta_anon] using herase + subst cb + have hmiddle := hcaTr.uniq world.venvWF theory.literalWF + theory.projections + (KVLCtx.IsDefEq.refl world.venvWF hIB.2.1.wf) hcbTr + exact haCa.trans world.venvWF hIB.2.1.wf <| + hmiddle.trans world.venvWF hIB.2.1.wf hbCb.symm + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind + (quickDefEq_wf theory hcollision hsorts hstructural + hcaSupport hcbSupport hcaTr hcbTr) + intro accepted afterQuick haccepted + cases accepted with + | true => + simp only [if_true] + exact RecM.WF.pure fun hI _ => + haCa.trans world.venvWF hI.2.1.wf <| + (haccepted rfl).trans world.venvWF hI.2.1.wf hbCb.symm + | false => + simp only [Bool.false_eq_true, if_false] + exact htail haSupport hbSupport ha hb + +end DefEqAfterCorePass + +namespace DefEqAfterNoDeltaPass + +/-- Semantic contract for lazy-delta and final-WHNF tiers after the cheap +no-delta pair has failed its immediate comparisons. -/ +def WF (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ {Delta state a b aV bV}, + support a → support b → + TrKExprS world.venv uvars world.nameOf trProj Delta a aV → + TrKExprS world.venv uvars world.nameOf trProj Delta b bV → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqInnerAfterNoDeltaPass a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx aV bV) + +/-- Close the second cheap normalization pass and transport a later verdict +back across both no-delta reductions. -/ +theorem closesAfterCorePass + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hsorts : SortComponentResources support) + (hstructural : QuickDefEqResources support) + (hreduction : DefEqCheapReductionContext layer semantics trProj world + support uvars) + (htail : WF layer semantics trProj world support uvars) : + DefEqAfterCorePass.WF layer semantics trProj world support uvars := by + intro Delta state a b aV bV haSupport hbSupport ha hb + unfold isDefEqInnerAfterCorePass + apply RecM.WF.bind (RecM.WF.withInv <| + hreduction.noDelta haSupport ha) + intro wa afterA hwa + rcases hwa with ⟨hIA, hwaSupport, waV, hwaTr, haWa⟩ + apply RecM.WF.bind (RecM.WF.withInv <| + hreduction.noDelta hbSupport hb) + intro wb afterB hwb + rcases hwb with ⟨hIB, hwbSupport, wbV, hwbTr, hbWb⟩ + cases haddr : wa.addr == wb.addr with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => by + have herase := + hcollision.expr hwaSupport hwbSupport (eq_of_beq haddr) + have hsame : wa = wb := by + simpa only [KExpr.eraseMeta_anon] using herase + subst wb + have hmiddle := hwaTr.uniq world.venvWF theory.literalWF + theory.projections + (KVLCtx.IsDefEq.refl world.venvWF hIB.2.1.wf) hwbTr + exact haWa.trans world.venvWF hIB.2.1.wf <| + hmiddle.trans world.venvWF hIB.2.1.wf hbWb.symm + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind + (quickDefEq_wf theory hcollision hsorts hstructural + hwaSupport hwbSupport hwaTr hwbTr) + intro accepted afterQuick haccepted + cases accepted with + | true => + simp only [if_true] + exact RecM.WF.pure fun hI _ => + haWa.trans world.venvWF hI.2.1.wf <| + (haccepted rfl).trans world.venvWF hI.2.1.wf hbWb.symm + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.mono (RecM.WF.withInv <| + htail hwaSupport hwbSupport hwaTr hwbTr) + · intro answer final hpost htrue + exact haWa.trans world.venvWF hpost.1.2.1.wf <| + (hpost.2 htrue).trans world.venvWF hpost.1.2.1.wf hbWb.symm + · intro _ _ _ + trivial + +/-- Compose both cheap passes behind the post-String seam. -/ +theorem closesAfterStringExpansion + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hsorts : SortComponentResources support) + (hstructural : QuickDefEqResources support) + (hreduction : DefEqCheapReductionContext layer semantics trProj world + support uvars) + (htail : WF layer semantics trProj world support uvars) : + DefEqAfterStringExpansion.WF layer semantics trProj world support + uvars := + DefEqAfterCorePass.closesAfterStringExpansion theory hcollision hsorts + hstructural hreduction + (closesAfterCorePass theory hcollision hsorts hstructural hreduction + htail) + +end DefEqAfterNoDeltaPass + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/Closure.lean b/Ix/Tc/Verify/DefEq/Closure.lean new file mode 100644 index 000000000..752558a78 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/Closure.lean @@ -0,0 +1,179 @@ +import Ix.Tc.Verify.DefEq.CacheShell +import Ix.Tc.Verify.DefEq.FinalWhnf.Closure +import Ix.Tc.Verify.DefEq.LazyDeltaClosure + +/-! +# Complete definitional-equality closure + +This module assembles the verified recursive DefEq tiers, the public cache +shell, and the exact `isDefEq` field of one unfolded method-table layer. The +resource record deliberately reuses witnesses owned by its lower closure +records: projection delta owns the shared Theory/collision/structural facts, +while final WHNF owns the direct reducer and primitive-expansion facts. +-/ + +namespace Ix.Tc + +namespace CacheEntry + +/-- If every direct declaration reference in the finite run support is +trusted, then either DefEq cache partition may safely mention any pair of +supported source addresses. The key itself carries no authority: its direct +roots are recovered through `SourceReferences`. -/ +theorem defEqReferencesAuthorized + {world : VerifyWorld} {support : RunSupport} + (htrusted : RecM.TrustedReferences world support) + {kind : DefEqCacheKind} {key : Address × Address × Address} + {answer : Bool} : + (CacheEntry.defEq kind key answer).ReferencesAuthorized + (CacheAuthority.stable world) support := by + intro id href + apply Or.inl + change CacheEntry.SourceReferences support key.1 id ∨ + CacheEntry.SourceReferences support key.2.1 id at href + rcases href with ⟨source, hsource, _haddr, hreference⟩ | + ⟨source, hsource, _haddr, hreference⟩ + · exact htrusted hsource hreference + · exact htrusted hsource hreference + +end CacheEntry + +namespace RecM + +/-- Concrete resources for the entire recursive and public DefEq method. +No field assumes soundness of `isDefEqInner`, `isDefEqWhnf`, or `isDefEq` +itself. -/ +structure DefEqClosureResources + {trProj : RawProjRel} {world : VerifyWorld} (support : RunSupport) + (proposition : PropositionClassifierContext trProj world support) + (eligible : KId .anon → Prop) where + finalWhnf : FinalWhnfClosureResources support proposition eligible + iteration : LazyDeltaIterationResources support proposition.model + projectionDelta : ProjectionDeltaClosureResources + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars + structural : StructuralCongruenceResources support + application : TryDefEqApp.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars + bool : BoolTruePrimitiveContext world + cheap : DefEqCheapReductionContext .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars + +namespace DefEqClosureResources + +/-- Supply the stopped lazy-delta continuation from concrete projection, +structural, application-spine, and final-WHNF closures. -/ +def stopped + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {proposition : PropositionClassifierContext trProj world support} + {eligible : KId .anon → Prop} + (resources : DefEqClosureResources support proposition eligible) : + StoppedContinuationClosureResources + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars where + projectionDelta := resources.projectionDelta + structural := resources.structural + application := resources.application + finalWhnf := resources.finalWhnf.finalWhnf + +/-- Assemble one complete bounded lazy-delta resource from its verified +iteration and stopped continuation. -/ +def lazyDelta + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {proposition : PropositionClassifierContext trProj world support} + {eligible : KId .anon → Prop} + (resources : DefEqClosureResources support proposition eligible) : + LazyDeltaClosureResources support proposition.model where + iteration := resources.iteration + stopped := resources.stopped + +/-- Close the complete recursive `isDefEqInner` program in production tier +order. -/ +theorem inner + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {proposition : PropositionClassifierContext trProj world support} + {eligible : KId .anon → Prop} + (resources : DefEqClosureResources support proposition eligible) : + DefEqInner.WF .noAccel trProj world support proposition.model := by + unfold DefEqInner.WF + exact DefEqAfterStringExpansion.closesInner + resources.projectionDelta.theory + resources.projectionDelta.collision + resources.projectionDelta.sorts + resources.projectionDelta.quick + resources.bool + resources.finalWhnf.string + resources.finalWhnf.canonical + resources.finalWhnf.directWhnf + (DefEqAfterProofIrrelevance.closesAfterStringExpansion + resources.projectionDelta.theory + resources.projectionDelta.collision + resources.projectionDelta.sorts + resources.projectionDelta.quick + resources.cheap + (isPropType_wf proposition) + (DefEqAfterProofIrrelevance.ofKernelResources resources.lazyDelta)) + +/-- Close the complete public `isDefEq` entry point, including both result +cache partitions and guarded equivalence-root fallbacks. -/ +theorem entryPoint + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {proposition : PropositionClassifierContext trProj world support} + {eligible : KId .anon → Prop} + (resources : DefEqClosureResources support proposition eligible) : + ∀ {Delta state a b aV bV}, + support a → support b → + TrKExprS world.venv proposition.model.keys.uvars world.nameOf trProj + Delta a aV → + TrKExprS world.venv proposition.model.keys.uvars world.nameOf trProj + Delta b bV → + RecM.WF .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world + support proposition.model.keys.uvars Delta state (isDefEq a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU proposition.model.keys.uvars Delta.toCtx aV + bV) := by + intro Delta state a b aV bV haSupport hbSupport ha hb + exact isDefEq_wf proposition.model resources.projectionDelta.theory + resources.projectionDelta.collision resources.inner + haSupport hbSupport ha hb + (fun _ctxAddr _kind _answer => + CacheEntry.defEqReferencesAuthorized + resources.iteration.trustedReferences) + +/-- The `isDefEq` field of one unfolded production method-table layer. All +recursive calls are discharged solely by the smaller table's `Methods.WFAt` +hypothesis. -/ +theorem nextDefEq_wf + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {proposition : PropositionClassifierContext trProj world support} + {eligible : KId .anon → Prop} + (resources : DefEqClosureResources support proposition eligible) + (methods : Methods .anon) + (hmethods : Methods.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars methods) : + ∀ {Delta state a b aV bV}, + support a → support b → + TrKExprS world.venv proposition.model.keys.uvars world.nameOf trProj + Delta a aV → + TrKExprS world.venv proposition.model.keys.uvars world.nameOf trProj + Delta b bV → + TcM.WF + (WhnfStateInv .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world + support proposition.model.keys.uvars Delta) state + ((RecM.isDefEq a b).run methods) + (fun answer _ => answer = true → + world.venv.IsDefEqU proposition.model.keys.uvars Delta.toCtx aV + bV) := by + intro Delta state a b aV bV haSupport hbSupport ha hb + exact (resources.entryPoint haSupport hbSupport ha hb) methods hmethods + +end DefEqClosureResources + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/DeltaClassification.lean b/Ix/Tc/Verify/DefEq/DeltaClassification.lean new file mode 100644 index 000000000..7f3d9525f --- /dev/null +++ b/Ix/Tc/Verify/DefEq/DeltaClassification.lean @@ -0,0 +1,113 @@ +import Ix.Tc.Verify.DefEq.AcceleratorGates +import Ix.Tc.Verify.Whnf.Runtime.LazyIngress + +/-! +# Lazy-delta head classification + +Delta classification performs up to two declaration lookups, so its primary +obligation is preservation across the installed lazy-ingress hook. The +classifier result only selects which already-sound reduction is attempted; +no semantic claim is attached to a negative answer. This module also closes +the exact stopped branch where neither head is classified as reducible. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Exact remaining one-step contract after the classifier establishes that +at least one operand has a delta-reducible head. -/ +def DefEqLazyDeltaAfterDeltaClassification.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftSource rightSource left right aHead bHead + aDelta bDelta}, + (!aDelta && !bDelta) = false → + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right) → + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepAfterDeltaClassification left right + aHead bHead aDelta bDelta) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) + +/-- Head classification preserves the complete recursive state invariant, +including successful, absent, and partially failing lazy declaration loads. -/ +theorem classifyDeltaHead_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (source : KExpr .anon) : + RecM.WF layer semantics trProj world support uvars Delta state + (classifyDeltaHead source) (fun _ _ => True) := by + unfold classifyDeltaHead + cases hhead : headConstId source with + | none => + exact RecM.WF.pure fun _ => trivial + | some id => + unfold isDelta + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.tryGetConst_wf hfault id state + intro found afterLookup _ + cases found with + | none => exact RecM.WF.pure fun _ => trivial + | some decl => + cases decl <;> simp only + all_goals try exact RecM.WF.pure fun _ => trivial + all_goals + split <;> exact RecM.WF.pure fun _ => trivial + +/-- Close both classifier lookups and the joint non-delta stopped result. -/ +theorem defEqLazyDeltaStepAfterAcceleratorMiss_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : Lean4Lean.VExpr} + {left right : KExpr .anon} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hafter : DefEqLazyDeltaAfterDeltaClassification.WFAt layer semantics + trProj world support uvars) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepAfterAcceleratorMiss left right) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) := by + unfold defEqLazyDeltaStepAfterAcceleratorMiss + apply RecM.WF.bind (classifyDeltaHead_wf hfault left) + intro leftDelta afterLeft _ + apply RecM.WF.bind (classifyDeltaHead_wf hfault right) + intro rightDelta afterRight _ + cases hstopped : (!leftDelta && !rightDelta) with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ => hpair + | false => + simp only [Bool.false_eq_true, if_false] + exact hafter hstopped hpair + +namespace DefEqLazyDeltaAfterAcceleratorMiss + +/-- Package classification against the actual anonymous lazy-ingress +contract used by the no-acceleration driver. -/ +theorem ofClassification + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (ingress : AnonLazyIngressContext .noAccel semantics trProj world + support) + (hafter : DefEqLazyDeltaAfterDeltaClassification.WFAt .noAccel semantics + trProj world support uvars) : + DefEqLazyDeltaAfterAcceleratorMiss.WFAt .noAccel semantics trProj world + support uvars := by + intro Delta state leftSource rightSource left right hpair + exact defEqLazyDeltaStepAfterAcceleratorMiss_wf ingress.preserves hafter + hpair + +end DefEqLazyDeltaAfterAcceleratorMiss + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/EqualRankCache.lean b/Ix/Tc/Verify/DefEq/EqualRankCache.lean new file mode 100644 index 000000000..3f1dc901c --- /dev/null +++ b/Ix/Tc/Verify/DefEq/EqualRankCache.lean @@ -0,0 +1,177 @@ +import Ix.Tc.Verify.DefEq.SameHeadSpine + +/-! +# Equal-rank same-head cache + +The same-head attempt is guarded by a narrow negative cache. Its entries +are rejection-only: they can skip work but never prove equality. This module +proves the exact lookup/attempt/write shell and preserves provenance for the +single write made after a genuine comparison miss. +-/ + +namespace Ix.Tc + +/-- Provenance available for every concrete failure marker this run may +insert. -/ +structure DefEqFailureCacheResources (semantics : CacheSemantics) + (world : VerifyWorld) (support : RunSupport) : Prop where + provenance : ∀ {left right : KExpr .anon} {ctxAddr : Address}, + support left → support right → + CacheProvenance semantics (CacheAuthority.stable world) support + (.defEqFailure (defEqFailureKey left right ctxAddr)) + +namespace CacheEntry + +/-- Trusted finite expression references authorize every direct root named +by a rejection-only DefEq marker. -/ +theorem defEqFailureReferencesAuthorized + {world : VerifyWorld} {support : RunSupport} + (htrusted : RecM.TrustedReferences world support) + {left right : KExpr .anon} {ctxAddr : Address} : + (CacheEntry.defEqFailure (defEqFailureKey left right ctxAddr)).ReferencesAuthorized + (CacheAuthority.stable world) support := by + intro id href + change CacheEntry.SourceReferences support + (defEqFailureKey left right ctxAddr).1 id ∨ + CacheEntry.SourceReferences support + (defEqFailureKey left right ctxAddr).2.1 id at href + rcases href with ⟨source, hsource, haddr, hreference⟩ | + ⟨source, hsource, haddr, hreference⟩ + · exact .inl (htrusted hsource hreference) + · exact .inl (htrusted hsource hreference) + +end CacheEntry + +namespace DefEqFailureCacheResources + +/-- The joint K2 suffix model supplies failure-marker provenance without any +semantic equality premise; validity of this partition is deliberately +vacuous on acceptance. -/ +theorem ofKernelSuffixModel + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (model : KernelSuffixModel trProj world) + (htrusted : RecM.TrustedReferences world support) : + DefEqFailureCacheResources (kernelCacheSemantics model.keys trProj) + world support where + provenance := by + intro left right ctxAddr hleft hright + simpa only [defEqFailureKey] using + model.defEqFailureProvenance hleft hright + (CacheEntry.defEqFailureReferencesAuthorized htrusted) + +end DefEqFailureCacheResources + +namespace RecM + +/-- The regular-hint lookup preserves the full recursive invariant through +all declaration shapes and every lazy-ingress outcome. -/ +theorem isRegular_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (id : KId .anon) : + RecM.WF layer semantics trProj world support uvars Delta state + (isRegular id) (fun _ _ => True) := by + unfold isRegular + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.tryGetConst_wf hfault id state + intro found afterLookup _ + cases found with + | none => exact RecM.WF.pure fun _ => trivial + | some decl => + cases decl with + | defn name levelParams kind safety hints lvls ty value leanAll block => + cases hints <;> exact RecM.WF.pure fun _ => trivial + | recr | axio | quot | indc | ctor => + exact RecM.WF.pure fun _ => trivial + +/-- Semantic contract for the cached same-head helper. -/ +def TrySameHeadSpineCached.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (trySameHeadSpineCached left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Close context-key calculation, cache lookup, the concrete same-head +attempt, and the rejection-only write on a genuine miss. -/ +theorem trySameHeadSpineCached_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : Lean4Lean.VExpr} + (hcache : DefEqFailureCacheResources semantics world support) + (hsame : TrySameHeadSpine.WFAt layer semantics trProj world support + uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (trySameHeadSpineCached left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold trySameHeadSpineCached + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.defEqCtxKey_wf (a := left) (b := right) (s := state) + intro ctxAddr afterKey hframe + apply RecM.WF.bind + (Q₁ := fun read after => read = after) + (RecM.WF.get fun _ => rfl) + intro read afterRead hread + subst read + cases hhit : afterRead.env.defEqFailure.contains + (defEqFailureKey left right ctxAddr) with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ => trivial + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind <| + hsame hleftSupport hrightSupport hleft hright + intro result afterAttempt hresult + cases result with + | some answer => + exact RecM.WF.pure fun _ => hresult + | none => + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => DefEqCacheUpdate.failure_whnfStateInv hI <| + hcache.provenance hleftSupport hrightSupport) + (fun _ => trivial) + · intro _ afterWrite _ + exact RecM.WF.pure fun _ => trivial + +namespace TrySameHeadSpineCached + +/-- Package the concrete cached helper. -/ +theorem ofResources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hcache : DefEqFailureCacheResources semantics world support) + (hsame : TrySameHeadSpine.WFAt layer semantics trProj world support + uvars) : + TrySameHeadSpineCached.WFAt layer semantics trProj world support + uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact trySameHeadSpineCached_wf hcache hsame hleftSupport hrightSupport + hleft hright + +end TrySameHeadSpineCached + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/EqualRankPrefix.lean b/Ix/Tc/Verify/DefEq/EqualRankPrefix.lean new file mode 100644 index 000000000..4a83030af --- /dev/null +++ b/Ix/Tc/Verify/DefEq/EqualRankPrefix.lean @@ -0,0 +1,120 @@ +import Ix.Tc.Verify.DefEq.EqualRankCache + +/-! +# Equal-rank prefix assembly + +This module assembles regular-hint lookup, the cached same-head attempt, and +the already-proved two-sided reduction continuation into the complete +equal-rank lazy-delta contract. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Complete equal-rank branch, including every skipped guard, cached miss, +positive same-head result, and the post-miss two-sided reducer. -/ +theorem defEqLazyDeltaStepWithEqualRank_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + {leftHead rightHead : Option (KId .anon)} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hcached : TrySameHeadSpineCached.WFAt layer semantics trProj world + support uvars) + (hafter : DefEqLazyDeltaAfterSameHeadMiss.WFAt layer semantics trProj + world support uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepWithEqualRank left right leftHead rightHead) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold defEqLazyDeltaStepWithEqualRank + cases leftHead with + | none => exact hafter hpair + | some leftId => + cases rightHead with + | none => exact hafter hpair + | some rightId => + apply RecM.WF.bind (isRegular_wf hfault leftId) + intro regular afterRegular _ + cases hguard : (leftId.addr == rightId.addr && regular) with + | false => + simp only [Bool.false_eq_true, if_false] + exact hafter hpair + | true => + simp only [if_true] + apply RecM.WF.bind <| + hcached hpair.leftSupport hpair.rightSupport hleft hright + intro result afterAttempt hresult + cases result with + | none => exact hafter hpair + | some answer => + exact RecM.WF.pure fun _ hanswer => + hleftEq.trans world.venvWF hDelta <| + (hresult hanswer).trans world.venvWF hDelta + hrightEq.symm + +namespace DefEqLazyDeltaEqualRank + +/-- Package the complete generic equal-rank branch. -/ +theorem ofPrefix + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hfault : ∀ {Delta}, TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hcached : TrySameHeadSpineCached.WFAt layer semantics trProj world + support uvars) + (hafter : DefEqLazyDeltaAfterSameHeadMiss.WFAt layer semantics trProj + world support uvars) : + DefEqLazyDeltaEqualRank.WFAt layer semantics trProj world support + uvars := by + intro Delta state leftSource rightSource left right leftHead rightHead hpair + intro methods hmethods hI + exact (defEqLazyDeltaStepWithEqualRank_wf hfault hcached hafter + hI.2.1.wf hpair) methods hmethods hI + +/-- Concrete no-acceleration/K2 construction of the equal-rank branch. -/ +theorem ofKernelResources + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (model : KernelSuffixModel trProj world) + (ingress : AnonLazyIngressContext .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support) + (theory : WhnfTheory trProj world model.keys.uvars) + (hcollision : support.CollisionFree) + (hspines : SameHeadSpineResources support) + (htrusted : TrustedReferences world support) + (hafter : DefEqLazyDeltaAfterSameHeadMiss.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars) : + DefEqLazyDeltaEqualRank.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := by + have hsame : TrySameHeadSpine.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := + TrySameHeadSpine.ofResources theory hcollision hspines + have hcached : TrySameHeadSpineCached.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := + TrySameHeadSpineCached.ofResources + (DefEqFailureCacheResources.ofKernelSuffixModel model htrusted) hsame + intro Delta state leftSource rightSource left right leftHead rightHead hpair + intro methods hmethods hI + exact (defEqLazyDeltaStepWithEqualRank_wf ingress.preserves hcached hafter + hI.2.1.wf hpair) methods hmethods hI + +end DefEqLazyDeltaEqualRank + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/EqualRankReduction.lean b/Ix/Tc/Verify/DefEq/EqualRankReduction.lean new file mode 100644 index 000000000..1d95349af --- /dev/null +++ b/Ix/Tc/Verify/DefEq/EqualRankReduction.lean @@ -0,0 +1,151 @@ +import Ix.Tc.Verify.DefEq.RankDispatch + +/-! +# Equal-rank two-sided reduction + +Once the guarded same-head attempt has not answered, equal-rank lazy delta +tries both unfolds before normalizing either result. This module proves all +four hit/miss combinations in that exact order and feeds every productive +combination through the common finishing checks. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Contract for the equal-rank continuation after the same-head prefix. -/ +def DefEqLazyDeltaAfterSameHeadMiss.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftSource rightSource left right}, + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right) → + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepAfterSameHeadMiss left right) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) + +/-- Close both equal-rank unfold probes, their four result combinations, and +the corresponding no-delta normalization calls. -/ +theorem defEqLazyDeltaStepAfterSameHeadMiss_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + (context : LazyDeltaReductionContext layer semantics trProj world support + uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepAfterSameHeadMiss left right) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold defEqLazyDeltaStepAfterSameHeadMiss + apply RecM.WF.bind + (RecM.WF.withInv <| + context.delta hpair.leftSupport hleft) + intro leftResult afterLeft hleftResult + rcases hleftResult with ⟨hILeft, hleftResult⟩ + apply RecM.WF.bind + (RecM.WF.withInv <| + context.delta hpair.rightSupport hright) + intro rightResult afterRight hrightResult + rcases hrightResult with ⟨hIRight, hrightResult⟩ + cases leftResult with + | none => + cases rightResult with + | none => + exact RecM.WF.pure fun _ => hpair + | some unfoldedRight => + rcases hrightResult with + ⟨hunfoldedSupport, hunfoldedMeaning⟩ + have hunfoldedPost := WhnfPost.transMeaning context.theory hDelta + hpair.right hunfoldedMeaning + obtain ⟨unfoldedV, hunfoldedTr, hunfoldedEq⟩ := hunfoldedPost + apply RecM.WF.bind + (RecM.WF.withInv <| + context.normalize hunfoldedSupport hunfoldedTr) + intro reduced afterNormalize hreduced + rcases hreduced with + ⟨hINormalize, hreducedSupport, hreducedPost⟩ + have hrightReduced := WhnfPost.transMeaning context.theory hDelta + ⟨unfoldedV, hunfoldedTr, hunfoldedEq⟩ + (WhnfPost.meaning hunfoldedTr hreducedPost) + exact finishDefEqLazyDeltaStep_wf context.theory context.collision + context.sorts context.structural + ⟨hpair.leftSupport, hreducedSupport, hpair.left, hrightReduced⟩ + | some unfoldedLeft => + rcases hleftResult with ⟨hleftSupport, hleftMeaning⟩ + have hleftUnfolded := WhnfPost.transMeaning context.theory hDelta + hpair.left hleftMeaning + obtain ⟨leftUnfoldedV, hleftUnfoldedTr, hleftUnfoldedEq⟩ := + hleftUnfolded + cases rightResult with + | none => + apply RecM.WF.bind + (RecM.WF.withInv <| + context.normalize hleftSupport hleftUnfoldedTr) + intro reduced afterNormalize hreduced + rcases hreduced with + ⟨hINormalize, hreducedSupport, hreducedPost⟩ + have hleftReduced := WhnfPost.transMeaning context.theory hDelta + ⟨leftUnfoldedV, hleftUnfoldedTr, hleftUnfoldedEq⟩ + (WhnfPost.meaning hleftUnfoldedTr hreducedPost) + exact finishDefEqLazyDeltaStep_wf context.theory context.collision + context.sorts context.structural + ⟨hreducedSupport, hpair.rightSupport, hleftReduced, hpair.right⟩ + | some unfoldedRight => + rcases hrightResult with ⟨hrightSupport, hrightMeaning⟩ + have hrightUnfolded := WhnfPost.transMeaning context.theory hDelta + hpair.right hrightMeaning + obtain ⟨rightUnfoldedV, hrightUnfoldedTr, hrightUnfoldedEq⟩ := + hrightUnfolded + apply RecM.WF.bind + (RecM.WF.withInv <| + context.normalize hleftSupport hleftUnfoldedTr) + intro reducedLeft afterNormalizeLeft hreducedLeft + rcases hreducedLeft with + ⟨hINormalizeLeft, hreducedLeftSupport, hreducedLeftPost⟩ + have hleftReduced := WhnfPost.transMeaning context.theory hDelta + ⟨leftUnfoldedV, hleftUnfoldedTr, hleftUnfoldedEq⟩ + (WhnfPost.meaning hleftUnfoldedTr hreducedLeftPost) + apply RecM.WF.bind + (RecM.WF.withInv <| + context.normalize hrightSupport hrightUnfoldedTr) + intro reducedRight afterNormalizeRight hreducedRight + rcases hreducedRight with + ⟨hINormalizeRight, hreducedRightSupport, hreducedRightPost⟩ + have hrightReduced := WhnfPost.transMeaning context.theory hDelta + ⟨rightUnfoldedV, hrightUnfoldedTr, hrightUnfoldedEq⟩ + (WhnfPost.meaning hrightUnfoldedTr hreducedRightPost) + exact finishDefEqLazyDeltaStep_wf context.theory context.collision + context.sorts context.structural + ⟨hreducedLeftSupport, hreducedRightSupport, hleftReduced, + hrightReduced⟩ + +namespace DefEqLazyDeltaAfterSameHeadMiss + +/-- Package the concrete two-sided reducer as the post-same-head contract. -/ +theorem ofReduction + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (context : LazyDeltaReductionContext layer semantics trProj world support + uvars) : + DefEqLazyDeltaAfterSameHeadMiss.WFAt layer semantics trProj world support + uvars := by + intro Delta state leftSource rightSource left right hpair + intro methods hmethods hI + exact (defEqLazyDeltaStepAfterSameHeadMiss_wf context hI.2.1.wf hpair) + methods hmethods hI + +end DefEqLazyDeltaAfterSameHeadMiss + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/Application.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/Application.lean new file mode 100644 index 000000000..4833994da --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/Application.lean @@ -0,0 +1,120 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.Contracts + +/-! +# Final-WHNF application comparison + +This module proves the exact short-circuiting application branch of the +constructor-directed final comparison. Argument equality is requested only +after function equality succeeds, matching the production order. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Finite child coverage for supported applications selected by the final +WHNF comparator. -/ +structure FinalWhnfApplicationResources (support : RunSupport) : Prop where + components : ∀ {fn arg : KExpr .anon} {info : ExprInfo .anon}, + support (.app fn arg info) → support fn ∧ support arg + +namespace RecM + +/-- Positive-result contract for the exact application helper. -/ +def TryDefEqWhnfApp.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftFn leftArg rightFn rightArg} + {leftInfo rightInfo : ExprInfo .anon} {leftV rightV : VExpr}, + support (.app leftFn leftArg leftInfo) → + support (.app rightFn rightArg rightInfo) → + TrKExprS world.venv uvars world.nameOf trProj Delta + (.app leftFn leftArg leftInfo) leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta + (.app rightFn rightArg rightInfo) rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfApp leftFn leftArg rightFn rightArg) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Exhaustive execution and semantic proof of the direct application +branch. -/ +theorem tryDefEqWhnfApp_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftFn leftArg rightFn rightArg : KExpr .anon} + {leftInfo rightInfo : ExprInfo .anon} {leftV rightV : VExpr} + (resources : FinalWhnfApplicationResources support) + (hleftSupport : support (.app leftFn leftArg leftInfo)) + (hrightSupport : support (.app rightFn rightArg rightInfo)) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta + (.app leftFn leftArg leftInfo) leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta + (.app rightFn rightArg rightInfo) rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfApp leftFn leftArg rightFn rightArg) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + obtain ⟨hleftFnSupport, hleftArgSupport⟩ := + resources.components hleftSupport + obtain ⟨hrightFnSupport, hrightArgSupport⟩ := + resources.components hrightSupport + cases hleft with + | app hleftFnType hleftArgType hleftFn hleftArg => + cases hright with + | app hrightFnType hrightArgType hrightFn hrightArg => + unfold tryDefEqWhnfApp + apply RecM.WF.bind <| + RecM.isDefEqCall_wf hleftFnSupport hrightFnSupport hleftFn + hrightFn + intro functionsEqual afterFunction hfunctions + cases functionsEqual with + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [if_true] + apply RecM.WF.bind <| + RecM.isDefEqCall_wf hleftArgSupport hrightArgSupport + hleftArg hrightArg + intro argumentsEqual afterArgument harguments + cases argumentsEqual with + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [if_true] + exact RecM.WF.pure fun hI _ => by + have hDelta : KVLCtx.WF world.venv uvars Delta := + hI.2.1.wf + have hfunctionTyped := + (hfunctions rfl).of_l world.venvWF hDelta.toCtx + hleftFnType + have hargumentTyped := + (harguments rfl).of_l world.venvWF hDelta.toCtx + hleftArgType + exact (hfunctionTyped.appDF hargumentTyped).toU + +namespace TryDefEqWhnfApp + +/-- Package the application proof for the structural-prefix assembly. -/ +theorem ofResources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (resources : FinalWhnfApplicationResources support) : + TryDefEqWhnfApp.WFAt layer semantics trProj world support uvars := by + intro Delta state leftFn leftArg rightFn rightArg leftInfo rightInfo + leftV rightV hleftSupport hrightSupport hleft hright + exact tryDefEqWhnfApp_wf resources hleftSupport hrightSupport hleft hright + +end TryDefEqWhnfApp + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/Closure.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/Closure.lean new file mode 100644 index 000000000..b97a2f20a --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/Closure.lean @@ -0,0 +1,105 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.NatBridge +import Ix.Tc.Verify.DefEq.FinalWhnf.EtaExpansion +import Ix.Tc.Verify.DefEq.FinalWhnf.StringExpansion +import Ix.Tc.Verify.DefEq.FinalWhnf.StructuralPrefix +import Ix.Tc.Verify.DefEq.FinalWhnf.StructureEta +import Ix.Tc.Verify.DefEq.FinalWhnf.UnitLike +import Ix.Tc.Verify.DefEq.PropositionClassifier + +/-! +# Complete final-WHNF comparison + +The final comparator consists of an exhaustive structural prefix followed by +the ordered Nat, lambda-eta, String, structure-eta, unit-like, and proof- +irrelevance fallbacks. This module assembles those independently verified +phases under one canonical K2 suffix model. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Concrete resources for every production phase of `isDefEqWhnf`. The +proposition-classifier context fixes the canonical K2 suffix model used by +all cache-aware fields. -/ +structure FinalWhnfClosureResources + {trProj : RawProjRel} {world : VerifyWorld} (support : RunSupport) + (proposition : PropositionClassifierContext trProj world support) + (eligible : KId .anon → Prop) where + structural : FinalWhnfStructuralResources .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars + nat : FinalWhnfNatResources world support + lambdaEta : FinalWhnfEtaResources support + directWhnf : DefEqDirectWhnf.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars + string : DefEqStringContext trProj world support + canonical : CanonicalPrimitiveStates .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars + structureEta : FinalWhnfStructEtaResources .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars eligible + unit : FinalWhnfUnitResources .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars + +namespace FinalWhnfClosureResources + +/-- Assemble the complete post-structure fallback in its exact production +order. -/ +theorem afterStructural + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {proposition : PropositionClassifierContext trProj world support} + {eligible : KId .anon → Prop} + (resources : FinalWhnfClosureResources support proposition eligible) : + IsDefEqWhnfAfterStructural.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world + support proposition.model.keys.uvars := by + have hafterStructEta : IsDefEqWhnfAfterStructEta.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world + support proposition.model.keys.uvars := + IsDefEqWhnfAfterStructEta.ofUnitAndProof + (TryDefEqUnit.ofResources resources.unit) + (isPropType_wf proposition) + have hafterString : IsDefEqWhnfAfterString.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world + support proposition.model.keys.uvars := + IsDefEqWhnfAfterString.ofStructEta + (TryDefEqWhnfStructEta.ofResources resources.structureEta) + hafterStructEta + have hafterEta : IsDefEqWhnfAfterEta.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world + support proposition.model.keys.uvars := + IsDefEqWhnfAfterEta.ofString + (TryDefEqWhnfString.ofContext resources.string resources.canonical) + hafterString + have hafterNat : IsDefEqWhnfAfterNat.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world + support proposition.model.keys.uvars := + IsDefEqWhnfAfterNat.ofEta resources.structural.theory + resources.lambdaEta resources.structural.collision resources.directWhnf + hafterEta + intro Delta state left right leftV rightV hleftSupport hrightSupport hleft + hright + exact isDefEqWhnfAfterStructural_wf + (TryDefEqWhnfNat.ofResources resources.structural.theory resources.nat) + hafterNat hleftSupport hrightSupport hleft hright + +/-- Close the complete concrete final-WHNF comparator. -/ +theorem finalWhnf + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {proposition : PropositionClassifierContext trProj world support} + {eligible : KId .anon → Prop} + (resources : FinalWhnfClosureResources support proposition eligible) : + IsDefEqWhnf.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world + support proposition.model.keys.uvars := + IsDefEqWhnf.ofPhases + (TryDefEqWhnfStructural.ofResources resources.structural) + resources.afterStructural + +end FinalWhnfClosureResources + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/Contracts.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/Contracts.lean new file mode 100644 index 000000000..f758d6b91 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/Contracts.lean @@ -0,0 +1,258 @@ +import Ix.Tc.Verify.DefEq.StoppedContinuation + +/-! +# Final-WHNF comparison contracts + +The final DefEq tier has two production-owned phases: a constructor-directed +structural prefix and the Nat/eta/String/structural fallback chain. These +contracts let their exhaustive proofs be developed independently and then +compose them back into `isDefEqWhnf`. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Exact positive-result contract for the let-declaration helper. -/ +def TryDefEqWhnfLet.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftName rightName ty1 val1 body1 ty2 val2 body2} + {leftNondep rightNondep : Bool} + {leftInfo rightInfo : ExprInfo .anon} {leftV rightV : Lean4Lean.VExpr}, + support (.letE leftName ty1 val1 body1 leftNondep leftInfo) → + support (.letE rightName ty2 val2 body2 rightNondep rightInfo) → + TrKExprS world.venv uvars world.nameOf trProj Delta + (.letE leftName ty1 val1 body1 leftNondep leftInfo) leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta + (.letE rightName ty2 val2 body2 rightNondep rightInfo) rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfLet leftName ty1 val1 body1 ty2 val2 body2) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result soundness for the optional Nat bridge. -/ +def TryDefEqWhnfNat.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfNat left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result soundness for the fallback chain after the Nat bridge +returns `none`. -/ +def IsDefEqWhnfAfterNat.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnfAfterNat left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result soundness for the optional lambda-eta phase. -/ +def TryDefEqWhnfEta.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfEta left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result soundness for the fallback chain after lambda eta +returns `none`. -/ +def IsDefEqWhnfAfterEta.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnfAfterEta left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result soundness for the optional String-literal expansion +phase. -/ +def TryDefEqWhnfString.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfString left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result soundness for the fallback chain after String expansion +returns `none`. -/ +def IsDefEqWhnfAfterString.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnfAfterString left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result soundness for the optional bidirectional structure-eta +phase. -/ +def TryDefEqWhnfStructEta.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfStructEta left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result soundness for the concrete unit-like shortcut. -/ +def TryDefEqUnit.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqUnit left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result soundness for the unit-like/proof-irrelevance tail after +structure eta returns `none`. -/ +def IsDefEqWhnfAfterStructEta.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnfAfterStructEta left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result soundness for the final proof-irrelevance fallback. -/ +def IsDefEqWhnfAfterUnit.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnfAfterUnit left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result soundness for the constructor-directed prefix. `none` +is deliberately only a control-flow result. -/ +def TryDefEqWhnfStructural.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfStructural left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result soundness for the fallback chain after the structural +prefix returns `none`. -/ +def IsDefEqWhnfAfterStructural.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnfAfterStructural left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- The two exact production phases close the final WHNF comparator. -/ +theorem isDefEqWhnf_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : Lean4Lean.VExpr} + (hstructural : TryDefEqWhnfStructural.WFAt layer semantics trProj world + support uvars) + (htail : IsDefEqWhnfAfterStructural.WFAt layer semantics trProj world + support uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnf left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold isDefEqWhnf + apply RecM.WF.bind <| + hstructural hleftSupport hrightSupport hleft hright + intro result afterStructural hresult + cases result with + | none => exact htail hleftSupport hrightSupport hleft hright + | some answer => exact RecM.WF.pure fun _ => hresult + +namespace IsDefEqWhnf + +/-- Package the phase composition as the contract used by the stopped +continuation. -/ +theorem ofPhases + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hstructural : TryDefEqWhnfStructural.WFAt layer semantics trProj world + support uvars) + (htail : IsDefEqWhnfAfterStructural.WFAt layer semantics trProj world + support uvars) : + IsDefEqWhnf.WFAt layer semantics trProj world support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact isDefEqWhnf_wf hstructural htail hleftSupport hrightSupport hleft + hright + +end IsDefEqWhnf + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/EtaExpansion.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/EtaExpansion.lean new file mode 100644 index 000000000..314f923cc --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/EtaExpansion.lean @@ -0,0 +1,424 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.Contracts +import Ix.Tc.Verify.DefEq.ProofIrrelevance + +/-! +# Final-WHNF lambda eta + +This module verifies the concrete eta expansion built by +`tryEtaExpansion`: inference exposes the non-lambda operand's function type, +the operand is lifted under one binder, and the generated +`λ x, liftedOperand x` is compared recursively. The finite resources below +cover the exact lift footprint and generated syntax; no semantic eta callback +is assumed. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Finite walker and generated-node closure for lambda eta. -/ +structure FinalWhnfEtaResources (support : RunSupport) : Prop where + liftBounds : ∀ {source : KExpr .anon}, support source → + WalkerRequest.Bounds (.lift source 1 0) + liftReach : ∀ {source : KExpr .anon}, support source → ∀ x, + KExpr.LiftReach 1 source 0 x → support x + forallDomain : ∀ {name : Mode.anon.F Name} + {bi : Mode.anon.F Lean.BinderInfo} {ty body : KExpr .anon} + {info : ExprInfo .anon}, + support (.all name bi ty body info) → support ty + variableNode : support (KExpr.mkVar 0 RecM.anonN : KExpr .anon) + application : ∀ {source : KExpr .anon}, support source → + support (KExpr.mkApp (KExpr.liftSpec source 1 0) + (KExpr.mkVar 0 RecM.anonN : KExpr .anon)) + lambda : ∀ {source ty : KExpr .anon} {name : Mode.anon.F Name} + {bi : Mode.anon.F Lean.BinderInfo}, + support source → support ty → + support (KExpr.mkLam name bi ty + (KExpr.mkApp (KExpr.liftSpec source 1 0) + (KExpr.mkVar 0 RecM.anonN : KExpr .anon))) + +namespace TcM + +/-- Request-independent Hoare rule for the lifting walker used by eta. -/ +theorem lift_whnf_wf_of_resources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {source : KExpr .anon} + {shift cutoff : UInt64} {state : TcState .anon} + (hcollision : support.CollisionFree) + (hbounds : WalkerRequest.Bounds (.lift source shift cutoff)) + (hreach : ∀ x, KExpr.LiftReach shift source cutoff x → support x) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) + state (TcM.runIntern (lift source shift cutoff)) + (fun result after => + result = KExpr.liftSpec source shift cutoff ∧ + InternUpdateFrame state after) := + TcM.runIntern_whnf_wf + (fun intern hwf hsupport => by + have post := Ix.Tc.lift_spec hcollision.expr hbounds.1 hbounds.2.1 + hreach hwf hsupport.expr + exact ⟨post.1, post.2.1, + hsupport.of_expr_univs post.2.2 + (lift_preservesUnivs source shift cutoff intern)⟩) + +end TcM + +namespace RecM + +/-- The generated eta lambda translates exactly to Theory's eta redex. -/ +theorem compareEtaExpansion_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {target source domain : KExpr .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {targetV sourceV domainV codomainV : VExpr} + (theory : WhnfTheory trProj world uvars) + (resources : FinalWhnfEtaResources support) + (hcollision : support.CollisionFree) + (htargetSupport : support target) (hsourceSupport : support source) + (htarget : TrKExprS world.venv uvars world.nameOf trProj Delta target + targetV) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hdomainSupport : support domain) + (hdomainType : world.venv.IsType uvars Delta.toCtx domainV) + (hdomain : TrKExprS world.venv uvars world.nameOf trProj Delta domain + domainV) + (hsourceType : world.venv.HasType uvars Delta.toCtx sourceV + (.forallE domainV codomainV)) : + RecM.WF layer semantics trProj world support uvars Delta state + (compareEtaExpansion target source name bi domain) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx targetV sourceV) := by + unfold compareEtaExpansion + have hliftBounds := resources.liftBounds hsourceSupport + have hliftReach := resources.liftReach hsourceSupport + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.lift_whnf_wf_of_resources hcollision hliftBounds hliftReach + intro lifted afterLift hliftPost + rcases hliftPost with ⟨hILift, rfl, _⟩ + have hliftedSupport : support (KExpr.liftSpec source 1 0) := + hliftReach _ (KExpr.LiftReach.spec 1 source 0) + have hcontextLift : KVLCtx.KBVLift Delta + ((none, .vlam domainV) :: Delta) 1 0 1 0 := + .skip (.vlam domainV) .refl + have hlifted : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam domainV) :: Delta) (KExpr.liftSpec source 1 0) + sourceV.lift := by + exact TrKExprS.weakBV_lbr world.venvWF.ordered + theory.projections.weakN hliftBounds.1 hsource hcontextLift rfl rfl + hliftBounds.2.1 hliftBounds.2.2 + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf hcollision resources.variableNode + intro variableNode afterVariable hvariablePost + rcases hvariablePost with ⟨hIVariable, rfl, _⟩ + have hvariable : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam domainV) :: Delta) + (KExpr.mkVar 0 anonN : KExpr .anon) (.bvar 0) := by + rw [KExpr.mkVar_shape] + exact .var rfl + have hbodySupport := resources.application hsourceSupport + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf hcollision hbodySupport + intro body afterBody hbodyPost + rcases hbodyPost with ⟨hIBody, rfl, _⟩ + have hbody : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam domainV) :: Delta) + (KExpr.mkApp (KExpr.liftSpec source 1 0) + (KExpr.mkVar 0 anonN : KExpr .anon)) + (.app sourceV.lift (.bvar 0)) := by + rw [KExpr.mkApp_shape] + exact .app (hsourceType.weak world.venvWF.ordered) + (.bvar .zero) hlifted hvariable + have hlambdaSupport := resources.lambda (name := name) (bi := bi) + hsourceSupport hdomainSupport + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf hcollision hlambdaSupport + intro lambdaNode afterLambda hlambdaPost + rcases hlambdaPost with ⟨hILambda, rfl, _⟩ + have hlambda : TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkLam name bi domain + (KExpr.mkApp (KExpr.liftSpec source 1 0) + (KExpr.mkVar 0 anonN : KExpr .anon))) + (.lam domainV (.app sourceV.lift (.bvar 0))) := by + rw [KExpr.mkLam_shape] + exact .lam hdomainType hdomain hbody + apply RecM.WF.mono + (RecM.isDefEqCall_wf htargetSupport hlambdaSupport htarget hlambda) + · intro answer final hanswer htrue + exact (hanswer htrue).trans world.venvWF hILambda.2.1.wf + ⟨_, .eta hsourceType⟩ + · intro _ _ _ + trivial + +/-- Inference and WHNF expose the function type consumed by the concrete eta +builder. Caught callback errors and non-function results are conservative +negative answers. -/ +theorem tryEtaExpansionAfterGuard_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {target source : KExpr .anon} {targetV sourceV : VExpr} + (theory : WhnfTheory trProj world uvars) + (resources : FinalWhnfEtaResources support) + (hcollision : support.CollisionFree) + (hwhnf : DefEqDirectWhnf.WFAt layer semantics trProj world support + uvars) + (htargetSupport : support target) (hsourceSupport : support source) + (htarget : TrKExprS world.venv uvars world.nameOf trProj Delta target + targetV) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryEtaExpansionAfterGuard target source) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx targetV sourceV) := by + unfold tryEtaExpansionAfterGuard + apply RecM.WF.bind + (tryOptionalInferOnlyCall_wf hsourceSupport hsource) + intro inferred afterInfer hinferred + cases inferred with + | none => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | some inferred => + rcases hinferred with + ⟨hinferredSupport, inferredV, hinferredTr, hsourceInferred⟩ + obtain ⟨inferredCoreV, hinferredCoreTr, hinferredCoreEq⟩ := + hinferredTr + simp only + apply RecM.WF.bind <| tryOptional_wf <| RecM.WF.withInv <| + hwhnf hinferredSupport hinferredCoreTr + intro reduced afterWhnf hreduced + cases reduced with + | none => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | some reduced => + rcases hreduced with + ⟨hIWhnf, hreducedSupport, reducedV, hreducedTr, + hinferredCoreReduced⟩ + cases reduced with + | var idx name info => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | fvar id name info => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | sort level info => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | const id levels info => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | app fn arg info => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | lam name bi domain body info => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | all name bi domain body info => + cases hreducedTr with + | all hdomainType hcodomainType hdomainTr hcodomainTr => + simp only + have hDelta : KVLCtx.WF world.venv uvars Delta := + hIWhnf.2.1.wf + have hsourceCore : world.venv.HasType uvars Delta.toCtx + sourceV inferredCoreV := + hsourceInferred.defeqU_r world.venvWF hDelta + hinferredCoreEq.symm + have hsourceFunction : world.venv.HasType uvars + Delta.toCtx sourceV (.forallE _ _) := + hsourceCore.defeqU_r world.venvWF hDelta + hinferredCoreReduced + exact compareEtaExpansion_wf theory resources hcollision + htargetSupport hsourceSupport htarget hsource + (resources.forallDomain hreducedSupport) hdomainType + hdomainTr hsourceFunction + | letE name ty val body nondep info => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | prj id field value info => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | nat value blob info => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | str value blob info => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + +/-- Exhaust the syntactic lambda/non-lambda guard around the verified eta +construction. -/ +theorem tryEtaExpansion_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {target source : KExpr .anon} {targetV sourceV : VExpr} + (theory : WhnfTheory trProj world uvars) + (resources : FinalWhnfEtaResources support) + (hcollision : support.CollisionFree) + (hwhnf : DefEqDirectWhnf.WFAt layer semantics trProj world support + uvars) + (htargetSupport : support target) (hsourceSupport : support source) + (htarget : TrKExprS world.venv uvars world.nameOf trProj Delta target + targetV) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryEtaExpansion target source) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx targetV sourceV) := by + cases target <;> cases source <;> + simp only [tryEtaExpansion, Bool.not_false, Bool.not_true, + Bool.false_or, Bool.true_or, if_true] + all_goals first + | exact tryEtaExpansionAfterGuard_wf theory resources hcollision hwhnf + htargetSupport hsourceSupport htarget hsource + | exact RecM.WF.pure fun _ htrue => by contradiction + +/-- The ordered, bidirectional eta attempts are sound; a successful reverse +attempt is flipped with Theory symmetry. -/ +theorem tryDefEqWhnfEtaAfterGuard_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (resources : FinalWhnfEtaResources support) + (hcollision : support.CollisionFree) + (hwhnf : DefEqDirectWhnf.WFAt layer semantics trProj world support + uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfEtaAfterGuard left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold tryDefEqWhnfEtaAfterGuard + apply RecM.WF.bind <| + tryEtaExpansion_wf theory resources hcollision hwhnf hleftSupport + hrightSupport hleft hright + intro accepted afterFirst hfirst + cases accepted with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => hfirst rfl + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind <| + tryEtaExpansion_wf theory resources hcollision hwhnf + hrightSupport hleftSupport hright hleft + intro reverseAccepted afterSecond hsecond + cases reverseAccepted with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => (hsecond rfl).symm + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + +/-- Exhaust the outer "either operand is a lambda" phase guard. -/ +theorem tryDefEqWhnfEta_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (resources : FinalWhnfEtaResources support) + (hcollision : support.CollisionFree) + (hwhnf : DefEqDirectWhnf.WFAt layer semantics trProj world support + uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfEta left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + cases left <;> cases right <;> + simp only [tryDefEqWhnfEta, Bool.false_or, Bool.true_or, if_true] + all_goals + exact tryDefEqWhnfEtaAfterGuard_wf theory resources hcollision hwhnf + hleftSupport hrightSupport hleft hright + +namespace TryDefEqWhnfEta + +/-- Package the concrete eta phase. -/ +theorem ofResources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (resources : FinalWhnfEtaResources support) + (hcollision : support.CollisionFree) + (hwhnf : DefEqDirectWhnf.WFAt layer semantics trProj world support + uvars) : + TryDefEqWhnfEta.WFAt layer semantics trProj world support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact tryDefEqWhnfEta_wf theory resources hcollision hwhnf hleftSupport + hrightSupport hleft hright + +end TryDefEqWhnfEta + +/-- Compose the eta phase with the exact remainder of the final-WHNF +fallback chain. -/ +theorem isDefEqWhnfAfterNat_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (heta : TryDefEqWhnfEta.WFAt layer semantics trProj world support uvars) + (htail : IsDefEqWhnfAfterEta.WFAt layer semantics trProj world support + uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnfAfterNat left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold isDefEqWhnfAfterNat + apply RecM.WF.bind <| + heta hleftSupport hrightSupport hleft hright + intro result afterEta hresult + cases result with + | none => exact htail hleftSupport hrightSupport hleft hright + | some answer => exact RecM.WF.pure fun _ => hresult + +namespace IsDefEqWhnfAfterNat + +/-- Package eta with the remaining post-eta contract. -/ +theorem ofEta + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (resources : FinalWhnfEtaResources support) + (hcollision : support.CollisionFree) + (hwhnf : DefEqDirectWhnf.WFAt layer semantics trProj world support + uvars) + (htail : IsDefEqWhnfAfterEta.WFAt layer semantics trProj world support + uvars) : + IsDefEqWhnfAfterNat.WFAt layer semantics trProj world support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact isDefEqWhnfAfterNat_wf + (TryDefEqWhnfEta.ofResources theory resources hcollision hwhnf) htail + hleftSupport hrightSupport hleft hright + +end IsDefEqWhnfAfterNat + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/LetDeclaration.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/LetDeclaration.lean new file mode 100644 index 000000000..5445f31de --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/LetDeclaration.lean @@ -0,0 +1,452 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.Contracts +import Ix.Tc.Verify.Infer.LetScopes + +/-! +# Final-WHNF let-declaration comparison + +The final comparator normally sees lets only when earlier reduction leaves +them stuck. Production still compares their types and values, opens both +bodies with one common fvar under the left let declaration, and compares the +opened bodies recursively. This module verifies that exact scoped program, +including allocation failure and scope restoration on callback errors. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Finite constructor descent and body-opening coverage for supported lets. +The right body is opened with the left let's display name, so body resources +are exposed for every anonymous-mode name. -/ +structure FinalWhnfLetResources (support : RunSupport) : Prop where + components : ∀ {name ty val body nondep info}, + support (.letE name ty val body nondep info) → + support ty ∧ support val ∧ + ∀ commonName, BinderOpeningResources support commonName body + +namespace TcM + +/-- Exact operational contract for `openLetWithFV`. On success it returns +the common canonical fvar as well as the first opened body; allocation +exhaustion is the only error and leaves the entry state unchanged. -/ +theorem openLetWithFV_scope + {support : RunSupport} + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {name : Mode.anon.F Name} + {ty val body : KExpr .anon} {tyV valV bodyV : VExpr} + (hty : TrKExprS world.venv uvars world.nameOf trProj Delta ty tyV) + (hval : TrKExprS world.venv uvars world.nameOf trProj Delta val valV) + (hvalType : world.venv.HasType uvars Delta.toCtx valV tyV) + (hbody : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlet tyV valV) :: Delta) body bodyV) + (hcollision : support.CollisionFree) + (hresources : BinderOpeningResources support name body) : + WhnfStateInv layer semantics trProj world support uvars Delta s → + match TcM.openLetWithFV name ty val body s with + | .ok (bodyOpen, fv, fvId) after => + fvId = ⟨s.env.nextFVarId⟩ ∧ + fv = KExpr.mkFVar ⟨s.env.nextFVarId⟩ name ∧ + bodyOpen = KExpr.instantiateRevSpec body + #[.mkFVar ⟨s.env.nextFVarId⟩ name] 0 ∧ + WhnfStateInv layer semantics trProj world support uvars + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet tyV valV) :: Delta) after ∧ + support bodyOpen ∧ + TrKExprS world.venv uvars world.nameOf trProj + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet tyV valV) :: Delta) bodyOpen bodyV + | .error _ after => + WhnfStateInv layer semantics trProj world support uvars Delta after ∧ + after = s := by + intro hI + have hfreshPost := (TcM.freshFVarId_wf (s := s) + (layer := layer) (semantics := semantics) (trProj := trProj) + (world := world) (support := support) (uvars := uvars) + (Delta := Delta)) hI + cases hfreshRun : TcM.freshFVarId (m := .anon) s with + | error err afterFresh => + rw [hfreshRun] at hfreshPost + simp only at hfreshPost + have hafter : afterFresh = s := hfreshPost.2.2 + subst afterFresh + have hopenError : TcM.openLetWithFV name ty val body s = + .error err s := by + unfold TcM.openLetWithFV + change EStateM.bind (TcM.freshFVarId (m := .anon)) _ s = _ + unfold EStateM.bind + rw [hfreshRun] + rw [hopenError] + exact ⟨hfreshPost.1, rfl⟩ + | ok fvId afterFresh => + rw [hfreshRun] at hfreshPost + simp only at hfreshPost + rcases hfreshPost.2 with ⟨hfvId, hafterFresh, hnext⟩ + subst fvId + subst afterFresh + let fv : KExpr .anon := .mkFVar ⟨s.env.nextFVarId⟩ name + obtain ⟨afterIntern, hinternRun, hIIntern, hInternFrame⟩ := + TcM.intern_whnf_eval hcollision + (hresources.fvarSupport ⟨s.env.nextFVarId⟩) hfreshPost.1 + let pushState : TcState .anon → TcState .anon := fun state => + {state with lctx := + state.lctx.push ⟨s.env.nextFVarId⟩ (.ldecl name ty val)} + let afterPush : TcState .anon := pushState afterIntern + have hkernelPush : + KernelStateWF semantics trProj world support afterPush := by + exact { + core := hIIntern.1.core.of_env_eq rfl + internSupport := by simpa [afterPush] using hIIntern.1.internSupport + caches := by simpa [afterPush] using hIIntern.1.caches + equivalences := by + simpa [afterPush, pushState] using hIIntern.1.equivalences } + have hIPush : WhnfStateInv layer semantics trProj world support uvars + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet tyV valV) :: Delta) afterPush := by + apply hI.openFVar hkernelPush + (TrKLocalDecl.vlet (nm := name) hty hval hvalType) + (by intro x hx; exact hx) + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.ctx hInternFrame + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.letVals hInternFrame + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.numLetBindings hInternFrame + · have hlctx : afterIntern.lctx = s.lctx := by + simpa [InternUpdateFrame] using + congrArg TcState.lctx hInternFrame + simp [afterPush, pushState, hlctx] + · have hnextEq : afterIntern.env.nextFVarId = + s.env.freshFVarId.2.nextFVarId := by + simpa [InternUpdateFrame] using congrArg + (fun state : TcState .anon => state.env.nextFVarId) + hInternFrame + simpa [afterPush, pushState, hnextEq] using hnext + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.prims hInternFrame + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.noAccel hInternFrame + have hopenBound := hresources.instRevBounds ⟨s.env.nextFVarId⟩ + have hbodyOpenTr := hbody.openFVarZero + (fv := ⟨s.env.nextFVarId⟩) (deps := Delta.fvars) (name := name) + hI.2.1.nextFVarId_fresh (by simpa using hopenBound.2.2) + have hbodyOpenSupport : support + (KExpr.instantiateRevSpec body #[fv] 0) := + hresources.instRevSupport ⟨s.env.nextFVarId⟩ _ + (KExpr.InstRevReach.spec ..) + obtain ⟨afterOpen, hopenRun, hIOpen, hOpenFrame⟩ := + instRev_whnf_eval_of_resources hcollision hopenBound + (hresources.instRevSupport ⟨s.env.nextFVarId⟩) hIPush + have hopenSuccess : TcM.openLetWithFV name ty val body s = + .ok (KExpr.instantiateRevSpec body #[fv] 0, fv, + ⟨s.env.nextFVarId⟩) afterOpen := by + unfold TcM.openLetWithFV + change EStateM.bind (TcM.freshFVarId (m := .anon)) _ s = _ + unfold EStateM.bind + rw [hfreshRun] + simp only + change EStateM.bind (TcM.intern fv) _ _ = _ + unfold EStateM.bind + rw [hinternRun] + simp only + change EStateM.bind + (modify pushState : TcM .anon PUnit) _ afterIntern = _ + unfold EStateM.bind + rw [show (modify pushState : TcM .anon PUnit) afterIntern = + EStateM.Result.ok () afterPush from rfl] + simp only + change EStateM.bind + (TcM.runIntern (instantiateRev body #[fv])) _ afterPush = _ + unfold EStateM.bind + rw [hopenRun] + rfl + rw [hopenSuccess] + refine ⟨rfl, rfl, rfl, hIOpen, ?_, ?_⟩ + · simpa [fv] using hbodyOpenSupport + · simpa [fv] using hbodyOpenTr + +end TcM + +namespace RecM + +/-- Scope an exact `openLetWithFV` continuation and restore the entry local +context on success and failure. -/ +theorem withLctxScope_openLetWithFV_wf + {beta : Type} {support : RunSupport} + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {name : Mode.anon.F Name} + {ty val body : KExpr .anon} {tyV valV bodyV : VExpr} + (hty : TrKExprS world.venv uvars world.nameOf trProj Delta ty tyV) + (hval : TrKExprS world.venv uvars world.nameOf trProj Delta val valV) + (hvalType : world.venv.HasType uvars Delta.toCtx valV tyV) + (hbody : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlet tyV valV) :: Delta) body bodyV) + (hcollision : support.CollisionFree) + (hresources : BinderOpeningResources support name body) + {k : KExpr .anon → KExpr .anon → FVarId → RecM .anon beta} + {Qinner Qouter : beta → TcState .anon → Prop} + (hk : ∀ {bodyOpen fv fvId after}, + fvId = ⟨s.env.nextFVarId⟩ → + fv = KExpr.mkFVar ⟨s.env.nextFVarId⟩ name → + bodyOpen = KExpr.instantiateRevSpec body + #[.mkFVar ⟨s.env.nextFVarId⟩ name] 0 → + support bodyOpen → + TrKExprS world.venv uvars world.nameOf trProj + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet tyV valV) :: Delta) bodyOpen bodyV → + RecM.WF layer semantics trProj world support uvars + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet tyV valV) :: Delta) after (k bodyOpen fv fvId) Qinner) + (hclose : ∀ result after, Qinner result after → + Qouter result + {after with lctx := after.lctx.truncate s.lctx.size}) : + RecM.WF layer semantics trProj world support uvars Delta s + (withLctxScope do + let (bodyOpen, fv, fvId) ← + TcM.openLetWithFV name ty val body + k bodyOpen fv fvId) + Qouter := by + intro methods hmethods hI + rw [RecM.withLctxScope_eq] + have hopenPost := TcM.openLetWithFV_scope hty hval hvalType hbody + hcollision hresources hI + cases hopenRun : TcM.openLetWithFV name ty val body s with + | error err afterOpen => + rw [hopenRun] at hopenPost + simp only at hopenPost + rcases hopenPost with ⟨hIOpen, hafterOpen⟩ + have hscopedError : + (do + let (bodyOpen, fv, fvId) ← + (liftM (TcM.openLetWithFV name ty val body) : + RecM .anon (KExpr .anon × KExpr .anon × FVarId)) + k bodyOpen fv fvId).run methods s = .error err afterOpen := by + change EStateM.bind (TcM.openLetWithFV name ty val body) + (fun opened => (k opened.1 opened.2.1 opened.2.2).run methods) s = _ + unfold EStateM.bind + rw [hopenRun] + rw [hscopedError] + subst afterOpen + simp only [LocalContext.truncate_size] + exact ⟨hIOpen, trivial⟩ + | ok opened afterOpen => + rcases opened with ⟨bodyOpen, fv, fvId⟩ + rw [hopenRun] at hopenPost + simp only at hopenPost + rcases hopenPost with + ⟨hfvId, hfv, hbodyEq, hIOpen, hbodySupport, hbodyTr⟩ + have htail := hk hfvId hfv hbodyEq hbodySupport hbodyTr + methods hmethods hIOpen + cases htailRun : (k bodyOpen fv fvId).run methods afterOpen with + | ok result after => + rw [htailRun] at htail + simp only at htail + have hscopedSuccess : + (do + let (bodyOpen, fv, fvId) ← + (liftM (TcM.openLetWithFV name ty val body) : + RecM .anon (KExpr .anon × KExpr .anon × FVarId)) + k bodyOpen fv fvId).run methods s = .ok result after := by + change EStateM.bind (TcM.openLetWithFV name ty val body) + (fun opened => + (k opened.1 opened.2.1 opened.2.2).run methods) s = _ + unfold EStateM.bind + rw [hopenRun] + exact htailRun + rw [hscopedSuccess] + exact ⟨hI.closeFVarAtEntry htail.1, hclose _ _ htail.2⟩ + | error tailErr after => + rw [htailRun] at htail + simp only at htail + have hscopedError : + (do + let (bodyOpen, fv, fvId) ← + (liftM (TcM.openLetWithFV name ty val body) : + RecM .anon (KExpr .anon × KExpr .anon × FVarId)) + k bodyOpen fv fvId).run methods s = + .error tailErr after := by + change EStateM.bind (TcM.openLetWithFV name ty val body) + (fun opened => + (k opened.1 opened.2.1 opened.2.2).run methods) s = _ + unfold EStateM.bind + rw [hopenRun] + exact htailRun + rw [hscopedError] + exact ⟨hI.closeFVarAtEntry htail.1, trivial⟩ + +/-- Exhaustive proof of the final-WHNF let helper. -/ +theorem tryDefEqWhnfLet_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftName rightName : Mode.anon.F Name} + {ty1 val1 body1 ty2 val2 body2 : KExpr .anon} + {leftNondep rightNondep : Bool} + {leftInfo rightInfo : ExprInfo .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (resources : FinalWhnfLetResources support) + (hleftSupport : + support (.letE leftName ty1 val1 body1 leftNondep leftInfo)) + (hrightSupport : + support (.letE rightName ty2 val2 body2 rightNondep rightInfo)) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta + (.letE leftName ty1 val1 body1 leftNondep leftInfo) leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta + (.letE rightName ty2 val2 body2 rightNondep rightInfo) rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfLet leftName ty1 val1 body1 ty2 val2 body2) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + obtain ⟨hty1Support, hval1Support, hbody1Resources⟩ := + resources.components hleftSupport + obtain ⟨hty2Support, hval2Support, hbody2Resources⟩ := + resources.components hrightSupport + cases hleft with + | letE hval1Type hty1 hval1 hbody1 => + cases hright with + | letE hval2Type hty2 hval2 hbody2 => + unfold tryDefEqWhnfLet + apply RecM.WF.bind <| + RecM.isDefEqCall_wf hty1Support hty2Support hty1 hty2 + intro typesEqual afterTypes htypes + cases typesEqual with + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [if_true] + apply RecM.WF.bind <| + RecM.isDefEqCall_wf hval1Support hval2Support hval1 hval2 + intro valuesEqual afterValues hvalues + cases valuesEqual with + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [if_true] + apply RecM.WF.bind <| by + apply withLctxScope_openLetWithFV_wf + (layer := layer) (semantics := semantics) + (trProj := trProj) (world := world) (uvars := uvars) + (Delta := Delta) (s := afterValues) + (k := fun body1Open fv _ => do + let body2Open ← + TcM.runIntern (instantiateRev body2 #[fv]) + isDefEqCall body1Open body2Open) + (Qinner := fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + (Qouter := fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + hty1 hval1 hval1Type hbody1 hcollision + (hbody1Resources leftName) + · intro body1Open fv fvId afterOpen hfvId hfv + hbody1OpenEq hbody1OpenSupport hbody1OpenTr + subst fvId + subst fv + let fresh : FVarId := + ⟨afterValues.env.nextFVarId⟩ + let common : KExpr .anon := .mkFVar fresh leftName + have hrightBounds := + (hbody2Resources leftName).instRevBounds fresh + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.instRev_whnf_wf_of_resources hcollision + hrightBounds + ((hbody2Resources leftName).instRevSupport + fresh)) + intro body2Open afterBody2 hbody2Post + rcases hbody2Post with + ⟨hIBody2, hbody2OpenEq, _⟩ + subst body2Open + have hDelta : KVLCtx.WF world.venv uvars Delta := + hIBody2.2.1.wf.1 + have hfresh : fresh ∉ Delta.fvars := by + exact (hIBody2.2.1.wf.2.1 fresh Delta.fvars rfl).1 + obtain ⟨level, hty1Sort⟩ := + hval1Type.isType world.venvWF hDelta.toCtx + have htypeTyped : world.venv.IsDefEq uvars + Delta.toCtx _ _ (.sort level) := + (htypes rfl).of_l world.venvWF hDelta.toCtx + hty1Sort + have hvalueTyped : world.venv.IsDefEq uvars + Delta.toCtx _ _ _ := + (hvalues rfl).of_l world.venvWF hDelta.toCtx + hval1Type + have hcontexts : KVLCtx.IsDefEq world.venv uvars + ((some (fresh, Delta.fvars), + .vlet _ _) :: Delta) + ((some (fresh, Delta.fvars), + .vlet _ _) :: Delta) := + .cons + (KVLCtx.IsDefEq.refl world.venvWF.ordered hDelta) + (by + intro candidate deps heq + cases heq + exact ⟨hfresh, fun _ h => h⟩) + (.vlet hvalueTyped htypeTyped) + have hbody2Raw := hbody2.openFVarZero + (fv := fresh) (deps := Delta.fvars) + (name := leftName) hfresh + (by simpa using hrightBounds.2.2) + obtain ⟨body2V', hbody2Retag⟩ := + hbody2Raw.defeqDFC world.venvWF theory.literalWF + theory.projections + (hcontexts.symm world.venvWF.ordered) + have hbody2Support : support + (KExpr.instantiateRevSpec body2 #[common] 0) := + (hbody2Resources leftName).instRevSupport fresh _ + (KExpr.InstRevReach.spec ..) + apply RecM.WF.mono + (RecM.isDefEqCall_wf hbody1OpenSupport + hbody2Support hbody1OpenTr + (by simpa [common] using hbody2Retag)) + · intro answer final hanswer resultTrue + have hbody2Bridge : world.venv.IsDefEqU uvars + Delta.toCtx body2V' rightV := by + simpa [KVLCtx.toCtx] using + TrKExprS.uniq world.venvWF theory.literalWF + theory.projections hcontexts hbody2Retag + hbody2Raw + exact (hanswer resultTrue).trans world.venvWF + hcontexts.wf.toCtx hbody2Bridge + · intro _ _ _ + trivial + · intro answer after hanswer + exact hanswer + intro bodiesEqual afterBodies hbodies + cases bodiesEqual with + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [if_true] + exact RecM.WF.pure fun _ => hbodies + +namespace TryDefEqWhnfLet + +/-- Package the scoped let proof for constructor-prefix assembly. -/ +theorem ofResources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (resources : FinalWhnfLetResources support) : + TryDefEqWhnfLet.WFAt layer semantics trProj world support uvars := by + intro Delta state leftName rightName ty1 val1 body1 ty2 val2 body2 + leftNondep rightNondep leftInfo rightInfo leftV rightV hleftSupport + hrightSupport hleft hright + exact tryDefEqWhnfLet_wf theory hcollision resources hleftSupport + hrightSupport hleft hright + +end TryDefEqWhnfLet + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/NatBridge.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/NatBridge.lean new file mode 100644 index 000000000..34562eb1b --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/NatBridge.lean @@ -0,0 +1,455 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.Contracts +import Ix.Tc.Verify.DefEq.NatOffset + +/-! +# Final-WHNF Nat bridge + +This module verifies the compact-Nat/constructor bridge at the head of the +final fallback chain. A successful successor peel records both the exact +Theory successor shape and the predecessor's canonical Nat type; recursive +predecessor equality can therefore be lifted through `Nat.succ` without +assuming injectivity or reflection beyond the trusted primitive table. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Trusted primitive facts and finite support needed by the final Nat +comparison. -/ +structure FinalWhnfNatResources (world : VerifyWorld) + (support : RunSupport) : Prop where + zero : RecM.NatZeroContext world + collision : support.CollisionFree + natContains : world.venv.contains ``Nat + generated : ∀ n, support (RecM.natExprFromValue n : KExpr .anon) + appArgument : ∀ {fn arg : KExpr .anon} {info : ExprInfo .anon}, + support (.app fn arg info) → support arg + +namespace RecM + +/-- Canonical Nat numerals have the canonical Nat type in every verified +context, derived directly from the trusted zero/successor declarations. -/ +private theorem finalNatLit_hasType + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Delta : KVLCtx} {prims : Primitives .anon} + (hcatalog : TrustedCatalogRel trProj world) + (htable : NoDeltaPrimitiveTableAgrees world prims) + (hprims : world.venv.HasPrimitives) : + ∀ n, world.venv.HasType uvars Delta.toCtx (.natLit n) .nat + | 0 => by + obtain ⟨ci, hlookup⟩ := htable.natZero.contains hcatalog + have hci := hprims.natZero hlookup + subst ci + exact Lean4Lean.VEnv.HasType.const hlookup (by simp) rfl + | n + 1 => + Lean4Lean.VEnv.HasType.app + (natSucc_hasType hcatalog htable hprims) + (finalNatLit_hasType hcatalog htable hprims n) + +/-- Reading the primitive table and classifying a Nat-like head does not +change checker state. No semantic fact is assigned to a negative result. -/ +theorem isNatLike_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {state : TcState .anon} (source : KExpr .anon) : + RecM.WF .noAccel semantics trProj world support uvars Delta state + (isNatLike source) (fun _ after => after = state) := by + unfold isNatLike + apply RecM.WF.bind (RecM.WF.withInv (prims_wf (s := state))) + intro runtimePrims afterRead hread + rcases hread with ⟨_, hprims, hafterRead⟩ + subst runtimePrims + subst afterRead + cases source <;> simp only + all_goals first + | exact RecM.WF.pure fun _ => rfl + | skip + rename_i fn arg info + cases fn <;> exact RecM.WF.pure fun _ => rfl + +/-- Positive-result contract for one Nat successor peel. -/ +def NatSuccOf.WFAt (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state source sourceV}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + RecM.WF .noAccel semantics trProj world support uvars Delta state + (natSuccOf source) + (fun result _ => match result with + | none => True + | some predecessor => + support predecessor ∧ ∃ predecessorV, + TrKExprS world.venv uvars world.nameOf trProj Delta + predecessor predecessorV ∧ + world.venv.HasType uvars Delta.toCtx predecessorV .nat ∧ + sourceV = .app .natSucc predecessorV) + +/-- The concrete successor recognizer is sound for compact positive literals +and explicit applications of the trusted `Nat.succ` primitive. -/ +theorem natSuccOf_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {state : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr} + (resources : FinalWhnfNatResources world support) + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF .noAccel semantics trProj world support uvars Delta state + (natSuccOf source) + (fun result _ => match result with + | none => True + | some predecessor => + support predecessor ∧ ∃ predecessorV, + TrKExprS world.venv uvars world.nameOf trProj Delta + predecessor predecessorV ∧ + world.venv.HasType uvars Delta.toCtx predecessorV .nat ∧ + sourceV = .app .natSucc predecessorV) := by + unfold natSuccOf + apply RecM.WF.bind (RecM.WF.withInv (prims_wf (s := state))) + intro runtimePrims afterRead hread + rcases hread with ⟨hI, hprims, hafterRead⟩ + subst runtimePrims + subst afterRead + have htable := resources.zero.table state.prims hI.noAccel_primitives + cases source with + | nat value blob info => + cases value with + | zero => + simp only [beq_self_eq_true, if_true] + exact RecM.WF.pure fun _ => trivial + | succ predecessor => + have hnonzero : (Nat.succ predecessor == 0) = false := by simp + simp only [hnonzero, Bool.false_eq_true, if_false, + Nat.succ_sub_one, pure_bind] + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf resources.collision + (resources.generated predecessor)) + intro result afterIntern hresult + rcases hresult with ⟨hIIntern, hresultEq, _⟩ + subst result + exact RecM.WF.pure fun _ => by + cases hsource + have hpredTr : TrKExprS world.venv uvars world.nameOf trProj + Delta (natExprFromValue predecessor : KExpr .anon) + (.natLit predecessor) := by + exact .nat (by simpa [Lean4Lean.VEnv.ContainsLits] using + resources.natContains) + have hpredType : world.venv.HasType uvars Delta.toCtx + (.natLit predecessor) .nat := + finalNatLit_hasType hI.1.core.trustedCatalog htable + resources.zero.theoryPrimitives predecessor + exact ⟨resources.generated predecessor, .natLit predecessor, + hpredTr, hpredType, rfl⟩ + | app fn arg info => + cases fn with + | const id levels fnInfo => + cases haddr : id.addr == state.prims.natSucc.addr with + | false => + simp only [haddr, Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [haddr, if_true] + exact RecM.WF.pure fun _ => by + cases hsource with + | app hfnType hargType hfn harg => + cases hfn with + | const hname hlookup hlevels harity => + have hid : id.addr = state.prims.natSucc.addr := + eq_of_beq haddr + have hnameEq := Option.some.inj <| + hname.symm.trans <| + (congrArg world.nameOf hid).trans + htable.natSucc.2 + subst_vars + have hci := resources.zero.theoryPrimitives.natSucc + hlookup + subst_vars + have hsize : levels.size = 0 := by + simpa using harity + have hlevelsEmpty : levels = #[] := + Array.eq_empty_of_size_eq_zero hsize + subst levels + have hDelta : KVLCtx.WF world.venv uvars Delta := + hI.2.1.wf + have hsucc := natSucc_hasType + (uvars := uvars) (Delta := Delta) + hI.1.core.trustedCatalog htable + resources.zero.theoryPrimitives + have hfunctionTypes := hfnType.uniqU world.venvWF + hDelta.toCtx hsucc + obtain ⟨_, hdomain⟩ := + hfunctionTypes.forallE_inv world.venvWF + hDelta.toCtx |>.1 + have hargNat := hargType.defeqU_r world.venvWF + hDelta.toCtx ⟨_, hdomain⟩ + exact ⟨resources.appArgument hsourceSupport, _, harg, + hargNat, rfl⟩ + | _ => + simp only + exact RecM.WF.pure fun _ => trivial + | _ => + simp only + exact RecM.WF.pure fun _ => trivial + +namespace NatSuccOf + +/-- Package the concrete successor recognizer. -/ +theorem ofResources + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (resources : FinalWhnfNatResources world support) : + NatSuccOf.WFAt semantics trProj world support uvars := by + intro Delta state source sourceV hsourceSupport hsource + exact natSuccOf_wf resources hsourceSupport hsource + +end NatSuccOf + +/-- Soundness of zero/successor comparison after the literal pair misses. -/ +theorem isDefEqNatAfterLiteral_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (resources : FinalWhnfNatResources world support) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF .noAccel semantics trProj world support uvars Delta state + (isDefEqNatAfterLiteral left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold isDefEqNatAfterLiteral + apply RecM.WF.bind <| + isNatZero_wf resources.zero hleftSupport hleft + intro leftZero afterLeft hleftZero + apply RecM.WF.bind <| + isNatZero_wf resources.zero hrightSupport hright + intro rightZero afterRight hrightZero + cases leftZero with + | true => + cases rightZero with + | true => + simp only [Bool.true_and, if_true] + exact RecM.WF.pure fun hI _ => by + have hleftValue := hleftZero rfl + have hrightValue := hrightZero rfl + subst leftV + subst rightV + exact Lean4Lean.VEnv.IsDefEqU.refl <| + hleft.wf world.venvWF.ordered theory.literalWF + theory.projections.wf hI.2.1.wf + | false => + simp only [Bool.true_and, Bool.false_eq_true, if_false] + apply RecM.WF.bind <| + natSuccOf_wf resources hleftSupport hleft + intro leftPred afterLeftPred hleftPred + apply RecM.WF.bind <| + natSuccOf_wf resources hrightSupport hright + intro rightPred afterRightPred hrightPred + cases leftPred <;> cases rightPred <;> + simp only + · exact RecM.WF.pure fun _ h => by contradiction + · exact RecM.WF.pure fun _ h => by contradiction + · exact RecM.WF.pure fun _ h => by contradiction + · rename_i leftPred rightPred + rcases hleftPred with + ⟨hleftPredSupport, leftPredV, hleftPredTr, + hleftPredType, hleftShape⟩ + rcases hrightPred with + ⟨hrightPredSupport, rightPredV, hrightPredTr, + hrightPredType, hrightShape⟩ + apply RecM.WF.mono <| RecM.WF.withInv <| + RecM.isDefEqCall_wf hleftPredSupport hrightPredSupport + hleftPredTr hrightPredTr + · intro answer final hanswer htrue + rw [hleftShape, hrightShape] + have htable := resources.zero.table final.prims + hanswer.1.noAccel_primitives + have hsucc := natSucc_hasType + (uvars := uvars) (Delta := Delta) + hanswer.1.1.core.trustedCatalog htable + resources.zero.theoryPrimitives + exact (hsucc.appDF <| + (hanswer.2 htrue).of_l world.venvWF + hanswer.1.2.1.wf.toCtx hleftPredType).toU + · intro _ _ _ + trivial + | false => + cases rightZero <;> + simp only [Bool.false_and, Bool.false_eq_true, if_false] + all_goals + apply RecM.WF.bind <| + natSuccOf_wf resources hleftSupport hleft + intro leftPred afterLeftPred hleftPred + apply RecM.WF.bind <| + natSuccOf_wf resources hrightSupport hright + intro rightPred afterRightPred hrightPred + cases leftPred <;> cases rightPred <;> + simp only + · exact RecM.WF.pure fun _ h => by contradiction + · exact RecM.WF.pure fun _ h => by contradiction + · exact RecM.WF.pure fun _ h => by contradiction + · rename_i leftPred rightPred + rcases hleftPred with + ⟨hleftPredSupport, leftPredV, hleftPredTr, + hleftPredType, hleftShape⟩ + rcases hrightPred with + ⟨hrightPredSupport, rightPredV, hrightPredTr, + hrightPredType, hrightShape⟩ + apply RecM.WF.mono <| RecM.WF.withInv <| + RecM.isDefEqCall_wf hleftPredSupport hrightPredSupport + hleftPredTr hrightPredTr + · intro answer final hanswer htrue + rw [hleftShape, hrightShape] + have htable := resources.zero.table final.prims + hanswer.1.noAccel_primitives + have hsucc := natSucc_hasType + (uvars := uvars) (Delta := Delta) + hanswer.1.1.core.trustedCatalog htable + resources.zero.theoryPrimitives + exact (hsucc.appDF <| + (hanswer.2 htrue).of_l world.venvWF + hanswer.1.2.1.wf.toCtx hleftPredType).toU + · intro _ _ _ + trivial + +/-- Complete direct-literal plus zero/successor Nat comparison. -/ +theorem isDefEqNat_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (resources : FinalWhnfNatResources world support) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF .noAccel semantics trProj world support uvars Delta state + (isDefEqNat left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + cases left <;> cases right <;> simp only [isDefEqNat] + all_goals + first + | exact isDefEqNatAfterLiteral_wf theory resources hleftSupport + hrightSupport hleft hright + | skip + have hleftTr := hleft + cases hleft + cases hright + exact RecM.WF.pure fun hI hanswer => by + have hvalue := eq_of_beq hanswer + subst_vars + exact Lean4Lean.VEnv.IsDefEqU.refl <| + hleftTr.wf world.venvWF.ordered theory.literalWF + theory.projections.wf hI.2.1.wf + +/-- Close the optional Nat gate itself. -/ +theorem tryDefEqWhnfNat_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (resources : FinalWhnfNatResources world support) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF .noAccel semantics trProj world support uvars Delta state + (tryDefEqWhnfNat left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold tryDefEqWhnfNat + apply RecM.WF.bind (isNatLike_wf left) + intro leftLike afterLeft hafterLeft + subst afterLeft + apply RecM.WF.bind (isNatLike_wf right) + intro rightLike afterRight hafterRight + subst afterRight + cases leftLike <;> cases rightLike <;> + simp only [Bool.false_and, Bool.true_and, Bool.false_eq_true, if_false, + if_true] + all_goals + first + | exact RecM.WF.pure fun _ => trivial + | skip + apply RecM.WF.bind <| + isDefEqNat_wf theory resources hleftSupport hrightSupport hleft hright + intro answer after hanswer + exact RecM.WF.pure fun _ => hanswer + +namespace TryDefEqWhnfNat + +/-- Package the concrete optional Nat bridge. -/ +theorem ofResources + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (resources : FinalWhnfNatResources world support) : + TryDefEqWhnfNat.WFAt .noAccel semantics trProj world support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact tryDefEqWhnfNat_wf theory resources hleftSupport hrightSupport + hleft hright + +end TryDefEqWhnfNat + +/-- The Nat bridge followed by the exact remaining tail closes the complete +post-structural fallback. -/ +theorem isDefEqWhnfAfterStructural_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (hnat : TryDefEqWhnfNat.WFAt .noAccel semantics trProj world support + uvars) + (htail : IsDefEqWhnfAfterNat.WFAt .noAccel semantics trProj world + support uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF .noAccel semantics trProj world support uvars Delta state + (isDefEqWhnfAfterStructural left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold isDefEqWhnfAfterStructural + apply RecM.WF.bind <| + hnat hleftSupport hrightSupport hleft hright + intro result afterNat hresult + cases result with + | none => exact htail hleftSupport hrightSupport hleft hright + | some answer => exact RecM.WF.pure fun _ => hresult + +namespace IsDefEqWhnfAfterStructural + +/-- Package the concrete Nat prefix with the remaining fallback contract. -/ +theorem ofNat + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (resources : FinalWhnfNatResources world support) + (htail : IsDefEqWhnfAfterNat.WFAt .noAccel semantics trProj world + support uvars) : + IsDefEqWhnfAfterStructural.WFAt .noAccel semantics trProj world support + uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact isDefEqWhnfAfterStructural_wf + (TryDefEqWhnfNat.ofResources theory resources) htail hleftSupport + hrightSupport hleft hright + +end IsDefEqWhnfAfterStructural + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/ProofTail.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/ProofTail.lean new file mode 100644 index 000000000..019226425 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/ProofTail.lean @@ -0,0 +1,147 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.Contracts +import Ix.Tc.Verify.DefEq.ProofIrrelevance + +/-! +# Final-WHNF proof-irrelevance tail + +The final fallback is the already-verified proof-irrelevance probe. This +module packages it at the final-WHNF seam and composes it with an independently +verified unit-like shortcut. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- The final-WHNF tail is exactly the concrete proof-irrelevance probe. -/ +theorem isDefEqWhnfAfterUnit_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (hisProp : IsPropType.WFAt layer semantics trProj world support uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnfAfterUnit left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + simpa only [isDefEqWhnfAfterUnit] using + (tryProofIrrel_wf hisProp hleftSupport hrightSupport hleft hright) + +namespace IsDefEqWhnfAfterUnit + +/-- Package the concrete proposition classifier at the terminal seam. -/ +theorem ofClassifier + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hisProp : IsPropType.WFAt layer semantics trProj world support uvars) : + IsDefEqWhnfAfterUnit.WFAt layer semantics trProj world support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact isDefEqWhnfAfterUnit_wf hisProp hleftSupport hrightSupport hleft + hright + +end IsDefEqWhnfAfterUnit + +/-- Compose the unit-like shortcut with the terminal proof-irrelevance +fallback. -/ +theorem isDefEqWhnfAfterStructEta_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (hunit : TryDefEqUnit.WFAt layer semantics trProj world support uvars) + (htail : IsDefEqWhnfAfterUnit.WFAt layer semantics trProj world support + uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnfAfterStructEta left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold isDefEqWhnfAfterStructEta + apply RecM.WF.bind <| + hunit hleftSupport hrightSupport hleft hright + intro accepted afterUnit haccepted + cases accepted with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => haccepted rfl + | false => + simp only [Bool.false_eq_true, if_false] + exact htail hleftSupport hrightSupport hleft hright + +namespace IsDefEqWhnfAfterStructEta + +/-- Package the unit-like and proof-irrelevance tail contracts. -/ +theorem ofUnitAndProof + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hunit : TryDefEqUnit.WFAt layer semantics trProj world support uvars) + (hisProp : IsPropType.WFAt layer semantics trProj world support uvars) : + IsDefEqWhnfAfterStructEta.WFAt layer semantics trProj world support + uvars := by + exact fun hleftSupport hrightSupport hleft hright => + isDefEqWhnfAfterStructEta_wf hunit + (IsDefEqWhnfAfterUnit.ofClassifier hisProp) + hleftSupport hrightSupport hleft hright + +end IsDefEqWhnfAfterStructEta + +/-- Compose the optional structure-eta phase with the unit/proof tail. -/ +theorem isDefEqWhnfAfterString_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (hstructEta : TryDefEqWhnfStructEta.WFAt layer semantics trProj world + support uvars) + (htail : IsDefEqWhnfAfterStructEta.WFAt layer semantics trProj world + support uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnfAfterString left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold isDefEqWhnfAfterString + apply RecM.WF.bind <| + hstructEta hleftSupport hrightSupport hleft hright + intro result afterStructEta hresult + cases result with + | none => exact htail hleftSupport hrightSupport hleft hright + | some answer => exact RecM.WF.pure fun _ => hresult + +namespace IsDefEqWhnfAfterString + +/-- Package structure eta with its concrete unit/proof continuation. -/ +theorem ofStructEta + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hstructEta : TryDefEqWhnfStructEta.WFAt layer semantics trProj world + support uvars) + (htail : IsDefEqWhnfAfterStructEta.WFAt layer semantics trProj world + support uvars) : + IsDefEqWhnfAfterString.WFAt layer semantics trProj world support + uvars := by + exact fun hleftSupport hrightSupport hleft hright => + isDefEqWhnfAfterString_wf hstructEta htail hleftSupport hrightSupport + hleft hright + +end IsDefEqWhnfAfterString + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/StringExpansion.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/StringExpansion.lean new file mode 100644 index 000000000..c23d6562e --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/StringExpansion.lean @@ -0,0 +1,151 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.Contracts +import Ix.Tc.Verify.DefEq.StringLiteral + +/-! +# Final-WHNF String-literal expansion + +This module verifies the ordered, bidirectional String-expansion phase in the +final-WHNF comparator. Each compact literal is expanded by the exact K1 plan, +whose result translates to the same Theory literal as the source syntax. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Once the syntax guard has found a String literal, both ordered expansion +attempts are sound. A successful reverse attempt is flipped semantically. -/ +theorem tryDefEqWhnfStringAfterGuard_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (context : DefEqStringContext trProj world support) + (hcanonical : CanonicalPrimitiveStates layer semantics trProj world + support uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfStringAfterGuard left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold tryDefEqWhnfStringAfterGuard + apply RecM.WF.bind <| + tryStringLitExpansion_wf context hcanonical hleftSupport hrightSupport + hleft hright + intro accepted afterFirst hfirst + cases accepted with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => hfirst rfl + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind <| + tryStringLitExpansion_wf context hcanonical hrightSupport + hleftSupport hright hleft + intro reverseAccepted afterSecond hsecond + cases reverseAccepted with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => (hsecond rfl).symm + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + +/-- Exhaust the outer "either operand is a String literal" guard. -/ +theorem tryDefEqWhnfString_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (context : DefEqStringContext trProj world support) + (hcanonical : CanonicalPrimitiveStates layer semantics trProj world + support uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfString left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold tryDefEqWhnfString + split + · exact tryDefEqWhnfStringAfterGuard_wf context hcanonical hleftSupport + hrightSupport hleft hright + · exact RecM.WF.pure fun _ => trivial + +namespace TryDefEqWhnfString + +/-- Package the concrete String-literal phase. -/ +theorem ofContext + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (context : DefEqStringContext trProj world support) + (hcanonical : CanonicalPrimitiveStates layer semantics trProj world + support uvars) : + TryDefEqWhnfString.WFAt layer semantics trProj world support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact tryDefEqWhnfString_wf context hcanonical hleftSupport hrightSupport + hleft hright + +end TryDefEqWhnfString + +/-- Compose the optional String phase with the remaining final-WHNF tail. -/ +theorem isDefEqWhnfAfterEta_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (hstring : TryDefEqWhnfString.WFAt layer semantics trProj world support + uvars) + (htail : IsDefEqWhnfAfterString.WFAt layer semantics trProj world support + uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnfAfterEta left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold isDefEqWhnfAfterEta + apply RecM.WF.bind <| + hstring hleftSupport hrightSupport hleft hright + intro result afterString hresult + cases result with + | none => exact htail hleftSupport hrightSupport hleft hright + | some answer => exact RecM.WF.pure fun _ => hresult + +namespace IsDefEqWhnfAfterEta + +/-- Package the String phase and its post-String continuation. -/ +theorem ofString + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hstring : TryDefEqWhnfString.WFAt layer semantics trProj world support + uvars) + (htail : IsDefEqWhnfAfterString.WFAt layer semantics trProj world support + uvars) : + IsDefEqWhnfAfterEta.WFAt layer semantics trProj world support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact isDefEqWhnfAfterEta_wf hstring htail hleftSupport hrightSupport + hleft hright + +end IsDefEqWhnfAfterEta + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/StructuralPrefix.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/StructuralPrefix.lean new file mode 100644 index 000000000..045b3a3d2 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/StructuralPrefix.lean @@ -0,0 +1,192 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.Application +import Ix.Tc.Verify.DefEq.FinalWhnf.LetDeclaration + +/-! +# Final-WHNF structural prefix + +This module covers every constructor pair in `tryDefEqWhnfStructural`. +Sorts, variables, constants, applications, binders, and literal pairs are +proved directly. The let-declaration scope is kept as its exact lower +contract so its allocation and dual-body opening proof can be discharged in +isolation. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Concrete resources for the constructor-directed final comparison. -/ +structure FinalWhnfStructuralResources + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) : Prop where + theory : WhnfTheory trProj world uvars + collision : support.CollisionFree + sorts : SortComponentResources support + quick : QuickDefEqResources support + constants : StructuralCongruenceResources support + applications : FinalWhnfApplicationResources support + lets : FinalWhnfLetResources support + +/-- Exhaustive constructor-prefix proof. -/ +theorem tryDefEqWhnfStructural_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (resources : FinalWhnfStructuralResources layer semantics trProj world + support uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfStructural left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + cases left <;> cases right <;> + simp only [tryDefEqWhnfStructural] + all_goals + first + | exact RecM.WF.pure fun _ => trivial + | skip + · rename_i leftIdx leftName leftInfo rightIdx rightName rightInfo + cases hidx : leftIdx == rightIdx with + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [if_true] + exact RecM.WF.pure fun hI _ => by + have hsameIdx : leftIdx = rightIdx := eq_of_beq hidx + subst rightIdx + have hleftWF := hleft.wf world.venvWF.ordered + resources.theory.literalWF + resources.theory.projections.wf hI.2.1.wf + cases hleft with + | var hleftLookup => + cases hright with + | var hrightLookup => + have hp := Option.some.inj + (hleftLookup.symm.trans hrightLookup) + have hvalue : leftV = rightV := congrArg Prod.fst hp + subst rightV + exact Lean4Lean.VEnv.IsDefEqU.refl hleftWF + · rename_i leftU leftInfo rightU rightInfo + cases hleft with + | sort hleftWF => + cases hright with + | sort hrightWF => + obtain ⟨hleftSize, hleftSubterms⟩ := + resources.sorts hleftSupport + obtain ⟨hrightSize, hrightSubterms⟩ := + resources.sorts hrightSupport + exact RecM.WF.pure fun _ heq => + ⟨_, .sortDF hleftWF hrightWF <| + univEq_sound + (resources.collision.univ.addrFaithful + (hleftSubterms leftU .refl) + (hrightSubterms rightU .refl)) + hleftSize hrightSize heq⟩ + · rename_i leftId leftLevels leftInfo rightId rightLevels rightInfo + cases hguard : + (leftId.addr == rightId.addr && + sameDefEqUniverses leftLevels rightLevels) with + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => by + obtain ⟨hid, hlevels⟩ := Bool.and_eq_true_iff.mp hguard + exact constantHeadsDefEq resources.collision + (resources.constants.universes hleftSupport) + (resources.constants.universes hrightSupport) + hleft hright hid hlevels + · rename_i leftFn leftArg leftInfo rightFn rightArg rightInfo + simpa only [bind_pure] using + (TryDefEqWhnfApp.ofResources resources.applications + hleftSupport hrightSupport hleft hright) + · apply RecM.WF.bind <| by + simpa only [quickDefEq] using + (quickDefEq_wf resources.theory resources.collision resources.sorts + resources.quick hleftSupport hrightSupport hleft hright) + intro answer after hanswer + cases answer with + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [if_true] + exact RecM.WF.pure fun _ => hanswer + · apply RecM.WF.bind <| by + simpa only [quickDefEq] using + (quickDefEq_wf resources.theory resources.collision resources.sorts + resources.quick hleftSupport hrightSupport hleft hright) + intro answer after hanswer + cases answer with + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [if_true] + exact RecM.WF.pure fun _ => hanswer + · rename_i leftName leftTy leftVal leftBody leftNondep leftInfo + rightName rightTy rightVal rightBody rightNondep rightInfo + simpa only [bind_pure] using + (TryDefEqWhnfLet.ofResources resources.theory resources.collision + resources.lets hleftSupport hrightSupport hleft hright) + · rename_i leftNat leftBlob leftInfo rightNat rightBlob rightInfo + cases hvalue : leftNat == rightNat with + | false => + exact RecM.WF.pure fun _ h => by contradiction + | true => + exact RecM.WF.pure fun hI _ => by + have hsame : leftNat = rightNat := eq_of_beq hvalue + subst rightNat + have hleftWF := hleft.wf world.venvWF.ordered + resources.theory.literalWF resources.theory.projections.wf + hI.2.1.wf + cases hleft + cases hright + exact Lean4Lean.VEnv.IsDefEqU.refl hleftWF + · rename_i leftString leftBlob leftInfo rightString rightBlob rightInfo + cases hvalue : leftString == rightString with + | false => + exact RecM.WF.pure fun _ h => by contradiction + | true => + exact RecM.WF.pure fun hI _ => by + have hsame : leftString = rightString := eq_of_beq hvalue + subst rightString + have hleftWF := hleft.wf world.venvWF.ordered + resources.theory.literalWF resources.theory.projections.wf + hI.2.1.wf + cases hleft + cases hright + exact Lean4Lean.VEnv.IsDefEqU.refl hleftWF + +namespace TryDefEqWhnfStructural + +/-- Package the constructor-prefix proof. -/ +theorem ofResources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (resources : FinalWhnfStructuralResources layer semantics trProj world + support uvars) : + TryDefEqWhnfStructural.WFAt layer semantics trProj world support + uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact tryDefEqWhnfStructural_wf resources hleftSupport hrightSupport hleft + hright + +end TryDefEqWhnfStructural + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/StructureEta.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/StructureEta.lean new file mode 100644 index 000000000..08cff5cf6 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/StructureEta.lean @@ -0,0 +1,507 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.StructureEtaTail +import Ix.Tc.Verify.Infer.Constants +import Ix.Tc.Verify.Infer.ProjectionTypes + +/-! +# Final-WHNF structure eta + +This module closes the outer structure-eta dispatcher around the verified +common-base scan and explicit projection loop. Runtime classification and +constructor lookup remain distinct from the semantic eta rule: a positive +`isStructLike` answer yields an explicit eligibility token, and the narrow +Theory boundary consumes that token together with the exact constructor +metadata, typing derivations, and field equations selected by production. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Exact constructor fields retained from the declaration returned by the +production lookup. -/ +def KConst.IsStructureConstructorFor (inductId : KId .anon) + (params fields : UInt64) : KConst .anon → Prop + | .ctor (induct := actualInduct) (params := actualParams) + (fields := actualFields) .. => + actualInduct = inductId ∧ actualParams = params ∧ actualFields = fields + | _ => False + +namespace RecM + +/-- Positive-result meaning of the concrete structure classifier. The +eligibility predicate is supplied by the semantic structure-eta model; this +contract does not identify a state-only classifier result with a Theory law. -/ +def FinalWhnfStructLike.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) + (eligible : KId .anon → Prop) : Prop := + ∀ {Delta state inductId}, + RecM.WF layer semantics trProj world support uvars Delta state + (isStructLike inductId) + (fun answer _ => answer = true → eligible inductId) + +/-- Semantic boundary for structure eta. Projection existence and the eta +law are indexed by the exact constructor application and immutable catalog +entry observed by production. -/ +structure FinalWhnfStructEtaTheory (trProj : RawProjRel) + (world : VerifyWorld) (eligible : KId .anon → Prop) : Prop where + projections : ∀ {uvars : Nat} {Delta : KVLCtx} + {source : KExpr .anon} {baseV : VExpr} + {ctorId inductId : KId .anon} {levels : Array (KUniv .anon)} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {entry : KConst .anon} {params fields : UInt64} + {base : KExpr .anon}, + source.collectSpine = (.const ctorId levels info, args) → + world.catalog ctorId = some entry → + entry.IsStructureConstructorFor inductId params fields → + eligible inductId → + TrKExprS world.venv uvars world.nameOf trProj Delta base baseV → + ∃ (structName : Lean.Name) (projectedV : Nat → VExpr), + world.nameOf inductId.addr = some structName ∧ + ∀ field, field < fields.toNat → + trProj Delta.toCtx structName field baseV (projectedV field) + eta : ∀ {uvars : Nat} {Delta : KVLCtx} + {source : KExpr .anon} {sourceV baseV : VExpr} + {ctorId inductId : KId .anon} {levels : Array (KUniv .anon)} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {entry : KConst .anon} {params fields : UInt64} + {fieldV : Nat → VExpr} + {baseTyV sourceTyV : VExpr}, + source.collectSpine = (.const ctorId levels info, args) → + world.trusted ctorId → + world.catalog ctorId = some entry → + entry.IsStructureConstructorFor inductId params fields → + eligible inductId → + args.size = params.toNat + fields.toNat → + TrAppSpine world.venv uvars world.nameOf trProj Delta + (.const ctorId levels info) args.toList sourceV → + (∀ field, field < fields.toNat → + TrKExprS world.venv uvars world.nameOf trProj Delta + args[params.toNat + field]! (fieldV field)) → + world.venv.HasType uvars Delta.toCtx baseV baseTyV → + world.venv.HasType uvars Delta.toCtx sourceV sourceTyV → + world.venv.IsDefEqU uvars Delta.toCtx baseTyV sourceTyV → + FinalWhnfStructEtaLaw trProj world uvars Delta inductId fields.toNat + fieldV baseV sourceV + +/-- Finite generated-projection footprint for the exact constructor source +selected by structure eta. -/ +def FinalWhnfStructEtaGeneratedSupport (world : VerifyWorld) + (support : RunSupport) (eligible : KId .anon → Prop) : Prop := + ∀ {source : KExpr .anon} {ctorId inductId : KId .anon} + {levels : Array (KUniv .anon)} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} {entry : KConst .anon} + {params fields : UInt64} {base : KExpr .anon}, + support source → + source.collectSpine = (.const ctorId levels info, args) → + world.catalog ctorId = some entry → + entry.IsStructureConstructorFor inductId params fields → + eligible inductId → + support base → + ∀ field, field < fields.toNat → + support (KExpr.mkPrj inductId field.toUInt64 base) + +/-- Complete run-scoped resources used by the outer structure-eta proof. -/ +structure FinalWhnfStructEtaResources (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) + (eligible : KId .anon → Prop) : Prop where + whnfTheory : WhnfTheory trProj world uvars + etaTheory : FinalWhnfStructEtaTheory trProj world eligible + collision : support.CollisionFree + noDelta : DefEqReduction.WFAt layer semantics trProj world support uvars + whnfNoDelta + classifier : FinalWhnfStructLike.WFAt layer semantics trProj world support + uvars eligible + lazyFault : ∀ {Delta : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + references : RecM.TrustedReferences world support + projectionValues : ProjectionValueSupport support + spines : ProjectionSpineSupport support + generated : FinalWhnfStructEtaGeneratedSupport world support eligible + +private theorem toNat_toUInt64_structureEta (n : Nat) : + n.toUInt64.toNat = n % UInt64.size := by + unfold Nat.toUInt64 + rfl + +/-- Caught no-delta normalization either returns the verified reduct or the +original source with reflexive Theory equality. -/ +theorem normalizeEtaStructSource_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr} + (theory : WhnfTheory trProj world uvars) + (hnoDelta : DefEqReduction.WFAt layer semantics trProj world support + uvars whnfNoDelta) + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer semantics trProj world support uvars Delta state + (normalizeEtaStructSource source) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) := by + unfold normalizeEtaStructSource + apply RecM.WF.bind <| tryOptional_wf <| RecM.WF.withInv <| + hnoDelta hsourceSupport hsource + intro reduced afterWhnf hreduced + cases reduced with + | some reduced => + simp only + rcases hreduced with ⟨_, hreduced⟩ + exact RecM.WF.pure fun _ => hreduced + | none => + simp only + exact RecM.WF.pure fun hI => + ⟨hsourceSupport, sourceV, hsource, + Lean4Lean.VEnv.IsDefEqU.refl (theory.exprWF hI.2.1 hsource)⟩ + +/-- Exhaust the size check, structure classifier, both caught inference +calls, inferred-type comparison, and the verified structure-eta tail for one +exact constructor declaration. -/ +theorem tryEtaStructAfterConstructor_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {eligible : KId .anon → Prop} + {Delta : KVLCtx} {state : TcState .anon} + {source base : KExpr .anon} {sourceV baseV : VExpr} + {ctorId inductId : KId .anon} {levels : Array (KUniv .anon)} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {entry : KConst .anon} {params fields : UInt64} + (resources : FinalWhnfStructEtaResources layer semantics trProj world + support uvars eligible) + (hsourceSupport : support source) (hbaseSupport : support base) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hbase : TrKExprS world.venv uvars world.nameOf trProj Delta base baseV) + (hspine : source.collectSpine = (.const ctorId levels info, args)) + (htrusted : world.trusted ctorId) + (hcatalog : world.catalog ctorId = some entry) + (hshape : entry.IsStructureConstructorFor inductId params fields) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryEtaStructAfterConstructor inductId params.toNat fields.toNat + base source args) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx baseV sourceV) := by + classical + unfold tryEtaStructAfterConstructor + cases hsize : (args.size != params.toNat + fields.toNat) with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ htrue => by contradiction + | false => + have hsizeEq : args.size = params.toNat + fields.toNat := by + exact eq_of_beq + (show (args.size == params.toNat + fields.toNat) = true by + simpa using hsize) + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind resources.classifier + intro structLike afterClassifier hstructLike + cases structLike with + | false => + simp only [Bool.not_false, if_true] + exact RecM.WF.pure fun _ htrue => by contradiction + | true => + have heligible : eligible inductId := hstructLike rfl + simp only [Bool.not_true, Bool.false_eq_true, if_false] + apply RecM.WF.bind + (tryOptionalInferOnlyCall_wf hsourceSupport hsource) + intro inferredSource afterSourceType hinferredSource + cases inferredSource with + | none => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | some sourceTy => + rcases hinferredSource with + ⟨hsourceTySupport, sourceTyV, hsourceTyTr, hsourceType⟩ + obtain ⟨sourceTyCoreV, hsourceTyCoreTr, + hsourceTyCoreEq⟩ := hsourceTyTr + simp only + apply RecM.WF.bind + (tryOptionalInferOnlyCall_wf hbaseSupport hbase) + intro inferredBase afterBaseType hinferredBase + cases inferredBase with + | none => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | some baseTy => + rcases hinferredBase with + ⟨hbaseTySupport, baseTyV, hbaseTyTr, hbaseType⟩ + obtain ⟨baseTyCoreV, hbaseTyCoreTr, hbaseTyCoreEq⟩ := + hbaseTyTr + simp only + apply RecM.WF.bind <| RecM.WF.withInv <| + isDefEqCall_wf hbaseTySupport hsourceTySupport + hbaseTyCoreTr hsourceTyCoreTr + intro typesEqual afterTypeEquality htypesEqual + rcases htypesEqual with ⟨hITypeEquality, htypesEqual⟩ + cases typesEqual with + | false => + simp only [Bool.not_false, if_true] + exact RecM.WF.pure fun _ htrue => by contradiction + | true => + simp only [Bool.not_true, Bool.false_eq_true, + if_false] + have hDelta : KVLCtx.WF world.venv uvars Delta := + hITypeEquality.2.1.wf + have hbaseCoreType : world.venv.HasType uvars + Delta.toCtx baseV baseTyCoreV := + hbaseType.defeqU_r world.venvWF hDelta + hbaseTyCoreEq.symm + have hsourceCoreType : world.venv.HasType uvars + Delta.toCtx sourceV sourceTyCoreV := + hsourceType.defeqU_r world.venvWF hDelta + hsourceTyCoreEq.symm + have hspineSupport := + resources.spines hsourceSupport hspine + have hspineTr := + trAppSpine_of_collectSpine hsource hspine + have hfieldMem : ∀ field, field < fields.toNat → + args[params.toNat + field]! ∈ args.toList := by + intro field hlt + have hidx : params.toNat + field < args.size := by + rw [hsizeEq] + omega + have hget : + args[params.toNat + field]? = + some args[params.toNat + field]! := by + rw [getElem?_pos args (params.toNat + field) hidx, + getElem!_pos args (params.toNat + field) hidx] + exact Array.mem_toList_iff.mpr + (Array.mem_of_getElem? hget) + have hfieldSupport : ∀ field, + field < fields.toNat → + support args[params.toNat + field]! := by + intro field hlt + exact hspineSupport.2 _ (hfieldMem field hlt) + have hfieldWitness : ∀ field, + field < fields.toNat → + ∃ fieldV, + TrKExprS world.venv uvars world.nameOf trProj + Delta args[params.toNat + field]! fieldV := by + intro field hlt + obtain ⟨fieldV, _, _, hfieldTr⟩ := + hspineTr.argument (hfieldMem field hlt) + exact ⟨fieldV, hfieldTr⟩ + let fieldV : Nat → VExpr := fun field => + if hlt : field < fields.toNat then + Classical.choose (hfieldWitness field hlt) + else baseV + have hfieldTr : ∀ field, field < fields.toNat → + TrKExprS world.venv uvars world.nameOf trProj Delta + args[params.toNat + field]! (fieldV field) := by + intro field hlt + simp only [fieldV, dif_pos hlt] + exact Classical.choose_spec + (hfieldWitness field hlt) + obtain ⟨structName, projectedV, hname, hprojection⟩ := + resources.etaTheory.projections hspine hcatalog hshape + heligible hbase + have hgenerated : ∀ field, field < fields.toNat → + support + (KExpr.mkPrj inductId field.toUInt64 base) := + resources.generated hsourceSupport hspine hcatalog + hshape heligible hbaseSupport + have hfieldIndex : ∀ field, field < fields.toNat → + field.toUInt64.toNat = field := by + intro field hlt + rw [toNat_toUInt64_structureEta] + exact Nat.mod_eq_of_lt + (Nat.lt_trans hlt fields.toNat_lt_size) + have heta : FinalWhnfStructEtaLaw trProj world uvars + Delta inductId fields.toNat fieldV baseV sourceV := + resources.etaTheory.eta hspine htrusted hcatalog + hshape heligible hsizeEq hspineTr hfieldTr + hbaseCoreType hsourceCoreType (htypesEqual rfl) + exact tryEtaStructAfterTypes_wf resources.whnfTheory + resources.collision resources.noDelta + resources.projectionValues hbaseSupport hbase + hfieldSupport hfieldTr structName hname hgenerated + (fun field hlt => by + rw [hfieldIndex field hlt] + exact hprojection field hlt) + hfieldIndex heta + +/-- Exhaust the actual constructor-head view and lazy declaration lookup. +Only the concrete `.ctor` result reaches the typed comparison theorem; every +other syntax or catalog shape is a conservative negative answer. -/ +theorem tryEtaStructAfterNormalization_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {eligible : KId .anon → Prop} + {Delta : KVLCtx} {state : TcState .anon} + {source base : KExpr .anon} {sourceV baseV : VExpr} + (resources : FinalWhnfStructEtaResources layer semantics trProj world + support uvars eligible) + (hsourceSupport : support source) (hbaseSupport : support base) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hbase : TrKExprS world.venv uvars world.nameOf trProj Delta base baseV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryEtaStructAfterNormalization base source) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx baseV sourceV) := by + unfold tryEtaStructAfterNormalization + rcases hspine : source.collectSpine with ⟨head, args⟩ + simp only + cases head with + | const ctorId levels info => + simp only + have htrusted : world.trusted ctorId := + resources.references hsourceSupport + (collectSpine_const_references hspine) + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.tryGetConst_loaded_wf resources.lazyFault ctorId state + intro found afterLookup hfound + rcases hfound with ⟨hILookup, hloaded⟩ + cases found with + | none => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | some entry => + cases entry <;> simp only + all_goals first + | exact RecM.WF.pure fun _ htrue => by contradiction + | skip + case ctor name levelParams isUnsafe lvls inductId cidx params + fields ty => + have hcatalog : world.catalog ctorId = some + (.ctor name levelParams isUnsafe lvls inductId cidx params + fields ty) := + hILookup.1.core.loaded (hloaded _ rfl) + have hshape : + (KConst.ctor name levelParams isUnsafe lvls inductId cidx + params fields ty).IsStructureConstructorFor inductId + params fields := + ⟨rfl, rfl, rfl⟩ + exact tryEtaStructAfterConstructor_wf resources hsourceSupport + hbaseSupport hsource hbase hspine htrusted hcatalog hshape + | var _ _ _ => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | fvar _ _ _ => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | sort _ _ => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | app _ _ _ => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | lam _ _ _ _ _ => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | all _ _ _ _ _ => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | letE _ _ _ _ _ _ => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | prj _ _ _ _ => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | nat _ _ _ => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | str _ _ _ => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + +/-- Compose caught normalization with the constructor dispatcher and +transport the successful equality back to the original left operand. -/ +theorem tryEtaStruct_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {eligible : KId .anon → Prop} + {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (resources : FinalWhnfStructEtaResources layer semantics trProj world + support uvars eligible) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryEtaStruct left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold tryEtaStruct + apply RecM.WF.bind <| + normalizeEtaStructSource_wf resources.whnfTheory resources.noDelta + hleftSupport hleft + intro normalized afterNormalization hnormalized + rcases hnormalized with + ⟨hnormalizedSupport, normalizedV, hnormalizedTr, hleftNormalized⟩ + apply RecM.WF.mono <| RecM.WF.withInv <| + tryEtaStructAfterNormalization_wf resources hrightSupport + hnormalizedSupport hright hnormalizedTr + · intro answer final hanswer htrue + exact hleftNormalized.trans world.venvWF hanswer.1.2.1.wf + (hanswer.2 htrue) + · intro _ _ _ + trivial + +/-- The bidirectional production wrapper is sound in both eta orientations; +the reverse success is transported by Theory symmetry. -/ +theorem tryDefEqWhnfStructEta_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {eligible : KId .anon → Prop} + {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (resources : FinalWhnfStructEtaResources layer semantics trProj world + support uvars eligible) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqWhnfStructEta left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold tryDefEqWhnfStructEta + apply RecM.WF.bind <| + tryEtaStruct_wf resources hleftSupport hrightSupport hleft hright + intro forward afterForward hforward + cases forward with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => hforward rfl + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind <| + tryEtaStruct_wf resources hrightSupport hleftSupport hright hleft + intro reverse afterReverse hreverse + cases reverse with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => (hreverse rfl).symm + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + +namespace TryDefEqWhnfStructEta + +/-- Package the concrete outer proof at the final-WHNF phase contract. -/ +theorem ofResources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {eligible : KId .anon → Prop} + (resources : FinalWhnfStructEtaResources layer semantics trProj world + support uvars eligible) : + TryDefEqWhnfStructEta.WFAt layer semantics trProj world support + uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport hleft + hright + exact tryDefEqWhnfStructEta_wf resources hleftSupport hrightSupport hleft + hright + +end TryDefEqWhnfStructEta + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/StructureEtaBase.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/StructureEtaBase.lean new file mode 100644 index 000000000..383376fd6 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/StructureEtaBase.lean @@ -0,0 +1,362 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.StructureEtaFields +import Ix.Tc.Verify.DefEq.CheapReduction + +/-! +# Structure-eta common-base scan + +The fast structure-eta path recognizes constructor fields that normalize to +projections of one common base. This module verifies the exact recursive +scan, including the uncaught field WHNF, caught base WHNF, projection-shape +checks, collision-safe base-address comparison, and every partial-error +state. A successful result carries the semantic projection equality for +each scanned field. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Invert the structural translation of one concrete projection while +retaining the resolved structure name and raw projection witness. -/ +theorem TrKExprS.prj_components + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {id : KId .anon} {idx : UInt64} + {value : KExpr .anon} {info : ExprInfo .anon} {projectedV : VExpr} + (h : TrKExprS world.venv uvars world.nameOf trProj Delta + (.prj id idx value info) projectedV) : + ∃ structName valueV, + world.nameOf id.addr = some structName ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta value valueV ∧ + trProj Delta.toCtx structName idx.toNat valueV projectedV := by + cases h with + | prj hname hvalue hprojection => + exact ⟨_, _, hname, hvalue, hprojection⟩ + +/-- One constructor field denotes the corresponding projection of the base +returned by `etaExpansionBaseLoop`. -/ +def EtaExpansionFieldAgreement (trProj : RawProjRel) + (world : VerifyWorld) (uvars : Nat) (Delta : KVLCtx) + (inductId : KId .anon) (field : Nat) (fieldV baseV : VExpr) : Prop := + ∃ structName projectedV, + world.nameOf inductId.addr = some structName ∧ + trProj Delta.toCtx structName field baseV projectedV ∧ + world.venv.IsDefEqU uvars Delta.toCtx fieldV projectedV + +/-- Semantic result of a common-base scan. If a seed was supplied, a +successful scan retains that exact concrete seed; this makes the first-field +transition from `none` to `some` explicit in the induction. -/ +def EtaExpansionBaseLoopPost (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) + (Delta : KVLCtx) (inductId : KId .anon) (field fuel : Nat) + (fieldV : Nat → VExpr) + (seed result : Option (KExpr .anon)) : Prop := + match result with + | none => True + | some base => + support base ∧ ∃ baseV, + TrKExprS world.venv uvars world.nameOf trProj Delta base baseV ∧ + (∀ prior, seed = some prior → base = prior) ∧ + ∀ offset, offset < fuel → + EtaExpansionFieldAgreement trProj world uvars Delta inductId + (field + offset) (fieldV offset) baseV + +namespace RecM + +/-- Exact proof of the common-base scanner. -/ +theorem etaExpansionBaseLoop_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {inductId : KId .anon} {numParams field fuel : Nat} + {args : Array (KExpr .anon)} {fieldV : Nat → VExpr} + {seed : Option (KExpr .anon)} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hnoDelta : DefEqReduction.WFAt layer semantics trProj world support + uvars whnfNoDelta) + (hprojectionValue : ∀ {id : KId .anon} {idx : UInt64} + {value : KExpr .anon} {info : ExprInfo .anon}, + support (.prj id idx value info) → support value) + (hseed : match seed with + | none => True + | some base => ∃ baseV, support base ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta base baseV) + (hfieldSupport : ∀ offset, offset < fuel → + support args[numParams + field + offset]!) + (hfield : ∀ offset, offset < fuel → + TrKExprS world.venv uvars world.nameOf trProj Delta + args[numParams + field + offset]! (fieldV offset)) : + RecM.WF layer semantics trProj world support uvars Delta state + (etaExpansionBaseLoop inductId numParams args fuel field seed) + (fun result _ => + EtaExpansionBaseLoopPost trProj world support uvars Delta inductId + field fuel fieldV seed result) := by + induction fuel generalizing state field fieldV seed with + | zero => + simp only [etaExpansionBaseLoop] + cases seed with + | none => + exact RecM.WF.pure fun _ => trivial + | some base => + rcases hseed with ⟨baseV, hbaseSupport, hbase⟩ + exact RecM.WF.pure fun _ => + ⟨hbaseSupport, baseV, hbase, fun prior hprior => by + cases hprior + rfl, fun offset hlt => by omega⟩ + | succ remaining ih => + simp only [etaExpansionBaseLoop] + have hzero : 0 < remaining + 1 := by omega + apply RecM.WF.bind <| RecM.WF.withInv <| + hnoDelta (hfieldSupport 0 hzero) (hfield 0 hzero) + intro reduced afterField hfieldReduced + rcases hfieldReduced with + ⟨hIField, hreducedSupport, reducedV, hreducedTr, hreduceEq⟩ + cases reduced <;> simp only + all_goals first + | exact RecM.WF.pure fun _ => trivial + | skip + case prj id idx value info => + obtain ⟨structName, valueV, hresolved, hvalueTr, + hrawProjection⟩ := hreducedTr.prj_components + cases hshape : + (id.addr != inductId.addr || idx.toNat != field) with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ => trivial + | false => + have hshapeParts := Bool.or_eq_false_iff.mp hshape + have hidAddr : id.addr = inductId.addr := eq_of_beq + (show (id.addr == inductId.addr) = true by + simpa using hshapeParts.1) + have hid : id = inductId := KId.anon_eq_of_addr_eq hidAddr + subst id + have hidx : idx.toNat = field := eq_of_beq + (show (idx.toNat == field) = true by + simpa using hshapeParts.2) + simp only [Bool.false_eq_true, if_false, pure_bind] + unfold etaExpansionBaseAfterProjection + have hvalueSupport := hprojectionValue hreducedSupport + apply RecM.WF.bind <| RecM.WF.withInv <| tryOptional_wf <| + RecM.WF.withInv <| hnoDelta hvalueSupport hvalueTr + intro normalized afterValue hnormalized + rcases hnormalized with ⟨hIValue, hnormalized⟩ + have hcontinue : ∀ {chosen : KExpr .anon} {chosenV : VExpr}, + support chosen → + TrKExprS world.venv uvars world.nameOf trProj Delta + chosen chosenV → + world.venv.IsDefEqU uvars Delta.toCtx + valueV chosenV → + RecM.WF layer semantics trProj world support uvars Delta + afterValue + (etaExpansionBaseAfterValue inductId numParams args + remaining field seed chosen) + (fun result _ => + EtaExpansionBaseLoopPost trProj world support uvars Delta + inductId field (remaining + 1) fieldV seed result) := by + intro chosen chosenV hchosenSupport hchosen hvalueChosen + unfold etaExpansionBaseAfterValue + cases seed with + | none => + simp only + apply RecM.WF.mono <| RecM.WF.withInv <| + ih (state := afterValue) (field := field + 1) + (fieldV := fun offset => fieldV (offset + 1)) + (seed := some chosen) + ⟨chosenV, hchosenSupport, hchosen⟩ + (fun offset hlt => by + simpa only [Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using + hfieldSupport (offset + 1) (by omega)) + (fun offset hlt => by + simpa only [Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using + hfield (offset + 1) (by omega)) + · intro result final htail + rcases htail with ⟨hIFinal, htail⟩ + cases result with + | none => trivial + | some resultBase => + rcases htail with + ⟨hresultSupport, resultBaseV, hresultTr, + hseedResult, htailAgreement⟩ + have hresultEq : resultBase = chosen := + hseedResult chosen rfl + subst resultBase + have hDelta : KVLCtx.WF world.venv uvars Delta := + hIFinal.2.1.wf + have hctx := + (KVLCtx.IsDefEq.refl world.venvWF.ordered + hDelta).defeqCtx + have hchosenResult := hchosen.uniq world.venvWF + theory.literalWF theory.projections + (KVLCtx.IsDefEq.refl world.venvWF hDelta) + hresultTr + have hvalueResult := hvalueChosen.trans world.venvWF + hDelta hchosenResult + have hrawProjection' : + trProj Delta.toCtx structName field valueV + reducedV := by + simpa only [hidx] using hrawProjection + obtain ⟨resultProjectedV, hresultProjection⟩ := + theory.projections.defeqDFC hctx hvalueResult + hrawProjection' + have hprojectionEq := theory.projections.uniq hctx + hrawProjection' hresultProjection hvalueResult + refine ⟨hresultSupport, resultBaseV, hresultTr, + ?_, ?_⟩ + · intro prior hprior + contradiction + · intro offset hlt + cases offset with + | zero => + exact ⟨structName, resultProjectedV, + hresolved, hresultProjection, + hreduceEq.trans world.venvWF hDelta + hprojectionEq⟩ + | succ offset => + simpa only [Nat.succ_eq_add_one, + Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using + htailAgreement offset (by omega) + · intro _ _ _ + trivial + | some base => + rcases hseed with ⟨baseV, hbaseSupport, hbase⟩ + cases haddr : (base.addr != chosen.addr) with + | true => + simp only [haddr, if_true] + exact RecM.WF.pure fun _ => trivial + | false => + simp only [haddr, Bool.false_eq_true, if_false, + pure_bind] + have haddrEq : (base.addr == chosen.addr) = true := by + simpa using haddr + have hbaseChosen : base = chosen := by + have herase := hcollision.expr.addrFaithful + hbaseSupport hchosenSupport haddrEq + simpa only [KExpr.eraseMeta_anon] using herase + subst chosen + apply RecM.WF.mono <| RecM.WF.withInv <| + ih (state := afterValue) (field := field + 1) + (fieldV := fun offset => fieldV (offset + 1)) + (seed := some base) + ⟨baseV, hbaseSupport, hbase⟩ + (fun offset hlt => by + simpa only [Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using + hfieldSupport (offset + 1) (by omega)) + (fun offset hlt => by + simpa only [Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using + hfield (offset + 1) (by omega)) + · intro result final htail + rcases htail with ⟨hIFinal, htail⟩ + cases result with + | none => trivial + | some resultBase => + rcases htail with + ⟨hresultSupport, resultBaseV, hresultTr, + hseedResult, htailAgreement⟩ + have hresultEq : resultBase = base := + hseedResult base rfl + subst resultBase + have hDelta : KVLCtx.WF world.venv uvars Delta := + hIFinal.2.1.wf + have hctx := + (KVLCtx.IsDefEq.refl world.venvWF.ordered + hDelta).defeqCtx + have hchosenResult := hchosen.uniq world.venvWF + theory.literalWF theory.projections + (KVLCtx.IsDefEq.refl world.venvWF hDelta) + hresultTr + have hvalueResult := hvalueChosen.trans + world.venvWF hDelta hchosenResult + have hrawProjection' : + trProj Delta.toCtx structName field valueV + reducedV := by + simpa only [hidx] using hrawProjection + obtain ⟨resultProjectedV, hresultProjection⟩ := + theory.projections.defeqDFC hctx hvalueResult + hrawProjection' + have hprojectionEq := theory.projections.uniq + hctx hrawProjection' hresultProjection + hvalueResult + refine ⟨hresultSupport, resultBaseV, hresultTr, + ?_, ?_⟩ + · intro prior hprior + cases hprior + rfl + · intro offset hlt + cases offset with + | zero => + exact ⟨structName, resultProjectedV, + hresolved, hresultProjection, + hreduceEq.trans world.venvWF hDelta + hprojectionEq⟩ + | succ offset => + simpa only [Nat.succ_eq_add_one, + Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using + htailAgreement offset (by omega) + · intro _ _ _ + trivial + cases normalized with + | none => + have hvalueRefl : world.venv.IsDefEqU uvars Delta.toCtx + valueV valueV := + Lean4Lean.VEnv.IsDefEqU.refl + (theory.exprWF hIValue.2.1 hvalueTr) + exact hcontinue hvalueSupport hvalueTr hvalueRefl + | some chosen => + rcases hnormalized with + ⟨_, hchosenSupport, chosenV, hchosen, hvalueChosen⟩ + exact hcontinue hchosenSupport hchosen hvalueChosen + +/-- Public wrapper for the common-base scan started with no seed. -/ +theorem etaExpansionBase_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {inductId : KId .anon} {numParams numFields : Nat} + {args : Array (KExpr .anon)} {fieldV : Nat → VExpr} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hnoDelta : DefEqReduction.WFAt layer semantics trProj world support + uvars whnfNoDelta) + (hprojectionValue : ∀ {id : KId .anon} {idx : UInt64} + {value : KExpr .anon} {info : ExprInfo .anon}, + support (.prj id idx value info) → support value) + (hfieldSupport : ∀ field, field < numFields → + support args[numParams + field]!) + (hfield : ∀ field, field < numFields → + TrKExprS world.venv uvars world.nameOf trProj Delta + args[numParams + field]! (fieldV field)) : + RecM.WF layer semantics trProj world support uvars Delta state + (etaExpansionBase inductId numParams numFields args) + (fun result _ => match result with + | none => True + | some base => support base ∧ ∃ baseV, + TrKExprS world.venv uvars world.nameOf trProj Delta base baseV ∧ + ∀ field, field < numFields → + EtaExpansionFieldAgreement trProj world uvars Delta inductId + field (fieldV field) baseV) := by + unfold etaExpansionBase + apply RecM.WF.mono <| + etaExpansionBaseLoop_wf theory hcollision hnoDelta hprojectionValue + (seed := none) trivial + (fun offset hlt => by simpa using hfieldSupport offset hlt) + (fun offset hlt => by simpa using hfield offset hlt) + · intro result final hpost + cases result with + | none => trivial + | some base => + rcases hpost with + ⟨hbaseSupport, baseV, hbase, _, hagreement⟩ + exact ⟨hbaseSupport, baseV, hbase, fun field hlt => by + simpa using hagreement field hlt⟩ + · intro _ _ _ + trivial + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/StructureEtaFields.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/StructureEtaFields.lean new file mode 100644 index 000000000..dc8703423 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/StructureEtaFields.lean @@ -0,0 +1,116 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.Contracts + +/-! +# Structure-eta field comparison + +This module verifies the named left-to-right field loop used by final-WHNF +structure eta. Its inputs describe exactly the finitely many generated +projection nodes and constructor arguments selected by that loop. A `true` +result retains a Theory equality for every compared field; malformed +structure metadata is not assumed here and remains the responsibility of the +outer constructor/classifier proof. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- The recursive field loop compares every requested projection with its +corresponding constructor field. Projection existence is explicit because +`TrProjOK` provides closure and uniqueness, not construction of the concrete +projection relation. -/ +theorem tryEtaStructFields_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {inductId : KId .anon} {numParams field fuel : Nat} + {base : KExpr .anon} {args : Array (KExpr .anon)} {baseV : VExpr} + (hcollision : support.CollisionFree) + (hbase : TrKExprS world.venv uvars world.nameOf trProj Delta base baseV) + (structName : Lean.Name) + (hname : world.nameOf inductId.addr = some structName) + (projectedV fieldV : Nat → VExpr) + (hprojectionSupport : ∀ offset, offset < fuel → + support (KExpr.mkPrj inductId (field + offset).toUInt64 base)) + (hfieldSupport : ∀ offset, offset < fuel → + support args[numParams + field + offset]!) + (hprojection : ∀ offset, offset < fuel → + trProj Delta.toCtx structName (field + offset).toUInt64.toNat + baseV (projectedV offset)) + (hfield : ∀ offset, offset < fuel → + TrKExprS world.venv uvars world.nameOf trProj Delta + args[numParams + field + offset]! (fieldV offset)) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryEtaStructFields inductId numParams base args fuel field) + (fun answer _ => answer = true → + ∀ offset, offset < fuel → + world.venv.IsDefEqU uvars Delta.toCtx + (projectedV offset) (fieldV offset)) := by + induction fuel generalizing field state projectedV fieldV with + | zero => + simp only [tryEtaStructFields] + exact RecM.WF.pure fun _ _ offset hlt => by omega + | succ remaining ih => + simp only [tryEtaStructFields] + have hzero : 0 < remaining + 1 := by omega + have hprojectionNode : + KExpr.mkPrj inductId field.toUInt64 base = + KExpr.mkPrj inductId (field + 0).toUInt64 base := by + simp + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf hcollision + (hprojectionNode ▸ hprojectionSupport 0 hzero) + intro projection afterIntern hprojectionPost + rcases hprojectionPost with ⟨hIIntern, hprojectionEq, _⟩ + subst projection + have hprojectionTr : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkPrj inductId field.toUInt64 base) (projectedV 0) := by + rw [KExpr.mkPrj_shape] + exact .prj hname hbase (by simpa using hprojection 0 hzero) + have hfieldNode : args[numParams + field]! = + args[numParams + field + 0]! := by simp + apply RecM.WF.bind <| + RecM.isDefEqCall_wf + (hprojectionNode ▸ hprojectionSupport 0 hzero) + (hfieldNode ▸ hfieldSupport 0 hzero) + hprojectionTr + (hfieldNode ▸ hfield 0 hzero) + intro equal afterEqual hequal + cases equal with + | false => + simp only [Bool.not_false, if_true] + exact RecM.WF.pure fun _ htrue => by contradiction + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + apply RecM.WF.mono <| + ih (state := afterEqual) (field := field + 1) + (projectedV := fun offset => projectedV (offset + 1)) + (fieldV := fun offset => fieldV (offset + 1)) + (fun offset hlt => by + simpa only [Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using + hprojectionSupport (offset + 1) (by omega)) + (fun offset hlt => by + simpa only [Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using hfieldSupport (offset + 1) (by omega)) + (fun offset hlt => by + simpa only [Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using hprojection (offset + 1) (by omega)) + (fun offset hlt => by + simpa only [Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using hfield (offset + 1) (by omega)) + · intro answer final htail htrue offset hlt + cases offset with + | zero => exact hequal rfl + | succ offset => + simpa only [Nat.succ_eq_add_one] using + htail htrue offset (by omega) + · intro _ _ _ + trivial + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/StructureEtaTail.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/StructureEtaTail.lean new file mode 100644 index 000000000..9d6f7a5f7 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/StructureEtaTail.lean @@ -0,0 +1,132 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.StructureEtaBase + +/-! +# Structure-eta tail after type agreement + +This module composes the common-base shortcut and explicit field loop after +the caller has established that the two operands have definitionally equal +types. The only semantic input is an eta law indexed by the exact field +projection equations proved by those loops. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Exact semantic continuation needed after all structure fields agree. +The outer constructor/classifier proof supplies this from the trusted +constructor metadata and the explicit structure-eta Theory boundary. -/ +def FinalWhnfStructEtaLaw (trProj : RawProjRel) (world : VerifyWorld) + (uvars : Nat) (Delta : KVLCtx) (inductId : KId .anon) + (numFields : Nat) (fieldV : Nat → VExpr) (baseV resultV : VExpr) : + Prop := + (∀ field, field < numFields → + EtaExpansionFieldAgreement trProj world uvars Delta inductId field + (fieldV field) baseV) → + world.venv.IsDefEqU uvars Delta.toCtx baseV resultV + +namespace RecM + +/-- Both structure-eta implementations establish the same finite family of +field equations before invoking the semantic eta law. -/ +theorem tryEtaStructAfterTypes_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {inductId : KId .anon} {numParams numFields : Nat} + {base : KExpr .anon} {args : Array (KExpr .anon)} + {baseV resultV : VExpr} {fieldV projectedV : Nat → VExpr} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hnoDelta : DefEqReduction.WFAt layer semantics trProj world support + uvars whnfNoDelta) + (hprojectionValue : ∀ {id : KId .anon} {idx : UInt64} + {value : KExpr .anon} {info : ExprInfo .anon}, + support (.prj id idx value info) → support value) + (hbaseSupport : support base) + (hbase : TrKExprS world.venv uvars world.nameOf trProj Delta base baseV) + (hfieldSupport : ∀ field, field < numFields → + support args[numParams + field]!) + (hfield : ∀ field, field < numFields → + TrKExprS world.venv uvars world.nameOf trProj Delta + args[numParams + field]! (fieldV field)) + (structName : Lean.Name) + (hname : world.nameOf inductId.addr = some structName) + (hgeneratedSupport : ∀ field, field < numFields → + support (KExpr.mkPrj inductId field.toUInt64 base)) + (hgenerated : ∀ field, field < numFields → + trProj Delta.toCtx structName field.toUInt64.toNat + baseV (projectedV field)) + (hfieldIndex : ∀ field, field < numFields → + field.toUInt64.toNat = field) + (heta : FinalWhnfStructEtaLaw trProj world uvars Delta inductId + numFields fieldV baseV resultV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryEtaStructAfterTypes inductId numParams numFields base args) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx baseV resultV) := by + unfold tryEtaStructAfterTypes + apply RecM.WF.bind <| + etaExpansionBase_wf theory hcollision hnoDelta hprojectionValue + hfieldSupport hfield + intro commonBase afterBase hcommonBase + have hexplicit : ∀ explicitState, + RecM.WF layer semantics trProj world support uvars Delta explicitState + (tryEtaStructFields inductId numParams base args numFields 0) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx baseV resultV) := by + intro explicitState + apply RecM.WF.mono <| + tryEtaStructFields_wf hcollision hbase structName hname projectedV + fieldV + (fun offset hlt => by simpa using hgeneratedSupport offset hlt) + (fun offset hlt => by simpa using hfieldSupport offset hlt) + (fun offset hlt => by simpa using hgenerated offset hlt) + (fun offset hlt => by simpa using hfield offset hlt) + · intro answer final hagreement htrue + apply heta + intro field hlt + have hprojection := hgenerated field hlt + rw [hfieldIndex field hlt] at hprojection + exact ⟨structName, projectedV field, hname, hprojection, + (hagreement htrue field hlt).symm⟩ + · intro _ _ _ + trivial + cases commonBase with + | none => + simpa only using hexplicit afterBase + | some commonBase => + rcases hcommonBase with + ⟨hcommonSupport, commonBaseV, hcommonTr, hcommonAgreement⟩ + simp only + apply RecM.WF.bind <| RecM.WF.withInv <| + RecM.isDefEqCall_wf hbaseSupport hcommonSupport hbase hcommonTr + intro equal afterEqual hequal + rcases hequal with ⟨hIEqual, hequal⟩ + cases equal with + | false => + simpa only [Bool.false_eq_true, if_false, pure_bind] using + hexplicit afterEqual + | true => + exact RecM.WF.pure fun _ _ => by + apply heta + intro field hlt + obtain ⟨fieldStructName, commonProjectedV, hfieldName, + hcommonProjection, hfieldCommon⟩ := + hcommonAgreement field hlt + have hDelta : KVLCtx.WF world.venv uvars Delta := + hIEqual.2.1.wf + have hctx := + (KVLCtx.IsDefEq.refl world.venvWF.ordered hDelta).defeqCtx + obtain ⟨baseProjectedV, hbaseProjection⟩ := + theory.projections.defeqDFC hctx (hequal rfl).symm + hcommonProjection + have hprojectionEq := theory.projections.uniq hctx + hcommonProjection hbaseProjection (hequal rfl).symm + exact ⟨fieldStructName, baseProjectedV, hfieldName, + hbaseProjection, + hfieldCommon.trans world.venvWF hDelta hprojectionEq⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/FinalWhnf/UnitLike.lean b/Ix/Tc/Verify/DefEq/FinalWhnf/UnitLike.lean new file mode 100644 index 000000000..83418c0ad --- /dev/null +++ b/Ix/Tc/Verify/DefEq/FinalWhnf/UnitLike.lean @@ -0,0 +1,255 @@ +import Ix.Tc.Verify.DefEq.FinalWhnf.ProofTail +import Ix.Tc.Verify.Infer.Constants +import Ix.Tc.Verify.Whnf.StructEta.RecursionClassifier + +/-! +# Final-WHNF unit-like equality + +The operational classifier is proved exhaustively against the immutable +catalog. Its semantic conclusion uses one deliberately narrow inductive +law: inhabitants of a type headed by a trusted zero-index inductive with one +nullary constructor are definitionally equal. Lean4Lean's current +`VEnv.addInduct` interface does not expose that law, so it remains an explicit +construction obligation for the inductive-theory bridge rather than being +inferred from concrete metadata alone. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Constructor metadata accepted by production's unit-like shortcut. -/ +def KConst.IsNullaryConstructor : KConst .anon → Prop + | .ctor (fields := fields) .. => fields = 0 + | _ => False + +/-- Exact immutable-catalog shape accepted by the unit-like classifier. -/ +def KConst.IsUnitLikeInductive (catalog : Catalog) : KConst .anon → Prop + | .indc (indices := indices) (ctors := ctors) .. => + indices = 0 ∧ ctors.size = 1 ∧ + ∃ ctor, catalog ctors[0]! = some ctor ∧ ctor.IsNullaryConstructor + | _ => False + +/-- Semantic inductive law missing from Lean4Lean's current `addInduct` +specification. It is indexed by the exact trusted catalog shape and by the +actual structurally translated type selected by production. -/ +structure FinalWhnfUnitTheory (trProj : RawProjRel) + (world : VerifyWorld) : Prop where + unique : ∀ {uvars : Nat} {Delta : KVLCtx} + {typeExpr : KExpr .anon} {typeV leftV rightV : VExpr} + {indId : KId .anon} {levels : Array (KUniv .anon)} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} {entry : KConst .anon}, + typeExpr.collectSpine = (.const indId levels info, args) → + TrKExprS world.venv uvars world.nameOf trProj Delta typeExpr typeV → + world.trusted indId → + world.catalog indId = some entry → + entry.IsUnitLikeInductive world.catalog → + world.venv.HasType uvars Delta.toCtx leftV typeV → + world.venv.HasType uvars Delta.toCtx rightV typeV → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV + +/-- Run-scoped resources for the concrete unit-like shortcut. -/ +structure FinalWhnfUnitResources (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop where + theory : FinalWhnfUnitTheory trProj world + references : RecM.TrustedReferences world support + lazyFault : ∀ {Delta : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + whnf : RecM.DefEqDirectWhnf.WFAt layer semantics trProj world support uvars + +namespace RecM + +/-- A positive classifier result is tied to the exact immutable-catalog +entries returned by both production lookups. -/ +theorem isUnitLikeInductive_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {indId : KId .anon} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) : + RecM.WF layer semantics trProj world support uvars Delta state + (isUnitLikeInductive indId) + (fun answer _ => answer = true → + ∃ entry, world.catalog indId = some entry ∧ + entry.IsUnitLikeInductive world.catalog) := by + unfold isUnitLikeInductive + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.tryGetConst_loaded_wf hfault indId state + intro found afterInd hfound + rcases hfound with ⟨hIInd, hloadedInd⟩ + cases found with + | none => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | some entry => + cases entry <;> simp only + all_goals first + | exact RecM.WF.pure fun _ htrue => by contradiction + | skip + case indc name levelParams lvls params indices isUnsafe block memberIdx + ty ctors leanAll => + cases hshape : (indices != 0 || ctors.size != 1) with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ htrue => by contradiction + | false => + have hshapeParts := Bool.or_eq_false_iff.mp hshape + have hindices : indices = 0 := by + exact eq_of_beq + (show (indices == 0) = true by simpa using hshapeParts.1) + have hctors : ctors.size = 1 := by + exact eq_of_beq + (show (ctors.size == 1) = true by simpa using hshapeParts.2) + simp only [Bool.false_eq_true, if_false] + let ctorId := ctors[0]! + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.tryGetConst_loaded_wf hfault ctorId afterInd + intro foundCtor afterCtor hfoundCtor + rcases hfoundCtor with ⟨hICtor, hloadedCtor⟩ + cases foundCtor with + | none => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | some ctor => + cases ctor <;> simp only + all_goals first + | exact RecM.WF.pure fun _ htrue => by contradiction + | skip + case ctor name levelParams isUnsafe lvls induct cidx params + fields ty => + exact RecM.WF.pure fun _ htrue => by + have hfields : fields = 0 := eq_of_beq htrue + have hindCatalog := hIInd.1.core.loaded + (hloadedInd _ rfl) + have hctorCatalog := hICtor.1.core.loaded + (hloadedCtor _ rfl) + exact ⟨_, hindCatalog, hindices, hctors, _, + hctorCatalog, hfields⟩ + +/-- The complete unit-like shortcut is sound against the explicit inductive +law. All caught inference/WHNF errors and malformed catalog shapes are +conservative negative results. -/ +theorem tryDefEqUnit_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (resources : FinalWhnfUnitResources layer semantics trProj world support + uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqUnit left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold tryDefEqUnit + apply RecM.WF.bind + (tryOptionalInferOnlyCall_wf hleftSupport hleft) + intro inferredLeft afterInferLeft hinferredLeft + cases inferredLeft with + | none => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | some leftTy => + rcases hinferredLeft with + ⟨hleftTySupport, leftTyV, hleftTyTr, hleftType⟩ + obtain ⟨leftTyCoreV, hleftTyCoreTr, hleftTyCoreEq⟩ := hleftTyTr + simp only + apply RecM.WF.bind <| tryOptional_wf <| RecM.WF.withInv <| + resources.whnf hleftTySupport hleftTyCoreTr + intro reducedTy afterWhnf hreducedTy + cases reducedTy with + | none => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | some leftTyWhnf => + rcases hreducedTy with + ⟨hIWhnf, hleftTyWhnfSupport, leftTyWhnfV, hleftTyWhnfTr, + hleftTyReduction⟩ + rcases hspine : leftTyWhnf.collectSpine with ⟨head, args⟩ + simp only [hspine] + cases head with + | const indId levels info => + simp only + have htrusted : world.trusted indId := + resources.references hleftTyWhnfSupport + (collectSpine_const_references hspine) + apply RecM.WF.bind <| + isUnitLikeInductive_wf resources.lazyFault + intro isUnit afterUnit hisUnit + cases isUnit with + | false => + simp only [Bool.not_false] + exact RecM.WF.pure fun _ htrue => by contradiction + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + obtain ⟨entry, hentry, hshape⟩ := hisUnit rfl + apply RecM.WF.bind + (tryOptionalInferOnlyCall_wf hrightSupport hright) + intro inferredRight afterInferRight hinferredRight + cases inferredRight with + | none => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | some rightTy => + rcases hinferredRight with + ⟨hrightTySupport, rightTyV, hrightTyTr, + hrightType⟩ + obtain ⟨rightTyCoreV, hrightTyCoreTr, + hrightTyCoreEq⟩ := hrightTyTr + simp only + apply RecM.WF.mono <| + isDefEqCall_wf hleftTyWhnfSupport hrightTySupport + hleftTyWhnfTr hrightTyCoreTr + · intro answer final hanswer htrue + have hDelta : KVLCtx.WF world.venv uvars Delta := + hIWhnf.2.1.wf + have hleftCoreType : world.venv.HasType uvars + Delta.toCtx leftV leftTyCoreV := + hleftType.defeqU_r world.venvWF hDelta + hleftTyCoreEq.symm + have hleftWhnfType : world.venv.HasType uvars + Delta.toCtx leftV leftTyWhnfV := + hleftCoreType.defeqU_r world.venvWF hDelta + hleftTyReduction + have hrightCoreType : world.venv.HasType uvars + Delta.toCtx rightV rightTyCoreV := + hrightType.defeqU_r world.venvWF hDelta + hrightTyCoreEq.symm + have hrightWhnfType : world.venv.HasType uvars + Delta.toCtx rightV leftTyWhnfV := + hrightCoreType.defeqU_r world.venvWF hDelta + (hanswer htrue).symm + exact resources.theory.unique hspine + hleftTyWhnfTr htrusted hentry hshape + hleftWhnfType hrightWhnfType + · intro _ _ _ + trivial + | _ => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + +namespace TryDefEqUnit + +/-- Package the concrete unit-like shortcut. -/ +theorem ofResources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (resources : FinalWhnfUnitResources layer semantics trProj world support + uvars) : + TryDefEqUnit.WFAt layer semantics trProj world support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact tryDefEqUnit_wf resources hleftSupport hrightSupport hleft hright + +end TryDefEqUnit + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/LazyDelta.lean b/Ix/Tc/Verify/DefEq/LazyDelta.lean new file mode 100644 index 000000000..9a92b1e44 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/LazyDelta.lean @@ -0,0 +1,283 @@ +import Ix.Tc.Verify.DefEq.ProofIrrelevance + +/-! +# Bounded lazy-delta DefEq closure + +The production lazy-delta tier is a bounded state machine over expression +pairs. This module fixes its semantic loop invariant and proves the bounded +driver and its post-loop continuation correct from exact contracts for one +step and the stopped tail. Individual reduction branches discharge those +contracts in subsequent modules. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- A current lazy-delta pair remains supported and each component is a +sound reduction of the corresponding original operand. -/ +structure DefEqPairInvariant (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) (Delta : KVLCtx) + (leftSource rightSource : VExpr) + (pair : KExpr .anon × KExpr .anon) : Prop where + leftSupport : support pair.1 + rightSupport : support pair.2 + left : WhnfPost trProj world uvars Delta leftSource pair.1 + right : WhnfPost trProj world uvars Delta rightSource pair.2 + +namespace DefEqPairInvariant + +/-- The input pair establishes the lazy-delta invariant reflexively. -/ +theorem refl {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {uvars : Nat} {Delta : KVLCtx} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right rightV) : + DefEqPairInvariant trProj world support uvars Delta leftV rightV + (left, right) := by + refine ⟨hleftSupport, hrightSupport, ?_, ?_⟩ + · exact WhnfPost.refl hleft <| + hleft.wf world.venvWF.ordered theory.literalWF theory.projections.wf + hDelta + · exact WhnfPost.refl hright <| + hright.wf world.venvWF.ordered theory.literalWF theory.projections.wf + hDelta + +/-- Transport a successful comparison of the current pair back across both +components of the loop invariant. -/ +theorem conclude {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {uvars : Nat} {Delta : KVLCtx} + {leftSource rightSource : VExpr} + {pair : KExpr .anon × KExpr .anon} + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource pair) + (hcurrent : ∀ {leftV rightV}, + TrKExprS world.venv uvars world.nameOf trProj Delta pair.1 leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta pair.2 rightV → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) : + world.venv.IsDefEqU uvars Delta.toCtx leftSource rightSource := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + exact hleftEq.trans world.venvWF hDelta <| + (hcurrent hleft hright).trans world.venvWF hDelta hrightEq.symm + +end DefEqPairInvariant + +/-- Semantic interpretation of one lazy-delta step action. -/ +def DefEqLazyDeltaActionPost (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) (Delta : KVLCtx) + (leftSource rightSource : VExpr) : + BoundedStep (KExpr .anon × KExpr .anon) + (LazyDeltaLoopResult .anon) → Prop + | .next pair => + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource pair + | .done (.answer result) => + result = true → + world.venv.IsDefEqU uvars Delta.toCtx leftSource rightSource + | .done (.stopped left right) => + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right) + +/-- Exact semantic contract for one production lazy-delta iteration. -/ +def DefEqLazyDeltaStep.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftSource rightSource pair}, + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource pair → + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStep pair) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) + +/-- A Nat-offset hit may be negative, but every positive hit proves equality +of the exact current operands. A miss carries no completeness claim. -/ +def TryDefEqOffset.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqOffset left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Exact remaining one-step contract once Nat-offset comparison misses. -/ +def DefEqLazyDeltaAfterOffsetMiss.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftSource rightSource pair}, + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource pair → + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepAfterOffsetMiss pair) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) + +/-- Close the production step's Nat-offset prefix. This theorem does not +assume shared-offset injectivity itself: that obligation is exactly the +`TryDefEqOffset.WFAt` premise. -/ +theorem defEqLazyDeltaStep_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} + {pair : KExpr .anon × KExpr .anon} + (hoffset : TryDefEqOffset.WFAt layer semantics trProj world support + uvars) + (hafter : DefEqLazyDeltaAfterOffsetMiss.WFAt layer semantics trProj + world support uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource pair) : + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStep pair) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold defEqLazyDeltaStep + apply RecM.WF.bind <| + hoffset hpair.leftSupport hpair.rightSupport hleft hright + intro result after hresult + cases result with + | none => + exact hafter hpair + | some answer => + exact RecM.WF.pure fun _ htrue => + hleftEq.trans world.venvWF hDelta <| + (hresult htrue).trans world.venvWF hDelta hrightEq.symm + +namespace DefEqLazyDeltaStep + +/-- Package the offset prefix theorem as the complete one-step contract. -/ +theorem ofOffset + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hoffset : TryDefEqOffset.WFAt layer semantics trProj world support + uvars) + (hafter : DefEqLazyDeltaAfterOffsetMiss.WFAt layer semantics trProj + world support uvars) : + DefEqLazyDeltaStep.WFAt layer semantics trProj world support uvars := by + intro Delta state leftSource rightSource pair hpair + intro methods hmethods hI + exact (defEqLazyDeltaStep_wf hoffset hafter hI.2.1.wf hpair) + methods hmethods hI + +end DefEqLazyDeltaStep + +/-- The bounded driver preserves the pair invariant until it either returns +a sound answer or exposes a stopped pair carrying the same invariant. -/ +theorem runDefEqLazyDelta_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (hstep : DefEqLazyDeltaStep.WFAt layer semantics trProj world support + uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (runDefEqLazyDelta left right) + (fun result _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftV rightV (.done result)) := by + unfold runDefEqLazyDelta + apply runBounded_wf + (P := fun pair => DefEqPairInvariant trProj world support uvars Delta + leftV rightV pair) + (Q := fun result _ => DefEqLazyDeltaActionPost trProj world support + uvars Delta leftV rightV (.done result)) + · intro pair current hpair + apply RecM.WF.mono (hstep (state := current) hpair) + · intro action _ haction + cases action <;> exact haction + · intro _ _ _ + trivial + · intro _ _ + trivial + · exact DefEqPairInvariant.refl theory hDelta hleftSupport hrightSupport + hleft hright + +/-- Semantic contract for the tiers entered from a stopped lazy-delta pair. -/ +def DefEqAfterLazyDeltaStopped.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftSource rightSource left right}, + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right) → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqAfterLazyDeltaStopped left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftSource rightSource) + +/-- The two exact contracts needed to close the production lazy-delta tier. -/ +structure DefEqLazyDeltaContext (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop where + step : DefEqLazyDeltaStep.WFAt layer semantics trProj world support uvars + stopped : DefEqAfterLazyDeltaStopped.WFAt layer semantics trProj world + support uvars + +/-- Compose the bounded driver with its post-loop continuation. -/ +theorem isDefEqInnerAfterProofIrrelevance_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (context : DefEqLazyDeltaContext layer semantics trProj world support + uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqInnerAfterProofIrrelevance left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold isDefEqInnerAfterProofIrrelevance + apply RecM.WF.bind <| + runDefEqLazyDelta_wf theory context.step hDelta hleftSupport + hrightSupport hleft hright + intro result after hresult + cases result with + | answer answer => + exact RecM.WF.pure fun _ htrue => hresult htrue + | stopped currentLeft currentRight => + exact context.stopped hresult + +/-- A verified lazy-delta context discharges the abstract tail contract used +by the already-verified pre-delta proof-irrelevance tier. -/ +theorem DefEqAfterProofIrrelevance.ofLazyDelta + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (context : DefEqLazyDeltaContext layer semantics trProj world support + uvars) : + DefEqAfterProofIrrelevance.WF layer semantics trProj world support + uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + intro methods hmethods hI + exact (isDefEqInnerAfterProofIrrelevance_wf theory context + hI.2.1.wf hleftSupport hrightSupport hleft hright) methods hmethods hI + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/LazyDeltaClosure.lean b/Ix/Tc/Verify/DefEq/LazyDeltaClosure.lean new file mode 100644 index 000000000..c3a2f4125 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/LazyDeltaClosure.lean @@ -0,0 +1,61 @@ +import Ix.Tc.Verify.DefEq.LazyDeltaIteration +import Ix.Tc.Verify.DefEq.StoppedContinuationClosure + +/-! +# Complete lazy-delta tier assembly + +The bounded driver needs one verified iteration and one verified continuation +for a stopped pair. This module joins those independently proved executable +surfaces under the canonical K2 suffix/cache model. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Resources for the complete bounded lazy-delta tier. Remaining semantic +work is visible inside the two component records rather than hidden behind a +contract for the outer driver. -/ +structure LazyDeltaClosureResources + {trProj : RawProjRel} {world : VerifyWorld} (support : RunSupport) + (model : KernelSuffixModel trProj world) where + iteration : LazyDeltaIterationResources support model + stopped : StoppedContinuationClosureResources + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars + +namespace DefEqLazyDeltaContext + +/-- Assemble the complete production lazy-delta context from the verified +iteration and stopped continuation. -/ +theorem ofKernelResources + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + (resources : LazyDeltaClosureResources support model) : + DefEqLazyDeltaContext .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars where + step := DefEqLazyDeltaStep.ofKernelResources model resources.iteration + stopped := DefEqAfterLazyDeltaStopped.ofClosureResources resources.stopped + +end DefEqLazyDeltaContext + +namespace DefEqAfterProofIrrelevance + +/-- Discharge the exact post-proof-irrelevance tail with the assembled +bounded lazy-delta reducer. -/ +theorem ofKernelResources + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + (resources : LazyDeltaClosureResources support model) : + DefEqAfterProofIrrelevance.WF .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := + DefEqAfterProofIrrelevance.ofLazyDelta resources.iteration.theory + (DefEqLazyDeltaContext.ofKernelResources resources) + +end DefEqAfterProofIrrelevance + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/LazyDeltaIteration.lean b/Ix/Tc/Verify/DefEq/LazyDeltaIteration.lean new file mode 100644 index 000000000..82913e244 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/LazyDeltaIteration.lean @@ -0,0 +1,111 @@ +import Ix.Tc.Verify.DefEq.EqualRankPrefix +import Ix.Tc.Verify.DefEq.NatOffsetDecomposition + +/-! +# Complete lazy-delta iteration assembly + +The individual production branches are proved in focused modules. This +module records their exact shared inputs and composes them, in execution +order, into the contract for one complete bounded lazy-delta iteration. + +The remaining inputs are deliberately concrete contracts rather than +acceptance oracles: Nat-offset decomposition, the K1 reducers reused by +DefEq, and finite run-scoped resources for same-head comparison and cache +writes. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Run-scoped resources needed to assemble every branch of one production +lazy-delta iteration under the canonical K2 cache semantics. -/ +structure LazyDeltaIterationResources + {trProj : RawProjRel} {world : VerifyWorld} (support : RunSupport) + (model : KernelSuffixModel trProj world) where + ingress : AnonLazyIngressContext .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + theory : WhnfTheory trProj world model.keys.uvars + collision : support.CollisionFree + sameHeadSpines : SameHeadSpineResources support + trustedReferences : TrustedReferences world support + offsetCandidates : NatOffsetCandidateContext .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + natZero : NatZeroContext world + natReduction : OptionalReduction.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars tryReduceNat + projectionWhnf : DefEqReduction.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars whnfNoDelta + deltaReduction : LazyDeltaReductionContext .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars + +namespace DefEqLazyDeltaStep + +/-- Compose every verified branch into the complete production one-step +contract. In particular, the equal-rank failure cache is used only inside +its rejection-only shell; positive equality is supplied by the same-head +semantic proof. -/ +theorem ofKernelResources + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (model : KernelSuffixModel trProj world) + (resources : LazyDeltaIterationResources support model) : + DefEqLazyDeltaStep.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := by + have hsameHeadMiss : DefEqLazyDeltaAfterSameHeadMiss.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := + DefEqLazyDeltaAfterSameHeadMiss.ofReduction resources.deltaReduction + have hequalRank : DefEqLazyDeltaEqualRank.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := + DefEqLazyDeltaEqualRank.ofKernelResources model resources.ingress + resources.theory resources.collision resources.sameHeadSpines + resources.trustedReferences hsameHeadMiss + have hprojectionMiss : DefEqLazyDeltaAfterProjectionMiss.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := + DefEqLazyDeltaAfterProjectionMiss.ofRankDispatch resources.ingress + resources.deltaReduction hequalRank + have hprojection : OptionalReduction.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars tryUnfoldProjApp := + tryUnfoldProjApp_wf resources.projectionWhnf + have hclassified : + DefEqLazyDeltaAfterDeltaClassification.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := + DefEqLazyDeltaAfterDeltaClassification.ofProjection resources.theory + hprojection hprojectionMiss + have haccelerators : DefEqLazyDeltaAfterAcceleratorMiss.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := + DefEqLazyDeltaAfterAcceleratorMiss.ofClassification resources.ingress + hclassified + have hnatMiss : DefEqLazyDeltaAfterNatMiss.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := + DefEqLazyDeltaAfterNatMiss.ofNoAccel resources.theory haccelerators + have hoffsetMiss : DefEqLazyDeltaAfterOffsetMiss.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := + DefEqLazyDeltaAfterOffsetMiss.ofNat resources.theory + resources.natReduction hnatMiss + have hoffset : TryDefEqOffset.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars := + TryDefEqOffset.ofContext resources.theory resources.natZero + (TryDefEqOffsetAfterCandidates.ofContext resources.offsetCandidates) + intro Delta state leftSource rightSource pair hpair + intro methods hmethods hI + exact (defEqLazyDeltaStep_wf hoffset hoffsetMiss hI.2.1.wf hpair) + methods hmethods hI + +end DefEqLazyDeltaStep + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/LoopFinish.lean b/Ix/Tc/Verify/DefEq/LoopFinish.lean new file mode 100644 index 000000000..79e1411de --- /dev/null +++ b/Ix/Tc/Verify/DefEq/LoopFinish.lean @@ -0,0 +1,66 @@ +import Ix.Tc.Verify.DefEq.ProjectionProbe + +/-! +# Lazy-delta loop finishing checks + +After a productive unfold, one lazy-delta iteration performs address equality +and the cheap structural comparison before returning the transformed pair to +the bounded driver. This module discharges both accepting checks against the +current pair and transports their result back through the loop invariant. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- The final address/structural checks either produce a sound positive +answer or return the unchanged current pair as the next loop state. -/ +theorem finishDefEqLazyDeltaStep_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hsorts : SortComponentResources support) + (hstructural : QuickDefEqResources support) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (finishDefEqLazyDeltaStep left right) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold finishDefEqLazyDeltaStep + cases haddr : left.addr == right.addr with + | true => + simp only [if_true] + exact RecM.WF.pure fun hI _ => + hleftEq.trans world.venvWF hI.2.1.wf <| + (DefEqMeaning.of_translations theory hI.2.1.wf hleft hright + (DefEqMeaning.of_addr_beq theory hI.2.1 hcollision + hpair.leftSupport hpair.rightSupport hleft haddr) rfl).trans + world.venvWF hI.2.1.wf hrightEq.symm + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind <| + quickDefEq_wf theory hcollision hsorts hstructural + hpair.leftSupport hpair.rightSupport hleft hright + intro accepted afterQuick haccepted + cases accepted with + | true => + simp only [if_true] + exact RecM.WF.pure fun hI _ => + hleftEq.trans world.venvWF hI.2.1.wf <| + (haccepted rfl).trans world.venvWF hI.2.1.wf + hrightEq.symm + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => hpair + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/NatOffset.lean b/Ix/Tc/Verify/DefEq/NatOffset.lean new file mode 100644 index 000000000..5aeee1ed3 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/NatOffset.lean @@ -0,0 +1,339 @@ +import Ix.Tc.Verify.DefEq.LazyDelta + +/-! +# Nat-offset comparison + +The generalized offset reducer begins with an exact literal/literal case and +then enters the structural zero/parser/rebuilder path. This module closes +the literal case and leaves the latter path behind a separately named +contract. In particular, no negative result is assigned semantic meaning. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Exact contract for the structural offset path after the direct pair of +Nat literals has been ruled out. -/ +def TryDefEqOffsetAfterLiteral.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqOffsetAfterLiteral left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Positive-result contract for the production Nat-zero recognizer. The +recognizer is permitted to miss, but acceptance identifies the exact Theory +zero expression. -/ +def IsNatZero.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state source sourceV}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + RecM.WF layer semantics trProj world support uvars Delta state + (isNatZero source) + (fun answer _ => answer = true → sourceV = VExpr.natZero) + +/-- Exact generalized offset contract after the joint zero probe misses. -/ +def TryDefEqOffsetAfterZeroMiss.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqOffsetAfterZeroMiss left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Exact decomposition/rebuild contract after both syntactic candidate +guards accept. -/ +def TryDefEqOffsetAfterCandidates.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqOffsetAfterCandidates left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- The exact primitive-table authority needed by `isNatZero`. The full +no-delta table is retained so the existing literal-extraction theorem can be +reused without introducing a second address-to-name proof. -/ +structure NatZeroContext (world : VerifyWorld) : Prop where + table : ∀ (prims : Primitives .anon), prims.CanonicalAnon → + NoDeltaPrimitiveTableAgrees world prims + theoryPrimitives : world.venv.HasPrimitives + +namespace NatZeroContext + +/-- Project the Nat-zero authority from an existing no-delta primitive +context. -/ +def ofNoDelta {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) : + NatZeroContext world where + table := context.table + theoryPrimitives := context.theoryPrimitives + +end NatZeroContext + +/-- The actual production Nat-zero recognizer is sound in no-acceleration +mode. A positive answer is converted to the already-proved canonical +`extractNatLit = some 0` translation theorem. -/ +theorem isNatZero_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {state : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr} + (context : NatZeroContext world) + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF .noAccel semantics trProj world support uvars Delta state + (isNatZero source) + (fun answer _ => answer = true → sourceV = VExpr.natZero) := by + unfold isNatZero + apply RecM.WF.bind (RecM.WF.withInv (prims_wf (s := state))) + intro runtimePrims afterRead hread + rcases hread with ⟨hI, hprims, hafterRead⟩ + subst runtimePrims + subst afterRead + have htable := context.table state.prims hI.noAccel_primitives + cases source <;> simp only + all_goals + exact RecM.WF.pure fun _ hanswer => by + have hresult := TrKExprS.of_extractNatLit (n := 0) htable + context.theoryPrimitives hsource (by simp_all [extractNatLit]) + simpa [VExpr.natLit] using hresult + +namespace IsNatZero + +/-- Package the concrete recognizer theorem at every universe count. -/ +theorem ofContext + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (context : NatZeroContext world) : + IsNatZero.WFAt .noAccel semantics trProj world support uvars := by + intro Delta state source sourceV hsourceSupport hsource + exact isNatZero_wf context hsourceSupport hsource + +end IsNatZero + +/-- Close the allocation-free candidate guard. Rejection returns `none`, +which intentionally carries no semantic obligation; acceptance delegates to +the exact decomposition/rebuild contract. -/ +theorem tryDefEqOffsetAfterZeroMiss_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (hafter : TryDefEqOffsetAfterCandidates.WFAt layer semantics trProj + world support uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqOffsetAfterZeroMiss left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + unfold tryDefEqOffsetAfterZeroMiss + apply RecM.WF.bind (RecM.WF.withInv (prims_wf (s := state))) + intro runtimePrims afterRead hread + rcases hread with ⟨hI, hprims, hafterRead⟩ + subst runtimePrims + subst afterRead + cases hguard : + (!natOffsetCandidate state.prims left || + !natOffsetCandidate state.prims right) with + | false => + simp only [Bool.false_eq_true, if_false] + exact hafter hleftSupport hrightSupport hleft hright + | true => + simp only [if_true] + exact RecM.WF.pure fun _ => trivial + +namespace TryDefEqOffsetAfterZeroMiss + +/-- Package candidate rejection as the complete post-zero contract. -/ +theorem ofCandidates + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hafter : TryDefEqOffsetAfterCandidates.WFAt layer semantics trProj + world support uvars) : + Ix.Tc.RecM.TryDefEqOffsetAfterZeroMiss.WFAt layer semantics trProj world + support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact tryDefEqOffsetAfterZeroMiss_wf hafter hleftSupport hrightSupport + hleft hright + +end TryDefEqOffsetAfterZeroMiss + +/-- Close the zero/zero branch after the literal fast path. -/ +theorem tryDefEqOffsetAfterLiteral_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (hzero : IsNatZero.WFAt layer semantics trProj world support uvars) + (hafter : TryDefEqOffsetAfterZeroMiss.WFAt layer semantics trProj world + support uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqOffsetAfterLiteral left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + have hleftWF := hleft.wf world.venvWF.ordered theory.literalWF + theory.projections.wf hDelta + unfold tryDefEqOffsetAfterLiteral + apply RecM.WF.bind (hzero hleftSupport hleft) + intro leftIsZero afterLeft hleftZero + apply RecM.WF.bind (hzero hrightSupport hright) + intro rightIsZero afterRight hrightZero + cases leftIsZero with + | false => + cases rightIsZero <;> + simp only [Bool.false_and, Bool.false_eq_true, if_false] <;> + exact hafter hleftSupport hrightSupport hleft hright + | true => + cases rightIsZero with + | false => + simp only [Bool.true_and, Bool.false_eq_true, if_false] + exact hafter hleftSupport hrightSupport hleft hright + | true => + simp only [Bool.true_and, if_true] + exact RecM.WF.pure fun _ _ => by + have hleftValue := hleftZero rfl + have hrightValue := hrightZero rfl + subst leftV + subst rightV + exact Lean4Lean.VEnv.IsDefEqU.refl hleftWF + +namespace TryDefEqOffsetAfterLiteral + +/-- Package the zero-prefix proof as the complete post-literal contract. -/ +theorem ofZero + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hzero : IsNatZero.WFAt layer semantics trProj world support uvars) + (hafter : TryDefEqOffsetAfterZeroMiss.WFAt layer semantics trProj world + support uvars) : + Ix.Tc.RecM.TryDefEqOffsetAfterLiteral.WFAt layer semantics trProj world + support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + intro methods hmethods hI + exact (tryDefEqOffsetAfterLiteral_wf theory hzero hafter hI.2.1.wf + hleftSupport hrightSupport hleft hright) methods hmethods hI + +end TryDefEqOffsetAfterLiteral + +/-- Close the direct Nat-literal branch of `tryDefEqOffset`. Equality of the +runtime literal payloads makes the two Theory literals definitionally equal +by reflexivity; every other constructor pair is delegated unchanged. -/ +theorem tryDefEqOffset_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (hafter : TryDefEqOffsetAfterLiteral.WFAt layer semantics trProj world + support uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryDefEqOffset left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + have hleftWF := hleft.wf world.venvWF.ordered theory.literalWF + theory.projections.wf hDelta + cases left <;> simp only [tryDefEqOffset, pure_bind] + all_goals + first + | exact hafter hleftSupport hrightSupport hleft hright + | skip + cases right + all_goals + first + | exact hafter hleftSupport hrightSupport hleft hright + | skip + cases hleft + cases hright + exact RecM.WF.pure fun _ hanswer => by + have hvalues := eq_of_beq hanswer + cases hvalues + exact Lean4Lean.VEnv.IsDefEqU.refl hleftWF + +namespace TryDefEqOffset + +/-- Package the literal-prefix proof as the complete offset contract. -/ +theorem ofAfterLiteral + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hafter : TryDefEqOffsetAfterLiteral.WFAt layer semantics trProj world + support uvars) : + Ix.Tc.RecM.TryDefEqOffset.WFAt layer semantics trProj world support + uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + intro methods hmethods hI + exact (tryDefEqOffset_wf theory hafter hI.2.1.wf hleftSupport + hrightSupport hleft hright) methods hmethods hI + +/-- Reduce the complete concrete offset contract to the remaining +decomposition/rebuild path. -/ +theorem ofContext + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (zeroContext : NatZeroContext world) + (hafter : TryDefEqOffsetAfterCandidates.WFAt .noAccel semantics trProj + world support uvars) : + Ix.Tc.RecM.TryDefEqOffset.WFAt .noAccel semantics trProj world support + uvars := + ofAfterLiteral theory <| + TryDefEqOffsetAfterLiteral.ofZero theory + (IsNatZero.ofContext zeroContext) + (TryDefEqOffsetAfterZeroMiss.ofCandidates hafter) + +end TryDefEqOffset + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/NatOffsetDecomposition.lean b/Ix/Tc/Verify/DefEq/NatOffsetDecomposition.lean new file mode 100644 index 000000000..5fb8ce726 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/NatOffsetDecomposition.lean @@ -0,0 +1,277 @@ +import Ix.Tc.Verify.DefEq.NatOffset +import Ix.Tc.Verify.Whnf.Iota.NatOffset + +/-! +# Nat-offset decomposition and reconstruction + +The optimized DefEq branch parses both operands as a base plus an offset, +removes their common positive suffix, rebuilds the two remainders, and invokes +the recursive DefEq callback once. Soundness needs only the forward +direction: equality of the rebuilt remainders lifts through the common chain +of `Nat.succ` applications. No injectivity or completeness claim is used. + +This module separates unconditional state safety from the one semantic fact +about successful parser/rebuilder executions. The latter is indexed by the +exact production runs, so it cannot authorize an unrelated generated term. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace TcM.WF + +/-- Retain the invariant and exact successful execution selected by a Hoare +triple. This combines the two facts needed at execution-indexed semantic +boundaries without giving those boundaries any state authority. -/ +theorem withInvRunEq {I : TcState m → Prop} {s : TcState m} + {x : TcM m α} {Q : α → TcState m → Prop} + {E : TcError m → TcState m → Prop} + (hx : TcM.WF I s x Q E) : + TcM.WF I s x + (fun value after => I after ∧ Q value after ∧ + x s = .ok value after) + E := by + intro hI + have hpost := hx hI + cases hrun : x s with + | ok value after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.1, hpost.2, rfl⟩ + | error err after => + rw [hrun] at hpost + exact hpost + +end TcM.WF + +namespace RecM + +/-- Semantic meaning of one rebuilt remainder after removing `common` +successors from the source. -/ +def NatOffsetRemainderMeaning (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) (Delta : KVLCtx) + (sourceV : VExpr) (common : Nat) (result : KExpr .anon) : Prop := + support result ∧ + ∃ resultV, + TrKExprS world.venv uvars world.nameOf trProj Delta result resultV ∧ + world.venv.HasType uvars Delta.toCtx resultV .nat ∧ + world.venv.IsDefEqU uvars Delta.toCtx sourceV + (natSuccIterV common resultV) + +/-- Exact semantic boundary for a successful decomposition followed by the +actual production rebuild. The two executions may be separated by other +read-only parsing work, so both starting invariants are explicit. -/ +structure NatOffsetReflection (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Prop where + success : ∀ {uvars : Nat} {Delta : KVLCtx} + {methods : Methods .anon} {source : KExpr .anon} {sourceV : VExpr} + {base : Option (KExpr .anon)} {total common : Nat} + {decomposeBefore decomposeAfter rebuildBefore rebuildAfter : + TcState .anon} {result : KExpr .anon}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + Methods.WFAt layer semantics trProj world support uvars methods → + WhnfStateInv layer semantics trProj world support uvars Delta + decomposeAfter → + WhnfStateInv layer semantics trProj world support uvars Delta + rebuildAfter → + (natOffsetDecompose source).run methods decomposeBefore = + .ok (some (base, total)) decomposeAfter → + common ≤ total → + (natOffsetRebuild base (total - common)).run methods rebuildBefore = + .ok result rebuildAfter → + NatOffsetRemainderMeaning trProj world support uvars Delta sourceV + common result + +/-- Primitive authority used only to lift recursive equality through the +common successor suffix. -/ +structure NatOffsetCandidateContext (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Prop where + table : ∀ prims, prims.CanonicalAnon → + NoDeltaPrimitiveTableAgrees world prims + theoryPrimitives : world.venv.HasPrimitives + reflection : NatOffsetReflection layer semantics trProj world support + +/-- `natOffsetDecompose` is read-only on every hit, miss, and bounded-parser +path. -/ +theorem natOffsetDecompose_state_wf {I : TcState .anon → Prop} + (methods : Methods .anon) (source : KExpr .anon) (s : TcState .anon) : + TcM.WF I s ((natOffsetDecompose source).run methods) + (fun _ _ => True) := by + unfold natOffsetDecompose + rw [ReaderT.run_bind] + apply TcM.WF.bind (prims_state_wf methods s) + intro prims afterRead _ + cases hextract : extractNatValue source prims with + | some value => + simp only + exact TcM.WF.pure fun _ => trivial + | none => + simp only [pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind (natOffset_state_wf methods source 0 afterRead) + intro parsed afterOffset _ + cases parsed with + | none => exact TcM.WF.pure fun _ => trivial + | some pair => + rcases pair with ⟨base, offset⟩ + cases hzero : offset == 0 with + | true => + simp only [hzero, if_true] + exact TcM.WF.pure fun _ => trivial + | false => + simp only [hzero, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + apply TcM.WF.bind (prims_state_wf methods afterOffset) + intro currentPrims afterSecondRead _ + cases hbase : extractNatValue base currentPrims with + | none => + simp only + exact TcM.WF.pure fun _ => trivial + | some value => + simp only + exact TcM.WF.pure fun _ => trivial + +/-- `natOffsetRebuild` either returns pure syntax or performs the already +proved read-only `mkNatAdd` primitive-table query. -/ +theorem natOffsetRebuild_state_wf {I : TcState .anon → Prop} + (methods : Methods .anon) (base : Option (KExpr .anon)) + (remainder : Nat) (s : TcState .anon) : + TcM.WF I s ((natOffsetRebuild base remainder).run methods) + (fun _ _ => True) := by + cases base with + | none => + exact TcM.WF.pure fun _ => trivial + | some base => + cases hzero : remainder == 0 with + | true => + simp only [natOffsetRebuild, hzero, if_true] + exact TcM.WF.pure fun _ => trivial + | false => + simp only [natOffsetRebuild, hzero, Bool.false_eq_true, if_false] + exact mkNatAdd_state_wf methods base + (natExprFromValue remainder) s + +/-- Complete production branch after both allocation-free candidate guards +accept. Positive recursive equality is transported through the common +successor suffix; every parser miss and the zero-common-offset case remains +an ordinary `none`. -/ +theorem tryDefEqOffsetAfterCandidates_wf + {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (context : NatOffsetCandidateContext .noAccel semantics trProj world + support) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF .noAccel semantics trProj world support uvars Delta state + (tryDefEqOffsetAfterCandidates left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + intro methods hmethods + unfold tryDefEqOffsetAfterCandidates + rw [ReaderT.run_bind] + apply TcM.WF.bind + (TcM.WF.withInvRunEq <| + natOffsetDecompose_state_wf methods left state) + intro leftResult afterLeft hleftResult + rcases hleftResult with ⟨hILeft, _, hleftRun⟩ + cases leftResult with + | none => exact TcM.WF.pure fun _ => trivial + | some leftParts => + rcases leftParts with ⟨baseLeft, leftOffset⟩ + rw [ReaderT.run_bind] + apply TcM.WF.bind + (TcM.WF.withInvRunEq <| + natOffsetDecompose_state_wf methods right afterLeft) + intro rightResult afterRight hrightResult + rcases hrightResult with ⟨hIRight, _, hrightRun⟩ + cases rightResult with + | none => exact TcM.WF.pure fun _ => trivial + | some rightParts => + rcases rightParts with ⟨baseRight, rightOffset⟩ + cases hzero : (min leftOffset rightOffset == 0) with + | true => + simp only [hzero, if_true] + exact TcM.WF.pure fun _ => trivial + | false => + simp only [hzero, Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (TcM.WF.withInvRunEq <| + natOffsetRebuild_state_wf methods baseLeft + (leftOffset - min leftOffset rightOffset) afterRight) + intro rebuiltLeft afterRebuildLeft hrebuiltLeft + rcases hrebuiltLeft with + ⟨hIRebuildLeft, _, hleftRebuildRun⟩ + have hleftMeaning := context.reflection.success + hleftSupport hleft hmethods hILeft hIRebuildLeft hleftRun + (Nat.min_le_left _ _) hleftRebuildRun + rw [ReaderT.run_bind] + apply TcM.WF.bind + (TcM.WF.withInvRunEq <| + natOffsetRebuild_state_wf methods baseRight + (rightOffset - min leftOffset rightOffset) + afterRebuildLeft) + intro rebuiltRight afterRebuildRight hrebuiltRight + rcases hrebuiltRight with + ⟨hIRebuildRight, _, hrightRebuildRun⟩ + have hrightMeaning := context.reflection.success + hrightSupport hright hmethods hIRight hIRebuildRight + hrightRun (Nat.min_le_right _ _) hrightRebuildRun + rcases hleftMeaning with + ⟨hrebuiltLeftSupport, rebuiltLeftV, hrebuiltLeftTr, + hrebuiltLeftType, hleftReconstruction⟩ + rcases hrightMeaning with + ⟨hrebuiltRightSupport, rebuiltRightV, hrebuiltRightTr, + hrebuiltRightType, hrightReconstruction⟩ + rw [ReaderT.run_bind] + apply TcM.WF.bind + ((RecM.isDefEqCall_wf hrebuiltLeftSupport + hrebuiltRightSupport hrebuiltLeftTr hrebuiltRightTr) + methods hmethods) + intro answer afterDefEq hanswer + exact TcM.WF.pure fun hIFinal htrue => by + have htable := context.table afterDefEq.prims + hIFinal.noAccel_primitives + have hsucc := natSucc_hasType + (uvars := uvars) (Delta := Delta) + hIFinal.1.core.trustedCatalog htable + context.theoryPrimitives + have hlift := natSuccIterV_congr world.venvWF + hIFinal.2.1.wf.toCtx hsucc hrebuiltLeftType + (hanswer htrue) (min leftOffset rightOffset) + exact hleftReconstruction.trans world.venvWF + hIFinal.2.1.wf <| + hlift.trans world.venvWF hIFinal.2.1.wf + hrightReconstruction.symm + +namespace TryDefEqOffsetAfterCandidates + +/-- Package the production branch as the exact continuation contract used by +the outer Nat-offset prefix. -/ +theorem ofContext + {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (context : NatOffsetCandidateContext .noAccel semantics trProj world + support) : + TryDefEqOffsetAfterCandidates.WFAt .noAccel semantics trProj world + support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact tryDefEqOffsetAfterCandidates_wf context hleftSupport hrightSupport + hleft hright + +end TryDefEqOffsetAfterCandidates + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/NatReduction.lean b/Ix/Tc/Verify/DefEq/NatReduction.lean new file mode 100644 index 000000000..6327d751a --- /dev/null +++ b/Ix/Tc/Verify/DefEq/NatReduction.lean @@ -0,0 +1,130 @@ +import Ix.Tc.Verify.DefEq.NatOffset + +/-! +# Lazy-delta Nat reduction + +After the offset probe misses, production conditionally tries the ordinary +Nat reducer on each operand. A successful reduction is compared recursively +against the opposite operand. This module composes the existing optional +reducer and predecessor DefEq contracts with the lazy-delta pair invariant. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Exact remaining one-step contract after both gated Nat reductions miss +or the gate is disabled. -/ +def DefEqLazyDeltaAfterNatMiss.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftSource rightSource left right}, + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right) → + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepAfterNatMiss left right) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) + +/-- Close the gated left/right Nat-reduction prefix. -/ +theorem defEqLazyDeltaStepAfterOffsetMiss_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + (theory : WhnfTheory trProj world uvars) + (hnat : OptionalReduction.WFAt .noAccel semantics trProj world support + uvars tryReduceNat) + (hafter : DefEqLazyDeltaAfterNatMiss.WFAt .noAccel semantics trProj + world support uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF .noAccel semantics trProj world support uvars Delta state + (defEqLazyDeltaStepAfterOffsetMiss (left, right)) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold defEqLazyDeltaStepAfterOffsetMiss + apply RecM.WF.bind + (Q₁ := fun observed after => observed = state ∧ after = state) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed afterRead hread + rcases hread with ⟨hObserved, hAfterRead⟩ + subst observed + subst afterRead + cases hgate : + ((!left.hasFVars && !right.hasFVars) || state.eagerReduce) with + | false => + simp only [Bool.false_eq_true, if_false] + exact hafter hpair + | true => + simp only [if_true] + apply RecM.WF.bind + (RecM.WF.withInv <| + hnat hpair.leftSupport hleft) + intro leftResult afterLeft hleftResult + rcases hleftResult with ⟨hILeft, hleftResult⟩ + cases leftResult with + | some reducedLeft => + rcases hleftResult with ⟨hreducedSupport, hreducedMeaning⟩ + have hleftReduced := WhnfPost.transMeaning theory hDelta + ⟨leftV, hleft, hleftEq⟩ hreducedMeaning + obtain ⟨reducedV, hreduced, hleftReducedEq⟩ := hleftReduced + apply RecM.WF.bind <| + RecM.isDefEqCall_wf hreducedSupport hpair.rightSupport + hreduced hright + intro answer afterEq hanswer + exact RecM.WF.pure fun _ htrue => + hleftReducedEq.trans world.venvWF hDelta <| + (hanswer htrue).trans world.venvWF hDelta hrightEq.symm + | none => + apply RecM.WF.bind + (RecM.WF.withInv <| + hnat hpair.rightSupport hright) + intro rightResult afterRight hrightResult + rcases hrightResult with ⟨hIRight, hrightResult⟩ + cases rightResult with + | some reducedRight => + rcases hrightResult with ⟨hreducedSupport, hreducedMeaning⟩ + have hrightReduced := WhnfPost.transMeaning theory hDelta + ⟨rightV, hright, hrightEq⟩ hreducedMeaning + obtain ⟨reducedV, hreduced, hrightReducedEq⟩ := hrightReduced + apply RecM.WF.bind <| + RecM.isDefEqCall_wf hpair.leftSupport hreducedSupport + hleft hreduced + intro answer afterEq hanswer + exact RecM.WF.pure fun _ htrue => + hleftEq.trans world.venvWF hDelta <| + (hanswer htrue).trans world.venvWF hDelta + hrightReducedEq.symm + | none => + exact hafter hpair + +namespace DefEqLazyDeltaAfterOffsetMiss + +/-- Package the Nat prefix as the complete post-offset-miss contract. -/ +theorem ofNat + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hnat : OptionalReduction.WFAt .noAccel semantics trProj world support + uvars tryReduceNat) + (hafter : DefEqLazyDeltaAfterNatMiss.WFAt .noAccel semantics trProj + world support uvars) : + DefEqLazyDeltaAfterOffsetMiss.WFAt .noAccel semantics trProj world + support uvars := by + intro Delta state leftSource rightSource pair hpair + rcases pair with ⟨left, right⟩ + intro methods hmethods hI + exact (defEqLazyDeltaStepAfterOffsetMiss_wf theory hnat hafter + hI.2.1.wf hpair) methods hmethods hI + +end DefEqLazyDeltaAfterOffsetMiss + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/OneSidedDelta.lean b/Ix/Tc/Verify/DefEq/OneSidedDelta.lean new file mode 100644 index 000000000..b6c5c8509 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/OneSidedDelta.lean @@ -0,0 +1,119 @@ +import Ix.Tc.Verify.DefEq.LoopFinish + +/-! +# One-sided lazy-delta unfolding + +Both a lone reducible head and an unequal-rank pair use the same operation: +unfold one operand, normalize that result without delta, and run the common +finishing checks. This module gives those shared production helpers their +complete pair-invariant contracts. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Semantic resources shared by one- and two-sided lazy-delta reductions. -/ +structure LazyDeltaReductionContext + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop where + theory : WhnfTheory trProj world uvars + collision : support.CollisionFree + sorts : SortComponentResources support + structural : QuickDefEqResources support + delta : OptionalReduction.WFAt layer semantics trProj world support uvars + deltaUnfoldOne + normalize : DefEqReduction.WFAt layer semantics trProj world support uvars + whnfNoDeltaForDefEq + +/-- The left-only production helper preserves the lazy-delta action +contract, including the exact unfold-miss stopped result. -/ +theorem defEqLazyDeltaStepWithLeftDelta_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + (context : LazyDeltaReductionContext layer semantics trProj world support + uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepWithLeftDelta left right) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + unfold defEqLazyDeltaStepWithLeftDelta + apply RecM.WF.bind + (RecM.WF.withInv <| + context.delta hpair.leftSupport hleft) + intro unfolded afterUnfold hunfolded + rcases hunfolded with ⟨hIUnfold, hunfolded⟩ + cases unfolded with + | none => + exact RecM.WF.pure fun _ => hpair + | some unfoldedLeft => + rcases hunfolded with ⟨hunfoldedSupport, hunfoldedMeaning⟩ + have hunfoldedPost := WhnfPost.transMeaning context.theory hDelta + hpair.left hunfoldedMeaning + obtain ⟨unfoldedV, hunfoldedTr, hunfoldedEq⟩ := hunfoldedPost + apply RecM.WF.bind + (RecM.WF.withInv <| + context.normalize hunfoldedSupport hunfoldedTr) + intro reduced afterNormalize hreduced + rcases hreduced with ⟨hINormalize, hreducedSupport, hreducedPost⟩ + have hleftReduced := WhnfPost.transMeaning context.theory hDelta + ⟨unfoldedV, hunfoldedTr, hunfoldedEq⟩ + (WhnfPost.meaning hunfoldedTr hreducedPost) + exact finishDefEqLazyDeltaStep_wf context.theory context.collision + context.sorts context.structural + ⟨hreducedSupport, hpair.rightSupport, hleftReduced, hpair.right⟩ + +/-- Symmetric proof for the right-only production helper. -/ +theorem defEqLazyDeltaStepWithRightDelta_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + (context : LazyDeltaReductionContext layer semantics trProj world support + uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepWithRightDelta left right) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) := by + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold defEqLazyDeltaStepWithRightDelta + apply RecM.WF.bind + (RecM.WF.withInv <| + context.delta hpair.rightSupport hright) + intro unfolded afterUnfold hunfolded + rcases hunfolded with ⟨hIUnfold, hunfolded⟩ + cases unfolded with + | none => + exact RecM.WF.pure fun _ => hpair + | some unfoldedRight => + rcases hunfolded with ⟨hunfoldedSupport, hunfoldedMeaning⟩ + have hunfoldedPost := WhnfPost.transMeaning context.theory hDelta + hpair.right hunfoldedMeaning + obtain ⟨unfoldedV, hunfoldedTr, hunfoldedEq⟩ := hunfoldedPost + apply RecM.WF.bind + (RecM.WF.withInv <| + context.normalize hunfoldedSupport hunfoldedTr) + intro reduced afterNormalize hreduced + rcases hreduced with ⟨hINormalize, hreducedSupport, hreducedPost⟩ + have hrightReduced := WhnfPost.transMeaning context.theory hDelta + ⟨unfoldedV, hunfoldedTr, hunfoldedEq⟩ + (WhnfPost.meaning hunfoldedTr hreducedPost) + exact finishDefEqLazyDeltaStep_wf context.theory context.collision + context.sorts context.structural + ⟨hpair.leftSupport, hreducedSupport, hpair.left, hrightReduced⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/ProjectionDeltaActive.lean b/Ix/Tc/Verify/DefEq/ProjectionDeltaActive.lean new file mode 100644 index 000000000..761d03ecb --- /dev/null +++ b/Ix/Tc/Verify/DefEq/ProjectionDeltaActive.lean @@ -0,0 +1,136 @@ +import Ix.Tc.Verify.DefEq.ProjectionDeltaRank + +/-! +# Active projection-delta branches + +This module closes the compact delta step after at least one head has been +classified as reducible. It covers both asymmetric projection probes and +all four flag combinations, then assembles the classifier prefix with rank, +unfold, normalization, and finishing proofs into the exact lower-step +contract used by the bounded projection driver. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Exhaustive active-flag proof for the compact projection-directed delta +step. -/ +theorem lazyDeltaReductionStepAfterActive_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + {leftHead rightHead : Option (KId .anon)} + {leftDelta rightDelta : Bool} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hprojection : OptionalReduction.WFAt layer semantics trProj world + support uvars tryUnfoldProjApp) + (hsame : TrySameHeadSpine.WFAt layer semantics trProj world support + uvars) + (context : ProjectionDeltaReductionContext layer semantics trProj world + support uvars) + (hactive : (!leftDelta && !rightDelta) = false) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (lazyDeltaReductionStepAfterActive left right leftHead rightHead + leftDelta rightDelta) + (fun result _ => LazyDeltaReductionStepPost trProj world support uvars + Delta leftSource rightSource result) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold lazyDeltaReductionStepAfterActive + cases leftDelta <;> cases rightDelta + case false.false => + simp at hactive + case false.true => + simp only [Bool.false_and, Bool.false_eq_true, if_false, + Bool.not_false, Bool.true_and, if_true] + apply RecM.WF.bind (RecM.WF.withInv <| + hprojection hpair.leftSupport hleft) + intro reduced afterProjection hreduced + rcases hreduced with ⟨hIProjection, hreduced⟩ + cases reduced with + | none => + exact lazyDeltaReductionStepWithRightDelta_wf context hDelta hpair + | some reducedLeft => + rcases hreduced with ⟨hreducedSupport, hreducedMeaning⟩ + have hleftReduced := WhnfPost.transMeaning context.finish.theory + hDelta hpair.left hreducedMeaning + exact finishLazyDeltaReductionStep_wf context.finish + ⟨hreducedSupport, hpair.rightSupport, hleftReduced, hpair.right⟩ + case true.false => + simp only [Bool.not_false, Bool.true_and, if_true] + apply RecM.WF.bind (RecM.WF.withInv <| + hprojection hpair.rightSupport hright) + intro reduced afterProjection hreduced + rcases hreduced with ⟨hIProjection, hreduced⟩ + cases reduced with + | none => + exact lazyDeltaReductionStepWithLeftDelta_wf context hDelta hpair + | some reducedRight => + rcases hreduced with ⟨hreducedSupport, hreducedMeaning⟩ + have hrightReduced := WhnfPost.transMeaning context.finish.theory + hDelta hpair.right hreducedMeaning + exact finishLazyDeltaReductionStep_wf context.finish + ⟨hpair.leftSupport, hreducedSupport, hpair.left, hrightReduced⟩ + case true.true => + simp only [Bool.not_true, Bool.and_false, Bool.false_eq_true, if_false] + exact lazyDeltaReductionStepWithBothDelta_wf hfault hsame context + hDelta hpair + +namespace LazyDeltaReductionAfterActive + +/-- Package the concrete active branches under the installed no-acceleration +lazy-ingress contract. -/ +theorem ofResources + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (ingress : AnonLazyIngressContext .noAccel semantics trProj world + support) + (hprojection : OptionalReduction.WFAt .noAccel semantics trProj world + support uvars tryUnfoldProjApp) + (hsame : TrySameHeadSpine.WFAt .noAccel semantics trProj world support + uvars) + (context : ProjectionDeltaReductionContext .noAccel semantics trProj + world support uvars) : + LazyDeltaReductionAfterActive.WFAt .noAccel semantics trProj world + support uvars := by + intro Delta state leftSource rightSource left right leftHead rightHead + leftDelta rightDelta hactive hpair + intro methods hmethods hI + exact (lazyDeltaReductionStepAfterActive_wf ingress.preserves hprojection + hsame context hactive hI.2.1.wf hpair) methods hmethods hI + +end LazyDeltaReductionAfterActive + +namespace LazyDeltaReductionStep + +/-- Complete production contract for one compact projection-delta step. -/ +theorem ofResources + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (ingress : AnonLazyIngressContext .noAccel semantics trProj world + support) + (hprojection : OptionalReduction.WFAt .noAccel semantics trProj world + support uvars tryUnfoldProjApp) + (hsame : TrySameHeadSpine.WFAt .noAccel semantics trProj world support + uvars) + (context : ProjectionDeltaReductionContext .noAccel semantics trProj + world support uvars) : + LazyDeltaReductionStep.WFAt .noAccel semantics trProj world support + uvars := + LazyDeltaReductionStep.ofActive ingress + (LazyDeltaReductionAfterActive.ofResources ingress hprojection hsame + context) + +end LazyDeltaReductionStep + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/ProjectionDeltaClosure.lean b/Ix/Tc/Verify/DefEq/ProjectionDeltaClosure.lean new file mode 100644 index 000000000..35d6e2d1c --- /dev/null +++ b/Ix/Tc/Verify/DefEq/ProjectionDeltaClosure.lean @@ -0,0 +1,124 @@ +import Ix.Tc.Verify.DefEq.ProjectionDeltaActive +import Ix.Tc.Verify.DefEq.ProjectionProbe + +/-! +# Projection-directed delta closure + +The branch proofs for the compact projection loop are deliberately split by +production control-flow seam. This module is their resource-level assembly: +it constructs the one-step contract, the direct projection contract, and the +bounded loop from concrete lower reducers and finite support facts. + +In particular, structural congruence no longer needs a free semantic contract +for `lazyDeltaProjReduction`. The only projection-specific semantic boundary +left here is `DirectProjectionReflection`, indexed by the exact successful +execution of `tryProjReduce`. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Concrete inputs needed by the complete no-acceleration projection-delta +loop. Every executable helper is named explicitly; no field assumes the +outer loop or its step is already sound. -/ +structure ProjectionDeltaClosureResources + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) where + theory : WhnfTheory trProj world uvars + ingress : AnonLazyIngressContext .noAccel semantics trProj world support + collision : support.CollisionFree + sorts : SortComponentResources support + quick : QuickDefEqResources support + sameHeadSpines : SameHeadSpineResources support + values : ProjectionValueResources support + projectionWhnf : DefEqReduction.WFAt .noAccel semantics trProj world + support uvars whnfNoDelta + delta : OptionalReduction.WFAt .noAccel semantics trProj world support + uvars deltaUnfoldOne + core : DefEqReduction.WFAt .noAccel semantics trProj world support uvars + whnfCore + directProjection : DirectProjectionReductionResources semantics trProj + world support + +namespace ProjectionDeltaClosureResources + +/-- The shared productive finish, projected from the complete resource +record. -/ +def finish + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (resources : ProjectionDeltaClosureResources semantics trProj world + support uvars) : + ProjectionDeltaFinishResources trProj world support uvars where + theory := resources.theory + collision := resources.collision + sorts := resources.sorts + structural := resources.quick + +/-- The unfold-and-normalize context shared by one- and two-sided branches. -/ +def reduction + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (resources : ProjectionDeltaClosureResources semantics trProj world + support uvars) : + ProjectionDeltaReductionContext .noAccel semantics trProj world support + uvars where + finish := resources.finish + delta := resources.delta + normalize := resources.core + +/-- Assemble every compact-step branch and the direct projection reducer into +the exact lower-resource record consumed by the bounded driver. -/ +theorem loop + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (resources : ProjectionDeltaClosureResources semantics trProj world + support uvars) : + ProjectionDeltaLoopResources .noAccel semantics trProj world support + uvars where + values := resources.values + step := LazyDeltaReductionStep.ofResources resources.ingress + (tryUnfoldProjApp_wf resources.projectionWhnf) + (TrySameHeadSpine.ofResources resources.theory resources.collision + resources.sameHeadSpines) + resources.reduction + projection := TryProjReduce.ofDirectResources resources.directProjection + +end ProjectionDeltaClosureResources + +namespace LazyDeltaProjReduction + +/-- Construct the bounded projection-directed comparison from concrete lower +resources, without assuming the outer helper's semantic contract. -/ +theorem ofClosureResources + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (resources : ProjectionDeltaClosureResources semantics trProj world + support uvars) : + LazyDeltaProjReduction.WFAt .noAccel semantics trProj world support + uvars := + LazyDeltaProjReduction.ofResources resources.theory resources.loop + +end LazyDeltaProjReduction + +namespace TryStructuralCongruence + +/-- Structural congruence with its matching-projection branch discharged by +the concrete projection-delta closure. -/ +theorem ofProjectionDeltaResources + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (resources : ProjectionDeltaClosureResources semantics trProj world + support uvars) + (structural : StructuralCongruenceResources support) : + TryStructuralCongruence.WFAt .noAccel semantics trProj world support + uvars := + TryStructuralCongruence.ofResources resources.theory resources.collision + structural (LazyDeltaProjReduction.ofClosureResources resources) + +end TryStructuralCongruence + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/ProjectionDeltaEqualRank.lean b/Ix/Tc/Verify/DefEq/ProjectionDeltaEqualRank.lean new file mode 100644 index 000000000..3b3a13c85 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/ProjectionDeltaEqualRank.lean @@ -0,0 +1,163 @@ +import Ix.Tc.Verify.DefEq.EqualRankCache +import Ix.Tc.Verify.DefEq.ProjectionDeltaUnfolding + +/-! +# Equal-rank projection-delta reduction + +At equal reducibility rank the compact projection loop first attempts raw +same-head spine congruence, then unfolds both operands and structurally +normalizes every successful unfold. The rejection-only cache used by the +main DefEq iteration is intentionally absent here; this proof follows the +actual compact helper. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Complete two-sided unfold tail after the compact same-head attempt does +not prove equality. -/ +theorem lazyDeltaReductionStepAfterSameHeadMiss_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + (context : ProjectionDeltaReductionContext layer semantics trProj world + support uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (lazyDeltaReductionStepAfterSameHeadMiss left right) + (fun result _ => LazyDeltaReductionStepPost trProj world support uvars + Delta leftSource rightSource result) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold lazyDeltaReductionStepAfterSameHeadMiss + apply RecM.WF.bind (RecM.WF.withInv <| + context.delta hpair.leftSupport hleft) + intro leftResult afterLeft hleftResult + rcases hleftResult with ⟨hILeft, hleftResult⟩ + apply RecM.WF.bind (RecM.WF.withInv <| + context.delta hpair.rightSupport hright) + intro rightResult afterRight hrightResult + rcases hrightResult with ⟨hIRight, hrightResult⟩ + cases leftResult with + | none => + cases rightResult with + | none => exact RecM.WF.pure fun _ => hpair + | some unfoldedRight => + rcases hrightResult with + ⟨hunfoldedSupport, hunfoldedMeaning⟩ + have hunfoldedPost := WhnfPost.transMeaning + context.finish.theory hDelta hpair.right hunfoldedMeaning + obtain ⟨unfoldedV, hunfoldedTr, unfoldedEq⟩ := hunfoldedPost + apply RecM.WF.bind (RecM.WF.withInv <| + context.normalize hunfoldedSupport hunfoldedTr) + intro reduced afterNormalize hreduced + rcases hreduced with + ⟨hINormalize, hreducedSupport, hreducedPost⟩ + have hrightReduced := WhnfPost.transMeaning + context.finish.theory hDelta + ⟨unfoldedV, hunfoldedTr, unfoldedEq⟩ + (WhnfPost.meaning hunfoldedTr hreducedPost) + exact finishLazyDeltaReductionStep_wf context.finish + ⟨hpair.leftSupport, hreducedSupport, hpair.left, hrightReduced⟩ + | some unfoldedLeft => + rcases hleftResult with ⟨hleftSupport, hleftMeaning⟩ + have hleftUnfolded := WhnfPost.transMeaning context.finish.theory + hDelta hpair.left hleftMeaning + obtain ⟨leftUnfoldedV, hleftUnfoldedTr, hleftUnfoldedEq⟩ := + hleftUnfolded + cases rightResult with + | none => + apply RecM.WF.bind (RecM.WF.withInv <| + context.normalize hleftSupport hleftUnfoldedTr) + intro reduced afterNormalize hreduced + rcases hreduced with + ⟨hINormalize, hreducedSupport, hreducedPost⟩ + have hleftReduced := WhnfPost.transMeaning context.finish.theory + hDelta ⟨leftUnfoldedV, hleftUnfoldedTr, hleftUnfoldedEq⟩ + (WhnfPost.meaning hleftUnfoldedTr hreducedPost) + exact finishLazyDeltaReductionStep_wf context.finish + ⟨hreducedSupport, hpair.rightSupport, hleftReduced, hpair.right⟩ + | some unfoldedRight => + rcases hrightResult with ⟨hrightSupport, hrightMeaning⟩ + have hrightUnfolded := WhnfPost.transMeaning context.finish.theory + hDelta hpair.right hrightMeaning + obtain ⟨rightUnfoldedV, hrightUnfoldedTr, hrightUnfoldedEq⟩ := + hrightUnfolded + apply RecM.WF.bind (RecM.WF.withInv <| + context.normalize hleftSupport hleftUnfoldedTr) + intro reducedLeft afterNormalizeLeft hreducedLeft + rcases hreducedLeft with + ⟨hINormalizeLeft, hreducedLeftSupport, hreducedLeftPost⟩ + have hleftReduced := WhnfPost.transMeaning context.finish.theory + hDelta ⟨leftUnfoldedV, hleftUnfoldedTr, hleftUnfoldedEq⟩ + (WhnfPost.meaning hleftUnfoldedTr hreducedLeftPost) + apply RecM.WF.bind (RecM.WF.withInv <| + context.normalize hrightSupport hrightUnfoldedTr) + intro reducedRight afterNormalizeRight hreducedRight + rcases hreducedRight with + ⟨hINormalizeRight, hreducedRightSupport, hreducedRightPost⟩ + have hrightReduced := WhnfPost.transMeaning context.finish.theory + hDelta ⟨rightUnfoldedV, hrightUnfoldedTr, hrightUnfoldedEq⟩ + (WhnfPost.meaning hrightUnfoldedTr hreducedRightPost) + exact finishLazyDeltaReductionStep_wf context.finish + ⟨hreducedLeftSupport, hreducedRightSupport, hleftReduced, + hrightReduced⟩ + +/-- Complete equal-rank compact branch, including the regular-hint lookup, +every raw same-head result, and the two-sided reduction tail. -/ +theorem lazyDeltaReductionStepWithEqualRank_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + {leftId rightId : KId .anon} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hsame : TrySameHeadSpine.WFAt layer semantics trProj world support + uvars) + (context : ProjectionDeltaReductionContext layer semantics trProj world + support uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (lazyDeltaReductionStepWithEqualRank left right leftId rightId) + (fun result _ => LazyDeltaReductionStepPost trProj world support uvars + Delta leftSource rightSource result) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold lazyDeltaReductionStepWithEqualRank + apply RecM.WF.bind (isRegular_wf hfault leftId) + intro regular afterRegular _ + cases hguard : (leftId.addr == rightId.addr && regular) with + | false => + simp only [Bool.false_eq_true, if_false] + exact lazyDeltaReductionStepAfterSameHeadMiss_wf context hDelta hpair + | true => + simp only [if_true] + apply RecM.WF.bind <| + hsame hpair.leftSupport hpair.rightSupport hleft hright + intro result afterSame hresult + cases result with + | none => + exact lazyDeltaReductionStepAfterSameHeadMiss_wf context hDelta + hpair + | some answer => + cases answer with + | false => + exact lazyDeltaReductionStepAfterSameHeadMiss_wf context + hDelta hpair + | true => + exact RecM.WF.pure fun _ => + hleftEq.trans world.venvWF hDelta <| + (hresult rfl).trans world.venvWF hDelta hrightEq.symm + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/ProjectionDeltaFinish.lean b/Ix/Tc/Verify/DefEq/ProjectionDeltaFinish.lean new file mode 100644 index 000000000..7dfe06a60 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/ProjectionDeltaFinish.lean @@ -0,0 +1,67 @@ +import Ix.Tc.Verify.DefEq.ProjectionDeltaStep + +/-! +# Finishing a productive projection-directed delta step + +After projection probing or delta unfolding changes a pair, the compact +projection loop performs its address and quick-structural checks and either +reports equality or schedules the transformed pair for another bounded +iteration. This module proves that shared finish once. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Semantic resources used only by the final address/quick comparison. -/ +structure ProjectionDeltaFinishResources (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop where + theory : WhnfTheory trProj world uvars + collision : support.CollisionFree + sorts : SortComponentResources support + structural : QuickDefEqResources support + +/-- The productive-pair finish either proves the original operands equal or +returns the unchanged transformed pair with its invariant. -/ +theorem finishLazyDeltaReductionStep_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + (resources : ProjectionDeltaFinishResources trProj world support uvars) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (finishLazyDeltaReductionStep left right) + (fun result _ => LazyDeltaReductionStepPost trProj world support uvars + Delta leftSource rightSource result) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold finishLazyDeltaReductionStep + apply RecM.WF.bind <| + quickDefEq_wf resources.theory resources.collision resources.sorts + resources.structural hpair.leftSupport hpair.rightSupport hleft hright + intro accepted afterQuick haccepted + cases hresult : (left.addr == right.addr || accepted) with + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => hpair + | true => + simp only [if_true] + exact RecM.WF.pure fun hI => by + have hcurrent : world.venv.IsDefEqU uvars Delta.toCtx leftV rightV := by + rcases Bool.or_eq_true_iff.mp hresult with haddr | hquick + · exact DefEqMeaning.of_translations resources.theory hI.2.1.wf + hleft hright + (DefEqMeaning.of_addr_beq resources.theory hI.2.1 + resources.collision hpair.leftSupport hpair.rightSupport + hleft haddr) rfl + · exact haccepted hquick + exact hleftEq.trans world.venvWF hI.2.1.wf <| + hcurrent.trans world.venvWF hI.2.1.wf hrightEq.symm + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/ProjectionDeltaLoop.lean b/Ix/Tc/Verify/DefEq/ProjectionDeltaLoop.lean new file mode 100644 index 000000000..ffb3e4f96 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/ProjectionDeltaLoop.lean @@ -0,0 +1,231 @@ +import Ix.Tc.Verify.DefEq.StructuralCongruence + +/-! +# Projection-directed lazy-delta loop + +The structural projection branch runs a second bounded lazy-delta loop over +the two projected values. A delta step may prove the values equal, expose a +new pair, or stop and try the projection reducer on both sides before one +final recursive comparison. This module proves the bounded driver from +exact contracts for those two lower helpers. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- A supported projection node exposes its value to the projection-directed +loop. -/ +structure ProjectionValueResources (support : RunSupport) : Prop where + value : ∀ {id : KId .anon} {field : UInt64} {source : KExpr .anon} + {info : ExprInfo .anon}, + support (.prj id field source info) → support source + +namespace RecM + +/-- Semantic interpretation of one `lazyDeltaReductionStep` result. -/ +def LazyDeltaReductionStepPost (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) (Delta : KVLCtx) + (leftSource rightSource : VExpr) + (result : LazyDeltaStep × KExpr .anon × KExpr .anon) : Prop := + match result.1 with + | .equal => + world.venv.IsDefEqU uvars Delta.toCtx leftSource rightSource + | .continue' | .unknown => + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (result.2.1, result.2.2) + +/-- Exact one-step contract for the projection-directed legacy delta +machine. This lower helper remains executable and branch-specific. -/ +def LazyDeltaReductionStep.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftSource rightSource left right}, + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right) → + RecM.WF layer semantics trProj world support uvars Delta state + (lazyDeltaReductionStep left right) + (fun result _ => LazyDeltaReductionStepPost trProj world support uvars + Delta leftSource rightSource result) + +/-- Exact semantic contract for a direct projection-reducer attempt. On a +hit, the returned raw expression is a sound reduction of the supplied Theory +projection. A miss carries no semantic claim. -/ +def TryProjReduce.WFAt (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ {Delta state id field source sourceV structName projectedV}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + world.nameOf id.addr = some structName → + trProj Delta.toCtx structName field.toNat sourceV projectedV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryProjReduce id field source) + (fun result _ => match result with + | none => True + | some reduced => support reduced ∧ + WhnfPost trProj world uvars Delta projectedV reduced) + +/-- Lower helper contracts and finite child coverage for the complete +projection-directed loop. -/ +structure ProjectionDeltaLoopResources (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop where + values : ProjectionValueResources support + step : LazyDeltaReductionStep.WFAt layer semantics trProj world support + uvars + projection : TryProjReduce.WFAt layer semantics trProj world support uvars + +/-- Complete bounded execution proof for `lazyDeltaProjReduction`. -/ +theorem lazyDeltaProjReduction_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {id : KId .anon} {field : UInt64} {left right : KExpr .anon} + {leftInfo rightInfo : ExprInfo .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (resources : ProjectionDeltaLoopResources layer semantics trProj world + support uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hleftSupport : support (.prj id field left leftInfo)) + (hrightSupport : support (.prj id field right rightInfo)) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta + (.prj id field left leftInfo) leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta + (.prj id field right rightInfo) rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (lazyDeltaProjReduction id field left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + cases hleft with + | prj hname hleftValue hleftProjection => + cases hright with + | prj hrightName hrightValue hrightProjection => + rename_i structName leftValueV rightStructName rightValueV + have hstructName : structName = rightStructName := + Option.some.inj (hname.symm.trans hrightName) + subst rightStructName + have hinitial : DefEqPairInvariant trProj world support uvars Delta + leftValueV rightValueV (left, right) := + DefEqPairInvariant.refl theory hDelta + (resources.values.value hleftSupport) + (resources.values.value hrightSupport) hleftValue hrightValue + unfold lazyDeltaProjReduction + apply runBounded_wf + (P := fun pair => DefEqPairInvariant trProj world support uvars Delta + leftValueV rightValueV pair) + (Q := fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + · intro pair current hpair + rcases pair with ⟨currentLeft, currentRight⟩ + apply RecM.WF.bind (resources.step hpair) + intro stepResult afterStep hstep + rcases stepResult with ⟨outcome, nextLeft, nextRight⟩ + cases outcome with + | equal => + exact RecM.WF.pure fun _ _ => + theory.projections.uniq + (KVLCtx.IsDefEq.refl world.venvWF.ordered hDelta).defeqCtx + hleftProjection hrightProjection hstep + | continue' => + exact RecM.WF.pure fun _ => hstep + | unknown => + obtain ⟨nextLeftV, hnextLeft, hleftNext⟩ := hstep.left + obtain ⟨nextRightV, hnextRight, hrightNext⟩ := hstep.right + have hctx := + (KVLCtx.IsDefEq.refl world.venvWF.ordered hDelta).defeqCtx + obtain ⟨nextLeftProjectionV, hnextLeftProjection⟩ := + theory.projections.defeqDFC hctx hleftNext hleftProjection + obtain ⟨nextRightProjectionV, hnextRightProjection⟩ := + theory.projections.defeqDFC hctx hrightNext hrightProjection + have hleftProjectionEq := theory.projections.uniq hctx + hleftProjection hnextLeftProjection hleftNext + have hrightProjectionEq := theory.projections.uniq hctx + hrightProjection hnextRightProjection hrightNext + apply RecM.WF.bind (RecM.WF.withInv <| + resources.projection hstep.leftSupport hnextLeft hname + hnextLeftProjection) + intro leftReduced afterLeftReduced hleftReduced + rcases hleftReduced with ⟨hILeftReduced, hleftReduced⟩ + apply RecM.WF.bind (RecM.WF.withInv <| + resources.projection hstep.rightSupport hnextRight hname + hnextRightProjection) + intro rightReduced afterRightReduced hrightReduced + rcases hrightReduced with ⟨hIRightReduced, hrightReduced⟩ + cases leftReduced with + | none => + apply RecM.WF.bind (RecM.WF.withInv <| + RecM.isDefEqCall_wf hstep.leftSupport hstep.rightSupport + hnextLeft hnextRight) + intro answer final hanswer + rcases hanswer with ⟨hI, hanswer⟩ + exact RecM.WF.pure fun _ htrue => + theory.projections.uniq + (KVLCtx.IsDefEq.refl world.venvWF.ordered + hI.2.1.wf).defeqCtx + hleftProjection hrightProjection <| + hleftNext.trans world.venvWF hI.2.1.wf <| + (hanswer htrue).trans world.venvWF hI.2.1.wf + hrightNext.symm + | some reducedLeft => + cases rightReduced with + | none => + apply RecM.WF.bind (RecM.WF.withInv <| + RecM.isDefEqCall_wf hstep.leftSupport + hstep.rightSupport hnextLeft hnextRight) + intro answer final hanswer + rcases hanswer with ⟨hI, hanswer⟩ + exact RecM.WF.pure fun _ htrue => + theory.projections.uniq + (KVLCtx.IsDefEq.refl world.venvWF.ordered + hI.2.1.wf).defeqCtx + hleftProjection hrightProjection <| + hleftNext.trans world.venvWF hI.2.1.wf <| + (hanswer htrue).trans world.venvWF hI.2.1.wf + hrightNext.symm + | some reducedRight => + rcases hleftReduced with + ⟨hleftReducedSupport, reducedLeftV, hleftReducedTr, + hleftReducedEq⟩ + rcases hrightReduced with + ⟨hrightReducedSupport, reducedRightV, hrightReducedTr, + hrightReducedEq⟩ + apply RecM.WF.bind (RecM.WF.withInv <| + RecM.isDefEqCall_wf hleftReducedSupport + hrightReducedSupport hleftReducedTr hrightReducedTr) + intro answer final hanswer + rcases hanswer with ⟨hI, hanswer⟩ + exact RecM.WF.pure fun _ htrue => + hleftProjectionEq.trans world.venvWF hI.2.1.wf <| + hleftReducedEq.trans world.venvWF hI.2.1.wf <| + (hanswer htrue).trans world.venvWF hI.2.1.wf <| + hrightReducedEq.symm.trans world.venvWF + hI.2.1.wf hrightProjectionEq.symm + · intro _ _ + trivial + · exact hinitial + +namespace LazyDeltaProjReduction + +/-- Construct the exact structural-congruence projection contract from the +bounded loop's lower helper contracts. -/ +theorem ofResources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (resources : ProjectionDeltaLoopResources layer semantics trProj world + support uvars) : + LazyDeltaProjReduction.WFAt layer semantics trProj world support + uvars := by + intro Delta state id field left right leftInfo rightInfo leftV rightV + hleftSupport hrightSupport hleft hright + intro methods hmethods hI + exact (lazyDeltaProjReduction_wf theory resources hI.2.1.wf + hleftSupport hrightSupport hleft hright) methods hmethods hI + +end LazyDeltaProjReduction + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/ProjectionDeltaRank.lean b/Ix/Tc/Verify/DefEq/ProjectionDeltaRank.lean new file mode 100644 index 000000000..f36da90b9 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/ProjectionDeltaRank.lean @@ -0,0 +1,71 @@ +import Ix.Tc.Verify.DefEq.ProjectionDeltaEqualRank + +/-! +# Projection-delta rank dispatch + +When both compact-loop operands are delta-reducible, production reads their +reducibility ranks and selects a left-only, right-only, or equal-rank helper. +Rank values carry no semantic authority: every selected helper is proved +sound independently. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- A direct reducibility-rank lookup preserves the recursive invariant +through every declaration shape and lazy-ingress outcome. -/ +theorem defRankId_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (id : KId .anon) : + RecM.WF layer semantics trProj world support uvars Delta state + (defRankId id) (fun _ _ => True) := by + simpa only [rankDeltaHead] using + (rankDeltaHead_wf (state := state) hfault (some id)) + +/-- Exhaustive rank dispatch for the compact projection-delta step. -/ +theorem lazyDeltaReductionStepWithBothDelta_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + {leftHead rightHead : Option (KId .anon)} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hsame : TrySameHeadSpine.WFAt layer semantics trProj world support + uvars) + (context : ProjectionDeltaReductionContext layer semantics trProj world + support uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (lazyDeltaReductionStepWithBothDelta left right leftHead rightHead) + (fun result _ => LazyDeltaReductionStepPost trProj world support uvars + Delta leftSource rightSource result) := by + unfold lazyDeltaReductionStepWithBothDelta + apply RecM.WF.bind (defRankId_wf hfault leftHead.get!) + intro leftRank afterLeftRank _ + apply RecM.WF.bind (defRankId_wf hfault rightHead.get!) + intro rightRank afterRightRank _ + cases hcompare : compareRank leftRank rightRank with + | lt => + simp + exact lazyDeltaReductionStepWithRightDelta_wf context hDelta hpair + | eq => + simp + exact lazyDeltaReductionStepWithEqualRank_wf hfault hsame context + hDelta hpair + | gt => + simp + exact lazyDeltaReductionStepWithLeftDelta_wf context hDelta hpair + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/ProjectionDeltaStep.lean b/Ix/Tc/Verify/DefEq/ProjectionDeltaStep.lean new file mode 100644 index 000000000..a95be5e66 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/ProjectionDeltaStep.lean @@ -0,0 +1,154 @@ +import Ix.Tc.Verify.DefEq.DeltaClassification +import Ix.Tc.Verify.DefEq.ProjectionReduction + +/-! +# Projection-directed delta step + +The inner projection loop uses a compact legacy delta step distinct from the +main DefEq lazy-delta iteration. Its first two effects are declaration +lookups that classify the operand heads. This module isolates those lookups +from the remaining rank/unfold/reduction branches and proves their complete +success, absence, and partial-error behavior through the installed anonymous +lazy-ingress contract. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Exact continuation contract once at least one projection-step operand is +known to have a delta-reducible head. -/ +def LazyDeltaReductionAfterActive.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftSource rightSource left right aHead bHead + aDelta bDelta}, + (!aDelta && !bDelta) = false → + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right) → + RecM.WF layer semantics trProj world support uvars Delta state + (lazyDeltaReductionStepAfterActive left right + aHead bHead aDelta bDelta) + (fun result _ => LazyDeltaReductionStepPost trProj world support uvars + Delta leftSource rightSource result) + +/-- Exact continuation contract after both projection-step head classifiers +have run. -/ +def LazyDeltaReductionAfterClassification.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftSource rightSource left right aHead bHead + aDelta bDelta}, + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right) → + RecM.WF layer semantics trProj world support uvars Delta state + (lazyDeltaReductionStepAfterClassification left right + aHead bHead aDelta bDelta) + (fun result _ => LazyDeltaReductionStepPost trProj world support uvars + Delta leftSource rightSource result) + +/-- The joint-negative classifier result is exactly the `.unknown` exit and +preserves the current pair invariant. Every active flag combination is +delegated with the concrete guard equation. -/ +theorem lazyDeltaReductionStepAfterClassification_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : Lean4Lean.VExpr} + {left right : KExpr .anon} {aHead bHead : Option (KId .anon)} + {aDelta bDelta : Bool} + (hactive : LazyDeltaReductionAfterActive.WFAt layer semantics trProj + world support uvars) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (lazyDeltaReductionStepAfterClassification left right + aHead bHead aDelta bDelta) + (fun result _ => LazyDeltaReductionStepPost trProj world support uvars + Delta leftSource rightSource result) := by + unfold lazyDeltaReductionStepAfterClassification + cases hnone : (!aDelta && !bDelta) with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ => hpair + | false => + simp only [Bool.false_eq_true, if_false] + exact hactive hnone hpair + +namespace LazyDeltaReductionAfterClassification + +/-- Package the exact inactive/active split as the post-classification +contract. -/ +theorem ofActive + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hactive : LazyDeltaReductionAfterActive.WFAt layer semantics trProj + world support uvars) : + LazyDeltaReductionAfterClassification.WFAt layer semantics trProj world + support uvars := by + intro Delta state leftSource rightSource left right aHead bHead aDelta + bDelta hpair + exact lazyDeltaReductionStepAfterClassification_wf hactive hpair + +end LazyDeltaReductionAfterClassification + +/-- Both production classifier lookups preserve the recursive invariant and +delegate their exact results to the post-classification continuation. -/ +theorem lazyDeltaReductionStep_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : Lean4Lean.VExpr} + {left right : KExpr .anon} + (ingress : AnonLazyIngressContext .noAccel semantics trProj world + support) + (hafter : LazyDeltaReductionAfterClassification.WFAt .noAccel semantics + trProj world support uvars) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF .noAccel semantics trProj world support uvars Delta state + (lazyDeltaReductionStep left right) + (fun result _ => LazyDeltaReductionStepPost trProj world support uvars + Delta leftSource rightSource result) := by + unfold lazyDeltaReductionStep + apply RecM.WF.bind (classifyDeltaHead_wf ingress.preserves left) + intro leftDelta afterLeft _ + apply RecM.WF.bind (classifyDeltaHead_wf ingress.preserves right) + intro rightDelta afterRight _ + exact hafter hpair + +namespace LazyDeltaReductionStep + +/-- Package the concrete head-classification prefix as the lower step +contract consumed by the bounded projection driver. -/ +theorem ofClassification + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (ingress : AnonLazyIngressContext .noAccel semantics trProj world + support) + (hafter : LazyDeltaReductionAfterClassification.WFAt .noAccel semantics + trProj world support uvars) : + LazyDeltaReductionStep.WFAt .noAccel semantics trProj world support + uvars := by + intro Delta state leftSource rightSource left right hpair + exact lazyDeltaReductionStep_wf ingress hafter hpair + +/-- Assemble the classifier prefix and its exact inactive/active split. -/ +theorem ofActive + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (ingress : AnonLazyIngressContext .noAccel semantics trProj world + support) + (hactive : LazyDeltaReductionAfterActive.WFAt .noAccel semantics trProj + world support uvars) : + LazyDeltaReductionStep.WFAt .noAccel semantics trProj world support + uvars := + ofClassification ingress + (LazyDeltaReductionAfterClassification.ofActive hactive) + +end LazyDeltaReductionStep + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/ProjectionDeltaUnfolding.lean b/Ix/Tc/Verify/DefEq/ProjectionDeltaUnfolding.lean new file mode 100644 index 000000000..425ab6fa7 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/ProjectionDeltaUnfolding.lean @@ -0,0 +1,114 @@ +import Ix.Tc.Verify.DefEq.ProjectionDeltaFinish + +/-! +# One-sided projection-delta unfolding + +Unequal-rank and asymmetric projection-miss branches unfold one operand, +run the production structural normalizer, and enter the common productive +finish. The two theorems here cover both directions, including unfold +misses and errors from either helper. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Reduction resources shared by the one- and two-sided compact projection +delta branches. -/ +structure ProjectionDeltaReductionContext + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop where + finish : ProjectionDeltaFinishResources trProj world support uvars + delta : OptionalReduction.WFAt layer semantics trProj world support uvars + deltaUnfoldOne + normalize : DefEqReduction.WFAt layer semantics trProj world support uvars + whnfCore + +/-- The left-only compact delta helper preserves the original pair semantics +on its unfold miss and composes unfold plus structural normalization on a +hit. -/ +theorem lazyDeltaReductionStepWithLeftDelta_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + (context : ProjectionDeltaReductionContext layer semantics trProj world + support uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (lazyDeltaReductionStepWithLeftDelta left right) + (fun result _ => LazyDeltaReductionStepPost trProj world support uvars + Delta leftSource rightSource result) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + unfold lazyDeltaReductionStepWithLeftDelta + apply RecM.WF.bind (RecM.WF.withInv <| + context.delta hpair.leftSupport hleft) + intro unfolded afterUnfold hunfolded + rcases hunfolded with ⟨hIUnfold, hunfolded⟩ + cases unfolded with + | none => + exact RecM.WF.pure fun _ => hpair + | some unfoldedLeft => + rcases hunfolded with ⟨hunfoldedSupport, hunfoldedMeaning⟩ + have hunfoldedPost := WhnfPost.transMeaning context.finish.theory + hDelta hpair.left hunfoldedMeaning + obtain ⟨unfoldedV, hunfoldedTr, unfoldedEq⟩ := hunfoldedPost + apply RecM.WF.bind (RecM.WF.withInv <| + context.normalize hunfoldedSupport hunfoldedTr) + intro reduced afterNormalize hreduced + rcases hreduced with + ⟨hINormalize, hreducedSupport, hreducedPost⟩ + have hleftReduced := WhnfPost.transMeaning context.finish.theory + hDelta ⟨unfoldedV, hunfoldedTr, unfoldedEq⟩ + (WhnfPost.meaning hunfoldedTr hreducedPost) + exact finishLazyDeltaReductionStep_wf context.finish + ⟨hreducedSupport, hpair.rightSupport, hleftReduced, hpair.right⟩ + +/-- Symmetric right-only compact delta helper. -/ +theorem lazyDeltaReductionStepWithRightDelta_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + (context : ProjectionDeltaReductionContext layer semantics trProj world + support uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (lazyDeltaReductionStepWithRightDelta left right) + (fun result _ => LazyDeltaReductionStepPost trProj world support uvars + Delta leftSource rightSource result) := by + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold lazyDeltaReductionStepWithRightDelta + apply RecM.WF.bind (RecM.WF.withInv <| + context.delta hpair.rightSupport hright) + intro unfolded afterUnfold hunfolded + rcases hunfolded with ⟨hIUnfold, hunfolded⟩ + cases unfolded with + | none => + exact RecM.WF.pure fun _ => hpair + | some unfoldedRight => + rcases hunfolded with ⟨hunfoldedSupport, hunfoldedMeaning⟩ + have hunfoldedPost := WhnfPost.transMeaning context.finish.theory + hDelta hpair.right hunfoldedMeaning + obtain ⟨unfoldedV, hunfoldedTr, unfoldedEq⟩ := hunfoldedPost + apply RecM.WF.bind (RecM.WF.withInv <| + context.normalize hunfoldedSupport hunfoldedTr) + intro reduced afterNormalize hreduced + rcases hreduced with + ⟨hINormalize, hreducedSupport, hreducedPost⟩ + have hrightReduced := WhnfPost.transMeaning context.finish.theory + hDelta ⟨unfoldedV, hunfoldedTr, unfoldedEq⟩ + (WhnfPost.meaning hunfoldedTr hreducedPost) + exact finishLazyDeltaReductionStep_wf context.finish + ⟨hpair.leftSupport, hreducedSupport, hpair.left, hrightReduced⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/ProjectionProbe.lean b/Ix/Tc/Verify/DefEq/ProjectionProbe.lean new file mode 100644 index 000000000..5e7944929 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/ProjectionProbe.lean @@ -0,0 +1,151 @@ +import Ix.Tc.Verify.DefEq.DeltaClassification + +/-! +# Lazy-delta projection probe + +When exactly one side is delta-reducible, lazy delta gives a projection-headed +opposite operand one no-delta normalization opportunity before unfolding the +definition. This module proves the helper as an optional reduction and then +closes both asymmetric branches, transporting a successful projection result +into the loop's pair invariant. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Exact remaining one-step contract after the asymmetric projection probe +is skipped or misses. -/ +def DefEqLazyDeltaAfterProjectionMiss.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftSource rightSource left right aHead bHead + aDelta bDelta}, + (!aDelta && !bDelta) = false → + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right) → + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepAfterProjectionMiss left right + aHead bHead aDelta bDelta) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) + +/-- The production projection probe is an optional reduction whenever the +public no-delta reducer has its standard support-and-meaning contract. -/ +theorem tryUnfoldProjApp_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hwhnf : DefEqReduction.WFAt layer semantics trProj world support uvars + whnfNoDelta) : + OptionalReduction.WFAt layer semantics trProj world support uvars + tryUnfoldProjApp := by + intro Delta source sourceV state hsourceSupport hsource + unfold tryUnfoldProjApp + generalize hspine : source.collectSpine = spine + rcases spine with ⟨head, args⟩ + cases head <;> simp only + all_goals try exact RecM.WF.pure fun _ => trivial + case prj => + apply RecM.WF.bind (hwhnf hsourceSupport hsource) + intro reduced afterReduced hreduced + cases haddr : reduced.addr == source.addr with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ => trivial + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => + ⟨hreduced.1, WhnfPost.meaning hsource hreduced.2⟩ + +/-- Close the projection-headed opposite-side probes in both directions. -/ +theorem defEqLazyDeltaStepAfterDeltaClassification_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + {aHead bHead : Option (KId .anon)} {aDelta bDelta : Bool} + (theory : WhnfTheory trProj world uvars) + (hproj : OptionalReduction.WFAt layer semantics trProj world support + uvars tryUnfoldProjApp) + (hafter : DefEqLazyDeltaAfterProjectionMiss.WFAt layer semantics trProj + world support uvars) + (hactive : (!aDelta && !bDelta) = false) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepAfterDeltaClassification left right + aHead bHead aDelta bDelta) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold defEqLazyDeltaStepAfterDeltaClassification + cases aDelta <;> cases bDelta + case false.false => + simp at hactive + case false.true => + simp only [Bool.false_and, Bool.false_eq_true, if_false, + Bool.not_false, Bool.true_and, if_true] + apply RecM.WF.bind + (RecM.WF.withInv <| + hproj hpair.leftSupport hleft) + intro reduced afterReduced hreduced + rcases hreduced with ⟨hI, hreduced⟩ + cases reduced with + | none => + exact hafter (aHead := aHead) (bHead := bHead) hactive hpair + | some reducedLeft => + rcases hreduced with ⟨hreducedSupport, hreducedMeaning⟩ + exact RecM.WF.pure fun _ => + ⟨hreducedSupport, hpair.rightSupport, + WhnfPost.transMeaning theory hDelta hpair.left hreducedMeaning, + hpair.right⟩ + case true.false => + simp only [Bool.not_true, Bool.true_and] + apply RecM.WF.bind + (RecM.WF.withInv <| + hproj hpair.rightSupport hright) + intro reduced afterReduced hreduced + rcases hreduced with ⟨hI, hreduced⟩ + cases reduced with + | none => + exact hafter (aHead := aHead) (bHead := bHead) hactive hpair + | some reducedRight => + rcases hreduced with ⟨hreducedSupport, hreducedMeaning⟩ + exact RecM.WF.pure fun _ => + ⟨hpair.leftSupport, hreducedSupport, hpair.left, + WhnfPost.transMeaning theory hDelta hpair.right hreducedMeaning⟩ + case true.true => + simp only [Bool.not_true, Bool.and_false, Bool.false_eq_true, if_false] + exact hafter (aHead := aHead) (bHead := bHead) hactive hpair + +namespace DefEqLazyDeltaAfterDeltaClassification + +/-- Package projection probing as the complete post-classification +contract. -/ +theorem ofProjection + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hproj : OptionalReduction.WFAt layer semantics trProj world support + uvars tryUnfoldProjApp) + (hafter : DefEqLazyDeltaAfterProjectionMiss.WFAt layer semantics trProj + world support uvars) : + DefEqLazyDeltaAfterDeltaClassification.WFAt layer semantics trProj world + support uvars := by + intro Delta state leftSource rightSource left right aHead bHead aDelta + bDelta hactive hpair + intro methods hmethods hI + exact (defEqLazyDeltaStepAfterDeltaClassification_wf theory hproj hafter + hactive hI.2.1.wf hpair) methods hmethods hI + +end DefEqLazyDeltaAfterDeltaClassification + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/ProjectionReduction.lean b/Ix/Tc/Verify/DefEq/ProjectionReduction.lean new file mode 100644 index 000000000..16b43d3b9 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/ProjectionReduction.lean @@ -0,0 +1,109 @@ +import Ix.Tc.Verify.DefEq.ProjectionDeltaLoop +import Ix.Tc.Verify.Whnf.Projection.NoAccelTail + +/-! +# Direct projection reduction inside DefEq + +The projection-directed DefEq loop invokes `tryProjReduce` on values that +already carry a Theory projection witness. The production helper's +state/support behavior is proved by the no-acceleration WHNF development; +the remaining semantic fact is deliberately indexed by the exact successful +helper execution. It therefore cannot authorize a different projection, +input, result, method table, or pair of states. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Semantic reflection for one successful direct projection-helper run. + +This record has no state authority: both endpoint invariants are premises, +and the result is tied to the exact production execution equation. -/ +structure DirectProjectionReflection (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Prop where + success : ∀ {uvars : Nat} {Delta : KVLCtx} + {methods : Methods .anon} {before after : TcState .anon} + {id : KId .anon} {field : UInt64} {source result : KExpr .anon} + {sourceV projectedV : VExpr} {structName : Lean.Name}, + Methods.WFAt .noAccel semantics trProj world support uvars methods → + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + world.nameOf id.addr = some structName → + trProj Delta.toCtx structName field.toNat sourceV projectedV → + WhnfStateInv .noAccel semantics trProj world support uvars Delta before → + WhnfStateInv .noAccel semantics trProj world support uvars Delta after → + (tryProjReduce id field source).run methods before = + .ok (some result) after → + WhnfPost trProj world uvars Delta projectedV result + +/-- The already-proved helper invariant plus exact semantic reflection are +the complete resources needed by the projection-directed DefEq loop. -/ +structure DirectProjectionReductionResources (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Prop where + helper : ProjectionHelper.WF .noAccel semantics trProj world support + reflection : DirectProjectionReflection semantics trProj world support + +/-- A direct production projection attempt preserves the complete recursive +state invariant on hits, misses, and errors. Only an exact successful hit is +sent to semantic reflection. -/ +theorem tryProjReduce_direct_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {id : KId .anon} {field : UInt64} {source : KExpr .anon} + {sourceV projectedV : VExpr} {structName : Lean.Name} + (resources : DirectProjectionReductionResources semantics trProj world + support) + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hname : world.nameOf id.addr = some structName) + (hprojection : + trProj Delta.toCtx structName field.toNat sourceV projectedV) : + RecM.WF .noAccel semantics trProj world support uvars Delta state + (tryProjReduce id field source) + (fun result _ => match result with + | none => True + | some reduced => support reduced ∧ + WhnfPost trProj world uvars Delta projectedV reduced) := by + intro methods hmethods hI + have hhelper := resources.helper (id := id) (field := field) hmethods + hsourceSupport hI + cases hrun : (tryProjReduce id field source).run methods state with + | error err after => + rw [hrun] at hhelper + exact hhelper + | ok result after => + rw [hrun] at hhelper + cases result with + | none => exact ⟨hhelper.1, trivial⟩ + | some reduced => + exact ⟨hhelper.1, hhelper.2, + resources.reflection.success hmethods hsourceSupport hsource + hname hprojection hI hhelper.1 hrun⟩ + +namespace TryProjReduce + +/-- Construct the exact lower-helper contract consumed by the bounded +projection loop. -/ +theorem ofDirectResources + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (resources : DirectProjectionReductionResources semantics trProj world + support) : + TryProjReduce.WFAt .noAccel semantics trProj world support uvars := by + intro Delta state id field source sourceV structName projectedV + hsourceSupport hsource hname hprojection + exact tryProjReduce_direct_wf resources hsourceSupport hsource hname + hprojection + +end TryProjReduce + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/ProofIrrelevance.lean b/Ix/Tc/Verify/DefEq/ProofIrrelevance.lean new file mode 100644 index 000000000..399b47ab7 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/ProofIrrelevance.lean @@ -0,0 +1,173 @@ +import Ix.Tc.Verify.DefEq.CheapReduction +import Ix.Tc.Verify.Whnf.StructEta.CallbackPrefix + +/-! +# Pre-delta proof irrelevance + +This tier infers both operands under the infer-only policy, establishes that +the first inferred type is a proposition, and compares the two inferred +types recursively. A positive result is justified by Theory proof +irrelevance; caught callback errors remain ordinary misses. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- The Infer spelling used by DefEq is operationally the same scoped +predecessor callback already verified for WHNF helpers. -/ +theorem tryOptionalInferOnlyCall_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryOptional (inferOnlyCall source)) + (fun result _ => match result with + | some ty => support ty ∧ + InferPost trProj world uvars Delta sourceV ty + | none => True) := by + simpa only [inferOnlyCall, inferOnlyRec] using + (tryOptionalInferOnlyRec_wf + (layer := layer) (semantics := semantics) (s := state) + hsourceSupport hsource) + +/-- Semantic contract for the memoized proposition-type classifier. Only a +positive result carries meaning; a negative result remains conservative. -/ +def IsPropType.WFAt (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ {Delta state source sourceV}, + support source → + TrKExpr world.venv uvars world.nameOf trProj Delta source sourceV → + RecM.WF layer semantics trProj world support uvars Delta state + (isPropType source) + (fun answer _ => answer = true → + world.venv.HasType uvars Delta.toCtx sourceV (.sort .zero)) + +/-- The concrete proof-irrelevance probe is sound once the memoized +proposition classifier satisfies its positive-result contract. -/ +theorem tryProofIrrel_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {a b : KExpr .anon} {aV bV : VExpr} + (hisProp : IsPropType.WFAt layer semantics trProj world support uvars) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv uvars world.nameOf trProj Delta a aV) + (hb : TrKExprS world.venv uvars world.nameOf trProj Delta b bV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryProofIrrel a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx aV bV) := by + unfold tryProofIrrel + apply RecM.WF.bind + (tryOptionalInferOnlyCall_wf haSupport ha) + intro aTy afterA haTy + cases aTy with + | none => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | some aTy => + rcases haTy with ⟨haTySupport, aTyV, haTyTr, haType⟩ + simp only + apply RecM.WF.bind (hisProp haTySupport haTyTr) + intro aIsProp afterProp haProp + cases aIsProp with + | false => + simp only [Bool.not_false] + exact RecM.WF.pure fun _ htrue => by contradiction + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + apply RecM.WF.bind + (tryOptionalInferOnlyCall_wf hbSupport hb) + intro bTy afterB hbTy + cases bTy with + | none => + simp only + exact RecM.WF.pure fun _ htrue => by contradiction + | some bTy => + rcases hbTy with ⟨hbTySupport, bTyV, hbTyTr, hbType⟩ + obtain ⟨aTyCoreV, haTyCoreTr, haTyEq⟩ := haTyTr + obtain ⟨bTyCoreV, hbTyCoreTr, hbTyEq⟩ := hbTyTr + simp only + apply RecM.WF.mono + (RecM.WF.withInv <| + isDefEqCall_wf haTySupport hbTySupport + haTyCoreTr hbTyCoreTr) + · intro answer final hpost htrue + have htypes : world.venv.IsDefEqU uvars Delta.toCtx + aTyV bTyV := + haTyEq.symm.trans world.venvWF hpost.1.2.1.wf <| + (hpost.2 htrue).trans world.venvWF hpost.1.2.1.wf + hbTyEq + exact ⟨aTyV, .proofIrrel (haProp rfl) haType + (hbType.defeqU_r world.venvWF hpost.1.2.1.wf + htypes.symm)⟩ + · intro _ _ _ + trivial + +namespace DefEqAfterProofIrrelevance + +/-- Semantic contract for the lazy-delta and final-WHNF tiers. -/ +def WF (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ {Delta state a b aV bV}, + support a → support b → + TrKExprS world.venv uvars world.nameOf trProj Delta a aV → + TrKExprS world.venv uvars world.nameOf trProj Delta b bV → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqInnerAfterProofIrrelevance a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx aV bV) + +/-- Close the pre-delta proof-irrelevance attempt. -/ +theorem closesAfterNoDeltaPass + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hisProp : IsPropType.WFAt layer semantics trProj world support uvars) + (htail : WF layer semantics trProj world support uvars) : + DefEqAfterNoDeltaPass.WF layer semantics trProj world support uvars := by + intro Delta state a b aV bV haSupport hbSupport ha hb + unfold isDefEqInnerAfterNoDeltaPass + apply RecM.WF.bind + (tryProofIrrel_wf hisProp haSupport hbSupport ha hb) + intro accepted after haccepted + cases accepted with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => haccepted rfl + | false => + simp only [Bool.false_eq_true, if_false] + exact htail haSupport hbSupport ha hb + +/-- Compose proof irrelevance with both preceding cheap passes. -/ +theorem closesAfterStringExpansion + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hsorts : SortComponentResources support) + (hstructural : QuickDefEqResources support) + (hreduction : DefEqCheapReductionContext layer semantics trProj world + support uvars) + (hisProp : IsPropType.WFAt layer semantics trProj world support uvars) + (htail : WF layer semantics trProj world support uvars) : + DefEqAfterStringExpansion.WF layer semantics trProj world support + uvars := + DefEqAfterNoDeltaPass.closesAfterStringExpansion theory hcollision hsorts + hstructural hreduction (closesAfterNoDeltaPass hisProp htail) + +end DefEqAfterProofIrrelevance + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/PropositionClassifier.lean b/Ix/Tc/Verify/DefEq/PropositionClassifier.lean new file mode 100644 index 000000000..9cadf8b35 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/PropositionClassifier.lean @@ -0,0 +1,217 @@ +import Ix.Tc.Verify.DefEq.ProofIrrelevance + +/-! +# Memoized proposition classification + +This module verifies the production `isPropType` implementation used by +proof irrelevance. Cache hits are interpreted through the joint K2 suffix +model. Cache misses infer the queried expression, normalize its inferred +type with the direct K1 reducer, and install only a provenance-certified +classification. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Resources needed by the concrete proposition classifier. Direct WHNF +is the already-closed K1 reducer; inference remains a predecessor-table edge +until K2 ties the recursive method-table knot. -/ +structure PropositionClassifierContext + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) where + model : KernelSuffixModel trProj world + collisionFree : support.CollisionFree + theory : WhnfTheory trProj world model.keys.uvars + whnf : DirectWhnf.WFAt (kernelCacheSemantics model.keys trProj) trProj + world support model.keys.uvars + references : forall {source : KExpr .anon} {id : KId .anon}, + support source -> source.References id -> world.trusted id + +namespace PropositionClassifierContext + +/-- The proposition-cache entry depends only on direct constant roots of the +queried expression, all of which are trusted by the run context. -/ +private theorem cacheReferences + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (context : PropositionClassifierContext trProj world support) + {source : KExpr .anon} {ctxAddr : Address} {answer : Bool} + (hsource : support source) : + (CacheEntry.isProp (source.addr, ctxAddr) answer).ReferencesAuthorized + (CacheAuthority.stable world) support := by + intro id href + apply Or.inl + obtain ⟨other, hother, haddr, hreference⟩ := href + have hsame : other = source := by + have herase := context.collisionFree.expr hother hsource haddr + simpa only [KExpr.eraseMeta_anon] using herase + subst other + exact context.references hsource hreference + +end PropositionClassifierContext + +namespace RecM + +/-- If direct WHNF exposes an inferred type as `Sort 0`, transport the +original typing derivation through both the quotient translation and the +reduction equality. -/ +private theorem hasTypeSortZero_of_whnf + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} (hDelta : KVLCtx.WF world.venv uvars Delta) + {sourceV sortCoreV sortV : VExpr} {u : KUniv .anon} + {info : ExprInfo .anon} + (hsourceType : world.venv.HasType uvars Delta.toCtx sourceV sortV) + (hsortEq : world.venv.IsDefEqU uvars Delta.toCtx sortCoreV sortV) + (hwhnf : WhnfPost trProj world uvars Delta sortCoreV (.sort u info)) + (hzero : u.isZero = true) : + world.venv.HasType uvars Delta.toCtx sourceV (.sort .zero) := by + obtain ⟨reducedV, hreduced, hsortReduced⟩ := hwhnf + cases hreduced with + | sort hlevel => + have htype := hsourceType.defeqU_r world.venvWF hDelta <| + hsortEq.symm.trans world.venvWF hDelta hsortReduced + simpa only [KUniv.toVLevel_of_isZero hzero] using htype + +/-- The uncached classifier is conservative on every failure and non-sort +result. Its sole positive case proves that the original concrete query has +Theory type `Sort 0`. -/ +private theorem classifyPropTypeUncached_wf + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (context : PropositionClassifierContext trProj world support) + {Delta : KVLCtx} {state : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv context.model.keys.uvars world.nameOf + trProj Delta source sourceV) : + RecM.WF .noAccel + (kernelCacheSemantics context.model.keys trProj) trProj world support + context.model.keys.uvars Delta state + (classifyPropTypeUncached source) + (fun answer _ => IsPropMeaning trProj world context.model.keys.uvars + Delta source answer) := by + unfold classifyPropTypeUncached + apply RecM.WF.bind + (tryOptionalInferOnlyCall_wf hsourceSupport hsource) + intro inferred afterInfer hinferred + cases inferred with + | none => + simp only + exact RecM.WF.pure fun _ => IsPropMeaning.false + | some sort => + rcases hinferred with + ⟨hsortSupport, sortV, hsortTranslation, hsourceType⟩ + obtain ⟨sortCoreV, hsortCore, hsortEq⟩ := hsortTranslation + simp only + apply RecM.WF.bind + (tryOptional_wf (RecM.WF.withInv <| + context.whnf hsortSupport hsortCore)) + intro reduced afterWhnf hreduced + cases reduced with + | none => + simp only + exact RecM.WF.pure fun _ => IsPropMeaning.false + | some reduced => + rcases hreduced with ⟨hIWhnf, _hreducedSupport, hwhnfPost⟩ + cases reduced with + | sort u info => + simp only + cases hzero : u.isZero with + | false => + exact RecM.WF.pure fun _ => IsPropMeaning.false + | true => + exact RecM.WF.pure fun _ _ => + ⟨sourceV, hsource, + hasTypeSortZero_of_whnf hIWhnf.2.1.wf hsourceType + hsortEq hwhnfPost hzero⟩ + | var | fvar | const | app | lam | all | letE | prj | nat | str => + simp only + exact RecM.WF.pure fun _ => IsPropMeaning.false + +/-- The production memoized proposition classifier satisfies the exact +positive-result contract consumed by proof irrelevance. -/ +theorem isPropType_wf + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (context : PropositionClassifierContext trProj world support) : + IsPropType.WFAt .noAccel + (kernelCacheSemantics context.model.keys trProj) trProj world support + context.model.keys.uvars := by + intro Delta state source sourceV hsourceSupport hsource + obtain ⟨sourceCoreV, hsourceCore, hsourceEq⟩ := hsource + unfold isPropType + apply RecM.WF.bind + (RecM.WF.liftTcM <| TcM.ctxAddrForLbr_model_matches_wf context.model) + intro ctxAddr afterKey hkey + rcases hkey with ⟨hrepresented, _hkeyFrame⟩ + apply RecM.WF.bind + (Q₁ := fun observed after => observed = afterKey ∧ after = afterKey) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed afterRead hread + rcases hread with ⟨hobserved, hafterRead⟩ + subst observed + subst afterRead + let found := afterKey.env.isPropCache[(source.addr, ctxAddr)]? + cases hfound : found with + | some cached => + have hhit : afterKey.env.isPropCache[(source.addr, ctxAddr)]? = + some cached := by + simpa [found] using hfound + simp only [hhit] + exact RecM.WF.pure fun + (hI : WhnfStateInv .noAccel + (kernelCacheSemantics context.model.keys trProj) trProj world + support context.model.keys.uvars Delta afterKey) => by + intro htrue + have hprovenance := hI.1.caches.hit (.isProp hhit) + have hmeaning := hprovenance.kernelIsPropMeaning hsourceSupport rfl + hrepresented + have hcoreType := IsPropMeaning.of_translation context.theory + hI.2.1.wf hsourceCore hmeaning htrue + exact hcoreType.defeqU_l world.venvWF hI.2.1.wf hsourceEq + | none => + have hmiss : afterKey.env.isPropCache[(source.addr, ctxAddr)]? = + none := by + simpa [found] using hfound + simp only [hmiss, pure_bind] + apply RecM.WF.bind + (Q₁ := fun answer _ => IsPropMeaning trProj world + context.model.keys.uvars Delta source answer) + (classifyPropTypeUncached_wf context hsourceSupport hsourceCore) + intro answer afterClassify hmeaning + have hprovenance := context.model.isPropProvenance + context.collisionFree hsourceSupport hrepresented hmeaning + (context.cacheReferences hsourceSupport) + apply RecM.WF.bind (Q₁ := fun _ _ => True) + · exact RecM.WF.modify + (fun hI => IsPropCacheUpdate.whnfStateInv hI hprovenance) + (fun _ => trivial) + · intro _ afterWrite _ + exact RecM.WF.pure fun + (hI : WhnfStateInv .noAccel + (kernelCacheSemantics context.model.keys trProj) trProj world + support context.model.keys.uvars Delta afterWrite) => by + intro htrue + have hcoreType := IsPropMeaning.of_translation context.theory + hI.2.1.wf hsourceCore hmeaning htrue + exact hcoreType.defeqU_l world.venvWF hI.2.1.wf hsourceEq + +/-- Concrete proof irrelevance, with the memoized classifier discharged by +the production cache proof above. -/ +theorem tryProofIrrel_classifier_wf + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (context : PropositionClassifierContext trProj world support) + {Delta : KVLCtx} {state : TcState .anon} + {a b : KExpr .anon} {aV bV : VExpr} + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv context.model.keys.uvars world.nameOf trProj + Delta a aV) + (hb : TrKExprS world.venv context.model.keys.uvars world.nameOf trProj + Delta b bV) : + RecM.WF .noAccel + (kernelCacheSemantics context.model.keys trProj) trProj world support + context.model.keys.uvars Delta state (tryProofIrrel a b) + (fun answer _ => answer = true -> + world.venv.IsDefEqU context.model.keys.uvars Delta.toCtx aV bV) := + tryProofIrrel_wf (isPropType_wf context) haSupport hbSupport ha hb + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/RankDispatch.lean b/Ix/Tc/Verify/DefEq/RankDispatch.lean new file mode 100644 index 000000000..b0cf3ee57 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/RankDispatch.lean @@ -0,0 +1,137 @@ +import Ix.Tc.Verify.DefEq.OneSidedDelta + +/-! +# Lazy-delta rank dispatch + +After projection probing, reducibility ranks select a left-only, right-only, +or equal-rank reduction. Rank values have no semantic interpretation in the +soundness theorem: they choose among reduction helpers that are proved sound +independently. Their declaration lookups must nevertheless preserve the +state invariant across lazy ingress. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Contract for the sole remaining equal-rank lazy-delta branch. -/ +def DefEqLazyDeltaEqualRank.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state leftSource rightSource left right aHead bHead}, + DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right) → + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepWithEqualRank left right aHead bHead) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) + +/-- Reducibility-rank lookup preserves the recursive state invariant through +all declaration shapes and lazy-load outcomes. -/ +theorem rankDeltaHead_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (head : Option (KId .anon)) : + RecM.WF layer semantics trProj world support uvars Delta state + (rankDeltaHead head) (fun _ _ => True) := by + unfold rankDeltaHead + cases head with + | none => exact RecM.WF.pure fun _ => trivial + | some id => + unfold defRankId + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.tryGetConst_wf hfault id state + intro found afterLookup _ + cases found with + | none => exact RecM.WF.pure fun _ => trivial + | some decl => + cases decl <;> simp only + all_goals try exact RecM.WF.pure fun _ => trivial + all_goals + split <;> try exact RecM.WF.pure fun _ => trivial + all_goals + split <;> exact RecM.WF.pure fun _ => trivial + +/-- Dispatch every post-projection flag/rank combination. The impossible +joint-negative flag case is excluded by the caller's exact gate equation. -/ +theorem defEqLazyDeltaStepAfterProjectionMiss_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + {aHead bHead : Option (KId .anon)} {aDelta bDelta : Bool} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (context : LazyDeltaReductionContext layer semantics trProj world support + uvars) + (hequal : DefEqLazyDeltaEqualRank.WFAt layer semantics trProj world + support uvars) + (hactive : (!aDelta && !bDelta) = false) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (defEqLazyDeltaStepAfterProjectionMiss left right + aHead bHead aDelta bDelta) + (fun action _ => DefEqLazyDeltaActionPost trProj world support uvars + Delta leftSource rightSource action) := by + unfold defEqLazyDeltaStepAfterProjectionMiss + cases aDelta <;> cases bDelta + case false.false => + simp at hactive + case false.true => + simp only [Bool.false_and, Bool.false_eq_true, if_false] + exact defEqLazyDeltaStepWithRightDelta_wf context hDelta hpair + case true.false => + simp only [Bool.true_and, Bool.false_eq_true, if_false, if_true] + exact defEqLazyDeltaStepWithLeftDelta_wf context hDelta hpair + case true.true => + simp only [Bool.true_and, if_true] + apply RecM.WF.bind (rankDeltaHead_wf hfault aHead) + intro leftRank afterLeftRank _ + apply RecM.WF.bind (rankDeltaHead_wf hfault bHead) + intro rightRank afterRightRank _ + cases heq : leftRank == rightRank with + | true => + simp only [if_true] + exact hequal hpair + | false => + simp only [Bool.false_eq_true, if_false] + cases hcompare : compareRank leftRank rightRank with + | lt => + exact defEqLazyDeltaStepWithRightDelta_wf context hDelta hpair + | eq => + exact defEqLazyDeltaStepWithRightDelta_wf context hDelta hpair + | gt => + exact defEqLazyDeltaStepWithLeftDelta_wf context hDelta hpair + +namespace DefEqLazyDeltaAfterProjectionMiss + +/-- Package rank dispatch with the concrete anonymous lazy-ingress contract. -/ +theorem ofRankDispatch + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (ingress : AnonLazyIngressContext .noAccel semantics trProj world + support) + (context : LazyDeltaReductionContext .noAccel semantics trProj world + support uvars) + (hequal : DefEqLazyDeltaEqualRank.WFAt .noAccel semantics trProj world + support uvars) : + DefEqLazyDeltaAfterProjectionMiss.WFAt .noAccel semantics trProj world + support uvars := by + intro Delta state leftSource rightSource left right aHead bHead aDelta + bDelta hactive hpair + intro methods hmethods hI + exact (defEqLazyDeltaStepAfterProjectionMiss_wf ingress.preserves context + hequal hactive hI.2.1.wf hpair) methods hmethods hI + +end DefEqLazyDeltaAfterProjectionMiss + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/SameHeadSpine.lean b/Ix/Tc/Verify/DefEq/SameHeadSpine.lean new file mode 100644 index 000000000..85c4dba3c --- /dev/null +++ b/Ix/Tc/Verify/DefEq/SameHeadSpine.lean @@ -0,0 +1,287 @@ +import Ix.Tc.Verify.DefEq.SpineArguments + +/-! +# Same-head constant spines + +This module closes the substantive accepting branch of equal-rank lazy +delta. Equal constant instances are justified by collision-safe universe +comparison, and successful recursive comparisons of every raw argument are +lifted through the complete typed application spine. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr VLevel) + +/-- Finite support coverage needed by constant-headed spine comparison. -/ +structure SameHeadSpineResources (support : RunSupport) : Prop where + arguments : ∀ {source head : KExpr .anon} + {args : Array (KExpr .anon)}, + support source → source.collectSpine = (head, args) → + ∀ arg, arg ∈ args.toList → support arg + universes : ∀ {source : KExpr .anon} {id : KId .anon} + {levels : Array (KUniv .anon)} {info : ExprInfo .anon} + {args : Array (KExpr .anon)}, + support source → + source.collectSpine = (.const id levels info, args) → + ∀ level, level ∈ levels.toList → + support.univ level ∧ level.size < UInt64.size + +namespace RecM + +/-- Every accepted pair in the pure universe loop denotes equivalent Theory +levels. -/ +theorem allDefEqUniversesList_sound + {support : RunSupport} (hcollision : support.CollisionFree) + (pairs : List (KUniv .anon × KUniv .anon)) + (hinputs : ∀ pair, pair ∈ pairs → + support.univ pair.1 ∧ pair.1.size < UInt64.size ∧ + support.univ pair.2 ∧ pair.2.size < UInt64.size) + (hresult : allDefEqUniversesList pairs = true) : + ∀ pair, pair ∈ pairs → pair.1.toVLevel ≈ pair.2.toVLevel := by + induction pairs with + | nil => + intro pair hmem + simp at hmem + | cons pair rest ih => + rcases pair with ⟨left, right⟩ + simp only [allDefEqUniversesList, Bool.and_eq_true] at hresult + intro candidate hmem + simp only [List.mem_cons] at hmem + rcases hmem with rfl | hmem + · obtain ⟨hleftSupport, hleftSize, hrightSupport, hrightSize⟩ := + hinputs (left, right) (by simp) + exact univEq_sound + (hcollision.univ.addrFaithful hleftSupport hrightSupport) + hleftSize hrightSize hresult.1 + · exact ih + (fun tail htail => hinputs tail (by simp [htail])) + hresult.2 candidate hmem + +/-- The complete constant-instance gate exposes equal arity and pairwise +semantic universe equality. -/ +theorem sameDefEqUniverses_sound + {support : RunSupport} (hcollision : support.CollisionFree) + {left right : Array (KUniv .anon)} + (hleft : ∀ level, level ∈ left.toList → + support.univ level ∧ level.size < UInt64.size) + (hright : ∀ level, level ∈ right.toList → + support.univ level ∧ level.size < UInt64.size) + (hresult : sameDefEqUniverses left right = true) : + left.toList.length = right.toList.length ∧ + ∀ pair, pair ∈ left.toList.zip right.toList → + pair.1.toVLevel ≈ pair.2.toVLevel := by + rw [sameDefEqUniverses, Bool.and_eq_true] at hresult + have hlength : left.toList.length = right.toList.length := by + simpa only [Array.length_toList] using eq_of_beq hresult.1 + refine ⟨hlength, ?_⟩ + have hloop : allDefEqUniversesList (left.toList.zip right.toList) = true := by + simpa only [Array.toList_zip] using hresult.2 + apply allDefEqUniversesList_sound hcollision _ _ hloop + intro pair hmem + obtain ⟨hleftSupport, hleftSize⟩ := + hleft pair.1 (left_mem_of_pair_mem_zip hmem) + obtain ⟨hrightSupport, hrightSize⟩ := + hright pair.2 (right_mem_of_pair_mem_zip hmem) + exact ⟨hleftSupport, hleftSize, hrightSupport, hrightSize⟩ + +private theorem forall₂_map_of_zip + {left right : List α} {f : α → β} {g : α → γ} + {R : β → γ → Prop} + (hlength : left.length = right.length) + (hrel : ∀ pair, pair ∈ left.zip right → R (f pair.1) (g pair.2)) : + List.Forall₂ R (left.map f) (right.map g) := by + induction left generalizing right with + | nil => + cases right with + | nil => exact .nil + | cons y ys => simp at hlength + | cons x xs ih => + cases right with + | nil => simp at hlength + | cons y ys => + have htailLength : xs.length = ys.length := by + simp only [List.length_cons] at hlength + omega + apply List.Forall₂.cons + · exact hrel (x, y) (by simp) + · apply ih htailLength + intro pair hmem + exact hrel pair (by simp [hmem]) + +/-- Equal anonymous constant addresses plus the certified universe gate give +definitional equality of the two translated constant heads. -/ +theorem constantHeadsDefEq + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + (hcollision : support.CollisionFree) + {leftId rightId : KId .anon} + {leftLevels rightLevels : Array (KUniv .anon)} + {leftInfo rightInfo : ExprInfo .anon} {leftV rightV : VExpr} + (hleftLevels : ∀ level, level ∈ leftLevels.toList → + support.univ level ∧ level.size < UInt64.size) + (hrightLevels : ∀ level, level ∈ rightLevels.toList → + support.univ level ∧ level.size < UInt64.size) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta + (.const leftId leftLevels leftInfo) leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta + (.const rightId rightLevels rightInfo) rightV) + (hid : (leftId.addr == rightId.addr) = true) + (hlevels : sameDefEqUniverses leftLevels rightLevels = true) : + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV := by + have hidEq : leftId = rightId := + KId.anon_eq_of_addr_eq (eq_of_beq hid) + subst rightId + cases hleft with + | const hleftName hleftConst hleftWF hleftArity => + cases hright with + | const hrightName hrightConst hrightWF hrightArity => + have hname := Option.some.inj (hleftName.symm.trans hrightName) + cases hname + have hconst := + Option.some.inj (hleftConst.symm.trans hrightConst) + cases hconst + obtain ⟨hlength, hpairs⟩ := sameDefEqUniverses_sound hcollision + hleftLevels hrightLevels hlevels + refine ⟨_, Lean4Lean.VEnv.IsDefEq.constDF hleftConst ?_ ?_ ?_ ?_⟩ + · intro level hmem + obtain ⟨raw, hraw, rfl⟩ := List.mem_map.mp hmem + exact hleftWF raw (by simpa using hraw) + · intro level hmem + obtain ⟨raw, hraw, rfl⟩ := List.mem_map.mp hmem + exact hrightWF raw (by simpa using hraw) + · simpa only [List.length_map, Array.length_toList] using hleftArity + · exact forall₂_map_of_zip hlength hpairs + +/-- Exact semantic contract for the production same-head helper. -/ +def TrySameHeadSpine.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (trySameHeadSpine left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Complete execution and semantic proof of `trySameHeadSpine`. -/ +theorem trySameHeadSpine_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hresources : SameHeadSpineResources support) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (trySameHeadSpine left right) + (fun result _ => match result with + | none => True + | some answer => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + rcases hleftCollect : left.collectSpine with ⟨leftHead, leftArgs⟩ + rcases hrightCollect : right.collectSpine with ⟨rightHead, rightArgs⟩ + unfold trySameHeadSpine + simp only [hleftCollect, hrightCollect] + cases leftHead <;> try exact RecM.WF.pure fun _ => trivial + case const leftId leftLevels leftInfo => + cases rightHead <;> try exact RecM.WF.pure fun _ => trivial + case const rightId rightLevels rightInfo => + cases hshape : + (leftId.addr != rightId.addr || leftArgs.size != rightArgs.size) with + | true => + simp only [hshape, if_true] + exact RecM.WF.pure fun _ => trivial + | false => + simp only [hshape, Bool.false_eq_true, if_false] + have hshapeParts := Bool.or_eq_false_iff.mp hshape + have hid : (leftId.addr == rightId.addr) = true := by + simpa using hshapeParts.1 + have hargsSize : leftArgs.size = rightArgs.size := by + exact eq_of_beq (by simpa using hshapeParts.2) + cases huniverses : + sameDefEqUniverses leftLevels rightLevels with + | false => + simp only [Bool.not_false, if_true] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + have hleftSpine := + trAppSpine_of_collectSpine hleft hleftCollect + have hrightSpine := + trAppSpine_of_collectSpine hright hrightCollect + apply RecM.WF.bind <| allDefEqSpineArgs_wf _ (by + intro pair hmem + have hmem' : pair ∈ + leftArgs.toList.zip rightArgs.toList := by + simpa only [Array.toList_zip] using hmem + have hleftMem := left_mem_of_pair_mem_zip hmem' + have hrightMem := right_mem_of_pair_mem_zip hmem' + obtain ⟨pairLeftV, pairLeftTy, hpairLeftTyped, + hpairLeft⟩ := hleftSpine.argument hleftMem + obtain ⟨pairRightV, pairRightTy, hpairRightTyped, + hpairRight⟩ := hrightSpine.argument hrightMem + exact ⟨hresources.arguments hleftSupport hleftCollect _ + hleftMem, + hresources.arguments hrightSupport hrightCollect _ + hrightMem, + pairLeftV, pairRightV, hpairLeft, hpairRight⟩) + intro accepted afterArgs haccepted + cases accepted with + | false => + simp only [Bool.not_false, if_true] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + exact RecM.WF.pure fun hI _ => by + have hDelta : KVLCtx.WF world.venv uvars Delta := + hI.2.1.wf + have hhead : ∀ {leftHeadV rightHeadV}, + TrKExprS world.venv uvars world.nameOf trProj Delta + (.const leftId leftLevels leftInfo) leftHeadV → + TrKExprS world.venv uvars world.nameOf trProj Delta + (.const rightId rightLevels rightInfo) rightHeadV → + world.venv.IsDefEqU uvars Delta.toCtx + leftHeadV rightHeadV := by + intro leftHeadV rightHeadV hleftHead hrightHead + exact constantHeadsDefEq hcollision + (hresources.universes hleftSupport hleftCollect) + (hresources.universes hrightSupport hrightCollect) + hleftHead hrightHead hid (by simpa using huniverses) + apply TrAppSpine.defEq_of_zip theory hDelta hleftSpine + hrightSpine + · simpa only [Array.length_toList] using hargsSize + · exact hhead + · intro pair hmem + exact haccepted rfl pair (by + simpa only [Array.toList_zip] using hmem) + +namespace TrySameHeadSpine + +/-- Package the concrete proof as the helper contract. -/ +theorem ofResources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hresources : SameHeadSpineResources support) : + TrySameHeadSpine.WFAt layer semantics trProj world support uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact trySameHeadSpine_wf theory hcollision hresources hleftSupport + hrightSupport hleft hright + +end TrySameHeadSpine + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/SpineArguments.lean b/Ix/Tc/Verify/DefEq/SpineArguments.lean new file mode 100644 index 000000000..42a436d0f --- /dev/null +++ b/Ix/Tc/Verify/DefEq/SpineArguments.lean @@ -0,0 +1,212 @@ +import Ix.Tc.Verify.DefEq.EqualRankReduction + +/-! +# Recursive application-spine arguments + +Same-head delta comparison and the later general application comparison use +one left-to-right recursive DefEq loop. This module proves that loop once +and gives its positive result a compositional Theory meaning. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- A raw argument pair has supported translations in the current context. -/ +def SpineArgInput (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) (Delta : KVLCtx) + (left right : KExpr .anon) : Prop := + support left ∧ support right ∧ + ∃ leftV rightV, + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV + +/-- Semantic witness retained for every argument pair after the loop +accepts. -/ +def SpineArgDefEq (trProj : RawProjRel) (world : VerifyWorld) + (uvars : Nat) (Delta : KVLCtx) (left right : KExpr .anon) : Prop := + ∃ leftV rightV, + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV ∧ + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV + +/-- Exact recursive-list loop: invariant preservation and a semantic witness +for every pair when the complete loop returns `true`. -/ +theorem allDefEqSpineArgsList_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + (pairs : List (KExpr .anon × KExpr .anon)) + (hinputs : ∀ pair, pair ∈ pairs → + SpineArgInput trProj world support uvars Delta pair.1 pair.2) : + ∀ state, + RecM.WF layer semantics trProj world support uvars Delta state + (allDefEqSpineArgsList pairs) + (fun answer _ => answer = true → + ∀ pair, pair ∈ pairs → + SpineArgDefEq trProj world uvars Delta pair.1 pair.2) := by + induction pairs with + | nil => + intro state + exact RecM.WF.pure fun _ _ pair hmem => by simp at hmem + | cons pair rest ih => + intro state + rcases pair with ⟨left, right⟩ + obtain ⟨hleftSupport, hrightSupport, leftV, rightV, hleft, hright⟩ := + hinputs (left, right) (by simp) + unfold allDefEqSpineArgsList + apply RecM.WF.bind + (RecM.isDefEqCall_wf hleftSupport hrightSupport hleft hright) + intro answer after hanswer + cases answer with + | false => + simp only [Bool.not_false, if_true] + exact RecM.WF.pure fun _ htrue => by contradiction + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + apply RecM.WF.mono + (ih (fun tail hmem => hinputs tail (by simp [hmem])) after) + · intro result final htail hresult candidate hmem + simp only [List.mem_cons] at hmem + rcases hmem with rfl | hmem + · exact ⟨leftV, rightV, hleft, hright, hanswer rfl⟩ + · exact htail hresult candidate hmem + · intro _ _ _ + trivial + +/-- Array wrapper used by both production spine comparators. -/ +theorem allDefEqSpineArgs_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + (pairs : Array (KExpr .anon × KExpr .anon)) + (hinputs : ∀ pair, pair ∈ pairs.toList → + SpineArgInput trProj world support uvars Delta pair.1 pair.2) : + RecM.WF layer semantics trProj world support uvars Delta state + (allDefEqSpineArgs pairs) + (fun answer _ => answer = true → + ∀ pair, pair ∈ pairs.toList → + SpineArgDefEq trProj world uvars Delta pair.1 pair.2) := by + unfold allDefEqSpineArgs + exact allDefEqSpineArgsList_wf pairs.toList hinputs state + +/-- Membership in a zipped list exposes membership of its left component. -/ +theorem left_mem_of_pair_mem_zip + {left right : List α} {a b : α} (h : (a, b) ∈ left.zip right) : + a ∈ left := by + induction left generalizing right with + | nil => simp at h + | cons x xs ih => + cases right with + | nil => simp at h + | cons y ys => + simp only [List.zip_cons_cons, List.mem_cons] at h ⊢ + rcases h with h | h + · exact Or.inl (congrArg Prod.fst h) + · exact Or.inr (ih h) + +/-- Membership in a zipped list exposes membership of its right component. -/ +theorem right_mem_of_pair_mem_zip + {left right : List α} {a b : α} (h : (a, b) ∈ left.zip right) : + b ∈ right := by + induction left generalizing right with + | nil => simp at h + | cons x xs ih => + cases right with + | nil => simp at h + | cons y ys => + simp only [List.zip_cons_cons, List.mem_cons] at h ⊢ + rcases h with h | h + · exact Or.inl (congrArg Prod.snd h) + · exact Or.inr (ih h) + +namespace TrAppSpine + +/-- Lift a positive semantic argument witness to any two translations of the +same raw pair. -/ +theorem argumentDefEq + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {left right : KExpr .anon} + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (h : SpineArgDefEq trProj world uvars Delta left right) + {leftV rightV : VExpr} + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV := by + obtain ⟨witnessLeft, witnessRight, hwitnessLeft, hwitnessRight, + hwitness⟩ := h + have hctx := KVLCtx.IsDefEq.refl world.venvWF.ordered hDelta + have hleftBridge := hleft.uniq world.venvWF theory.literalWF + theory.projections hctx hwitnessLeft + have hrightBridge := hwitnessRight.uniq world.venvWF theory.literalWF + theory.projections hctx hright + exact hleftBridge.trans world.venvWF hDelta.toCtx <| + hwitness.trans world.venvWF hDelta.toCtx hrightBridge + +/-- Pointwise equality of two equally long raw spines lifts a semantic +equality of their heads to semantic equality of the complete applications. -/ +theorem defEq_of_zip + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {leftHead rightHead : KExpr .anon} + {leftArgs rightArgs : List (KExpr .anon)} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hleft : TrAppSpine world.venv uvars world.nameOf trProj Delta + leftHead leftArgs leftV) + (hright : TrAppSpine world.venv uvars world.nameOf trProj Delta + rightHead rightArgs rightV) + (hlength : leftArgs.length = rightArgs.length) + (hhead : ∀ {leftHeadV rightHeadV}, + TrKExprS world.venv uvars world.nameOf trProj Delta leftHead + leftHeadV → + TrKExprS world.venv uvars world.nameOf trProj Delta rightHead + rightHeadV → + world.venv.IsDefEqU uvars Delta.toCtx leftHeadV rightHeadV) + (hargs : ∀ pair, pair ∈ leftArgs.zip rightArgs → + SpineArgDefEq trProj world uvars Delta pair.1 pair.2) : + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV := by + induction hleft generalizing rightArgs rightV with + | head hleftHead => + cases hright with + | head hrightHead => exact hhead hleftHead hrightHead + | app hprefix hfun harg hargTr => simp at hlength + | @app leftPrefix leftCurrent leftArg leftArgV A B hleftPrefix + hleftFun hleftArg hleftArgTr ih => + cases hright with + | head hrightHead => simp at hlength + | @app rightPrefix rightCurrent rightArg rightArgV A' B' + hrightPrefix hrightFun hrightArg hrightArgTr => + have hprefixLength : leftPrefix.length = rightPrefix.length := by + simpa only [List.length_append, List.length_singleton, + Nat.add_right_cancel_iff] using hlength + have hzip : + (leftPrefix ++ [leftArg]).zip + (rightPrefix ++ [rightArg]) = + leftPrefix.zip rightPrefix ++ [(leftArg, rightArg)] := by + simpa using List.zip_append hprefixLength + have hprefixArgs : ∀ pair, + pair ∈ leftPrefix.zip rightPrefix → + SpineArgDefEq trProj world uvars Delta pair.1 pair.2 := by + intro pair hmem + exact hargs pair (by rw [hzip]; simp [hmem]) + have hcurrent := ih hrightPrefix hprefixLength hprefixArgs + have hcurrentTyped := + hcurrent.of_l world.venvWF hDelta.toCtx hleftFun + have hlast : SpineArgDefEq trProj world uvars Delta + leftArg rightArg := + hargs (leftArg, rightArg) (by rw [hzip]; simp) + have hlastEq := argumentDefEq theory hDelta hlast + hleftArgTr hrightArgTr + have hlastTyped := + hlastEq.of_l world.venvWF hDelta.toCtx hleftArg + exact ⟨_, Lean4Lean.VEnv.IsDefEq.appDF hcurrentTyped hlastTyped⟩ + +end TrAppSpine + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/StoppedContinuation.lean b/Ix/Tc/Verify/DefEq/StoppedContinuation.lean new file mode 100644 index 000000000..7abd12ca5 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/StoppedContinuation.lean @@ -0,0 +1,195 @@ +import Ix.Tc.Verify.DefEq.ApplicationSpine +import Ix.Tc.Verify.DefEq.StructuralCongruence + +/-! +# Stopped lazy-delta continuation + +Once bounded lazy delta stops, production tries structural congruence, reduces +both sides with `whnfCore`, recursively compares a changed pair, and otherwise +tries address equality, quick structural equality, application-spine equality, +and the final WHNF comparator in that order. This module proves that exact +outer control flow from contracts for its substantive helpers. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Exact semantic contract for the final full-WHNF comparison tier. Its +constructor-exhaustive implementation is intentionally separated from the +outer stopped-continuation control flow. -/ +def IsDefEqWhnf.WFAt (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqWhnf left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- The exact helper contracts consumed by the stopped continuation. -/ +structure StoppedContinuationResources (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop where + structural : TryStructuralCongruence.WFAt layer semantics trProj world + support uvars + core : DefEqReduction.WFAt layer semantics trProj world support uvars + whnfCore + sorts : SortComponentResources support + quick : QuickDefEqResources support + application : TryDefEqApp.WFAt layer semantics trProj world support uvars + finalWhnf : IsDefEqWhnf.WFAt layer semantics trProj world support uvars + +/-- Complete execution proof of the production continuation after lazy delta +stops. Every accepting branch is transported back to the two original +operands retained by `DefEqPairInvariant`. -/ +theorem isDefEqAfterLazyDeltaStopped_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {leftSource rightSource : VExpr} {left right : KExpr .anon} + (theory : WhnfTheory trProj world uvars) + (collision : support.CollisionFree) + (resources : StoppedContinuationResources layer semantics trProj world + support uvars) + (hpair : DefEqPairInvariant trProj world support uvars Delta + leftSource rightSource (left, right)) : + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqAfterLazyDeltaStopped left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftSource rightSource) := by + obtain ⟨leftV, hleft, hleftEq⟩ := hpair.left + obtain ⟨rightV, hright, hrightEq⟩ := hpair.right + unfold isDefEqAfterLazyDeltaStopped + apply RecM.WF.bind <| + resources.structural hpair.leftSupport hpair.rightSupport hleft hright + intro structurallyEqual afterStructural hstructural + cases structurallyEqual with + | true => + simp only [if_true] + exact RecM.WF.pure fun hI _ => + hleftEq.trans world.venvWF hI.2.1.wf <| + (hstructural rfl).trans world.venvWF hI.2.1.wf hrightEq.symm + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind (RecM.WF.withInv <| + resources.core hpair.leftSupport hleft) + intro leftCore afterLeftCore hleftCore + rcases hleftCore with + ⟨hILeftCore, hleftCoreSupport, leftCoreV, hleftCoreTr, + hleftCoreEq⟩ + apply RecM.WF.bind (RecM.WF.withInv <| + resources.core hpair.rightSupport hright) + intro rightCore afterRightCore hrightCore + rcases hrightCore with + ⟨hIRightCore, hrightCoreSupport, rightCoreV, hrightCoreTr, + hrightCoreEq⟩ + cases hchanged : + (leftCore.addr != left.addr || rightCore.addr != right.addr) with + | true => + simp only [if_true, pure_bind] + apply RecM.WF.bind (RecM.WF.withInv <| + RecM.isDefEqCall_wf hleftCoreSupport hrightCoreSupport + hleftCoreTr hrightCoreTr) + intro answer final hpost + rcases hpost with ⟨hI, hanswer⟩ + exact RecM.WF.pure fun _ htrue => + hleftEq.trans world.venvWF hI.2.1.wf <| + hleftCoreEq.trans world.venvWF hI.2.1.wf <| + (hanswer htrue).trans world.venvWF hI.2.1.wf <| + hrightCoreEq.symm.trans world.venvWF hI.2.1.wf + hrightEq.symm + | false => + simp only [Bool.false_eq_true, if_false] + cases haddr : leftCore.addr == rightCore.addr with + | true => + simp only [if_true] + exact RecM.WF.pure fun hI _ => by + have herase := collision.expr hleftCoreSupport + hrightCoreSupport (eq_of_beq haddr) + have hsame : leftCore = rightCore := by + simpa only [KExpr.eraseMeta_anon] using herase + subst rightCore + have hmiddle := hleftCoreTr.uniq world.venvWF + theory.literalWF theory.projections + (KVLCtx.IsDefEq.refl world.venvWF hI.2.1.wf) + hrightCoreTr + exact hleftEq.trans world.venvWF hI.2.1.wf <| + hleftCoreEq.trans world.venvWF hI.2.1.wf <| + hmiddle.trans world.venvWF hI.2.1.wf <| + hrightCoreEq.symm.trans world.venvWF hI.2.1.wf + hrightEq.symm + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind <| + quickDefEq_wf theory collision resources.sorts + resources.quick hleftCoreSupport hrightCoreSupport + hleftCoreTr hrightCoreTr + intro quicklyEqual afterQuick hquick + cases quicklyEqual with + | true => + simp only [if_true] + exact RecM.WF.pure fun hI _ => + hleftEq.trans world.venvWF hI.2.1.wf <| + hleftCoreEq.trans world.venvWF hI.2.1.wf <| + (hquick rfl).trans world.venvWF hI.2.1.wf <| + hrightCoreEq.symm.trans world.venvWF hI.2.1.wf + hrightEq.symm + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind <| + resources.application hleftCoreSupport + hrightCoreSupport hleftCoreTr hrightCoreTr + intro applicationsEqual afterApplication happlication + cases applicationsEqual with + | true => + simp only [if_true] + exact RecM.WF.pure fun hI _ => + hleftEq.trans world.venvWF hI.2.1.wf <| + hleftCoreEq.trans world.venvWF hI.2.1.wf <| + (happlication rfl).trans world.venvWF + hI.2.1.wf <| + hrightCoreEq.symm.trans world.venvWF + hI.2.1.wf hrightEq.symm + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.mono (RecM.WF.withInv <| + resources.finalWhnf hleftCoreSupport + hrightCoreSupport hleftCoreTr hrightCoreTr) + · intro answer final hpost htrue + rcases hpost with ⟨hI, hanswer⟩ + exact hleftEq.trans world.venvWF hI.2.1.wf <| + hleftCoreEq.trans world.venvWF hI.2.1.wf <| + (hanswer htrue).trans world.venvWF hI.2.1.wf <| + hrightCoreEq.symm.trans world.venvWF + hI.2.1.wf hrightEq.symm + · intro _ _ _ + trivial + +namespace DefEqAfterLazyDeltaStopped + +/-- Package the production theorem as the exact stopped-continuation +contract used by the bounded lazy-delta driver. -/ +theorem ofResources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (collision : support.CollisionFree) + (resources : StoppedContinuationResources layer semantics trProj world + support uvars) : + DefEqAfterLazyDeltaStopped.WFAt layer semantics trProj world support + uvars := by + intro Delta state leftSource rightSource left right hpair + exact isDefEqAfterLazyDeltaStopped_wf theory collision resources hpair + +end DefEqAfterLazyDeltaStopped + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/StoppedContinuationClosure.lean b/Ix/Tc/Verify/DefEq/StoppedContinuationClosure.lean new file mode 100644 index 000000000..9a0839005 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/StoppedContinuationClosure.lean @@ -0,0 +1,70 @@ +import Ix.Tc.Verify.DefEq.ProjectionDeltaClosure +import Ix.Tc.Verify.DefEq.StoppedContinuation + +/-! +# Stopped-continuation closure + +Once bounded lazy delta stops, the remaining DefEq control flow consumes a +structural probe, `whnfCore`, application-spine comparison, and final WHNF +comparison. This module constructs that resource record with the structural +projection branch supplied by the concrete projection-delta closure. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Concrete lower resources for the no-acceleration stopped continuation. +The projection-delta record already owns the shared core, sort, and quick +comparison inputs, so they are not repeated here. -/ +structure StoppedContinuationClosureResources + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) where + projectionDelta : ProjectionDeltaClosureResources semantics trProj world + support uvars + structural : StructuralCongruenceResources support + application : TryDefEqApp.WFAt .noAccel semantics trProj world support + uvars + finalWhnf : IsDefEqWhnf.WFAt .noAccel semantics trProj world support + uvars + +namespace StoppedContinuationClosureResources + +/-- Assemble the exact helper record consumed by the production stopped +continuation. -/ +def stopped + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (resources : StoppedContinuationClosureResources semantics trProj world + support uvars) : + StoppedContinuationResources .noAccel semantics trProj world support + uvars where + structural := TryStructuralCongruence.ofProjectionDeltaResources + resources.projectionDelta resources.structural + core := resources.projectionDelta.core + sorts := resources.projectionDelta.sorts + quick := resources.projectionDelta.quick + application := resources.application + finalWhnf := resources.finalWhnf + +end StoppedContinuationClosureResources + +namespace DefEqAfterLazyDeltaStopped + +/-- Close the complete stopped continuation without assuming either +structural congruence or the bounded projection loop as a free contract. -/ +theorem ofClosureResources + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + (resources : StoppedContinuationClosureResources semantics trProj world + support uvars) : + DefEqAfterLazyDeltaStopped.WFAt .noAccel semantics trProj world support + uvars := + DefEqAfterLazyDeltaStopped.ofResources resources.projectionDelta.theory + resources.projectionDelta.collision resources.stopped + +end DefEqAfterLazyDeltaStopped + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/StringLiteral.lean b/Ix/Tc/Verify/DefEq/StringLiteral.lean new file mode 100644 index 000000000..2b33592fc --- /dev/null +++ b/Ix/Tc/Verify/DefEq/StringLiteral.lean @@ -0,0 +1,203 @@ +import Ix.Tc.Verify.DefEq.BoolTrue +import Ix.Tc.Verify.Whnf.Projection.StringExpansion + +/-! +# String-literal definitional equality + +The third recursive tier expands compact String syntax before either side is +normalized. K1's expansion plan proves that the concrete intern transaction +terminates with a supported, structurally translatable term. DefEq needs the +stronger fact recorded here: that exact generated term translates to the same +Theory literal as the compact source syntax. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- A K1 String-expansion plan together with the exact Theory meaning needed +by DefEq. Merely knowing that the generated expression has *some* +translation would not justify comparing it in place of the source literal. -/ +structure DefEqStringExpansionPlan + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (p : Primitives .anon) (value : String) where + plan : RecM.StringExpansionPlan trProj world support p value + literalTranslation : ∀ uvars Delta, + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkApp (RecM.stringMkConst p) plan.list) + (.trLiteral (.strVal value)) + +/-- Run-scoped String resources for every canonical primitive table that can +occur in an invariant state. -/ +structure DefEqStringContext (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) where + collisionFree : support.CollisionFree + plan : ∀ p, p.CanonicalAnon → ∀ value, + DefEqStringExpansionPlan trProj world support p value + +namespace RecM + +attribute [local irreducible] strLitToConstructor + strLitToConstructorWithPrimitives + +/-- A concrete semantic plan strengthens K1's exact-result expansion theorem +with the particular Theory literal required by DefEq. -/ +theorem strLitToConstructor_defeq_plan_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} {value : String} + (hcollision : support.CollisionFree) + (semanticPlan : + DefEqStringExpansionPlan trProj world support s.prims value) : + RecM.WF layer semantics trProj world support uvars Delta s + (strLitToConstructor value) + (fun expanded _ => support expanded ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta expanded + (.trLiteral (.strVal value))) := by + apply RecM.WF.mono + (strLitToConstructor_plan_exact_wf hcollision semanticPlan.plan) + · intro expanded after hpost + rcases hpost with ⟨hexact, hsupported, _⟩ + subst expanded + exact ⟨hsupported, semanticPlan.literalTranslation uvars Delta⟩ + · intro _ _ _ + trivial + +/-- The concrete String expansion returns a supported expression whose +structural translation is exactly the compact source literal's translation. -/ +theorem strLitToConstructor_defeq_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} {value : String} + (context : DefEqStringContext trProj world support) + (hcanonical : CanonicalPrimitiveStates layer semantics trProj world + support uvars) : + RecM.WF layer semantics trProj world support uvars Delta s + (strLitToConstructor value) + (fun expanded _ => support expanded ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta expanded + (.trLiteral (.strVal value))) := by + intro methods hmethods hI + exact strLitToConstructor_defeq_plan_wf context.collisionFree + (context.plan s.prims (hcanonical hI) value) methods hmethods hI + +/-- Expanding a compact String literal and accepting the recursive comparison +is sound. Every non-String source returns `false` without touching state. -/ +theorem tryStringLitExpansion_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {source other : KExpr .anon} {sourceV otherV : VExpr} + (context : DefEqStringContext trProj world support) + (hcanonical : CanonicalPrimitiveStates layer semantics trProj world + support uvars) + (hsourceSupport : support source) (hotherSupport : support other) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hother : TrKExprS world.venv uvars world.nameOf trProj Delta other + otherV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryStringLitExpansion source other) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx sourceV otherV) := by + cases hsource <;> simp only [tryStringLitExpansion] + all_goals first + | exact RecM.WF.pure fun _ hanswer => by contradiction + | skip + rename_i value blob info hcontains + apply RecM.WF.bind (strLitToConstructor_defeq_wf context hcanonical) + intro expanded after hExpanded + exact isDefEqCall_wf hExpanded.1 hotherSupport hExpanded.2 hother + +namespace DefEqAfterStringExpansion + +/-- Semantic contract for the recursive tiers following literal String +expansion. -/ +def WF (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ {Delta state a b aV bV}, + support a → support b → + TrKExprS world.venv uvars world.nameOf trProj Delta a aV → + TrKExprS world.venv uvars world.nameOf trProj Delta b bV → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqInnerAfterStringExpansion a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx aV bV) + +/-- Discharge both ordered String-expansion attempts. The second attempt's +recursive equality is reversed semantically before it is returned for the +original `(a,b)` order. -/ +theorem closesAfterBoolTrue + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (context : DefEqStringContext trProj world support) + (hcanonical : CanonicalPrimitiveStates layer semantics trProj world + support uvars) + (htail : WF layer semantics trProj world support uvars) : + DefEqAfterBoolTrue.WF layer semantics trProj world support uvars := by + intro Delta state a b aV bV haSupport hbSupport ha hb + unfold isDefEqInnerAfterBoolTrue + cases hguard : hasStringLiteralPair a b with + | false => + simp only [Bool.false_eq_true, if_false] + exact htail haSupport hbSupport ha hb + | true => + simp only [if_true] + apply RecM.WF.bind + (tryStringLitExpansion_wf context hcanonical + haSupport hbSupport ha hb) + intro acceptedAB afterAB hacceptedAB + cases acceptedAB with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => hacceptedAB rfl + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind + (tryStringLitExpansion_wf context hcanonical + hbSupport haSupport hb ha) + intro acceptedBA afterBA hacceptedBA + cases acceptedBA with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => (hacceptedBA rfl).symm + | false => + simp only [Bool.false_eq_true, if_false] + exact htail haSupport hbSupport ha hb + +/-- Assemble structural comparison, eager Bool reduction, and literal String +expansion, leaving the post-String recursive tail explicit. -/ +theorem closesInner + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hsorts : SortComponentResources support) + (hstructural : QuickDefEqResources support) + (boolContext : BoolTruePrimitiveContext world) + (stringContext : DefEqStringContext trProj world support) + (hcanonical : CanonicalPrimitiveStates layer semantics trProj world + support uvars) + (hwhnf : DefEqDirectWhnf.WFAt layer semantics trProj world support + uvars) + (htail : WF layer semantics trProj world support uvars) : + ∀ {Delta state a b aV bV}, + support a → support b → + TrKExprS world.venv uvars world.nameOf trProj Delta a aV → + TrKExprS world.venv uvars world.nameOf trProj Delta b bV → + RecM.WF layer semantics trProj world support uvars Delta state + (isDefEqInner a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx aV bV) := + DefEqAfterBoolTrue.closesInner theory hcollision hsorts hstructural + boolContext hcanonical hwhnf + (closesAfterBoolTrue stringContext hcanonical htail) + +end DefEqAfterStringExpansion + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/Structural.lean b/Ix/Tc/Verify/DefEq/Structural.lean new file mode 100644 index 000000000..42b54b18b --- /dev/null +++ b/Ix/Tc/Verify/DefEq/Structural.lean @@ -0,0 +1,318 @@ +import Ix.Tc.Verify.Infer.BinderScopes +import Ix.Tc.Verify.Infer.Callbacks +import Ix.Tc.Verify.Infer.SortTypes + +/-! +# Structural definitional equality + +The first recursive DefEq tier compares sorts and matching binders without +normalization. Binder comparison uses one common freshly allocated fvar for +both bodies. The second body starts in the second domain's Theory context, +so its proof must be transported into the first domain's context before the +recursive callback is invoked. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Finite resources needed to open both bodies of one quick binder +comparison with the common production fvar. -/ +structure QuickBinderResources (support : RunSupport) + (name : Mode.anon.F Name) (body1 body2 : KExpr .anon) : Prop where + left : BinderOpeningResources support name body1 + right : BinderOpeningResources support name body2 + +/-- Constructor descent needed by `quickDefEq`. The common fvar carries +the left binder's display name, so each supported body exposes opening +resources for that (anonymous-mode singleton) name rather than only for its +own enclosing node. -/ +structure QuickDefEqResources (support : RunSupport) : Prop where + lambda : ∀ {name bi ty body info}, + support (.lam name bi ty body info) → + support ty ∧ ∀ commonName, + BinderOpeningResources support commonName body + forallE : ∀ {name bi ty body info}, + support (.all name bi ty body info) → + support ty ∧ ∀ commonName, + BinderOpeningResources support commonName body + +namespace RecM + +/-- Soundness of the common-fvar binder comparison. A successful result +provides both the domain equality and the body equality in the first +domain's context; this is exactly the pair needed by lambda and Pi +congruence. -/ +theorem quickBinder_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty1 body1 ty2 body2 : KExpr .anon} + {ty1V body1V ty2V body2V : VExpr} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hresources : QuickBinderResources support name body1 body2) + (hty1Support : support ty1) (hty2Support : support ty2) + (hty1Type : world.venv.IsType uvars Delta.toCtx ty1V) + (hty1 : TrKExprS world.venv uvars world.nameOf trProj Delta ty1 ty1V) + (hty2 : TrKExprS world.venv uvars world.nameOf trProj Delta ty2 ty2V) + (hbody1 : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam ty1V) :: Delta) body1 body1V) + (hbody2 : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam ty2V) :: Delta) body2 body2V) : + RecM.WF layer semantics trProj world support uvars Delta s + (quickBinder name bi ty1 body1 ty2 body2) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx ty1V ty2V ∧ + world.venv.IsDefEqU uvars (ty1V :: Delta.toCtx) body1V body2V) := by + unfold quickBinder + apply RecM.WF.bind + (RecM.isDefEqCall_wf hty1Support hty2Support hty1 hty2) + intro domainsEqual afterDomains hdomains + cases domainsEqual with + | false => + simp only [Bool.not_false, if_true] + exact RecM.WF.pure fun _ h => by contradiction + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + apply RecM.withLctxScope_openBinder_wf + (layer := layer) (semantics := semantics) (trProj := trProj) + (world := world) (uvars := uvars) (Delta := Delta) + (s := afterDomains) (bi := bi) + (k := fun body1Open fv => do + let commonFVar ← TcM.intern (KExpr.mkFVar fv name) + let body2Open ← + TcM.runIntern (instantiateRev body2 #[commonFVar]) + isDefEqCall body1Open body2Open) + (Qinner := fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx ty1V ty2V ∧ + world.venv.IsDefEqU uvars + (ty1V :: Delta.toCtx) body1V body2V) + (Qouter := fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx ty1V ty2V ∧ + world.venv.IsDefEqU uvars + (ty1V :: Delta.toCtx) body1V body2V) + hty1 hty1Type hbody1 hcollision hresources.left + · intro body1Open fv afterOpen hfv hbody1OpenEq + hbody1OpenSupport hbody1OpenTr + subst fv + let fresh : FVarId := ⟨afterDomains.env.nextFVarId⟩ + let common : KExpr .anon := .mkFVar fresh name + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf hcollision + (hresources.left.fvarSupport fresh)) + intro commonFVar afterIntern hcommon + rcases hcommon with ⟨hIIntern, hcommonEq, _⟩ + subst commonFVar + have hrightBounds := hresources.right.instRevBounds fresh + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.instRev_whnf_wf_of_resources hcollision hrightBounds + (hresources.right.instRevSupport fresh)) + intro body2Open afterBody2 hbody2Post + rcases hbody2Post with ⟨hIBody2, hbody2OpenEq, _⟩ + subst body2Open + have hDelta : KVLCtx.WF world.venv uvars Delta := + hIBody2.2.1.wf.1 + have hfresh : fresh ∉ Delta.fvars := by + exact (hIBody2.2.1.wf.2.1 fresh Delta.fvars rfl).1 + obtain ⟨level, hty1Sort⟩ := hty1Type + have hdomainTyped : world.venv.IsDefEq uvars Delta.toCtx + ty1V ty2V (.sort level) := + hdomains rfl |>.of_l world.venvWF hDelta.toCtx hty1Sort + have hcontexts : KVLCtx.IsDefEq world.venv uvars + ((some (fresh, Delta.fvars), .vlam ty1V) :: Delta) + ((some (fresh, Delta.fvars), .vlam ty2V) :: Delta) := + .cons (KVLCtx.IsDefEq.refl world.venvWF.ordered hDelta) + (by + intro fv deps heq + cases heq + exact ⟨hfresh, fun _ h => h⟩) + (.vlam hdomainTyped) + have hbody2Raw := hbody2.openFVarZero + (fv := fresh) (deps := Delta.fvars) (name := name) + hfresh (by simpa using hrightBounds.2.2) + obtain ⟨body2V', hbody2Retag⟩ := hbody2Raw.defeqDFC + world.venvWF theory.literalWF theory.projections + (hcontexts.symm world.venvWF.ordered) + have hbody2Support : support + (KExpr.instantiateRevSpec body2 #[common] 0) := + hresources.right.instRevSupport fresh _ + (KExpr.InstRevReach.spec ..) + apply RecM.WF.mono + (RecM.isDefEqCall_wf hbody1OpenSupport hbody2Support + hbody1OpenTr (by simpa [common] using hbody2Retag)) + · intro answer final hanswer resultTrue + have hbody2Bridge : world.venv.IsDefEqU uvars + (ty1V :: Delta.toCtx) body2V' body2V := by + simpa [KVLCtx.toCtx] using + TrKExprS.uniq world.venvWF theory.literalWF + theory.projections hcontexts hbody2Retag hbody2Raw + exact ⟨hdomains rfl, + (hanswer resultTrue).trans world.venvWF + hcontexts.wf.toCtx hbody2Bridge⟩ + · intro _ _ _ + trivial + · intro answer after hanswer + exact hanswer + +/-- Soundness of the complete Tier-1 structural probe. Mismatched +constructors return `false`; the three accepting shapes are justified by +universe equality or the common-fvar binder theorem above. -/ +theorem quickDefEq_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {a b : KExpr .anon} {aV bV : VExpr} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hsorts : SortComponentResources support) + (hresources : QuickDefEqResources support) + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv uvars world.nameOf trProj Delta a aV) + (hb : TrKExprS world.venv uvars world.nameOf trProj Delta b bV) : + RecM.WF layer semantics trProj world support uvars Delta s + (quickDefEq a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx aV bV) := by + cases ha <;> cases hb <;> simp only [quickDefEq] + all_goals + first + | exact RecM.WF.pure fun _ h => by contradiction + | skip + · rename_i u info1 huWF v info2 hvWF + obtain ⟨huSize, huSubterms⟩ := hsorts haSupport + obtain ⟨hvSize, hvSubterms⟩ := hsorts hbSupport + exact RecM.WF.pure fun _ heq => + ⟨_, .sortDF huWF hvWF <| + univEq_sound + (hcollision.univ.addrFaithful + (huSubterms u .refl) (hvSubterms v .refl)) + huSize hvSize heq⟩ + · rename_i name1 bi1 ty1 body1 info1 ty1V body1V + hty1Type hty1 hbody1 name2 bi2 ty2 body2 info2 ty2V body2V + hty2Type hty2 hbody2 + obtain ⟨hty1Support, hbody1Resources⟩ := + hresources.lambda haSupport + obtain ⟨hty2Support, hbody2Resources⟩ := + hresources.lambda hbSupport + apply RecM.WF.mono + (RecM.WF.withInv <| quickBinder_wf theory hcollision + { left := hbody1Resources name1 + right := hbody2Resources name1 } + hty1Support hty2Support hty1Type hty1 hty2 hbody1 hbody2) + · intro answer final hpost hanswer + rcases hpost with ⟨hI, hsemantic⟩ + rcases hsemantic hanswer with ⟨hdomainEq, hbodyEq⟩ + have hDelta : KVLCtx.WF world.venv uvars Delta := hI.2.1.wf + obtain ⟨domainLevel, hty1Sort⟩ := hty1Type + have hdomainTyped : world.venv.IsDefEq uvars Delta.toCtx + ty1V ty2V (.sort domainLevel) := + hdomainEq.of_l world.venvWF hDelta.toCtx hty1Sort + have hDeltaBody : KVLCtx.WF world.venv uvars + ((none, .vlam ty1V) :: Delta) := + ⟨hDelta, nofun, ⟨domainLevel, hty1Sort⟩⟩ + obtain ⟨bodyTy, hbody1Typed⟩ := hbody1.wf + world.venvWF.ordered theory.literalWF theory.projections.wf + hDeltaBody + have hbodyTyped : world.venv.IsDefEq uvars + (ty1V :: Delta.toCtx) body1V body2V bodyTy := + hbodyEq.of_l world.venvWF hDeltaBody.toCtx (by + simpa [KVLCtx.toCtx] using hbody1Typed) + exact (Lean4Lean.VEnv.IsDefEq.lamDF + hdomainTyped hbodyTyped).toU + · intro _ _ _ + trivial + · rename_i name1 bi1 ty1 body1 info1 ty1V body1V + hty1Type hbody1Type hty1 hbody1 name2 bi2 ty2 body2 info2 + ty2V body2V hty2Type hbody2Type hty2 hbody2 + obtain ⟨hty1Support, hbody1Resources⟩ := + hresources.forallE haSupport + obtain ⟨hty2Support, hbody2Resources⟩ := + hresources.forallE hbSupport + apply RecM.WF.mono + (RecM.WF.withInv <| quickBinder_wf theory hcollision + { left := hbody1Resources name1 + right := hbody2Resources name1 } + hty1Support hty2Support hty1Type hty1 hty2 hbody1 hbody2) + · intro answer final hpost hanswer + rcases hpost with ⟨hI, hsemantic⟩ + rcases hsemantic hanswer with ⟨hdomainEq, hbodyEq⟩ + have hDelta : KVLCtx.WF world.venv uvars Delta := hI.2.1.wf + obtain ⟨domainLevel, hty1Sort⟩ := hty1Type + have hdomainTyped : world.venv.IsDefEq uvars Delta.toCtx + ty1V ty2V (.sort domainLevel) := + hdomainEq.of_l world.venvWF hDelta.toCtx hty1Sort + have hDeltaBody : KVLCtx.WF world.venv uvars + ((none, .vlam ty1V) :: Delta) := + ⟨hDelta, nofun, ⟨domainLevel, hty1Sort⟩⟩ + obtain ⟨bodyLevel, hbody1Sort⟩ := hbody1Type + have hbodyTyped : world.venv.IsDefEq uvars + (ty1V :: Delta.toCtx) body1V body2V (.sort bodyLevel) := + hbodyEq.of_l world.venvWF hDeltaBody.toCtx (by + simpa [KVLCtx.toCtx] using hbody1Sort) + exact (Lean4Lean.VEnv.IsDefEq.forallEDF + hdomainTyped hbodyTyped).toU + · intro _ _ _ + trivial + +namespace DefEqAfterQuick + +/-- Semantic contract for the production-owned tail after Tier 1 misses. +Later tier modules refine and discharge this boundary; keeping it generic in +the cache semantics lets the structural proof be reused at the final K2 +stack. -/ +def WF (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ {Delta s a b aV bV}, + support a → support b → + TrKExprS world.venv uvars world.nameOf trProj Delta a aV → + TrKExprS world.venv uvars world.nameOf trProj Delta b bV → + RecM.WF layer semantics trProj world support uvars Delta s + (isDefEqInnerAfterQuick a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx aV bV) + +/-- Tier 1 plus a verified tail establishes the complete recursive-inner +contract. This theorem follows the exact production seam: a successful +quick result exits immediately, while a miss delegates to the remaining +tiers in the quick comparison's post-state. -/ +theorem closesInner + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hsorts : SortComponentResources support) + (hresources : QuickDefEqResources support) + (htail : WF layer semantics trProj world support uvars) : + ∀ {Delta s a b aV bV}, + support a → support b → + TrKExprS world.venv uvars world.nameOf trProj Delta a aV → + TrKExprS world.venv uvars world.nameOf trProj Delta b bV → + RecM.WF layer semantics trProj world support uvars Delta s + (isDefEqInner a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx aV bV) := by + intro Delta s a b aV bV haSupport hbSupport ha hb + unfold isDefEqInner + apply RecM.WF.bind + (quickDefEq_wf theory hcollision hsorts hresources + haSupport hbSupport ha hb) + intro quick afterQuick hquick + cases quick with + | false => + simp only [Bool.false_eq_true, if_false] + exact htail haSupport hbSupport ha hb + | true => + simp only [if_true] + exact RecM.WF.pure fun _ _ => hquick rfl + +end DefEqAfterQuick + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq/StructuralCongruence.lean b/Ix/Tc/Verify/DefEq/StructuralCongruence.lean new file mode 100644 index 000000000..08b130443 --- /dev/null +++ b/Ix/Tc/Verify/DefEq/StructuralCongruence.lean @@ -0,0 +1,148 @@ +import Ix.Tc.Verify.DefEq.SameHeadSpine + +/-! +# Post-delta structural congruence + +This helper recognizes equal constant instances and de Bruijn variables +directly. Matching projections delegate to the bounded projection-delta +loop through an exact contract over the concrete projected sources. All +other shapes and all failed guards return `false` without a completeness +claim. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Finite universe support for constant nodes selected by structural +congruence. -/ +structure StructuralCongruenceResources (support : RunSupport) : Prop where + universes : ∀ {id : KId .anon} {levels : Array (KUniv .anon)} + {info : ExprInfo .anon}, + support (.const id levels info) → + ∀ level, level ∈ levels.toList → + support.univ level ∧ level.size < UInt64.size + +namespace RecM + +/-- Soundness boundary for the exact bounded projection-delta helper. The +contract is indexed by translations of the two concrete projection nodes; +it cannot authorize an unrelated projection or field. -/ +def LazyDeltaProjReduction.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state id field left right leftInfo rightInfo leftV rightV}, + support (.prj id field left leftInfo) → + support (.prj id field right rightInfo) → + TrKExprS world.venv uvars world.nameOf trProj Delta + (.prj id field left leftInfo) leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta + (.prj id field right rightInfo) rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (lazyDeltaProjReduction id field left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Exact positive-result contract for `tryStructuralCongruence`. -/ +def TryStructuralCongruence.WFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta state left right leftV rightV}, + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + RecM.WF layer semantics trProj world support uvars Delta state + (tryStructuralCongruence left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +/-- Exhaustive execution proof of post-delta structural congruence. -/ +theorem tryStructuralCongruence_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {state : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr} + (theory : WhnfTheory trProj world uvars) + (collision : support.CollisionFree) + (resources : StructuralCongruenceResources support) + (projection : LazyDeltaProjReduction.WFAt layer semantics trProj world + support uvars) + (hleftSupport : support left) (hrightSupport : support right) + (hleft : TrKExprS world.venv uvars world.nameOf trProj Delta left leftV) + (hright : TrKExprS world.venv uvars world.nameOf trProj Delta right + rightV) : + RecM.WF layer semantics trProj world support uvars Delta state + (tryStructuralCongruence left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) := by + cases left <;> cases right <;> simp only [tryStructuralCongruence] + all_goals + first + | exact RecM.WF.pure fun _ h => by contradiction + | skip + · rename_i leftIdx leftName leftInfo rightIdx rightName rightInfo + exact RecM.WF.pure fun hI hanswer => by + have hidx : leftIdx = rightIdx := eq_of_beq hanswer + subst rightIdx + have hleftWF := hleft.wf world.venvWF.ordered theory.literalWF + theory.projections.wf hI.2.1.wf + cases hleft with + | var hleftLookup => + cases hright with + | var hrightLookup => + have hp := Option.some.inj + (hleftLookup.symm.trans hrightLookup) + have hvalue : leftV = rightV := congrArg Prod.fst hp + subst rightV + exact Lean4Lean.VEnv.IsDefEqU.refl hleftWF + · rename_i leftId leftLevels leftInfo rightId rightLevels rightInfo + exact RecM.WF.pure fun _ hanswer => by + obtain ⟨hid, hlevels⟩ := Bool.and_eq_true_iff.mp hanswer + exact constantHeadsDefEq collision + (resources.universes hleftSupport) + (resources.universes hrightSupport) + hleft hright hid hlevels + · rename_i leftId leftField leftValue leftInfo rightId rightField + rightValue rightInfo + cases hguard : + (leftId.addr != rightId.addr || leftField != rightField) with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ h => by contradiction + | false => + simp only [Bool.false_eq_true, if_false] + obtain ⟨hid, hfield⟩ := Bool.or_eq_false_iff.mp hguard + have hid' : leftId = rightId := + KId.anon_eq_of_addr_eq <| eq_of_beq + (show (leftId.addr == rightId.addr) = true by simpa using hid) + have hfield' : leftField = rightField := eq_of_beq + (show (leftField == rightField) = true by simpa using hfield) + subst rightId + subst rightField + exact projection hleftSupport hrightSupport hleft hright + +namespace TryStructuralCongruence + +/-- Package the exhaustive helper proof for the stopped lazy-delta +continuation. -/ +theorem ofResources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + (collision : support.CollisionFree) + (resources : StructuralCongruenceResources support) + (projection : LazyDeltaProjReduction.WFAt layer semantics trProj world + support uvars) : + TryStructuralCongruence.WFAt layer semantics trProj world support + uvars := by + intro Delta state left right leftV rightV hleftSupport hrightSupport + hleft hright + exact tryStructuralCongruence_wf theory collision resources projection + hleftSupport hrightSupport hleft hright + +end TryStructuralCongruence + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Env.lean b/Ix/Tc/Verify/Env.lean index 3524e5e80..15dc7a04c 100644 --- a/Ix/Tc/Verify/Env.lean +++ b/Ix/Tc/Verify/Env.lean @@ -92,35 +92,6 @@ open Std (HashMap) open Lean4Lean (VExpr VLevel VEnv VConstant VConstVal VDefVal VDecl VInductDecl) -/-! ### Env-extension monotonicity of the translation - -The environment only grows during a run (lazy ingress); every -translation fact transports along `VEnv.LE` (upstream -`TrExprS.mono`). `trProj` never mentions the env, so its facts -transport for free. -/ - -theorem TrKExprS.mono {env env' : VEnv} (henv : env ≤ env') - {uvars : Nat} {nameOf : Address → Option Lean.Name} - {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} - {m : Mode} {Δ : KVLCtx} {e : KExpr m} {e' : VExpr} - (H : TrKExprS env uvars nameOf trProj Δ e e') : - TrKExprS env' uvars nameOf trProj Δ e e' := by - induction H with - | var h1 => exact .var h1 - | fvar h1 => exact .fvar h1 - | sort h1 => exact .sort h1 - | const h1 h2 h3 h4 => exact .const h1 (henv.1 h2) h3 h4 - | app h1 h2 _ _ ih1 ih2 => - exact .app (h1.mono henv) (h2.mono henv) ih1 ih2 - | lam h1 _ _ ih1 ih2 => exact .lam (h1.mono henv) ih1 ih2 - | all h1 h2 _ _ ih1 ih2 => - exact .all (h1.mono henv) (h2.mono henv) ih1 ih2 - | letE h1 _ _ _ ih1 ih2 ih3 => - exact .letE (h1.mono henv) ih1 ih2 ih3 - | prj h1 _ h3 ih => exact .prj h1 ih h3 - | nat h1 => exact .nat (h1.mono henv) - | str h1 => exact .str (h1.mono henv) - /-! ### Constant safety -/ /-- The safety level of a constant (upstream `ConstantInfo.safety`, @@ -443,7 +414,11 @@ end TrustInsert /-- Provenance for one trusted catalog id. Standalone entries retain their actual declaration-WF transition. Ambient inductive-family entries retain -the oracle's raw translation, exact Theory lookup, and constant-WF fact. -/ +the oracle's raw translation, exact Theory lookup, constant-WF fact, and every +registered recursor-rule and exact iota-pattern witnesses. Keeping both here +is important: `TrustedCatalogLog.find` is the consumer path from an admission +event to WHNF, so dropping either at this boundary would make the oracle's +rule semantics unusable after admission. -/ inductive TrustedCatalogEntry (trProj : RawProjRel) (catalog : Catalog) (nameOf : Address → Option Lean.Name) (env : VEnv) (id : KId .anon) : Prop @@ -458,6 +433,12 @@ inductive TrustedCatalogEntry (trProj : RawProjRel) (catalog : Catalog) RawInductiveConstRel env nameOf trProj id c name ci → env.constants name = some ci → ci.WF env → + (∀ ⦃rule⦄, c.HasRecursorRule rule → + RawRecursorRuleRel env nameOf trProj id c rule) → + (∀ ⦃ruleIndex rule⦄, c.RecursorRuleAt ruleIndex rule → + ∃ pattern, + RawRecursorRulePatternRel env catalog nameOf id c rule pattern ∧ + pattern.ruleIndex = ruleIndex) → TrustedCatalogEntry trProj catalog nameOf env id namespace TrustedCatalogEntry @@ -470,9 +451,12 @@ theorem mono {trProj : RawProjRel} {catalog : Catalog} cases h with | standalone hcat hraw hwf hinstalled => exact .standalone hcat (hraw.mono henv) hwf (hinstalled.trans henv) - | ambient hcat hraw hlookup hwf => + | ambient hcat hraw hlookup hwf hrules hpatterns => exact .ambient hcat (hraw.mono henv) (henv.constants hlookup) - (hwf.mono henv) + (hwf.mono henv) (fun _ hrule => (hrules hrule).mono henv) + (fun {_ _} hrule => by + obtain ⟨pattern, hpattern, hindex⟩ := hpatterns hrule + exact ⟨pattern, hpattern.mono henv, hindex⟩) /-- Both provenance cases expose the exact catalog/name/Theory lookup needed by expression translation. -/ @@ -504,9 +488,50 @@ theorem lookup {trProj : RawProjRel} {catalog : Catalog} | «opaque» _ hadd => exact ⟨_, _, _, hcat, hname, hinstalled.constants (VEnv.addConst_self hadd)⟩ - | ambient hcat hraw hlookup hwf => + | ambient hcat hraw hlookup hwf hrules hpatterns => exact ⟨_, _, _, hcat, hraw.nameEq, hlookup⟩ +/-- Recover the registered Theory equation for any concrete recursor rule +carried by this trusted entry. Standalone promotion cannot produce a +recursor declaration, so only an ambient inductive admission inhabits the +positive case. -/ +theorem recursorRule {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {env : VEnv} + {id : KId .anon} (h : TrustedCatalogEntry trProj catalog nameOf env id) + {c : KConst .anon} {rule : RecRule .anon} + (hcatalog : catalog id = some c) (hrule : c.HasRecursorRule rule) : + RawRecursorRuleRel env nameOf trProj id c rule := by + cases h with + | @standalone c' d before after hcatalog' hraw hwf hinstalled => + have hc : c' = c := Option.some.inj (hcatalog'.symm.trans hcatalog) + subst c' + cases hraw <;> exact False.elim hrule + | @ambient c' name ci hcatalog' hraw hlookup hwf hrules hpatterns => + have hc : c' = c := Option.some.inj (hcatalog'.symm.trans hcatalog) + subst c' + exact hrules hrule + +/-- Recover the exact Lean4Lean iota-pattern witness associated with a +trusted concrete recursor rule. -/ +theorem recursorPattern {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {env : VEnv} + {id : KId .anon} (h : TrustedCatalogEntry trProj catalog nameOf env id) + {c : KConst .anon} {ruleIndex : Nat} {rule : RecRule .anon} + (hcatalog : catalog id = some c) + (hrule : c.RecursorRuleAt ruleIndex rule) : + ∃ pattern, + RawRecursorRulePatternRel env catalog nameOf id c rule pattern ∧ + pattern.ruleIndex = ruleIndex := by + cases h with + | @standalone c' d before after hcatalog' hraw hwf hinstalled => + have hc : c' = c := Option.some.inj (hcatalog'.symm.trans hcatalog) + subst c' + cases hraw <;> exact False.elim hrule + | @ambient c' name ci hcatalog' hraw hlookup hwf hrules hpatterns => + have hc : c' = c := Option.some.inj (hcatalog'.symm.trans hcatalog) + subst c' + exact hpatterns hrule + end TrustedCatalogEntry /-! ### Unified trusted-constant view -/ @@ -649,6 +674,8 @@ theorem find {trProj : RawProjRel} {catalog : Catalog} · obtain ⟨c, name, ci, hcat, hraw, hlookup, hwf⟩ := oracle.translateBlock hnew exact .ambient hcat hraw hlookup hwf + (fun rule hrule => oracle.recursorFacts hnew hcat hrule) + fun {_ _} hrule => oracle.recursorPatterns hnew hcat hrule · exact (ih hold).mono oracle.envLE end TrustedCatalogLog @@ -679,6 +706,28 @@ theorem find {trProj : RawProjRel} {world : VerifyWorld} TrustedCatalogEntry trProj world.catalog world.nameOf world.venv id := TrustedCatalogLog.find h htrusted +/-- Resolve a concrete rule of a trusted recursor to the well-formed Theory +equation recorded when its ambient inductive block was admitted. -/ +theorem recursorRule {trProj : RawProjRel} {world : VerifyWorld} + (h : TrustedCatalogRel trProj world) {id : KId .anon} + {c : KConst .anon} {rule : RecRule .anon} + (htrusted : world.trusted id) (hcatalog : world.catalog id = some c) + (hrule : c.HasRecursorRule rule) : + RawRecursorRuleRel world.venv world.nameOf trProj id c rule := + (h.find htrusted).recursorRule hcatalog hrule + +/-- Resolve the exact iota-pattern semantics retained for a trusted concrete +recursor rule. -/ +theorem recursorPattern {trProj : RawProjRel} {world : VerifyWorld} + (h : TrustedCatalogRel trProj world) {id : KId .anon} + {c : KConst .anon} {ruleIndex : Nat} {rule : RecRule .anon} + (htrusted : world.trusted id) (hcatalog : world.catalog id = some c) + (hrule : c.RecursorRuleAt ruleIndex rule) : + ∃ pattern, + RawRecursorRulePatternRel world.venv world.catalog world.nameOf + id c rule pattern ∧ pattern.ruleIndex = ruleIndex := + (h.find htrusted).recursorPattern hcatalog hrule + /-- Resolve an exact catalog constant through either standalone or ambient trusted provenance. This is the whole-`KEnv`-free replacement for the consumer use of `TrKEnv.find?`. -/ @@ -714,7 +763,7 @@ theorem resolve {trProj : RawProjRel} {world : VerifyWorld} have hlookup := hinstalled.constants (VEnv.addConst_self hadd) exact ⟨_, _, hcatalog, htrusted, hname, hlookup, rfl, htype, hordered.constWF hlookup⟩ - | @ambient c' name ci hcatalog' hraw hlookup hwf => + | @ambient c' name ci hcatalog' hraw hlookup hwf hrules hpatterns => have hc : c' = c := Option.some.inj (hcatalog'.symm.trans hcatalog) subst c' exact ⟨name, ci, hcatalog, htrusted, hraw.nameEq, hlookup, diff --git a/Ix/Tc/Verify/EquivalenceManager.lean b/Ix/Tc/Verify/EquivalenceManager.lean new file mode 100644 index 000000000..c70ec6d8d --- /dev/null +++ b/Ix/Tc/Verify/EquivalenceManager.lean @@ -0,0 +1,564 @@ +import Ix.Tc.Verify.Totalization +import Ix.Tc.Verify.Expr +import Batteries.Data.Array.Lemmas +import Std.Data.HashMap.Lemmas + +/-! +# Semantic validity of the DefEq equivalence manager + +The production manager is a union-find whose reads perform path halving. +This file verifies it once against an arbitrary equivalence relation on +`EqKey`. The invariant deliberately does not depend on acyclicity or rank +correctness: the bounded `find` may stop early, but every traversed parent +edge remains semantically valid. That is sufficient for sound positive +queries, root representatives, path compression, and union. +-/ + +namespace Ix.Tc + +namespace EquivManager + +private instance : ReflBEq EqKey where + rfl := by + intro key + rcases key with ⟨exprAddr, ctxAddr, lbr, exprLbr⟩ + change ((exprAddr == exprAddr) && (ctxAddr == ctxAddr) && + (lbr == lbr) && (exprLbr == exprLbr)) = true + simp + +private instance : LawfulBEq EqKey where + eq_of_beq := by + intro left right h + rcases left with ⟨leftExpr, leftCtx, leftLbr, leftExprLbr⟩ + rcases right with ⟨rightExpr, rightCtx, rightLbr, rightExprLbr⟩ + change ((leftExpr == rightExpr) && (leftCtx == rightCtx) && + (leftLbr == rightLbr) && (leftExprLbr == rightExprLbr)) = true at h + simp only [Bool.and_eq_true] at h + have hexpr : leftExpr = rightExpr := eq_of_beq h.1.1.1 + have hctx : leftCtx = rightCtx := eq_of_beq h.1.1.2 + have hlbr : leftLbr = rightLbr := eq_of_beq h.1.2 + have hexprLbr : leftExprLbr = rightExprLbr := eq_of_beq h.2 + subst rightExpr + subst rightCtx + subst rightLbr + subst rightExprLbr + rfl + +private instance : LawfulHashable EqKey where + hash_eq left right h := by + have heq : left = right := eq_of_beq h + subst right + rfl + +private theorem Array.getElemBang_setBang + {α : Type} [Inhabited α] (xs : Array α) (i j : Nat) (v : α) + (hi : i < xs.size) (hj : j < xs.size) : + (xs.set! i v)[j]! = if i = j then v else xs[j]! := by + simp [Array.set!_eq_setIfInBounds, Array.setIfInBounds, hi, hj, + Array.getElem_set] + +private theorem Array.getElemBang_push + {α : Type} [Inhabited α] (xs : Array α) (v : α) (i : Nat) + (hi : i < (xs.push v).size) : + (xs.push v)[i]! = if h : i < xs.size then xs[i]! else v := by + by_cases h : i < xs.size + · simp [getElem!_def, Array.getElem?_push, h, Nat.ne_of_lt h] + · have hieq : i = xs.size := by + simp only [Array.size_push] at hi + omega + subst i + simp + +/-- Semantic validity of the mutable parent table against fixed node labels. +Every parent stays in bounds and every parent edge denotes the selected +equivalence relation. -/ +structure ParentSound (R : EqKey → EqKey → Prop) + (labels : Array EqKey) (parent : Array Nat) : Prop where + size_eq : labels.size = parent.size + parent_lt : ∀ {i}, i < parent.size → parent[i]! < parent.size + edge : ∀ {i}, i < parent.size → + R labels[i]! labels[parent[i]!]! + +namespace ParentSound + +/-- Relation weakening leaves the representation facts untouched. -/ +theorem mono {R S : EqKey → EqKey → Prop} {labels : Array EqKey} + {parent : Array Nat} (hRS : ∀ {a b}, R a b → S a b) + (h : ParentSound R labels parent) : ParentSound S labels parent := + ⟨h.size_eq, h.parent_lt, fun hi => hRS (h.edge hi)⟩ + +/-- One path-halving write replaces `i → parent(i)` by +`i → parent(parent(i))`; transitivity proves the new edge sound. -/ +theorem halve {R : EqKey → EqKey → Prop} (hR : Equivalence R) + {labels : Array EqKey} {parent : Array Nat} + (h : ParentSound R labels parent) {i : Nat} + (hi : i < parent.size) : + ParentSound R labels (parent.set! i parent[parent[i]!]!) := by + let p := parent[i]! + let gp := parent[p]! + have hp : p < parent.size := h.parent_lt hi + have hgp : gp < parent.size := h.parent_lt hp + have hip : R labels[i]! labels[p]! := h.edge hi + have hpgp : R labels[p]! labels[gp]! := h.edge hp + have higp : R labels[i]! labels[gp]! := hR.trans hip hpgp + refine ⟨?_, ?_, ?_⟩ + · simpa [Array.size_set!] using h.size_eq + · intro j hj + have hj' : j < parent.size := by simpa [Array.size_set!] using hj + rw [Array.getElemBang_setBang parent i j gp hi hj'] + split + · simpa only [Array.size_set!] using hgp + · simpa only [Array.size_set!] using h.parent_lt hj' + · intro j hj + have hj' : j < parent.size := by simpa [Array.size_set!] using hj + have hlabels : labels.size = parent.size := h.size_eq + rw [Array.getElemBang_setBang parent i j gp hi hj'] + split + · next hij => + subst j + exact higp + · exact h.edge hj' + +/-- Repointing one in-bounds node to an in-bounds semantically equivalent +node preserves parent-table soundness. -/ +theorem setParent {R : EqKey → EqKey → Prop} + {labels : Array EqKey} {parent : Array Nat} + (h : ParentSound R labels parent) {source target : Nat} + (hsource : source < parent.size) (htarget : target < parent.size) + (hrel : R labels[source]! labels[target]!) : + ParentSound R labels (parent.set! source target) := by + refine ⟨?_, ?_, ?_⟩ + · simpa only [Array.size_set!] using h.size_eq + · intro i hi + have hi' : i < parent.size := by + simpa only [Array.size_set!] using hi + rw [Array.getElemBang_setBang parent source i target hsource hi'] + split + · simpa only [Array.size_set!] using htarget + · simpa only [Array.size_set!] using h.parent_lt hi' + · intro i hi + have hi' : i < parent.size := by + simpa only [Array.size_set!] using hi + rw [Array.getElemBang_setBang parent source i target hsource hi'] + split + · next heq => + subst i + exact hrel + · exact h.edge hi' + +/-- The bounded path-halving loop preserves all parent-edge meanings and +relates its input node to the node it returns, even on fuel exhaustion. -/ +theorem findGo + {R : EqKey → EqKey → Prop} (hR : Equivalence R) + (labels : Array EqKey) (fuel : Nat) (parent : Array Nat) (node : Nat) + (h : ParentSound R labels parent) (hnode : node < parent.size) : + let result := EquivManager.find.go parent node fuel + ParentSound R labels result.2 ∧ + result.1 < result.2.size ∧ + R labels[node]! labels[result.1]! := by + induction fuel generalizing parent node with + | zero => + simp only [EquivManager.find_go_zero] + exact ⟨h, hnode, hR.refl _⟩ + | succ fuel ih => + rw [EquivManager.find_go_succ] + split + · let p := parent[node]! + let gp := parent[p]! + let parent' := parent.set! node gp + have hp : p < parent.size := h.parent_lt hnode + have hgp : gp < parent.size := h.parent_lt hp + have hparent' : ParentSound R labels parent' := h.halve hR hnode + have hsize : parent'.size = parent.size := by + simp [parent', Array.size_set!] + have hgp' : gp < parent'.size := by simpa [hsize] + have hread : parent'[node]! = gp := by + rw [Array.getElemBang_setBang parent node node gp hnode hnode] + simp + have hnext : parent'[node]! < parent'.size := by simpa [hread] + have hstep : R labels[node]! labels[parent'[node]!]! := by + exact hparent'.edge (by simpa [hsize] using hnode) + have hrec := ih parent' parent'[node]! hparent' hnext + rcases out : EquivManager.find.go parent' parent'[node]! fuel with + ⟨root, finalParent⟩ + rw [out] at hrec + exact ⟨hrec.1, hrec.2.1, hR.trans hstep hrec.2.2⟩ + · exact ⟨h, hnode, hR.refl _⟩ + +end ParentSound + +@[simp] theorem find_keyToNode (em : EquivManager) (node : Nat) : + (em.find node).2.keyToNode = em.keyToNode := by + rw [EquivManager.find_equation] + +@[simp] theorem find_nodeToKey (em : EquivManager) (node : Nat) : + (em.find node).2.nodeToKey = em.nodeToKey := by + rw [EquivManager.find_equation] + +@[simp] theorem find_rank (em : EquivManager) (node : Nat) : + (em.find node).2.rank = em.rank := by + rw [EquivManager.find_equation] + +/-- Allocating a key never changes an existing node label. -/ +theorem nodeForKey_oldLabel (em : EquivManager) (key : EqKey) + {i : Nat} (hi : i < em.nodeToKey.size) : + (em.nodeForKey key).2.nodeToKey[i]! = em.nodeToKey[i]! := by + unfold EquivManager.nodeForKey + split + · rfl + · rw [Array.getElemBang_push em.nodeToKey key i + (by simpa using Nat.lt_succ_of_lt hi)] + simp only [hi, ↓reduceDIte] + +/-- Allocating a key preserves the bounds of every existing parent node. -/ +theorem nodeForKey_oldBound (em : EquivManager) (key : EqKey) + {i : Nat} (hi : i < em.parent.size) : + i < (em.nodeForKey key).2.parent.size := by + unfold EquivManager.nodeForKey + split + · exact hi + · simp only [Array.size_push] + exact Nat.lt_succ_of_lt hi + +/-- Complete representation invariant for the concrete manager. Hash-map +lookups resolve to in-bounds nodes carrying the queried key; the parent table +is semantically sound with respect to those immutable labels. -/ +structure WF (R : EqKey → EqKey → Prop) (em : EquivManager) : Prop where + parents : ParentSound R em.nodeToKey em.parent + keyToNode : ∀ {key node}, em.keyToNode[key]? = some node → + node < em.parent.size ∧ em.nodeToKey[node]! = key + +namespace WF + +/-- The empty manager represents every equivalence relation. -/ +theorem empty {R : EqKey → EqKey → Prop} : WF R EquivManager.empty := by + refine ⟨?_, ?_⟩ + · refine ⟨rfl, ?_, ?_⟩ <;> + simp [EquivManager.empty] + · simp [EquivManager.empty] + +/-- Resetting the manager restores the empty invariant. -/ +theorem clear {R : EqKey → EqKey → Prop} (em : EquivManager) : + WF R em.clear := by + simpa [EquivManager.clear] using (empty (R := R)) + +/-- Pointwise strengthening of the semantic relation preserves manager +validity. -/ +theorem mono {R S : EqKey → EqKey → Prop} {em : EquivManager} + (hRS : ∀ {a b}, R a b → S a b) (h : WF R em) : WF S em := + ⟨h.parents.mono hRS, h.keyToNode⟩ + +/-- One justified parent-link update preserves the complete manager +representation. -/ +theorem setParent {R : EqKey → EqKey → Prop} {em : EquivManager} + (h : WF R em) {source target : Nat} + (hsource : source < em.parent.size) (htarget : target < em.parent.size) + (hrel : R em.nodeToKey[source]! em.nodeToKey[target]!) : + WF R {em with parent := em.parent.set! source target} := by + refine ⟨h.parents.setParent hsource htarget hrel, ?_⟩ + intro key node hlookup + have hold := h.keyToNode hlookup + exact ⟨by simpa only [Array.size_set!] using hold.1, hold.2⟩ + +/-- `find` performs only sound path-halving writes. Its returned node is in +bounds and semantically related to the requested node. -/ +theorem find {R : EqKey → EqKey → Prop} (hR : Equivalence R) + {em : EquivManager} (h : WF R em) {node : Nat} + (hnode : node < em.parent.size) : + let result := em.find node + WF R result.2 ∧ result.1 < result.2.parent.size ∧ + R em.nodeToKey[node]! result.2.nodeToKey[result.1]! := by + rw [EquivManager.find_equation] + have hgo := ParentSound.findGo hR em.nodeToKey em.parent.size em.parent + node h.parents hnode + rcases out : EquivManager.find.go em.parent node em.parent.size with + ⟨root, parent⟩ + rw [out] at hgo + have hparentSize : parent.size = em.parent.size := by + rw [← hgo.1.size_eq, ← h.parents.size_eq] + have hkeyToNode : ∀ {key node}, em.keyToNode[key]? = some node → + node < parent.size ∧ em.nodeToKey[node]! = key := by + intro key node hlookup + have hold := h.keyToNode hlookup + exact ⟨by simpa [hparentSize] using hold.1, hold.2⟩ + exact ⟨⟨hgo.1, hkeyToNode⟩, hgo.2.1, hgo.2.2⟩ + +/-- Looking up an existing key leaves the manager unchanged; allocating a +new key appends one reflexive root and records its exact reverse label. -/ +theorem nodeForKey {R : EqKey → EqKey → Prop} (hR : Equivalence R) + {em : EquivManager} (h : WF R em) (key : EqKey) : + let result := em.nodeForKey key + WF R result.2 ∧ result.1 < result.2.parent.size ∧ + result.2.nodeToKey[result.1]! = key := by + unfold EquivManager.nodeForKey + split + · next node hlookup => + have hnode := h.keyToNode hlookup + exact ⟨h, hnode.1, hnode.2⟩ + · next hmissing => + let node := em.parent.size + let em' : EquivManager := { + em with + parent := em.parent.push node + rank := em.rank.push 0 + nodeToKey := em.nodeToKey.push key + keyToNode := em.keyToNode.insert key node } + have hlabelSize : em.nodeToKey.size = em.parent.size := + h.parents.size_eq + have hparents : ParentSound R em'.nodeToKey em'.parent := by + refine ⟨?_, ?_, ?_⟩ + · simp [em', hlabelSize] + · intro i hi + simp only [em', Array.size_push] at hi ⊢ + rw [Array.getElemBang_push em.parent node i (by simpa using hi)] + split + · exact Nat.lt_succ_of_lt (h.parents.parent_lt ‹_›) + · simpa [node] using hi + · intro i hi + simp only [em', Array.size_push] at hi + change R (em.nodeToKey.push key)[i]! + (em.nodeToKey.push key)[(em.parent.push node)[i]!]! + have hparentRead := Array.getElemBang_push em.parent node i + (by simpa using hi) + rw [hparentRead] + split + · next hiOld => + have hlabelsRead := Array.getElemBang_push em.nodeToKey key i + (by simpa [hlabelSize] using hi) + rw [hlabelsRead] + simp only [show i < em.nodeToKey.size by + simpa [hlabelSize] using hiOld, ↓reduceDIte] + have hp := h.parents.parent_lt hiOld + have hpLabel : em.parent[i]! < em.nodeToKey.size := by + simpa [hlabelSize] using hp + have hparentLabel := Array.getElemBang_push em.nodeToKey key + em.parent[i]! (by + simpa using Nat.lt_succ_of_lt hpLabel) + rw [hparentLabel] + simp only [hpLabel, ↓reduceDIte] + exact h.parents.edge hiOld + · next hiOld => + have hieq : i = node := by + simp only [node] at hiOld ⊢ + omega + subst i + simp [em', node, hlabelSize, hR.refl] + refine ⟨⟨hparents, ?_⟩, ?_, ?_⟩ + · intro other otherNode hlookup + rw [Std.HashMap.getElem?_insert] at hlookup + split at hlookup + · next heq => + have hkey : key = other := eq_of_beq heq + subst other + cases hlookup + constructor + · simp [em', node] + · have hlast := Array.getElemBang_push em.nodeToKey key + em.parent.size (by simp [hlabelSize]) + have hnot : ¬em.parent.size < em.nodeToKey.size := by + omega + simp only [hnot, ↓reduceDIte] at hlast + exact hlast + · next hne => + have hold := h.keyToNode hlookup + have holdLabel : otherNode < em.nodeToKey.size := by + simpa [hlabelSize] using hold.1 + constructor + · simpa [em'] using Nat.lt_succ_of_lt hold.1 + · rw [Array.getElemBang_push em.nodeToKey key otherNode] + · simp only [holdLabel, ↓reduceDIte] + exact hold.2 + · simpa [em', hlabelSize] using Nat.lt_succ_of_lt hold.1 + · simp only [Array.size_push] + omega + · have hlast := Array.getElemBang_push em.nodeToKey key + em.parent.size (by simp [hlabelSize]) + have hnot : ¬em.parent.size < em.nodeToKey.size := by + omega + simp only [hnot, ↓reduceDIte] at hlast + simpa only using hlast + +/-- Union by rank preserves validity once the two requested nodes are known +semantically equivalent. -/ +theorem union {R : EqKey → EqKey → Prop} (hR : Equivalence R) + {em : EquivManager} (h : WF R em) {a b : Nat} + (ha : a < em.parent.size) (hb : b < em.parent.size) + (hab : R em.nodeToKey[a]! em.nodeToKey[b]!) : + WF R (em.union a b).2 := by + unfold EquivManager.union + have hfindA := h.find hR ha + rcases hfa : em.find a with ⟨ra, em1⟩ + rw [hfa] at hfindA + have hlabels1 : em1.nodeToKey = em.nodeToKey := by + have hframe := EquivManager.find_nodeToKey em a + rw [hfa] at hframe + exact hframe + have hb1 : b < em1.parent.size := by + rw [← hfindA.1.parents.size_eq, hlabels1, h.parents.size_eq] + exact hb + have hfindB := hfindA.1.find hR hb1 + rcases hfb : em1.find b with ⟨rb, em2⟩ + rw [hfb] at hfindB + have hlabels2 : em2.nodeToKey = em1.nodeToKey := by + have hframe := EquivManager.find_nodeToKey em1 b + rw [hfb] at hframe + exact hframe + have hra : R em.nodeToKey[a]! em.nodeToKey[ra]! := by + simpa [hlabels1] using hfindA.2.2 + have hrb : R em.nodeToKey[b]! em.nodeToKey[rb]! := by + simpa [hlabels1, hlabels2] using hfindB.2.2 + have hroots : R em2.nodeToKey[ra]! em2.nodeToKey[rb]! := by + rw [hlabels2, hlabels1] + exact hR.trans (hR.symm hra) (hR.trans hab hrb) + simp only [hfa, hfb] + split + · simpa using hfindB.1 + · simp only [Id.run, pure_bind] + have hraBound : ra < em2.parent.size := by + rw [← hfindB.1.parents.size_eq, hlabels2, + hfindA.1.parents.size_eq] + exact hfindA.2.1 + have hrbBound : rb < em2.parent.size := hfindB.2.1 + split + · exact hfindB.1.setParent hraBound hrbBound hroots + · split + · exact hfindB.1.setParent hrbBound hraBound (hR.symm hroots) + · have hlinked := hfindB.1.setParent hrbBound hraBound + (hR.symm hroots) + exact ⟨hlinked.parents, hlinked.keyToNode⟩ + +/-- A positive equivalence query is justified by the selected relation, and +path halving preserves the manager invariant on either Boolean result. -/ +theorem isEquiv {R : EqKey → EqKey → Prop} (hR : Equivalence R) + {em : EquivManager} (h : WF R em) (k1 k2 : EqKey) : + let result := em.isEquiv k1 k2 + WF R result.2 ∧ (result.1 = true → R k1 k2) := by + unfold EquivManager.isEquiv + split + · next hsame => + refine ⟨h, fun _ => ?_⟩ + have heq : k1 = k2 := eq_of_beq hsame + subst k2 + exact hR.refl _ + · next hne => + cases hmap1 : em.keyToNode[k1]? with + | none => simp [hmap1, h] + | some n1 => + cases hmap2 : em.keyToNode[k2]? with + | none => simp [hmap1, hmap2, h] + | some n2 => + simp only [hmap1, hmap2] + have hn1 := h.keyToNode hmap1 + have hn2 := h.keyToNode hmap2 + have hfind1 := h.find hR hn1.1 + rcases hf1 : em.find n1 with ⟨r1, em1⟩ + rw [hf1] at hfind1 + have hlabels1 : em1.nodeToKey = em.nodeToKey := by + have hframe := EquivManager.find_nodeToKey em n1 + rw [hf1] at hframe + exact hframe + have hn2' : n2 < em1.parent.size := by + rw [← hfind1.1.parents.size_eq, hlabels1, + h.parents.size_eq] + exact hn2.1 + have hfind2 := hfind1.1.find hR hn2' + rcases hf2 : em1.find n2 with ⟨r2, em2⟩ + rw [hf2] at hfind2 + simp only [hf1, hf2] + refine ⟨hfind2.1, fun hroots => ?_⟩ + have hr : r1 = r2 := eq_of_beq hroots + have hk1 : R k1 em.nodeToKey[r1]! := by + rw [← hn1.2] + simpa [hlabels1] using hfind1.2.2 + have hlabels2 : em2.nodeToKey = em1.nodeToKey := by + have hframe := EquivManager.find_nodeToKey em1 n2 + rw [hf2] at hframe + exact hframe + have hk2 : R k2 em.nodeToKey[r2]! := by + rw [← hn2.2] + simpa [hlabels1, hlabels2] using hfind2.2.2 + subst r2 + exact hR.trans hk1 (hR.symm hk2) + +/-- A returned representative is related to the queried key. -/ +theorem findRootKey {R : EqKey → EqKey → Prop} (hR : Equivalence R) + {em : EquivManager} (h : WF R em) (key : EqKey) : + let result := em.findRootKey key + WF R result.2 ∧ + ∀ rootKey, result.1 = some rootKey → R key rootKey := by + unfold EquivManager.findRootKey + cases hmap : em.keyToNode[key]? with + | none => simp [h] + | some node => + simp only + have hnode := h.keyToNode hmap + have hfind := h.find hR hnode.1 + rcases hf : em.find node with ⟨root, em1⟩ + rw [hf] at hfind + simp only [hf] + refine ⟨hfind.1, ?_⟩ + intro rootKey hroot + have hrootBound : root < em1.nodeToKey.size := by + rw [hfind.1.parents.size_eq] + exact hfind.2.1 + have hrootLabel : em1.nodeToKey[root]! = rootKey := by + simpa [getElem!_def, hrootBound] using hroot + have hrel : R key em1.nodeToKey[root]! := by + rw [← hnode.2] + exact hfind.2.2 + simpa [hrootLabel] using hrel + +/-- Two sequential representative lookups preserve validity and relate each +optional representative to its own queried key. This is the exact pure +operation used by DefEq's root-cache second chance. -/ +theorem findRootKeys {R : EqKey → EqKey → Prop} (hR : Equivalence R) + {em : EquivManager} (h : WF R em) (left right : EqKey) : + let result := + let (leftRoot, em) := em.findRootKey left + let (rightRoot, em) := em.findRootKey right + ((leftRoot, rightRoot), em) + WF R result.2 ∧ + (∀ root, result.1.1 = some root → R left root) ∧ + (∀ root, result.1.2 = some root → R right root) := by + have hleft := h.findRootKey hR left + rcases hleftRun : em.findRootKey left with ⟨leftRoot, em1⟩ + rw [hleftRun] at hleft + have hright := hleft.1.findRootKey hR right + rcases hrightRun : em1.findRootKey right with ⟨rightRoot, em2⟩ + rw [hrightRun] at hright + simp only [hleftRun, hrightRun] + exact ⟨hright.1, hleft.2, hright.2⟩ + +/-- Recording one already-justified equivalence preserves manager validity. -/ +theorem addEquiv {R : EqKey → EqKey → Prop} (hR : Equivalence R) + {em : EquivManager} (h : WF R em) {k1 k2 : EqKey} + (hk : R k1 k2) : WF R (em.addEquiv k1 k2) := by + unfold EquivManager.addEquiv + have hnode1 := h.nodeForKey hR k1 + rcases hn1 : em.nodeForKey k1 with ⟨n1, em1⟩ + rw [hn1] at hnode1 + have hnode2 := hnode1.1.nodeForKey hR k2 + rcases hn2 : em1.nodeForKey k2 with ⟨n2, em2⟩ + rw [hn2] at hnode2 + have hn1LabelBound : n1 < em1.nodeToKey.size := by + rw [hnode1.1.parents.size_eq] + exact hnode1.2.1 + have hn1Label : em2.nodeToKey[n1]! = k1 := by + have hframe := EquivManager.nodeForKey_oldLabel em1 k2 hn1LabelBound + rw [hn2] at hframe + exact hframe.trans hnode1.2.2 + have hnodes : R em2.nodeToKey[n1]! em2.nodeToKey[n2]! := by + rw [hn1Label, hnode2.2.2] + exact hk + have hn1Bound2 : n1 < em2.parent.size := by + have hframe := EquivManager.nodeForKey_oldBound em1 k2 hnode1.2.1 + rw [hn2] at hframe + exact hframe + simpa only [hn1, hn2] using + hnode2.1.union hR hn1Bound2 hnode2.2.1 hnodes + +end WF + +end EquivManager + +end Ix.Tc diff --git a/Ix/Tc/Verify/Execution.lean b/Ix/Tc/Verify/Execution.lean index 929e4df63..af5a00132 100644 --- a/Ix/Tc/Verify/Execution.lean +++ b/Ix/Tc/Verify/Execution.lean @@ -72,6 +72,9 @@ inductive ExecutionRequests : {α : Type} → (us : Array (KUniv .anon)) : ExecutionRequests (TcM.instantiateUnivParams e us) s [.instUniv e us] + | cheapBeta (s : TcState .anon) (e : KExpr .anon) : + ExecutionRequests (TcM.runIntern (cheapBetaReduce e)) s + [.cheapBeta e] | bind {s : TcState .anon} {x : TcM .anon α} {f : α → TcM .anon β} {before after : List WalkerRequest} @@ -129,7 +132,7 @@ theorem intern_eq_of_nil {α : Type} {x : TcM .anon α} | set initial target hintern => exact hintern | modifyGet s f hintern => exact hintern | internExpr | internUniv | lift | subst | simulSubst | instRev | - abstractFVars | instUniv => + abstractFVars | instUniv | cheapBeta => exact absurd hnil (by simp) | bind hx hf ihx ihf => rename_i s x f before after diff --git a/Ix/Tc/Verify/Inductive.lean b/Ix/Tc/Verify/Inductive.lean index 6f911f167..567851e24 100644 --- a/Ix/Tc/Verify/Inductive.lean +++ b/Ix/Tc/Verify/Inductive.lean @@ -1,4 +1,6 @@ import Ix.Tc.Verify.Decl +import Ix.Tc.Verify.Trans +import Lean4Lean.Theory.Typing.Pattern /-! # Ambient inductive oracle @@ -41,12 +43,134 @@ def KConst.HasRecursorRule (c : KConst .anon) (rule : RecRule .anon) : Prop := | .recr (rules := rules) .. => rule ∈ rules | _ => False +/-- Major-argument position used by the production iota reducer. The +`UInt64` additions intentionally occur before `toNat`; recursor validation +must rule out overflow rather than this view silently changing runtime +indexing to mathematical addition. -/ +def KConst.RecursorMajorIdx : KConst .anon → Option Nat + | .recr (params := params) (motives := motives) (minors := minors) + (indices := indices) .. => + some ((params + motives + minors + indices).toNat) + | _ => none + +/-- The descriptor-only Nat fast path and the ordinary iota reducer must +select the same major argument. The former converts each count to `Nat` +before adding, while the latter performs wrapping `UInt64` additions first. +This predicate is therefore the exact no-overflow obligation needed to move +between those two production computations. -/ +def KConst.RecursorMajorIdxCoherent : KConst .anon → Prop + | .recr (params := params) (motives := motives) (minors := minors) + (indices := indices) .. => + (params + motives + minors + indices).toNat = + params.toNat + motives.toNat + minors.toNat + indices.toNat + | _ => False + +/-- Exact positional membership of a concrete recursor rule. Unlike +`HasRecursorRule`, this retains the constructor dispatch index. -/ +def KConst.RecursorRuleAt (c : KConst .anon) (index : Nat) + (rule : RecRule .anon) : Prop := + match c with + | .recr (rules := rules) .. => rules[index]? = some rule + | _ => False + +namespace KConst.RecursorRuleAt + +/-- Positional rule evidence implies ordinary array membership while +retaining the stronger dispatch index for consumers that need it. -/ +theorem hasRecursorRule {c : KConst .anon} {index : Nat} + {rule : RecRule .anon} (h : c.RecursorRuleAt index rule) : + c.HasRecursorRule rule := by + cases c <;> simp only [KConst.RecursorRuleAt] at h + case recr rules => + exact Array.mem_of_getElem? h + +end KConst.RecursorRuleAt + +/-- Constructor metadata relevant to iota pattern matching. -/ +def KConst.ConstructorAt (c : KConst .anon) (index : Nat) + (params fields : UInt64) : Prop := + match c with + | .ctor (cidx := cidx) (params := actualParams) + (fields := actualFields) .. => + cidx.toNat = index ∧ actualParams = params ∧ actualFields = fields + | _ => False + /-- A Theory expression is an application spine headed by `name`. -/ inductive HeadConst (name : Lean.Name) : VExpr → Prop | const (levels : List Lean4Lean.VLevel) : HeadConst name (.const name levels) | app {fn arg : VExpr} : HeadConst name fn → HeadConst name (.app fn arg) +/-- An application spine has exactly `arity` arguments above a constant +head. This is the counted form needed to distinguish an iota major from an +arbitrary later occurrence of the same constructor. -/ +inductive HeadConstN (name : Lean.Name) : Nat → VExpr → Prop + | const (levels : List Lean4Lean.VLevel) : + HeadConstN name 0 (.const name levels) + | app {arity : Nat} {fn arg : VExpr} : + HeadConstN name arity fn → HeadConstN name (arity + 1) (.app fn arg) + +namespace HeadConstN + +/-- Matching `varN (const name) arity` exposes exactly that many application +arguments over `name`. -/ +theorem of_varN_matches {name : Lean.Name} {arity : Nat} {source : VExpr} + {levels : List Lean4Lean.VLevel} + {captures : ((Lean4Lean.Pattern.const name).varN arity).Path → VExpr} + (h : Lean4Lean.Pattern.Matches + ((Lean4Lean.Pattern.const name).varN arity) + source levels captures) : + HeadConstN name arity source := by + induction arity generalizing source with + | zero => + change Lean4Lean.Pattern.Matches (.const name) + source levels captures at h + cases h + exact .const levels + | succ arity ih => + change Lean4Lean.Pattern.Matches + (.var ((Lean4Lean.Pattern.const name).varN arity)) + source levels captures at h + cases h with + | var hprefix => + simpa [Nat.add_comm, Nat.add_left_comm, Nat.add_assoc] using + HeadConstN.app (ih hprefix) + +end HeadConstN + +/-- Exact Theory pattern selected by an ordinary constructor iota rule. -/ +def RecursorIotaPattern (recursorName : Lean.Name) (majorIdx : Nat) + (constructorName : Lean.Name) (constructorArgs : Nat) : + Lean4Lean.Pattern := + (Lean4Lean.SimplePattern.iota recursorName majorIdx constructorName + constructorArgs).toPattern + +namespace RecursorIotaPattern + +/-- Invert an iota-pattern match into its exact recursor and constructor +application arities. The final application is the major: `recursorPrefix` +contains precisely the parameters/motives/minors/indices before it. -/ +theorem matches_shape + {recursorName constructorName : Lean.Name} + {majorIdx constructorArgs : Nat} {source : VExpr} + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern recursorName majorIdx constructorName + constructorArgs).Path → VExpr} + (h : Lean4Lean.Pattern.Matches + (RecursorIotaPattern recursorName majorIdx constructorName + constructorArgs) source levels captures) : + ∃ recursorPrefix major, + source = .app recursorPrefix major ∧ + HeadConstN recursorName majorIdx recursorPrefix ∧ + HeadConstN constructorName constructorArgs major := by + simp only [RecursorIotaPattern, Lean4Lean.SimplePattern.toPattern] at h + cases h with + | app hrecursor hconstructor => + exact ⟨_, _, rfl, HeadConstN.of_varN_matches hrecursor, + HeadConstN.of_varN_matches hconstructor⟩ + +end RecursorIotaPattern + /-- Raw translation of one constant supplied by an ambient inductive block. There is intentionally no block-typing derivation here; that semantic fact is the oracle boundary. -/ @@ -71,36 +195,171 @@ theorem mono {env env' : VEnv} (henv : env ≤ env') end RawInductiveConstRel -/-- Semantic evidence for one concrete recursor rule. The registered Theory -defeq is well-formed, its left side is headed by the translated recursor, and -its right side is the raw translation of the concrete rule body. K1 will -refine the exact argument-spine correspondence used by reduction. -/ -def RawRecursorRuleRel (env : VEnv) +/-- Semantic evidence for one concrete recursor rule and one particular +registered Theory equation. The raw relation preserves admission syntax; +the structural relation additionally proves that the same closed rule body +is typed at the equation's universe arity. Keeping both prevents an +untyped/raw translation from being passed to the verified universe +instantiator as though it were `TrKExprS`. -/ +def RegisteredRecursorRuleRhsRel (env : VEnv) (nameOf : Address → Option Lean.Name) (trProj : RawProjRel) - (id : KId .anon) (c : KConst .anon) (rule : RecRule .anon) : Prop := - ∃ name constant defeq, + (id : KId .anon) (c : KConst .anon) (rule : RecRule .anon) + (defeq : VDefEq) : Prop := + ∃ name constant, RawInductiveConstRel env nameOf trProj id c name constant ∧ env.constants name = some constant ∧ env.defeqs defeq ∧ defeq.WF env ∧ HeadConst name defeq.lhs ∧ - RawExprRel env nameOf trProj [] rule.rhs defeq.rhs + RawExprRel env nameOf trProj [] rule.rhs defeq.rhs ∧ + TrKExprS env defeq.uvars nameOf trProj [] rule.rhs defeq.rhs + +/-- Existential rule-level form retained by the inductive oracle and trusted +catalog log. -/ +def RawRecursorRuleRel (env : VEnv) + (nameOf : Address → Option Lean.Name) (trProj : RawProjRel) + (id : KId .anon) (c : KConst .anon) (rule : RecRule .anon) : Prop := + ∃ defeq, RegisteredRecursorRuleRhsRel env nameOf trProj id c rule defeq + +namespace RegisteredRecursorRuleRhsRel + +/-- A fixed registered RHS certificate survives trusted-world extension. -/ +theorem mono {env env' : VEnv} (henv : env ≤ env') + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {id : KId .anon} {c : KConst .anon} {rule : RecRule .anon} + {defeq : VDefEq} + (h : RegisteredRecursorRuleRhsRel env nameOf trProj id c rule defeq) : + RegisteredRecursorRuleRhsRel env' nameOf trProj id c rule defeq := by + obtain ⟨name, constant, hraw, hlookup, hregistered, hwf, hhead, + hrhsRaw, hrhsTyped⟩ := h + exact ⟨name, constant, hraw.mono henv, henv.constants hlookup, + henv.defeqs hregistered, hwf.mono henv, hhead, hrhsRaw.mono henv, + hrhsTyped.mono henv⟩ + +/-- The registered Theory RHS really is typed. This follows independently +from the new structural translation field, but exposing both facts makes the +remaining concrete-instantiation bridge auditable. -/ +theorem rhsTyped + {env : VEnv} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {id : KId .anon} {c : KConst .anon} + {rule : RecRule .anon} {defeq : VDefEq} + (h : RegisteredRecursorRuleRhsRel env nameOf trProj id c rule defeq) : + env.HasType defeq.uvars [] defeq.rhs defeq.type := by + obtain ⟨_, _, _, _, _, hwf, _, _, _⟩ := h + exact hwf.2 + +end RegisteredRecursorRuleRhsRel namespace RawRecursorRuleRel +/-- Select the exact registered equation retained by a rule certificate. -/ +theorem registeredRhs + {env : VEnv} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {id : KId .anon} {c : KConst .anon} + {rule : RecRule .anon} + (h : RawRecursorRuleRel env nameOf trProj id c rule) : + ∃ defeq, + RegisteredRecursorRuleRhsRel env nameOf trProj id c rule defeq := h + theorem mono {env env' : VEnv} (henv : env ≤ env') {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} {id : KId .anon} {c : KConst .anon} {rule : RecRule .anon} (h : RawRecursorRuleRel env nameOf trProj id c rule) : RawRecursorRuleRel env' nameOf trProj id c rule := by - obtain ⟨name, constant, defeq, hraw, hlookup, hregistered, hwf, hhead, - hrhs⟩ := h - exact ⟨name, constant, defeq, hraw.mono henv, - henv.constants hlookup, henv.defeqs hregistered, hwf.mono henv, hhead, - hrhs.mono henv⟩ + obtain ⟨defeq, hrhs⟩ := h + exact ⟨defeq, hrhs.mono henv⟩ end RawRecursorRuleRel +/-! ### Exact recursor-pattern provenance -/ + +/- Semantic pattern evidence for one concrete recursor rule. + +`RawRecursorRuleRel` records a registered equation and its translated RHS, +but a recursor-headed expression alone does not determine which argument is +the major or which constructor rule was selected. This relation retains the +missing data in Lean4Lean's own rewrite vocabulary: + +* the rule's exact array index and the production major index; +* the exact catalogued constructor at that index, including parameter and + field arities; +* a `SimplePattern.iota` RHS/check pair sound for every extension of the + admission environment. + +The final clause mirrors `VEnv.Params.pat_wf` without requiring a global +`Params` instance. It is a Theory/iota assumption boundary, not a statement +about WHNF execution or the Nat linear fast path. -/ +/-- The finite data of one exact Theory iota pattern. It lives in `Type` +because the dependent RHS/check values are computational data; the semantic +relation below remains proof-irrelevant. -/ +structure RecursorRulePattern where + recursorName : Lean.Name + constructorId : KId .anon + constructorName : Lean.Name + constructorParams : UInt64 + constructorFields : UInt64 + ruleIndex : Nat + majorIdx : Nat + rhs : (RecursorIotaPattern recursorName majorIdx constructorName + (constructorParams.toNat + constructorFields.toNat)).RHS + checks : (RecursorIotaPattern recursorName majorIdx constructorName + (constructorParams.toNat + constructorFields.toNat)).Check + +/-- Proof-irrelevant semantic realization of exact iota-pattern data for one +concrete rule. -/ +def RawRecursorRulePatternRel (env : VEnv) (catalog : Catalog) + (nameOf : Address → Option Lean.Name) (id : KId .anon) + (c : KConst .anon) (rule : RecRule .anon) + (pattern : RecursorRulePattern) : Prop := + nameOf id.addr = some pattern.recursorName ∧ + c.RecursorMajorIdx = some pattern.majorIdx ∧ + c.RecursorMajorIdxCoherent ∧ + c.RecursorRuleAt pattern.ruleIndex rule ∧ + nameOf pattern.constructorId.addr = some pattern.constructorName ∧ + (∃ ctor, + catalog pattern.constructorId = some ctor ∧ + ctor.ConstructorAt pattern.ruleIndex pattern.constructorParams + pattern.constructorFields) ∧ + rule.fields = pattern.constructorFields ∧ + ∀ {env' : VEnv}, env ≤ env' → + ∀ {uvars : Nat} {Gamma : List VExpr} {source : VExpr} + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + {A : VExpr}, + Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + source levels captures → + env'.HasType uvars Gamma source A → + pattern.checks.OK (env'.IsDefEqU uvars Gamma) levels captures → + env'.IsDefEqU uvars Gamma source + (pattern.rhs.apply levels captures) + +namespace RawRecursorRulePatternRel + +/-- Pattern provenance is stable under trusted-world extension. The sound +law was deliberately quantified over all future environments, so extending +the admission prefix only composes its lower bound. -/ +theorem mono {env env' : VEnv} (henv : env ≤ env') {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {id : KId .anon} + {c : KConst .anon} {rule : RecRule .anon} + {pattern : RecursorRulePattern} + (h : RawRecursorRulePatternRel env catalog nameOf id c rule pattern) : + RawRecursorRulePatternRel env' catalog nameOf id c rule pattern := by + rcases h with + ⟨hname, hmajor, hcoherent, hrule, hctorName, hctor, hfields, hsound⟩ + exact ⟨hname, hmajor, hcoherent, hrule, hctorName, hctor, hfields, by + intro future hfuture uvars Gamma source levels captures A + hmatches htype hchecks + exact hsound (henv.trans hfuture) hmatches htype hchecks⟩ + +end RawRecursorRulePatternRel + /-- One oracle-backed admission of an already-validated ambient inductive block. `members` is exact for this admission step; `fresh` prevents the oracle from re-certifying an existing trusted id. @@ -127,6 +386,12 @@ structure InductiveOracle (trProj : RawProjRel) (catalog : Catalog) recursorFacts : ∀ ⦃id c rule⦄, members id → catalog id = some c → c.HasRecursorRule rule → RawRecursorRuleRel after nameOf trProj id c rule + recursorPatterns : ∀ ⦃id c ruleIndex rule⦄, + members id → catalog id = some c → + c.RecursorRuleAt ruleIndex rule → + ∃ pattern, + RawRecursorRulePatternRel after catalog nameOf id c rule pattern ∧ + pattern.ruleIndex = ruleIndex namespace InductiveOracle diff --git a/Ix/Tc/Verify/Infer.lean b/Ix/Tc/Verify/Infer.lean new file mode 100644 index 000000000..72ec43dfc --- /dev/null +++ b/Ix/Tc/Verify/Infer.lean @@ -0,0 +1,338 @@ +import Ix.Tc.Verify.Suffix +import Ix.Tc.Verify.Knot + +/-! +# K2 inference semantics + +This module replaces the inference-cache portion of K1's fallback semantics +with its exact Theory meaning. Algorithmic branch proofs will consume the +hit and insertion interfaces defined here. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace TcM + +/-- Inference and WHNF deliberately share the exact production key +algorithm; the theorem pins that policy so the cache proof cannot drift from +runtime behavior. -/ +@[simp] theorem inferKey_eq_whnfKey (source : KExpr .anon) : + TcM.inferKey source = TcM.whnfKey source := rfl + +/-- Inference-key computation preserves the complete fixed-world invariant +and returns the concrete source address in the first component. -/ +theorem inferKey_wf {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {source : KExpr .anon} + {s : TcState .anon} : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.inferKey source) + (fun key s' => key.1 = source.addr ∧ ContextKeyFrame s s') := by + simpa using (TcM.whnfKey_wf (layer := layer) (semantics := semantics) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Δ := Delta) (source := source) (s := s)) + +/-- The canonical operational key interpretation needs no representation +oracle for inference: the successful key run itself is the witness. -/ +theorem inferKey_operational_matches_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {source : KExpr .anon} + {s : TcState .anon} : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.inferKey source) + (fun key s' => + (operationalWhnfContextKeys trProj world uvars).Matches trProj world + s Delta source key ∧ ContextKeyFrame s s') := by + simpa using + (TcM.whnfKey_matches_wf (layer := layer) (semantics := semantics) + (trProj := trProj) (world := world) (support := support) + (keys := operationalWhnfContextKeys trProj world uvars) + (Δ := Delta) (source := source) (s := s) + (fun key s' hctx hrun => + operationalWhnfContextKeys.represents hctx hrun)) + +end TcM + +namespace RecM + +/-- A validated inference-cache hit returns immediately after the shared key +computation, in either inference policy. -/ +theorem inferWith_fullHit + {inferRec : KExpr .anon -> RecM .anon (KExpr .anon)} + {methods : Methods .anon} {source cached : KExpr .anon} + {key : Address × Address} {s s' : TcState .anon} + (hkey : TcM.inferKey source s = .ok key s') + (hhit : s'.env.inferCache[key]? = some cached) : + (inferWith inferRec source).run methods s = .ok cached s' := by + unfold inferWith + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (TcM.inferKey source) _ s = _ + unfold EStateM.bind + rw [hkey] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s' = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s' = .ok s' s' from rfl] + simp only [hhit] + rfl + +/-- An infer-only entry is consulted only after the validated cache misses +and the captured policy bit is true. -/ +theorem inferWith_inferOnlyHit + {inferRec : KExpr .anon -> RecM .anon (KExpr .anon)} + {methods : Methods .anon} {source cached : KExpr .anon} + {key : Address × Address} {s s' : TcState .anon} + (hpolicy : s.inferOnly = true) + (hkey : TcM.inferKey source s = .ok key s') + (hfullMiss : s'.env.inferCache[key]? = none) + (hhit : s'.env.inferOnlyCache[key]? = some cached) : + (inferWith inferRec source).run methods s = .ok cached s' := by + unfold inferWith + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (TcM.inferKey source) _ s = _ + unfold EStateM.bind + rw [hkey] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s' = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s' = .ok s' s' from rfl] + simp only [hfullMiss, hpolicy] + simp only [pure_bind, if_true] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s' = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s' = .ok s' s' from rfl] + simp only [hhit] + rfl + +namespace InferCacheUpdate + +/-- Installing a certified full inference result changes only its physical +cache partition and preserves the complete checker invariant. -/ +theorem full_whnfStateInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {key : Address × Address} {ty : KExpr .anon} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hnew : CacheProvenance semantics (CacheAuthority.stable world) support + (.expr .infer key ty)) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with env := {s.env with + inferCache := s.env.inferCache.insert key ty}} := by + rcases hI with ⟨hkernel, hctx, hlayer⟩ + refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ + · exact hkernel.core.of_consts_eq rfl (by + simpa using hkernel.core.intern) + · simpa using hkernel.internSupport + · exact hkernel.caches.insertInfer hnew + · exact hkernel.equivalences + · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer + +/-- Installing an infer-only result cannot widen it into the validated full +partition; the corresponding state update preserves all other invariants. -/ +theorem inferOnly_whnfStateInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {key : Address × Address} {ty : KExpr .anon} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hnew : CacheProvenance semantics (CacheAuthority.stable world) support + (.expr .inferOnly key ty)) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with env := {s.env with + inferOnlyCache := s.env.inferOnlyCache.insert key ty}} := by + rcases hI with ⟨hkernel, hctx, hlayer⟩ + refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ + · exact hkernel.core.of_consts_eq rfl (by + simpa using hkernel.core.intern) + · simpa using hkernel.internSupport + · exact hkernel.caches.insertInferOnly hnew + · exact hkernel.equivalences + · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer + +end InferCacheUpdate + +end RecM + +/-- A concrete inference result translates to a Theory type of the translated +source expression in the represented mixed context. -/ +def InferMeaning (trProj : RawProjRel) (world : VerifyWorld) + (uvars : Nat) (Delta : KVLCtx) (source ty : KExpr .anon) : Prop := + ∃ sourceV, + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV ∧ + InferPost trProj world uvars Delta sourceV ty + +namespace InferMeaning + +theorem mono {trProj : RawProjRel} {before after : VerifyWorld} + (hle : before ≤ after) {uvars : Nat} {Delta : KVLCtx} + {source ty : KExpr .anon} + (h : InferMeaning trProj before uvars Delta source ty) : + InferMeaning trProj after uvars Delta source ty := by + obtain ⟨sourceV, hsource, tyV, hty, hhasType⟩ := h + obtain ⟨tyCoreV, htyCore, htyEq⟩ := hty + refine ⟨sourceV, ?_, tyV, ⟨tyCoreV, ?_, htyEq.mono hle.venv⟩, + hhasType.mono hle.venv⟩ + · simpa only [← hle.nameOf] using hsource.mono hle.venv + · simpa only [← hle.nameOf] using htyCore.mono hle.venv + +theorem of_post {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Delta : KVLCtx} {source ty : KExpr .anon} + {sourceV : VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hpost : InferPost trProj world uvars Delta sourceV ty) : + InferMeaning trProj world uvars Delta source ty := + ⟨sourceV, hsource, hpost⟩ + +/-- Recover the caller-indexed postcondition from cache meaning. Structural +translation is unique only up to definitional equality, so the proof uses +Theory uniqueness before transporting the typing derivation. -/ +theorem post {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) {Delta : KVLCtx} + (hDelta : KVLCtx.WF world.venv uvars Delta) + {source ty : KExpr .anon} {sourceV : VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (h : InferMeaning trProj world uvars Delta source ty) : + InferPost trProj world uvars Delta sourceV ty := by + obtain ⟨cachedV, hcached, tyV, hty, hhasType⟩ := h + refine ⟨tyV, hty, ?_⟩ + have hctx := KVLCtx.IsDefEq.refl world.venvWF hDelta + have hsourceEq := hcached.uniq world.venvWF theory.literalWF + theory.projections hctx hsource + exact hhasType.defeqU_l world.venvWF hDelta hsourceEq + +end InferMeaning + +namespace ExprCacheKind + +inductive IsInfer : ExprCacheKind → Prop + | infer : IsInfer .infer + | inferOnly : IsInfer .inferOnly + +end ExprCacheKind + +/-- Exact validity of the two inference cache families. All other entries +retain the semantics already established by the caller (normally K1 WHNF). -/ +def InferCacheValid (keys : WhnfContextKeys) (trProj : RawProjRel) + (fallback : CacheSemantics) (authority : CacheAuthority) + (support : RunSupport) : CacheEntry → Prop + | .expr .infer key ty | .expr .inferOnly key ty => + ∀ source, support source → source.addr = key.1 → + ∀ Delta, keys.Represents source.lbr key.2 Delta → + InferMeaning trProj authority.world keys.uvars Delta source ty + | entry => fallback.Valid authority support entry + +namespace InferCacheValid + +theorem mono {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {before after : CacheAuthority} + {support : RunSupport} {entry : CacheEntry} (hle : before ≤ after) + (h : InferCacheValid keys trProj fallback before support entry) : + InferCacheValid keys trProj fallback after support entry := by + cases entry with + | expr kind key value => + cases kind with + | infer | inferOnly => + intro source hsource haddr Delta hctx + exact (h source hsource haddr Delta hctx).mono hle.world + | whnf | whnfNoDelta | whnfNoDeltaCheap | whnfCore | whnfCoreCheap => + exact fallback.mono hle h + | defEq | defEqFailure | unfold | natSuccStuck | isProp | isRec | + recursor | recMajors | blockPeer | blockResult => + exact fallback.mono hle h + +theorem expr {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {kind : ExprCacheKind} + {key : Address × Address} {ty source : KExpr .anon} + (hkind : kind.IsInfer) + (h : InferCacheValid keys trProj fallback authority support + (.expr kind key ty)) + (hsource : support source) (haddr : source.addr = key.1) + {Delta : KVLCtx} (hctx : keys.Represents source.lbr key.2 Delta) : + InferMeaning trProj authority.world keys.uvars Delta source ty := by + cases hkind <;> exact h source hsource haddr Delta hctx + +end InferCacheValid + +/-- Overlay K2's inference meanings on the already-selected cache semantics. -/ +def inferCacheSemantics (keys : WhnfContextKeys) (trProj : RawProjRel) + (fallback : CacheSemantics) : CacheSemantics where + Valid := InferCacheValid keys trProj fallback + mono := InferCacheValid.mono + Equiv := fallback.Equiv + equivEquivalence := fallback.equivEquivalence + equivMono := fallback.equivMono + blockError := by + intro authority support block err + exact fallback.blockError authority support block err + +namespace CacheProvenance + +theorem inferMeaning {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {kind : ExprCacheKind} + {key : Address × Address} {ty source : KExpr .anon} + (h : CacheProvenance (inferCacheSemantics keys trProj fallback) + authority support (.expr kind key ty)) + (hkind : kind.IsInfer) (hsource : support source) + (haddr : source.addr = key.1) {Delta : KVLCtx} + (hctx : keys.Represents source.lbr key.2 Delta) : + InferMeaning trProj authority.world keys.uvars Delta source ty := + InferCacheValid.expr hkind h.valid hsource haddr hctx + +theorem inferMeaningOfMatches {keys : WhnfContextKeys} + {trProj : RawProjRel} {fallback : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {kind : ExprCacheKind} {key : Address × Address} + {ty source : KExpr .anon} {s : TcState .anon} {Delta : KVLCtx} + (h : CacheProvenance (inferCacheSemantics keys trProj fallback) + authority support (.expr kind key ty)) + (hkind : kind.IsInfer) (hsource : support source) + (hmatch : keys.Matches trProj authority.world s Delta source key) : + InferMeaning trProj authority.world keys.uvars Delta source ty := + h.inferMeaning hkind hsource hmatch.sourceAddr hmatch.2.1 + +end CacheProvenance + +namespace CacheInvariant + +theorem inferHitOfMatches {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {env : KEnv .anon} {kind : ExprCacheKind} + {key : Address × Address} {ty source : KExpr .anon} + {s : TcState .anon} {Delta : KVLCtx} + (h : CacheInvariant (inferCacheSemantics keys trProj fallback) + authority support env) + (hhit : env.HasCacheEntry (.expr kind key ty)) + (hkind : kind.IsInfer) (hsource : support source) + (hmatch : keys.Matches trProj authority.world s Delta source key) : + InferMeaning trProj authority.world keys.uvars Delta source ty := + (h.hit hhit).inferMeaningOfMatches hkind hsource hmatch + +end CacheInvariant + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/Applications.lean b/Ix/Tc/Verify/Infer/Applications.lean new file mode 100644 index 000000000..53a71457b --- /dev/null +++ b/Ix/Tc/Verify/Infer/Applications.lean @@ -0,0 +1,286 @@ +import Ix.Tc.Verify.Infer.FunctionTypes +import Ix.Tc.Verify.Whnf.Beta.LambdaInstantiation + +/-! +# Application inference + +Application inference is the first dispatcher branch that composes all three +recursive services: inference of the function and (in full mode) argument, +direct WHNF exposure of the inferred function type, and DefEq validation of +the argument type. The final dependent codomain is produced by the verified +single-substitution walker. + +The run support is finite and deliberately not constructor-closed. The +application census below therefore records both source-component descent and +the exact family of substitution requests reachable after a supported +codomain has been exposed. +-/ + +namespace Ix.Tc + +/-- Finite-support obligations for supported applications that reach the +uncached inference dispatcher. Quantifying the final clause over supported +codomains is still finite, and avoids pretending that every possible WHNF +result belongs to the run. -/ +def ApplicationInferCensus (support : RunSupport) + (requests : List WalkerRequest) : Prop := + forall {f a : KExpr .anon} {info : ExprInfo .anon}, + support (.app f a info) -> + support f /\ support a /\ + forall {cod}, support cod -> + WalkerRequest.subst cod a 0 ∈ requests + +namespace TcM + +/-- `isEagerReduce` observes the application spine and primitive table but +does not mutate the checker state. -/ +theorem isEagerReduce_wf {I : TcState .anon -> Prop} + (e : KExpr .anon) (s : TcState .anon) : + TcM.WF I s (TcM.isEagerReduce e) (fun _ after => after = s) := by + intro hI + rcases hspine : e.collectSpine with ⟨head, args⟩ + cases hsize : args.size != 2 <;> + cases head <;> + simp [TcM.isEagerReduce, hspine, hsize, hI] + change I s /\ s = s + exact ⟨hI, rfl⟩ + +end TcM + +namespace RecM + +/-- Updating the eager-reduction marker changes only operational +bookkeeping. In particular, an error returned by the following DefEq call +may retain the marker without invalidating the semantic state invariant. -/ +theorem setEagerReduce_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} (value : Bool) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (modify fun state => { state with eagerReduce := value }) + (fun _ _ => True) := + RecM.WF.modify + (fun hI => hI.of_semantic_fields_eq rfl rfl rfl rfl rfl rfl rfl rfl) + (fun _ => trivial) + +/-- Theory meaning of the substitution returned by application inference. +Translation uniqueness reconciles the recursively inferred function type +with the Pi already present in the source application's structural typing. +Pi injectivity then aligns the exposed domain and codomain. -/ +private theorem applicationResult + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Delta : KVLCtx} + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + {a cod : KExpr .anon} + {fV aV A B fTyV domV codV : Lean4Lean.VExpr} + (hfun : world.venv.HasType uvars Delta.toCtx fV (.forallE A B)) + (harg : world.venv.HasType uvars Delta.toCtx aV A) + (hargTr : TrKExprS world.venv uvars world.nameOf trProj Delta a aV) + (hfTy : world.venv.HasType uvars Delta.toCtx fV fTyV) + (hview : world.venv.IsDefEqU uvars Delta.toCtx fTyV + (.forallE domV codV)) + (hcodTr : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam domV) :: Delta) cod codV) + (hbounds : WalkerRequest.Bounds (.subst cod a 0)) : + InferPost trProj world uvars Delta (.app fV aV) + (KExpr.substSpec cod a 0) := by + have hfTyEq : world.venv.IsDefEqU uvars Delta.toCtx fTyV + (.forallE A B) := + hfTy.uniqU world.venvWF hDelta hfun + have hforallEq : world.venv.IsDefEqU uvars Delta.toCtx + (.forallE A B) (.forallE domV codV) := + hfTyEq.symm.trans world.venvWF hDelta hview + have hdomainEq : world.venv.IsDefEqU uvars Delta.toCtx A domV := + let ⟨level, hEq⟩ := + (hforallEq.forallE_inv world.venvWF hDelta.toCtx).1 + ⟨.sort level, hEq⟩ + have hcodEq : world.venv.IsDefEqU uvars (A :: Delta.toCtx) B codV := + let ⟨level, hEq⟩ := + (hforallEq.forallE_inv world.venvWF hDelta.toCtx).2 + ⟨.sort level, hEq⟩ + have hargAtDom : world.venv.HasType uvars Delta.toCtx aV domV := + harg.defeqU_r world.venvWF hDelta hdomainEq + have hresultTr : TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.substSpec cod a 0) (codV.inst aV) := + TrKExprS.instN_lbr world.venvWF.ordered theory.projections.weakN + theory.projections.instN hbounds.2.1 hargTr hargAtDom hcodTr + (.zero : KVLCtx.KInstN Delta aV domV 0 0 + ((none, .vlam domV) :: Delta) Delta) + rfl hbounds.2.2.2.2 + have hcodInstEq : world.venv.IsDefEqU uvars Delta.toCtx + (B.inst aV) (codV.inst aV) := + hcodEq.instN world.venvWF.ordered .zero harg + refine ⟨codV.inst aV, ?_, ?_⟩ + · exact hresultTr.trKExpr world.venvWF.ordered theory.literalWF + theory.projections.wf hDelta + · exact (Lean4Lean.VEnv.HasType.app hfun harg).defeqU_r + world.venvWF hDelta hcodInstEq + +/-- Execute the final substitution and package its support and Theory +meaning. This helper is shared by full and infer-only application paths. -/ +private theorem finishApplication_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {uvars : Nat} {Delta : KVLCtx} + {s : TcState .anon} + (theory : WhnfTheory trProj world uvars) + {a cod : KExpr .anon} + {fV aV A B fTyV domV codV : Lean4Lean.VExpr} + (hfun : world.venv.HasType uvars Delta.toCtx fV (.forallE A B)) + (harg : world.venv.HasType uvars Delta.toCtx aV A) + (hargTr : TrKExprS world.venv uvars world.nameOf trProj Delta a aV) + (hfTy : world.venv.HasType uvars Delta.toCtx fV fTyV) + (hview : world.venv.IsDefEqU uvars Delta.toCtx fTyV + (.forallE domV codV)) + (hcodTr : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam domV) :: Delta) cod codV) + (hmem : WalkerRequest.subst cod a 0 ∈ requests) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (liftM (TcM.runIntern (subst cod a 0))) + (fun result _ => support result /\ + InferPost trProj world uvars Delta (.app fV aV) result) := by + apply RecM.WF.mono + (RecM.WF.withInv <| RecM.WF.liftTcM <| + hrun.subst_whnf_wf hmem) + · intro result final hresult + rcases hresult with ⟨hIfinal, rfl, _⟩ + have hresultSupport : support (KExpr.substSpec cod a 0) := + hrun.coverage.subst hmem _ (KExpr.SubstReach.spec a cod 0) + exact ⟨hresultSupport, + applicationResult theory hIfinal.2.1.wf hfun harg hargTr hfTy + hview hcodTr (hrun.requestBounds hmem)⟩ + · intro _ _ _ + trivial + +/-- The complete application branch of the uncached syntax dispatcher. +Full mode validates the inferred argument type, including the production +eager-reduction marker protocol. Infer-only mode skips those callbacks but +returns the same substitution-backed semantic type. -/ +theorem inferUncached_app_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {uvars : Nat} {Delta : KVLCtx} + {s : TcState .anon} {inferOnly : Bool} + {f a : KExpr .anon} {info : ExprInfo .anon} + {sourceV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hcensus : ApplicationInferCensus support requests) + (hsourceSupport : support (.app f a info)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.app f a info) sourceV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (inferUncached inferCall inferOnly (.app f a info)) + (fun ty _ => support ty /\ + InferPost trProj world uvars Delta sourceV ty) := by + cases hsource with + | app hfun harg hfunTr hargTr => + rename_i fV aV A B + obtain ⟨hfunSupport, hargSupport, hsubst⟩ := + hcensus hsourceSupport + cases inferOnly with + | false => + unfold inferUncached + simp only [Bool.not_false, if_true] + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.inferCall_wf hfunSupport hfunTr) + intro fTy afterFun hfunPost + rcases hfunPost with + ⟨_, hfTySupport, fTyV, hfTyTr, hfTy⟩ + apply RecM.WF.bind + (RecM.WF.withInv <| + RecM.ensureForallDirect_wf hwhnf hcomponents hfTySupport + hfTyTr) + intro exposed afterForall hforallPost + rcases exposed with ⟨dom, cod⟩ + rcases hforallPost with + ⟨_, domV, codV, hdomSupport, hcodSupport, _, _, hdomTr, + hcodTr, hview⟩ + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.inferCall_wf hargSupport hargTr) + intro aTy afterArg hargPost + rcases hargPost with + ⟨_, haTySupport, aTyV, haTyTr, _⟩ + obtain ⟨aTyCoreV, haTyCoreTr, _⟩ := haTyTr + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.isEagerReduce_wf a afterArg) + intro eager afterEager heager + rcases heager with ⟨_, rfl⟩ + cases eager with + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind + (RecM.isDefEqCall_wf haTySupport hdomSupport + haTyCoreTr hdomTr) + intro equal afterEq _ + cases equal with + | false => + simp only [Bool.not_false, if_true, pure_bind] + apply RecM.WF.bind + (Q₁ := fun read state => read = state) + (RecM.WF.get fun _ => rfl) + intro read state _ + apply RecM.WF.bind + (Q₁ := fun _ _ => False) + (RecM.WF.throw fun _ => trivial) + intro _ _ impossible + exact impossible.elim + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + exact finishApplication_wf hrun theory hfun harg hargTr + hfTy hview hcodTr (hsubst hcodSupport) + | true => + simp only [if_true] + apply RecM.WF.bind (RecM.setEagerReduce_wf true) + intro _ afterSet _ + apply RecM.WF.bind + (RecM.isDefEqCall_wf haTySupport hdomSupport + haTyCoreTr hdomTr) + intro equal afterEq _ + apply RecM.WF.bind (RecM.setEagerReduce_wf false) + intro _ afterReset _ + cases equal with + | false => + simp only [Bool.not_false, if_true, pure_bind] + apply RecM.WF.bind + (Q₁ := fun read state => read = state) + (RecM.WF.get fun _ => rfl) + intro read state _ + apply RecM.WF.bind + (Q₁ := fun _ _ => False) + (RecM.WF.throw fun _ => trivial) + intro _ _ impossible + exact impossible.elim + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + exact finishApplication_wf hrun theory hfun harg hargTr + hfTy hview hcodTr (hsubst hcodSupport) + | true => + unfold inferUncached + simp only [Bool.not_true, Bool.false_eq_true, if_false] + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.inferCall_wf hfunSupport hfunTr) + intro fTy afterFun hfunPost + rcases hfunPost with + ⟨_, hfTySupport, fTyV, hfTyTr, hfTy⟩ + apply RecM.WF.bind + (RecM.WF.withInv <| + RecM.ensureForallDirect_wf hwhnf hcomponents hfTySupport + hfTyTr) + intro exposed afterForall hforallPost + rcases exposed with ⟨dom, cod⟩ + rcases hforallPost with + ⟨_, domV, codV, _, hcodSupport, _, _, _, hcodTr, hview⟩ + exact finishApplication_wf hrun theory hfun harg hargTr hfTy + hview hcodTr (hsubst hcodSupport) + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/BinderClosing.lean b/Ix/Tc/Verify/Infer/BinderClosing.lean new file mode 100644 index 000000000..b4db219d9 --- /dev/null +++ b/Ix/Tc/Verify/Infer/BinderClosing.lean @@ -0,0 +1,435 @@ +import Ix.Tc.Verify.Infer.BinderScopes + +/-! +# Semantic binder closing for inference + +Lambda and let inference open a de Bruijn binder as a fresh free variable, +infer under that tagged context, and then call `abstractFVars` before leaving +the scope. This module proves the reverse half of that round trip: singleton +fvar abstraction retags the concrete expression back to the original +de Bruijn context without changing its Theory translation. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr VLocalDecl) + +namespace KVLCtx.RetagFVar + +/-- Reverse the distinguished-variable lookup introduced by retagging. -/ +theorem find?_hit_rev + {fvData : FVarId × List FVarId} {decl : VLocalDecl} + {depth : Nat} {source target : KVLCtx} + (W : KVLCtx.RetagFVar fvData decl depth source target) : + ∀ {e A : VExpr}, target.find? (.inr fvData.1) = some (e, A) → + source.find? (.inl depth) = some (e, A) := by + induction W with + | zero => + intro e A H + simp [KVLCtx.find?, KVLCtx.next] at H ⊢ + exact H + | @succ depth source target d W ih => + intro e A H + simp [KVLCtx.find?, KVLCtx.next] at H ⊢ + obtain ⟨e', A', H, rfl, rfl⟩ := H + exact ⟨_, _, ih H, rfl, rfl⟩ + +/-- Variables below the retagged binder keep the same de Bruijn index. -/ +theorem find?_lt_rev + {fvData : FVarId × List FVarId} {decl : VLocalDecl} + {depth : Nat} {source target : KVLCtx} + (W : KVLCtx.RetagFVar fvData decl depth source target) : + ∀ {j : Nat} {e A : VExpr}, j < depth → + target.find? (.inl j) = some (e, A) → + source.find? (.inl j) = some (e, A) := by + induction W with + | zero => intro j e A hj; omega + | @succ depth source target d W ih => + intro j e A hj H + cases j with + | zero => simpa [KVLCtx.find?, KVLCtx.next] using H + | succ j => + simp [KVLCtx.find?, KVLCtx.next] at H ⊢ + obtain ⟨e', A', H, rfl, rfl⟩ := H + exact ⟨_, _, ih (by omega) H, rfl, rfl⟩ + +/-- Variables at or above the retagged binder regain the one index consumed +by its de Bruijn form. -/ +theorem find?_ge_rev + {fvData : FVarId × List FVarId} {decl : VLocalDecl} + {depth : Nat} {source target : KVLCtx} + (W : KVLCtx.RetagFVar fvData decl depth source target) : + ∀ {j : Nat} {e A : VExpr}, depth ≤ j → + target.find? (.inl j) = some (e, A) → + source.find? (.inl (j + 1)) = some (e, A) := by + induction W with + | zero => + intro j e A hj H + simp [KVLCtx.find?, KVLCtx.next] at H ⊢ + exact H + | @succ depth source target d W ih => + intro j e A hj H + cases j with + | zero => omega + | succ j => + simp [KVLCtx.find?, KVLCtx.next] at H ⊢ + obtain ⟨e', A', H, rfl, rfl⟩ := H + exact ⟨_, _, ih (by omega) H, rfl, rfl⟩ + +/-- Any other fvar lookup is unaffected by retagging. -/ +theorem find?_fvar_ne_rev + {fvData : FVarId × List FVarId} {decl : VLocalDecl} + {depth : Nat} {source target : KVLCtx} + (W : KVLCtx.RetagFVar fvData decl depth source target) : + ∀ {fv : FVarId} {e A : VExpr}, fv ≠ fvData.1 → + target.find? (.inr fv) = some (e, A) → + source.find? (.inr fv) = some (e, A) := by + induction W with + | zero => + intro fv e A hne H + simp [KVLCtx.find?, KVLCtx.next, Ne.symm hne] at H ⊢ + exact H + | @succ depth source target d W ih => + intro fv e A hne H + simp [KVLCtx.find?, KVLCtx.next] at H ⊢ + obtain ⟨e', A', H, rfl, rfl⟩ := H + exact ⟨_, _, ih hne H, rfl, rfl⟩ + +end KVLCtx.RetagFVar + +@[simp] theorem abstractFVarPositions_singleton_hit (fv : FVarId) : + (abstractFVarPositions #[fv])[fv]? = some 0 := by + simp [abstractFVarPositions] + +theorem abstractFVarPositions_singleton_miss {fv other : FVarId} + (hne : other ≠ fv) : + (abstractFVarPositions #[fv])[other]? = none := by + simp [abstractFVarPositions, Ne.symm hne] + +/-- Singleton fvar abstraction reverses a context retag at any syntactic +binder depth. `Constructed` supplies the no-wrap fact for the `i + 1` +variable arm; the size bound supplies every recursive `depth + 1`. -/ +theorem TrKExprS.closeFVarSpec + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + {target : KVLCtx} {body : KExpr .anon} {bodyV : VExpr} + (H : TrKExprS env uvars nameOf trProj target body bodyV) + (hcon : KExpr.Constructed body) : + ∀ {fvData : FVarId × List FVarId} {decl : VLocalDecl} + {source : KVLCtx} {dk : Nat} {depth : UInt64}, + KVLCtx.RetagFVar fvData decl dk source target → + depth.toNat = dk → + depth.toNat + body.size + 1 < UInt64.size → + TrKExprS env uvars nameOf trProj source + (KExpr.abstractFVarsSpec body + (abstractFVarPositions #[fvData.1]) 1 depth) bodyV := by + intro fvData decl source dk depth W hdepth hbig + induction hcon generalizing source target dk depth bodyV with + | @var idx name md hidx => + rw [KExpr.mkVar_shape] at H + cases H with + | @var _ _ _ _ e A hfind => + rw [KExpr.mkVar_shape, KExpr.abstractFVarsSpec] + by_cases hge : idx ≥ depth + · rw [if_pos hge, KExpr.mkVar_shape] + refine .var (A := A) ?_ + have hsucc : (idx + 1).toNat = idx.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + Nat.mod_eq_of_lt hidx] + rw [hsucc] + exact W.find?_ge_rev (by + rw [← hdepth] + exact UInt64.le_iff_toNat_le.mp hge) hfind + · rw [if_neg hge] + refine .var (A := A) ?_ + exact W.find?_lt_rev (by + rw [← hdepth] + have hnle : ¬depth.toNat ≤ idx.toNat := fun h => + hge (UInt64.le_iff_toNat_le.mpr h) + omega) hfind + | @fvar id name md => + rw [KExpr.mkFVar_shape] at H + cases H with + | @fvar _ _ _ _ e A hfind => + rw [KExpr.mkFVar_shape, KExpr.abstractFVarsSpec] + by_cases heq : id = fvData.1 + · subst id + simp only [abstractFVarPositions_singleton_hit, UInt64.add_zero] + rw [KExpr.mkVar_shape] + refine .var (A := A) ?_ + simpa only [UInt64.add_zero, hdepth] using + W.find?_hit_rev hfind + · simp only [abstractFVarPositions_singleton_miss heq] + exact .fvar (W.find?_fvar_ne_rev heq hfind) + | @sort u md => + rw [KExpr.mkSort_shape] at H + cases H with + | sort hu => + exact .sort hu + | @const id us md => + rw [KExpr.mkConst_shape] at H + cases H with + | const hname hconst hus hsize => + exact .const hname hconst hus hsize + | @app f arg md hf harg ihf iharg => + rw [KExpr.mkApp_shape] at H + cases H with + | @app _ _ _ _ fV argV A B hfun hargTy hfTr hargTr => + have hbig' : depth.toNat + (f.size + arg.size + 1) + 1 < + UInt64.size := hbig + rw [KExpr.mkApp_shape, KExpr.abstractFVarsSpec, + KExpr.mkApp_shape] + exact .app (W.toCtx_eq.symm ▸ hfun) (W.toCtx_eq.symm ▸ hargTy) + (ihf hfTr W hdepth (by omega)) + (iharg hargTr W hdepth (by omega)) + | @lam name bi ty inner md hty hinner ihty ihinner => + rw [KExpr.mkLam_shape] at H + cases H with + | @lam _ _ _ _ _ _ tyV innerV htyType htyTr hinnerTr => + have hbig' : depth.toNat + (ty.size + inner.size + 1) + 1 < + UInt64.size := hbig + have hsucc : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + hdepth] + exact Nat.mod_eq_of_lt + (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.mkLam_shape, KExpr.abstractFVarsSpec, + KExpr.mkLam_shape] + exact .lam (W.toCtx_eq.symm ▸ htyType) + (ihty htyTr W hdepth (by omega)) + (ihinner hinnerTr W.succ hsucc (by rw [hsucc]; omega)) + | @all name bi ty inner md hty hinner ihty ihinner => + rw [KExpr.mkAll_shape] at H + cases H with + | @all _ _ _ _ _ _ tyV innerV htyType hinnerType htyTr hinnerTr => + have hbig' : depth.toNat + (ty.size + inner.size + 1) + 1 < + UInt64.size := hbig + have hsucc : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + hdepth] + exact Nat.mod_eq_of_lt + (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.mkAll_shape, KExpr.abstractFVarsSpec, + KExpr.mkAll_shape] + exact .all (W.toCtx_eq.symm ▸ htyType) + (by simpa [W.toCtx_eq] using hinnerType) + (ihty htyTr W hdepth (by omega)) + (ihinner hinnerTr W.succ hsucc (by rw [hsucc]; omega)) + | @letE name ty val inner nondep md hty hval hinner ihty ihval ihinner => + rw [KExpr.mkLet_shape] at H + cases H with + | @letE _ _ _ _ _ _ _ tyV valV innerV hvalType htyTr hvalTr + hinnerTr => + have hbig' : depth.toNat + + (ty.size + val.size + inner.size + 1) + 1 < UInt64.size := + hbig + have hsucc : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + hdepth] + exact Nat.mod_eq_of_lt + (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.mkLet_shape, KExpr.abstractFVarsSpec, + KExpr.mkLet_shape] + exact .letE (W.toCtx_eq.symm ▸ hvalType) + (ihty htyTr W hdepth (by omega)) + (ihval hvalTr W hdepth (by omega)) + (ihinner hinnerTr W.succ hsucc (by rw [hsucc]; omega)) + | @prj id field val md hval ihval => + rw [KExpr.mkPrj_shape] at H + cases H with + | @prj _ _ _ _ _ structName valueV resultV hname hvalTr hproj => + rw [KExpr.mkPrj_shape, KExpr.abstractFVarsSpec, + KExpr.mkPrj_shape] + exact .prj hname (ihval hvalTr W hdepth (by + rw [KExpr.mkPrj_shape] at hbig + change depth.toNat + (val.size + 1) + 1 < UInt64.size at hbig + omega)) (W.toCtx_eq.symm ▸ hproj) + | @nat value blob md => + rw [KExpr.mkNat_shape] at H + cases H with + | nat hlit => + exact .nat hlit + | @str value blob md => + rw [KExpr.mkStr_shape] at H + cases H with + | str hlit => + exact .str hlit + +/-- Entry-depth form used after `openBinder`/`openLet`. -/ +theorem TrKExprS.closeFVarZero + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + {Delta : KVLCtx} {decl : VLocalDecl} + {body : KExpr .anon} {bodyV : VExpr} + {fv : FVarId} {deps : List FVarId} + (H : TrKExprS env uvars nameOf trProj + ((some (fv, deps), decl) :: Delta) body bodyV) + (hbounds : WalkerRequest.Bounds (.abstractFVars body #[fv])) : + TrKExprS env uvars nameOf trProj ((none, decl) :: Delta) + (KExpr.abstractFVarsSpec body (abstractFVarPositions #[fv]) 1 0) + bodyV := by + apply H.closeFVarSpec hbounds.1 (.zero (fvData := (fv, deps))) rfl + have hbig := hbounds.2.2.2 + change body.lbr.toNat + body.size + 1 < UInt64.size at hbig + have : body.size + 1 < UInt64.size := by omega + simpa using this + +/-- The API-level fast path is semantically identical to the singleton +abstraction specification under its audited bounds. -/ +theorem TrKExprS.closeFVarResult + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + {Delta : KVLCtx} {decl : VLocalDecl} + {body : KExpr .anon} {bodyV : VExpr} + {fv : FVarId} {deps : List FVarId} + (H : TrKExprS env uvars nameOf trProj + ((some (fv, deps), decl) :: Delta) body bodyV) + (hbounds : WalkerRequest.Bounds (.abstractFVars body #[fv])) : + TrKExprS env uvars nameOf trProj ((none, decl) :: Delta) + (KExpr.abstractFVarsResult body #[fv]) bodyV := by + have hspec := H.closeFVarZero hbounds + unfold KExpr.abstractFVarsResult + change TrKExprS env uvars nameOf trProj ((none, decl) :: Delta) + (if #[fv].isEmpty || (!body.hasFVars && body.lbr == 0) then body + else KExpr.abstractFVarsSpec body + (abstractFVarPositions #[fv]) 1 0) bodyV + split + · next hfast => + have hnotEmpty : (#[fv] : Array FVarId).isEmpty = false := rfl + have hfastRaw : (!body.hasFVars) = true ∧ body.lbr = 0 := by + simpa only [hnotEmpty, Bool.false_or, Bool.and_eq_true, + beq_iff_eq] using hfast + have hfast' : body.hasFVars = false ∧ body.lbr = 0 := by + cases hbody : body.hasFVars <;> simp_all + have hid := KExpr.abstractFVarsSpec_id + (pos := abstractFVarPositions #[fv]) (n := 1) (depth := 0) + hbounds.1 (by simpa using hbounds.2.2.1) hfast'.1 + (by rw [hfast'.2]; + exact UInt64.le_iff_toNat_le.mpr (Nat.le_refl 0)) + rw [hid] at hspec + exact hspec + · exact hspec + +/-- Finite closure needed to abstract one dynamically allocated fvar from +any supported recursive result. `FVarId` itself is finite, and the body +quantifier is restricted to the finite run support. -/ +structure SingletonAbstractionResources (support : RunSupport) : Prop where + bounds : ∀ {body : KExpr .anon}, support body → ∀ fv : FVarId, + WalkerRequest.Bounds (.abstractFVars body #[fv]) + reach : ∀ {body : KExpr .anon}, support body → ∀ fv x, + KExpr.AbstractReach (abstractFVarPositions #[fv]) + #[fv].size.toUInt64 body 0 x → support x + +namespace RunAssumptions + +/-- Request-independent operational/semantic closing rule. This is the +form needed by recursive callbacks, whose freshly allocated id is not known +when a concrete execution request list is formed. -/ +theorem abstractFVars_close_whnf_wf_of_resources + {support : RunSupport} + (hcollision : support.CollisionFree) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {decl : VLocalDecl} + {body : KExpr .anon} {bodyV : VExpr} + {fv : FVarId} {deps : List FVarId} + (hbounds : WalkerRequest.Bounds (.abstractFVars body #[fv])) + (hreach : ∀ x, KExpr.AbstractReach (abstractFVarPositions #[fv]) + #[fv].size.toUInt64 body 0 x → support x) + (hbody : TrKExprS world.venv uvars world.nameOf trProj + ((some (fv, deps), decl) :: Delta) body bodyV) + {s : TcState .anon} : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars + ((some (fv, deps), decl) :: Delta)) s + (TcM.runIntern (abstractFVars body #[fv])) + (fun result after => + result = KExpr.abstractFVarsResult body #[fv] ∧ + support result ∧ InternUpdateFrame s after ∧ + TrKExprS world.venv uvars world.nameOf trProj + ((none, decl) :: Delta) result bodyV) := by + have hresultTr := hbody.closeFVarResult hbounds + have hresultSupport : support (KExpr.abstractFVarsResult body #[fv]) := by + unfold KExpr.abstractFVarsResult + split + · exact hreach body + (KExpr.AbstractReach.self (abstractFVarPositions #[fv]) + #[fv].size.toUInt64 body 0) + · exact hreach _ + (KExpr.AbstractReach.spec (abstractFVarPositions #[fv]) + #[fv].size.toUInt64 body 0) + apply TcM.WF.mono + (TcM.runIntern_whnf_wf (fun it hwf hsupport => + abstractFVars_support_spec hcollision hbounds hreach hwf hsupport)) + · intro result after hpost + rcases hpost with ⟨rfl, hframe⟩ + exact ⟨rfl, hresultSupport, hframe, hresultTr⟩ + · intro _ _ herror + exact herror + +/-- Execution-list specialization used when the abstraction request is +known statically. -/ +theorem abstractFVars_close_whnf_wf + {alpha : Type} {initial : TcState .anon} + {program : TcM .anon alpha} {requests : List WalkerRequest} + {support : RunSupport} + (h : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {decl : VLocalDecl} + {body : KExpr .anon} {bodyV : VExpr} + {fv : FVarId} {deps : List FVarId} + (hmem : WalkerRequest.abstractFVars body #[fv] ∈ requests) + (hbody : TrKExprS world.venv uvars world.nameOf trProj + ((some (fv, deps), decl) :: Delta) body bodyV) + {s : TcState .anon} : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars + ((some (fv, deps), decl) :: Delta)) s + (TcM.runIntern (abstractFVars body #[fv])) + (fun result after => + result = KExpr.abstractFVarsResult body #[fv] ∧ + support result ∧ InternUpdateFrame s after ∧ + TrKExprS world.venv uvars world.nameOf trProj + ((none, decl) :: Delta) result bodyV) := + abstractFVars_close_whnf_wf_of_resources h.collisionFree + (h.requestBounds hmem) (h.coverage.abstractFVars hmem) hbody + +end RunAssumptions + +namespace SingletonAbstractionResources + +/-- Package the generic closing theorem through the finite recursive-result +resource used by lambda and let inference. -/ +theorem close_whnf_wf + {support : RunSupport} + (hresources : SingletonAbstractionResources support) + (hcollision : support.CollisionFree) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {decl : VLocalDecl} + {body : KExpr .anon} {bodyV : VExpr} + {fv : FVarId} {deps : List FVarId} + (hbodySupport : support body) + (hbody : TrKExprS world.venv uvars world.nameOf trProj + ((some (fv, deps), decl) :: Delta) body bodyV) + {s : TcState .anon} : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars + ((some (fv, deps), decl) :: Delta)) s + (TcM.runIntern (abstractFVars body #[fv])) + (fun result after => + result = KExpr.abstractFVarsResult body #[fv] ∧ + support result ∧ InternUpdateFrame s after ∧ + TrKExprS world.venv uvars world.nameOf trProj + ((none, decl) :: Delta) result bodyV) := + RunAssumptions.abstractFVars_close_whnf_wf_of_resources hcollision + (hresources.bounds hbodySupport fv) + (hresources.reach hbodySupport fv) hbody + +end SingletonAbstractionResources + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/BinderOpening.lean b/Ix/Tc/Verify/Infer/BinderOpening.lean new file mode 100644 index 000000000..10ffe909e --- /dev/null +++ b/Ix/Tc/Verify/Infer/BinderOpening.lean @@ -0,0 +1,300 @@ +import Ix.Tc.Verify.Infer.ScopedLocals + +/-! +# Semantic binder opening for inference + +Inference replaces one de Bruijn binder with a freshly minted free variable +before making its recursive call. The concrete syntax loses one bvar, but +the Theory context keeps the same local declaration. This module models +that retagging and proves that `instantiateRev` preserves the translated +Theory expression. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr VLocalDecl) + +namespace KVLCtx + +variable (fvData : FVarId × List FVarId) (decl : VLocalDecl) in +/-- Retag one de Bruijn local as a free-variable local at a given syntactic +binder depth. The Theory context is unchanged. -/ +inductive RetagFVar : Nat → KVLCtx → KVLCtx → Prop + | zero {Delta : KVLCtx} : + RetagFVar 0 ((none, decl) :: Delta) ((some fvData, decl) :: Delta) + | succ {depth : Nat} {source target : KVLCtx} {d : VLocalDecl} : + RetagFVar depth source target → + RetagFVar (depth + 1) ((none, d) :: source) ((none, d) :: target) + +theorem RetagFVar.toCtx_eq + {fvData : FVarId × List FVarId} {decl : VLocalDecl} + {depth : Nat} {source target : KVLCtx} + (W : RetagFVar fvData decl depth source target) : + source.toCtx = target.toCtx := by + induction W with + | zero => cases decl <;> rfl + | @succ depth source target d W ih => + cases d <;> simp [KVLCtx.toCtx, ih] + +theorem RetagFVar.find?_hit + {fvData : FVarId × List FVarId} {decl : VLocalDecl} + {depth : Nat} {source target : KVLCtx} + (W : RetagFVar fvData decl depth source target) : + ∀ {e A : VExpr}, source.find? (.inl depth) = some (e, A) → + target.find? (.inr fvData.1) = some (e, A) := by + induction W with + | zero => + intro e A H + simp [find?, next] at H ⊢ + exact H + | @succ depth source target d _ ih => + intro e A H + simp [find?, next] at H ⊢ + obtain ⟨e', A', H, rfl, rfl⟩ := H + exact ⟨_, _, ih H, rfl, rfl⟩ + +theorem RetagFVar.find?_lt + {fvData : FVarId × List FVarId} {decl : VLocalDecl} + {depth : Nat} {source target : KVLCtx} + (W : RetagFVar fvData decl depth source target) : + ∀ {j : Nat} {e A : VExpr}, j < depth → + source.find? (.inl j) = some (e, A) → + target.find? (.inl j) = some (e, A) := by + induction W with + | zero => intro j e A hj; omega + | @succ depth source target d _ ih => + intro j e A hj H + cases j with + | zero => simpa [find?, next] using H + | succ j => + simp [find?, next] at H ⊢ + obtain ⟨e', A', H, rfl, rfl⟩ := H + exact ⟨_, _, ih (by omega) H, rfl, rfl⟩ + +theorem RetagFVar.find?_gt + {fvData : FVarId × List FVarId} {decl : VLocalDecl} + {depth : Nat} {source target : KVLCtx} + (W : RetagFVar fvData decl depth source target) : + ∀ {j : Nat} {e A : VExpr}, depth < j → + source.find? (.inl j) = some (e, A) → + target.find? (.inl (j - 1)) = some (e, A) := by + induction W with + | zero => + intro j e A hj H + cases j with + | zero => omega + | succ j => simpa [find?, next] using H + | @succ depth source target d _ ih => + intro j e A hj H + cases j with + | zero => omega + | succ j => + cases j with + | zero => omega + | succ j => + simp [find?, next] at H ⊢ + obtain ⟨e', A', H, rfl, rfl⟩ := H + exact ⟨_, _, ih (by omega) H, rfl, rfl⟩ + +theorem RetagFVar.find?_fvar + {fvData : FVarId × List FVarId} {decl : VLocalDecl} + {depth : Nat} {source target : KVLCtx} + (W : RetagFVar fvData decl depth source target) + (hfresh : fvData.1 ∉ source.fvars) : + ∀ {fv : FVarId} {e A : VExpr}, + source.find? (.inr fv) = some (e, A) → + target.find? (.inr fv) = some (e, A) := by + induction W with + | @zero Delta => + intro fv e A H + have hmem : fv ∈ Delta.fvars := by + simpa using find?_inr_mem H + have hne : fvData.1 ≠ fv := fun heq => + hfresh (by simpa [heq] using hmem) + simp [find?, next, hne] at H ⊢ + exact H + | @succ depth source target d _ ih => + intro fv e A H + simp only [fvars_cons_none] at hfresh + simp [find?, next] at H ⊢ + obtain ⟨e', A', H, rfl, rfl⟩ := H + exact ⟨_, _, ih hfresh H, rfl, rfl⟩ + +end KVLCtx + +/-- Replacing one de Bruijn binder with its freshly tagged fvar leaves the +Theory expression unchanged. -/ +theorem TrKExprS.openFVar + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + {source : KVLCtx} {body : KExpr .anon} {bodyV : VExpr} + (H : TrKExprS env uvars nameOf trProj source body bodyV) : + ∀ {fvData : FVarId × List FVarId} {decl : VLocalDecl} + {target : KVLCtx} {dk : Nat} {depth : UInt64} + {name : Mode.anon.F Name}, + KVLCtx.RetagFVar fvData decl dk source target → + depth.toNat = dk → + fvData.1 ∉ source.fvars → + depth.toNat + body.size + 1 < UInt64.size → + TrKExprS env uvars nameOf trProj target + (KExpr.instantiateRevSpec body #[.mkFVar fvData.1 name] depth) + bodyV := by + induction H with + | @var source i name info e A hfind => + intro fvData decl target dk depth fvName W hdepth hfresh hbig + rw [KExpr.instantiateRevSpec] + have harrSize : + #[KExpr.mkFVar fvData.1 fvName].size.toUInt64 = 1 := rfl + rw [harrSize] + have hsuccNat : (depth + 1).toNat = depth.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig) + by_cases heq : i = depth + · subst i + have hlt : depth < depth + 1 := + UInt64.lt_iff_toNat_lt.mpr (by rw [hsuccNat]; omega) + have hwindow : ((depth ≥ depth && depth < depth + 1) = true) := by + simp [hlt] + rw [if_pos hwindow] + simp + exact .fvar (W.find?_hit (by simpa [hdepth] using hfind)) + · by_cases hgt : depth < i + · have hgeSucc : depth + 1 ≤ i := + UInt64.le_iff_toNat_le.mpr (by + rw [hsuccNat] + have := UInt64.lt_iff_toNat_lt.mp hgt + omega) + have hnltSucc : ¬i < depth + 1 := fun hlt => by + have hlt' := UInt64.lt_iff_toNat_lt.mp hlt + have hge' := UInt64.le_iff_toNat_le.mp hgeSucc + omega + have hwindow : ¬((i ≥ depth && i < depth + 1) = true) := by + simp [hnltSucc] + rw [if_neg hwindow, if_pos hgeSucc, KExpr.mkVar_shape] + refine .var (A := A) ?_ + have hOneLe : (1 : UInt64) ≤ i := + UInt64.le_iff_toNat_le.mpr (by + have := UInt64.lt_iff_toNat_lt.mp hgt + simp only [UInt64.toNat_ofNat] + omega) + rw [UInt64.toNat_sub_of_le i 1 hOneLe, + show (1 : UInt64).toNat = 1 from rfl] + exact W.find?_gt (by + rw [← hdepth] + exact UInt64.lt_iff_toNat_lt.mp hgt) hfind + · have hlt : i.toNat < dk := by + have hne : i.toNat ≠ depth.toNat := fun h => + heq (UInt64.toNat_inj.mp h) + have hnlt : ¬depth.toNat < i.toNat := fun h => + hgt (UInt64.lt_iff_toNat_lt.mpr h) + omega + have hnge : ¬i ≥ depth := fun h => by + have hle := UInt64.le_iff_toNat_le.mp h + have hne : depth.toNat ≠ i.toNat := fun hEq => + heq (UInt64.toNat_inj.mp hEq.symm) + exact hgt (UInt64.lt_iff_toNat_lt.mpr (by omega)) + have hngeSucc : ¬i ≥ depth + 1 := fun h => + hnge (UInt64.le_iff_toNat_le.mpr (by + have h' := UInt64.le_iff_toNat_le.mp h + rw [hsuccNat] at h' + omega)) + have hwindow : ¬((i ≥ depth && i < depth + 1) = true) := by + simp [hnge] + rw [if_neg hwindow, if_neg hngeSucc] + exact .var (W.find?_lt hlt hfind) + | @fvar source fv name info e A hfind => + intro fvData decl target dk depth fvName W hdepth hfresh hbig + exact .fvar (W.find?_fvar hfresh hfind) + | @sort source u info hu => + intro fvData decl target dk depth fvName W hdepth hfresh hbig + exact .sort hu + | @const source id us info cname ci hname hconst hus hsize => + intro fvData decl target dk depth fvName W hdepth hfresh hbig + exact .const hname hconst hus hsize + | @app source f a info fV aV A B hfun harg hf ha ihf iha => + intro fvData decl target dk depth fvName W hdepth hfresh hbig + have hbig' : depth.toNat + (f.size + a.size + 1) + 1 < + UInt64.size := hbig + rw [KExpr.instantiateRevSpec, KExpr.mkApp_shape] + exact .app (W.toCtx_eq ▸ hfun) (W.toCtx_eq ▸ harg) + (ihf W hdepth hfresh (by omega)) + (iha W hdepth hfresh (by omega)) + | @lam source name bi ty body info tyV bodyV htype hty hbody ihty ihbody => + intro fvData decl target dk depth fvName W hdepth hfresh hbig + have hbig' : depth.toNat + (ty.size + body.size + 1) + 1 < + UInt64.size := hbig + have hsucc : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.instantiateRevSpec, KExpr.mkLam_shape] + exact .lam (W.toCtx_eq ▸ htype) + (ihty W hdepth hfresh (by omega)) + (ihbody W.succ hsucc (by simpa using hfresh) (by + rw [hsucc] + omega)) + | @all source name bi ty body info tyV bodyV htyType hbodyType hty hbody + ihty ihbody => + intro fvData decl target dk depth fvName W hdepth hfresh hbig + have hbig' : depth.toNat + (ty.size + body.size + 1) + 1 < + UInt64.size := hbig + have hsucc : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.instantiateRevSpec, KExpr.mkAll_shape] + exact .all (W.toCtx_eq ▸ htyType) + (by simpa [W.toCtx_eq] using hbodyType) + (ihty W hdepth hfresh (by omega)) + (ihbody W.succ hsucc (by simpa using hfresh) (by + rw [hsucc] + omega)) + | @letE source name ty val body nondep info tyV valV bodyV hvalType hty + hval hbody ihty ihval ihbody => + intro fvData decl target dk depth fvName W hdepth hfresh hbig + have hbig' : depth.toNat + + (ty.size + val.size + body.size + 1) + 1 < UInt64.size := hbig + have hsucc : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.instantiateRevSpec, KExpr.mkLet_shape] + exact .letE (W.toCtx_eq ▸ hvalType) + (ihty W hdepth hfresh (by omega)) + (ihval W hdepth hfresh (by omega)) + (ihbody W.succ hsucc (by simpa using hfresh) (by + rw [hsucc] + omega)) + | @prj source sid field val info sName valueV resultV hname hval hproj + ihval => + intro fvData decl target dk depth fvName W hdepth hfresh hbig + have hbig' : depth.toNat + (val.size + 1) + 1 < UInt64.size := hbig + rw [KExpr.instantiateRevSpec, KExpr.mkPrj_shape] + exact .prj hname (ihval W hdepth hfresh (by omega)) + (W.toCtx_eq ▸ hproj) + | @nat source value blob info hlit => + intro fvData decl target dk depth fvName W hdepth hfresh hbig + exact .nat hlit + | @str source value blob info hlit => + intro fvData decl target dk depth fvName W hdepth hfresh hbig + exact .str hlit + +/-- Entry-depth specialization used by the three production binder branches. -/ +theorem TrKExprS.openFVarZero + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + {Delta : KVLCtx} {decl : VLocalDecl} + {body : KExpr .anon} {bodyV : VExpr} + {fv : FVarId} {deps : List FVarId} {name : Mode.anon.F Name} + (H : TrKExprS env uvars nameOf trProj + ((none, decl) :: Delta) body bodyV) + (hfresh : fv ∉ Delta.fvars) + (hbound : body.size + 1 < UInt64.size) : + TrKExprS env uvars nameOf trProj + ((some (fv, deps), decl) :: Delta) + (KExpr.instantiateRevSpec body #[.mkFVar fv name] 0) bodyV := + H.openFVar .zero rfl (by simpa using hfresh) (by simpa using hbound) + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/BinderScopes.lean b/Ix/Tc/Verify/Infer/BinderScopes.lean new file mode 100644 index 000000000..57a67e3b1 --- /dev/null +++ b/Ix/Tc/Verify/Infer/BinderScopes.lean @@ -0,0 +1,334 @@ +import Ix.Tc.Verify.Infer.BinderOpening + +/-! +# Operational binder scopes for inference + +The semantic retagging theorem in `BinderOpening` describes the result of +opening a de Bruijn binder. This module verifies the production +`TcM.openBinder` helper, including fvar allocation, interning, local-context +extension, walker execution, and the allocation-exhaustion error path. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Finite closure needed by a generic recursive method contract when it +opens `body` with a freshly allocated anonymous-mode fvar. The fvar id is a +`UInt64`, so quantifying over every possible id still describes a finite +family. This is deliberately a support resource rather than request-list +membership: a finite execution certificate records only the id reached by +one concrete run, whereas `RecM.WF` ranges over every invariant callback +state. + +The reach clause includes the source, every intermediate walker node, and +the final opened body. The bounds clause is the exact arithmetic contract +consumed by `instantiateRev_spec`. -/ +structure BinderOpeningResources (support : RunSupport) + (name : Mode.anon.F Name) (body : KExpr .anon) : Prop where + fvarSupport : ∀ fv : FVarId, support (.mkFVar fv name) + instRevSupport : ∀ (fv : FVarId) (x : KExpr .anon), + KExpr.InstRevReach #[.mkFVar fv name] body 0 x → support x + instRevBounds : ∀ fv : FVarId, + WalkerRequest.Bounds (.instRev body #[.mkFVar fv name]) + +namespace TcM + +/-- Hoare form of request-independent binder instantiation. This is the +compositional counterpart of `instRev_whnf_eval_of_resources`: callers that +continue in `RecM` can retain the exact opened body and intern-only frame +without selecting a concrete execution request. -/ +theorem instRev_whnf_wf_of_resources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {body : KExpr .anon} + {fvars : Array (KExpr .anon)} {s : TcState .anon} + (hcollision : support.CollisionFree) + (hbounds : WalkerRequest.Bounds (.instRev body fvars)) + (hreach : ∀ x, KExpr.InstRevReach fvars body 0 x → support x) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.runIntern (instantiateRev body fvars)) + (fun result after => + result = KExpr.instantiateRevSpec body fvars 0 ∧ + InternUpdateFrame s after) := + TcM.runIntern_whnf_wf + (fun it hwf hsupport => by + have post := Ix.Tc.instantiateRev_spec hcollision.expr hbounds.1 + hbounds.2.2 hreach hwf hsupport.expr + exact ⟨post.1, post.2.1, + hsupport.of_expr_univs post.2.2 + (instantiateRev_preservesUnivs body fvars it)⟩) + +/-- Request-independent execution of the binder-opening walker. Generic +recursive closure cannot select one concrete request indexed by a callback's +post-state, so this form consumes the finite support resource directly. -/ +theorem instRev_whnf_eval_of_resources + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {body : KExpr .anon} + {fvars : Array (KExpr .anon)} {s : TcState .anon} + (hcollision : support.CollisionFree) + (hbounds : WalkerRequest.Bounds (.instRev body fvars)) + (hreach : ∀ x, KExpr.InstRevReach fvars body 0 x → support x) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) : + ∃ after, + TcM.runIntern (instantiateRev body fvars) s = + .ok (KExpr.instantiateRevSpec body fvars 0) after ∧ + WhnfStateInv layer semantics trProj world support uvars Delta after ∧ + InternUpdateFrame s after := + TcM.runIntern_whnf_eval + (fun it hwf hsupport => by + have post := Ix.Tc.instantiateRev_spec hcollision.expr hbounds.1 + hbounds.2.2 hreach hwf hsupport.expr + exact ⟨post.1, post.2.1, + hsupport.of_expr_univs post.2.2 + (instantiateRev_preservesUnivs body fvars it)⟩) + hI + +/-- Opening a translated binder either fails before changing the semantic +context, or returns its freshly tagged body under the corresponding extended +concrete and ghost contexts. -/ +theorem openBinder_scope + {support : RunSupport} + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body : KExpr .anon} {tyV bodyV : VExpr} + (hty : TrKExprS world.venv uvars world.nameOf trProj Delta ty tyV) + (htyType : world.venv.IsType uvars Delta.toCtx tyV) + (hbody : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam tyV) :: Delta) body bodyV) + (hcollision : support.CollisionFree) + (hresources : BinderOpeningResources support name body) : + WhnfStateInv layer semantics trProj world support uvars Delta s → + match TcM.openBinder name bi ty body s with + | .ok (bodyOpen, fvId) after => + fvId = ⟨s.env.nextFVarId⟩ ∧ + bodyOpen = KExpr.instantiateRevSpec body + #[.mkFVar ⟨s.env.nextFVarId⟩ name] 0 ∧ + WhnfStateInv layer semantics trProj world support uvars + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), .vlam tyV) :: Delta) + after ∧ + support bodyOpen ∧ + TrKExprS world.venv uvars world.nameOf trProj + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), .vlam tyV) :: Delta) + bodyOpen bodyV + | .error _ after => + WhnfStateInv layer semantics trProj world support uvars Delta after ∧ + after = s := by + intro hI + have hfreshPost := (TcM.freshFVarId_wf (s := s) + (layer := layer) (semantics := semantics) (trProj := trProj) + (world := world) (support := support) (uvars := uvars) + (Delta := Delta)) hI + cases hfreshRun : TcM.freshFVarId (m := .anon) s with + | error err afterFresh => + rw [hfreshRun] at hfreshPost + simp only at hfreshPost + have hafter : afterFresh = s := hfreshPost.2.2 + subst afterFresh + have hopenError : TcM.openBinder name bi ty body s = .error err s := by + unfold TcM.openBinder + change EStateM.bind (TcM.freshFVarId (m := .anon)) _ s = _ + unfold EStateM.bind + rw [hfreshRun] + rw [hopenError] + exact ⟨hfreshPost.1, rfl⟩ + | ok fvId afterFresh => + rw [hfreshRun] at hfreshPost + simp only at hfreshPost + rcases hfreshPost.2 with ⟨hfvId, hafterFresh, hnext⟩ + subst fvId + subst afterFresh + let fv : KExpr .anon := .mkFVar ⟨s.env.nextFVarId⟩ name + obtain ⟨afterIntern, hinternRun, hIIntern, hInternFrame⟩ := + TcM.intern_whnf_eval hcollision + (hresources.fvarSupport ⟨s.env.nextFVarId⟩) hfreshPost.1 + let pushState : TcState .anon → TcState .anon := fun state => + {state with lctx := + state.lctx.push ⟨s.env.nextFVarId⟩ (.cdecl name bi ty)} + let afterPush : TcState .anon := pushState afterIntern + have hkernelPush : + KernelStateWF semantics trProj world support afterPush := by + exact { + core := hIIntern.1.core.of_env_eq rfl + internSupport := by simpa [afterPush] using hIIntern.1.internSupport + caches := by simpa [afterPush] using hIIntern.1.caches + equivalences := by + simpa [afterPush, pushState] using hIIntern.1.equivalences } + have hIPush : WhnfStateInv layer semantics trProj world support uvars + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), .vlam tyV) :: Delta) + afterPush := by + apply hI.openFVar hkernelPush + (TrKLocalDecl.vlam (nm := name) (bi := bi) hty htyType) + (by intro x hx; exact hx) + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.ctx hInternFrame + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.letVals hInternFrame + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.numLetBindings hInternFrame + · have hlctx : afterIntern.lctx = s.lctx := by + simpa [InternUpdateFrame] using + congrArg TcState.lctx hInternFrame + simp [afterPush, pushState, hlctx] + · have hnextEq : afterIntern.env.nextFVarId = + s.env.freshFVarId.2.nextFVarId := by + simpa [InternUpdateFrame] using congrArg + (fun state : TcState .anon => state.env.nextFVarId) + hInternFrame + simpa [afterPush, pushState, hnextEq] using hnext + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.prims hInternFrame + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.noAccel hInternFrame + have hopenBound := hresources.instRevBounds ⟨s.env.nextFVarId⟩ + have hbodyOpenTr := hbody.openFVarZero + (fv := ⟨s.env.nextFVarId⟩) (deps := Delta.fvars) (name := name) + hI.2.1.nextFVarId_fresh (by simpa using hopenBound.2.2) + have hbodyOpenSupport : support + (KExpr.instantiateRevSpec body #[fv] 0) := + hresources.instRevSupport ⟨s.env.nextFVarId⟩ _ + (KExpr.InstRevReach.spec ..) + obtain ⟨afterOpen, hopenRun, hIOpen, hOpenFrame⟩ := + instRev_whnf_eval_of_resources hcollision hopenBound + (hresources.instRevSupport ⟨s.env.nextFVarId⟩) hIPush + have hopenSuccess : TcM.openBinder name bi ty body s = + .ok (KExpr.instantiateRevSpec body #[fv] 0, + ⟨s.env.nextFVarId⟩) afterOpen := by + unfold TcM.openBinder + change EStateM.bind (TcM.freshFVarId (m := .anon)) _ s = _ + unfold EStateM.bind + rw [hfreshRun] + simp only + change EStateM.bind (TcM.intern fv) _ _ = _ + unfold EStateM.bind + rw [hinternRun] + simp only + change EStateM.bind + (modify pushState : TcM .anon PUnit) _ afterIntern = _ + unfold EStateM.bind + rw [show (modify pushState : TcM .anon PUnit) afterIntern = + EStateM.Result.ok () afterPush from rfl] + simp only + change EStateM.bind + (TcM.runIntern (instantiateRev body #[fv])) _ afterPush = _ + unfold EStateM.bind + rw [hopenRun] + rfl + rw [hopenSuccess] + refine ⟨rfl, rfl, hIOpen, ?_, ?_⟩ + · simpa [fv] using hbodyOpenSupport + · simpa [fv] using hbodyOpenTr + +end TcM + +namespace RecM + +/-- Compose verified binder opening with an arbitrary continuation under the +tagged context. `withLctxScope` closes the concrete and ghost fvar frame on +both continuation success and continuation error; allocation exhaustion is +the only pre-push error and restores the unchanged entry state. -/ +theorem withLctxScope_openBinder_wf + {beta : Type} {support : RunSupport} + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body : KExpr .anon} {tyV bodyV : VExpr} + (hty : TrKExprS world.venv uvars world.nameOf trProj Delta ty tyV) + (htyType : world.venv.IsType uvars Delta.toCtx tyV) + (hbody : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam tyV) :: Delta) body bodyV) + (hcollision : support.CollisionFree) + (hresources : BinderOpeningResources support name body) + {k : KExpr .anon → FVarId → RecM .anon beta} + {Qinner Qouter : beta → TcState .anon → Prop} + (hk : ∀ {bodyOpen fv after}, + fv = ⟨s.env.nextFVarId⟩ → + bodyOpen = KExpr.instantiateRevSpec body + #[.mkFVar ⟨s.env.nextFVarId⟩ name] 0 → + support bodyOpen → + TrKExprS world.venv uvars world.nameOf trProj + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), .vlam tyV) :: Delta) + bodyOpen bodyV → + RecM.WF layer semantics trProj world support uvars + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), .vlam tyV) :: Delta) + after (k bodyOpen fv) Qinner) + (hclose : ∀ result after, Qinner result after → + Qouter result + {after with lctx := after.lctx.truncate s.lctx.size}) : + RecM.WF layer semantics trProj world support uvars Delta s + (withLctxScope do + let (bodyOpen, fv) ← TcM.openBinder name bi ty body + k bodyOpen fv) + Qouter := by + intro methods hmethods hI + rw [RecM.withLctxScope_eq] + have hopenPost := TcM.openBinder_scope (bi := bi) hty htyType hbody + hcollision hresources hI + cases hopenRun : TcM.openBinder name bi ty body s with + | error err afterOpen => + rw [hopenRun] at hopenPost + simp only at hopenPost + rcases hopenPost with ⟨hIOpen, hafterOpen⟩ + have hscopedError : + (do + let (bodyOpen, fv) ← + (liftM (TcM.openBinder name bi ty body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods s = .error err afterOpen := by + change EStateM.bind (TcM.openBinder name bi ty body) + (fun opened => (k opened.1 opened.2).run methods) s = _ + unfold EStateM.bind + rw [hopenRun] + rw [hscopedError] + subst afterOpen + simp only [LocalContext.truncate_size] + exact ⟨hIOpen, trivial⟩ + | ok opened afterOpen => + rcases opened with ⟨bodyOpen, fv⟩ + rw [hopenRun] at hopenPost + simp only at hopenPost + rcases hopenPost with + ⟨hfv, hbodyEq, hIOpen, hbodySupport, hbodyTr⟩ + have htail := hk hfv hbodyEq hbodySupport hbodyTr + methods hmethods hIOpen + cases htailRun : (k bodyOpen fv).run methods afterOpen with + | ok result after => + rw [htailRun] at htail + simp only at htail + have hscopedSuccess : + (do + let (bodyOpen, fv) ← + (liftM (TcM.openBinder name bi ty body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods s = .ok result after := by + change EStateM.bind (TcM.openBinder name bi ty body) + (fun opened => (k opened.1 opened.2).run methods) s = _ + unfold EStateM.bind + rw [hopenRun] + exact htailRun + rw [hscopedSuccess] + exact ⟨hI.closeFVarAtEntry htail.1, hclose _ _ htail.2⟩ + | error tailErr after => + rw [htailRun] at htail + simp only at htail + have hscopedError : + (do + let (bodyOpen, fv) ← + (liftM (TcM.openBinder name bi ty body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods s = .error tailErr after := by + change EStateM.bind (TcM.openBinder name bi ty body) + (fun opened => (k opened.1 opened.2).run methods) s = _ + unfold EStateM.bind + rw [hopenRun] + exact htailRun + rw [hscopedError] + exact ⟨hI.closeFVarAtEntry htail.1, trivial⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/CacheShell.lean b/Ix/Tc/Verify/Infer/CacheShell.lean new file mode 100644 index 000000000..e9166c92e --- /dev/null +++ b/Ix/Tc/Verify/Infer/CacheShell.lean @@ -0,0 +1,220 @@ +import Ix.Tc.Verify.DefEq + +/-! +# Inference cache shell + +This module verifies the policy split around the uncached inference +dispatcher. It records the exact production executions for both cache-write +partitions and for the full/infer-only miss paths, including partial errors +before any result is cached. +-/ + +namespace Ix.Tc + +namespace RecM + +@[simp] theorem cacheInferResult_full_run + (methods : Methods .anon) (s : TcState .anon) + (key : Address × Address) (ty : KExpr .anon) : + (cacheInferResult false key ty).run methods s = + .ok () {s with env := {s.env with + inferCache := s.env.inferCache.insert key ty}} := by + rfl + +@[simp] theorem cacheInferResult_inferOnly_run + (methods : Methods .anon) (s : TcState .anon) + (key : Address × Address) (ty : KExpr .anon) : + (cacheInferResult true key ty).run methods s = + .ok () {s with env := {s.env with + inferOnlyCache := s.env.inferOnlyCache.insert key ty}} := by + rfl + +/-- A certified validated inference result can be installed in the full +partition without changing any other semantic state component. -/ +theorem cacheInferResult_full_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {key : Address × Address} {ty : KExpr .anon} + (hnew : CacheProvenance semantics (CacheAuthority.stable world) support + (.expr .infer key ty)) : + RecM.WF layer semantics trProj world support uvars Delta s + (cacheInferResult false key ty) (fun _ _ => True) := by + intro methods _ hI + rw [cacheInferResult_full_run] + exact ⟨InferCacheUpdate.full_whnfStateInv hI hnew, trivial⟩ + +/-- Infer-only results remain confined to their policy partition. -/ +theorem cacheInferResult_inferOnly_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {key : Address × Address} {ty : KExpr .anon} + (hnew : CacheProvenance semantics (CacheAuthority.stable world) support + (.expr .inferOnly key ty)) : + RecM.WF layer semantics trProj world support uvars Delta s + (cacheInferResult true key ty) (fun _ _ => True) := by + intro methods _ hI + rw [cacheInferResult_inferOnly_run] + exact ⟨InferCacheUpdate.inferOnly_whnfStateInv hI hnew, trivial⟩ + +/-- Exact successful full-mode miss: the uncached result is written only to +the validated partition. -/ +theorem inferWith_fullMiss_success + {inferRec : KExpr .anon → RecM .anon (KExpr .anon)} + {methods : Methods .anon} {source ty : KExpr .anon} + {key : Address × Address} {s sKey sBody : TcState .anon} + (hpolicy : s.inferOnly = false) + (hkey : TcM.inferKey source s = .ok key sKey) + (hfullMiss : sKey.env.inferCache[key]? = none) + (hbody : (inferUncached inferRec false source).run methods sKey = + .ok ty sBody) : + (inferWith inferRec source).run methods s = + .ok ty {sBody with env := {sBody.env with + inferCache := sBody.env.inferCache.insert key ty}} := by + unfold inferWith + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only [hpolicy] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.inferKey source) _ s = _ + unfold EStateM.bind + rw [hkey] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ sKey = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) sKey = .ok sKey sKey from rfl] + simp only [hfullMiss, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind + ((inferUncached inferRec false source).run methods) _ sKey = _ + unfold EStateM.bind + rw [hbody] + rfl + +/-- An uncached full-mode error is propagated with its partial state and no +inference-cache write. -/ +theorem inferWith_fullMiss_error + {inferRec : KExpr .anon → RecM .anon (KExpr .anon)} + {methods : Methods .anon} {source : KExpr .anon} + {key : Address × Address} {s sKey sBody : TcState .anon} + {err : TcError .anon} + (hpolicy : s.inferOnly = false) + (hkey : TcM.inferKey source s = .ok key sKey) + (hfullMiss : sKey.env.inferCache[key]? = none) + (hbody : (inferUncached inferRec false source).run methods sKey = + .error err sBody) : + (inferWith inferRec source).run methods s = .error err sBody := by + unfold inferWith + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only [hpolicy] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.inferKey source) _ s = _ + unfold EStateM.bind + rw [hkey] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ sKey = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) sKey = .ok sKey sKey from rfl] + simp only [hfullMiss, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind + ((inferUncached inferRec false source).run methods) _ sKey = _ + unfold EStateM.bind + rw [hbody] + +/-- Exact successful infer-only miss: after both partitions miss, the result +is written only to the infer-only partition. -/ +theorem inferWith_inferOnlyMiss_success + {inferRec : KExpr .anon → RecM .anon (KExpr .anon)} + {methods : Methods .anon} {source ty : KExpr .anon} + {key : Address × Address} {s sKey sBody : TcState .anon} + (hpolicy : s.inferOnly = true) + (hkey : TcM.inferKey source s = .ok key sKey) + (hfullMiss : sKey.env.inferCache[key]? = none) + (hinferOnlyMiss : sKey.env.inferOnlyCache[key]? = none) + (hbody : (inferUncached inferRec true source).run methods sKey = + .ok ty sBody) : + (inferWith inferRec source).run methods s = + .ok ty {sBody with env := {sBody.env with + inferOnlyCache := sBody.env.inferOnlyCache.insert key ty}} := by + unfold inferWith + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only [hpolicy] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.inferKey source) _ s = _ + unfold EStateM.bind + rw [hkey] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ sKey = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) sKey = .ok sKey sKey from rfl] + simp only [hfullMiss] + simp only [pure_bind, if_true] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ sKey = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) sKey = .ok sKey sKey from rfl] + simp only [hinferOnlyMiss] + rw [ReaderT.run_bind] + change EStateM.bind + ((inferUncached inferRec true source).run methods) _ sKey = _ + unfold EStateM.bind + rw [hbody] + rfl + +/-- Infer-only dispatcher errors likewise propagate before any cache write. -/ +theorem inferWith_inferOnlyMiss_error + {inferRec : KExpr .anon → RecM .anon (KExpr .anon)} + {methods : Methods .anon} {source : KExpr .anon} + {key : Address × Address} {s sKey sBody : TcState .anon} + {err : TcError .anon} + (hpolicy : s.inferOnly = true) + (hkey : TcM.inferKey source s = .ok key sKey) + (hfullMiss : sKey.env.inferCache[key]? = none) + (hinferOnlyMiss : sKey.env.inferOnlyCache[key]? = none) + (hbody : (inferUncached inferRec true source).run methods sKey = + .error err sBody) : + (inferWith inferRec source).run methods s = .error err sBody := by + unfold inferWith + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only [hpolicy] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.inferKey source) _ s = _ + unfold EStateM.bind + rw [hkey] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ sKey = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) sKey = .ok sKey sKey from rfl] + simp only [hfullMiss] + simp only [pure_bind, if_true] + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ sKey = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) sKey = .ok sKey sKey from rfl] + simp only [hinferOnlyMiss] + rw [ReaderT.run_bind] + change EStateM.bind + ((inferUncached inferRec true source).run methods) _ sKey = _ + unfold EStateM.bind + rw [hbody] + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/CacheSoundness.lean b/Ix/Tc/Verify/Infer/CacheSoundness.lean new file mode 100644 index 000000000..4911b4106 --- /dev/null +++ b/Ix/Tc/Verify/Infer/CacheSoundness.lean @@ -0,0 +1,271 @@ +import Ix.Tc.Verify.Infer.Dispatcher + +/-! +# Inference cache soundness + +This module closes the production `inferWith` shell around the exhaustive +uncached dispatcher. Cache hits are accepted only through canonical K2 +provenance. Cache misses build new provenance from the exact key execution, +finite expression collision freedom, suffix transport, and the concrete +uncached typing result before mutating either cache partition. +-/ + +namespace Ix.Tc + +namespace TcM + +/-- A joint K2 suffix model turns the actual inference-key execution into the +same operational match used to validate both hits and writes. -/ +theorem inferKey_model_matches_wf + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : KernelSuffixModel trProj world) + {Delta : KVLCtx} {source : KExpr .anon} {s : TcState .anon} : + TcM.WF + (WhnfStateInv layer (kernelCacheSemantics model.keys trProj) trProj + world support model.keys.uvars Delta) s + (TcM.inferKey source) + (fun key s' => + model.keys.Matches trProj world s Delta source key /\ + ContextKeyFrame s s') := by + simpa using + (TcM.whnfKey_matches_wf + (layer := layer) (semantics := kernelCacheSemantics model.keys trProj) + (trProj := trProj) (world := world) (support := support) + (keys := model.keys) (Δ := Delta) (source := source) (s := s) + (fun _ _ hctx hrun => model.represents hctx hrun)) + +end TcM + +namespace UncachedInference.Context + +/-- Every direct constant root of a newly inferred cache entry is trusted: +source witnesses and the concrete result both lie in the finite run support. -/ +private theorem cacheReferences + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + (context : UncachedInference.Context initial program requests + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars) + {kind : ExprCacheKind} {key : Address × Address} {ty : KExpr .anon} + (hty : support ty) : + (CacheEntry.expr kind key ty).ReferencesAuthorized + (CacheAuthority.stable world) support := by + intro id href + apply Or.inl + rcases href with hsource | hresult + · obtain ⟨source, hsourceSupport, _, hsourceRef⟩ := hsource + exact context.references hsourceSupport hsourceRef + · exact context.references hty hresult + +/-- Execute one uncached result and install it in exactly the partition +selected at `inferWith` entry. The write occurs only after collision-robust +semantic provenance has been constructed. -/ +private theorem missTail_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + (context : UncachedInference.Context initial program requests + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars) + {Delta : KVLCtx} {before s : TcState .anon} {inferOnly : Bool} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + {key : Address × Address} + (hmatch : model.keys.Matches trProj world before Delta source key) + (hsourceSupport : support source) + (hsource : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta + source sourceV) : + RecM.WF .noAccel (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s + (do + let ty ← RecM.inferUncached RecM.inferCall inferOnly source + RecM.cacheInferResult inferOnly key ty + pure ty) + (fun result _ => support result /\ + InferPost trProj world model.keys.uvars Delta sourceV result) := by + cases inferOnly with + | false => + apply RecM.WF.bind + (RecM.WF.withInv <| + RecM.inferUncached_wf context hsourceSupport hsource) + intro ty afterBody hbody + rcases hbody with ⟨_, hty, hpost⟩ + have hprovenance := model.inferProvenance + context.projection.run.collisionFree .infer hsourceSupport hty hmatch + (InferMeaning.of_post hsource hpost) + (context.cacheReferences hty) + apply RecM.WF.bind + (RecM.cacheInferResult_full_wf hprovenance) + intro _ afterWrite _ + exact RecM.WF.pure fun _ => ⟨hty, hpost⟩ + | true => + apply RecM.WF.bind + (RecM.WF.withInv <| + RecM.inferUncached_wf context hsourceSupport hsource) + intro ty afterBody hbody + rcases hbody with ⟨_, hty, hpost⟩ + have hprovenance := model.inferProvenance + context.projection.run.collisionFree .inferOnly hsourceSupport hty + hmatch (InferMeaning.of_post hsource hpost) + (context.cacheReferences hty) + apply RecM.WF.bind + (RecM.cacheInferResult_inferOnly_wf hprovenance) + intro _ afterWrite _ + exact RecM.WF.pure fun _ => ⟨hty, hpost⟩ + +end UncachedInference.Context + +namespace RecM + +/-- Complete production inference entry point: key errors preserve the +invariant, full-cache hits are accepted in either policy, infer-only hits are +accepted only under the captured infer-only policy, and both miss paths write +only provenance-certified results to their respective partitions. -/ +theorem inferWith_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + (context : UncachedInference.Context initial program requests + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars) + {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta + source sourceV) : + RecM.WF .noAccel (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s (inferWith inferCall source) + (fun result _ => support result /\ + InferPost trProj world model.keys.uvars Delta sourceV result) := by + unfold inferWith + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s /\ after = s) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + apply RecM.WF.bind + (Q₁ := fun key _ => + model.keys.Matches trProj world s Delta source key) + · apply RecM.WF.liftTcM + exact TcM.WF.mono (TcM.inferKey_model_matches_wf model) + (fun _ _ h => h.1) (fun _ _ h => h) + · intro key afterKey hmatch + apply RecM.WF.bind + (Q₁ := fun current after => current = afterKey /\ after = afterKey) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro current afterRead hread + rcases hread with ⟨hCurrent, hAfterRead⟩ + subst current + subst afterRead + let fullFound := afterKey.env.inferCache[key]? + cases hfullFound : fullFound with + | some cached => + have hhit : afterKey.env.inferCache[key]? = some cached := by + simpa [fullFound] using hfullFound + simp only [hhit] + exact RecM.WF.pure fun hI => by + have hprovenance := hI.1.caches.hit (.infer hhit) + have hmeaning := hprovenance.kernelInferMeaningOfMatches + .infer hsourceSupport hmatch + exact ⟨hprovenance.supported.2, + hmeaning.post context.projection.theory hI.2.1.wf hsource⟩ + | none => + have hfullMiss : afterKey.env.inferCache[key]? = none := by + simpa [fullFound] using hfullFound + simp only [hfullMiss] + cases hpolicy : s.inferOnly with + | false => + simp only [Bool.false_eq_true, if_false] + exact context.missTail_wf hmatch hsourceSupport hsource + | true => + simp only [pure_bind, if_true] + apply RecM.WF.bind + (Q₁ := fun current after => + current = afterKey /\ after = afterKey) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro current afterInferOnlyRead hread + rcases hread with ⟨hCurrent, hAfterRead⟩ + subst current + subst afterInferOnlyRead + let inferOnlyFound := afterKey.env.inferOnlyCache[key]? + cases hinferOnlyFound : inferOnlyFound with + | some cached => + have hhit : afterKey.env.inferOnlyCache[key]? = some cached := by + simpa [inferOnlyFound] using hinferOnlyFound + simp only [hhit] + exact RecM.WF.pure fun hI => by + have hprovenance := hI.1.caches.hit (.inferOnly hhit) + have hmeaning := hprovenance.kernelInferMeaningOfMatches + .inferOnly hsourceSupport hmatch + exact ⟨hprovenance.supported.2, + hmeaning.post context.projection.theory hI.2.1.wf hsource⟩ + | none => + have hmiss : afterKey.env.inferOnlyCache[key]? = none := by + simpa [inferOnlyFound] using hinferOnlyFound + simp only [hmiss] + exact context.missTail_wf hmatch hsourceSupport hsource + +/-- Public inference inherits the complete `inferWith` cache contract; its +recursive edges remain tied exclusively through the caller's smaller method +table. -/ +theorem infer_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + (context : UncachedInference.Context initial program requests + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars) + {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta + source sourceV) : + RecM.WF .noAccel (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s (infer source) + (fun result _ => support result /\ + InferPost trProj world model.keys.uvars Delta sourceV result) := by + simpa [infer] using + (RecM.inferWith_wf context hsourceSupport hsource) + +end RecM + +namespace UncachedInference.Context + +/-- The inference field of one unfolded production method-table layer. The +proof consumes only the semantic contract of the smaller table supplied by +the knot induction hypothesis. -/ +theorem nextInfer_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + (context : UncachedInference.Context initial program requests + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars) + (methods : Methods .anon) + (hmethods : Methods.WFAt .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars methods) : + forall {Delta : KVLCtx} {s : TcState .anon} {source : KExpr .anon} + {sourceV : Lean4Lean.VExpr}, + support source -> + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV -> + TcM.WF + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta) s + ((RecM.infer source).run methods) + (fun result _ => support result /\ + InferPost trProj world model.keys.uvars Delta sourceV result) := by + intro Delta s source sourceV hsourceSupport hsource + exact (RecM.infer_wf context hsourceSupport hsource) methods hmethods + +end UncachedInference.Context + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/Callbacks.lean b/Ix/Tc/Verify/Infer/Callbacks.lean new file mode 100644 index 000000000..d429b077c --- /dev/null +++ b/Ix/Tc/Verify/Infer/Callbacks.lean @@ -0,0 +1,72 @@ +import Ix.Tc.Verify.Infer.Literals + +/-! +# Inference callback contracts + +These adapters expose the three recursive services used by the uncached +inference dispatcher: predecessor-layer inference, predecessor-layer DefEq, +and the already-closed direct WHNF implementation used by `ensureSortDirect` +and `ensureForallDirect`. +-/ + +namespace Ix.Tc + +namespace DirectWhnf + +/-- Semantic contract for the direct `RecM.whnf` body at one universe count. +K1's fixed-universe closure constructs this contract when K2 assembles the +joint layer. -/ +def WFAt (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + forall {Delta s source sourceV}, + support source -> + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV -> + RecM.WF .noAccel semantics trProj world support uvars Delta s + (RecM.whnf source) + (fun result _ => support result /\ + WhnfPost trProj world uvars Delta sourceV result) + +end DirectWhnf + +namespace RecM + +/-- The ordinary recursive inference edge is exactly the predecessor +method-table field. -/ +theorem inferCall_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsource : support source) + (htr : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (inferCall source) + (fun ty _ => support ty /\ + InferPost trProj world uvars Delta sourceV ty) := by + intro methods hmethods + simpa only [inferCall, ReaderT.run_bind, ReaderT.run_monadLift, + pure_bind] using hmethods.infer hsource htr + +/-- The ordinary recursive DefEq edge is exactly the predecessor table's +soundness contract. -/ +theorem isDefEqCall_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv uvars world.nameOf trProj Delta b vb) : + RecM.WF layer semantics trProj world support uvars Delta s + (isDefEqCall a b) + (fun answer _ => answer = true -> + world.venv.IsDefEqU uvars Delta.toCtx va vb) := by + intro methods hmethods + simpa only [isDefEqCall, ReaderT.run_bind, ReaderT.run_monadLift, + pure_bind] using + hmethods.isDefEq haSupport hbSupport ha hb + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/CheapBeta.lean b/Ix/Tc/Verify/Infer/CheapBeta.lean new file mode 100644 index 000000000..6675d9765 --- /dev/null +++ b/Ix/Tc/Verify/Infer/CheapBeta.lean @@ -0,0 +1,462 @@ +import Ix.Tc.Verify.Infer.BinderScopes +import Ix.Tc.Verify.Whnf.Beta.Meaning +import Ix.Tc.Verify.Whnf.Structural.ApplicationCongruence + +/-! +# Audited cheap beta reduction + +Lambda and let inference run `cheapBetaReduce` inside the intern table. This +module connects its pure plan to the finite `WalkerRequest.cheapBeta` +footprint and proves exact execution while preserving the complete checker +invariant. The Theory-level beta meaning is intentionally a separate layer; +the operational theorem here cannot silently assume it. +-/ + +namespace Ix.Tc + +namespace RecM.BetaPeel + +/-- Prefix one already-proved peel by the outermost lambda and its first +argument. -/ +theorem prepend + {inner body : KExpr .anon} {consumed : List (KExpr .anon)} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty arg : KExpr .anon} {info : ExprInfo .anon} + (h : BetaPeel inner consumed body) : + BetaPeel (.lam name bi ty inner info) (arg :: consumed) body := by + induction h with + | nil => + simpa using + (BetaPeel.snoc (arg := arg) + (BetaPeel.nil (.lam name bi ty inner info))) + | snoc hprefix ih => + simpa [List.cons_append] using BetaPeel.snoc ih + +/-- `peelLamsN` consumes exactly the corresponding list prefix. -/ +theorem of_peelLamsN (head : KExpr .anon) (args : List (KExpr .anon)) : + let (body, consumed) := peelLamsN args.length head + BetaPeel head (args.take consumed) body ∧ consumed ≤ args.length := by + induction args generalizing head with + | nil => + simp only [List.length_nil, peelLamsN, List.take_zero] + exact ⟨BetaPeel.nil head, Nat.le_refl 0⟩ + | cons arg args ih => + cases head with + | lam name bi ty inner info => + simp only [List.length_cons] + generalize hpeel : peelLamsN args.length inner = peeled + rcases peeled with ⟨body, consumed⟩ + have hrun : + peelLamsN (args.length + 1) (.lam name bi ty inner info) = + (body, consumed + 1) := by + rw [peelLamsN, hpeel] + rw [hrun] + have htail := ih inner + rw [hpeel] at htail + dsimp only at htail + refine ⟨?_, by omega⟩ + simpa only [List.take_succ_cons] using + (htail.1.prepend (name := name) (bi := bi) (ty := ty) + (arg := arg) (info := info)) + | var | fvar | sort | const | app | all | letE | prj | nat | str => + simp only [List.length_cons, peelLamsN, List.take_zero] + exact ⟨BetaPeel.nil _, Nat.zero_le _⟩ + +end RecM.BetaPeel + +namespace WalkerRequest.Bounds + +/-- Recover the simultaneous-substitution budget for the exact prefix +selected by a cheap-beta plan. -/ +theorem cheapBeta_simul + {source head body : KExpr .anon} {args : Array (KExpr .anon)} + {consumed : Nat} + (h : WalkerRequest.Bounds (.cheapBeta source)) + (hspine : source.collectSpine = (head, args)) + (hpeel : peelLamsN args.size head = (body, consumed)) : + WalkerRequest.Bounds + (.simulSubst body (args.extract 0 consumed).reverse 0) := + h.2 hspine hpeel + +end WalkerRequest.Bounds + +private theorem toNat_toUInt64_cheapBeta (n : Nat) : + n.toUInt64.toNat = n % UInt64.size := by + unfold Nat.toUInt64 + rfl + +/-- A successful cheap-beta plan is exactly the simultaneous substitution +of the consumed lambda prefix followed by the untouched application suffix. +This is the arithmetic seam behind the selected-variable fast path: the +production index `consumed - k - 1` is index `k` in the reversed prefix. -/ +theorem cheapBetaPlan?_simul + {source : KExpr .anon} {plan : CheapBetaPlan .anon} + (hplan : cheapBetaPlan? source = some plan) + (hbounds : WalkerRequest.Bounds (.cheapBeta source)) : + ∃ (head body : KExpr .anon) (args : Array (KExpr .anon)) + (consumed : Nat), + source.collectSpine = (head, args) ∧ + peelLamsN args.size head = (body, consumed) ∧ + consumed ≤ args.size ∧ + plan.base = KExpr.simulSubstSpec body + (args.extract 0 consumed).reverse 0 ∧ + plan.trailing = (args.extract consumed args.size).toList := by + cases source with + | app f arg info => + simp only [cheapBetaPlan?] at hplan + generalize hspine : (KExpr.app f arg info).collectSpine = spine at hplan + rcases spine with ⟨head, args⟩ + cases head with + | lam name bi ty inner lamInfo => + generalize hpeel : + peelLamsN args.size (.lam name bi ty inner lamInfo) = peeled + at hplan + rcases peeled with ⟨body, consumed⟩ + have hcount := + RecM.BetaPeel.of_peelLamsN + (.lam name bi ty inner lamInfo) args.toList + rw [show args.toList.length = args.size by simp, hpeel] at hcount + dsimp only at hcount + have hsim := hbounds.2 hspine hpeel + have hprefixSize : (args.extract 0 consumed).size = consumed := by + simp only [Array.size_extract] + omega + by_cases hclosed : body.lbr == 0 + · simp only [hclosed, if_true, Option.some.injEq] at hplan + subst plan + have hlbr : body.lbr ≤ 0 := by + rw [beq_iff_eq.mp hclosed] + exact UInt64.le_iff_toNat_le.mpr (Nat.le_refl 0) + have hsimEq := KExpr.simulSubstSpec_id hsim.1 + (by simpa only [UInt64.toNat_zero, Nat.zero_add, hprefixSize] + using hsim.2.2.2.1) + hlbr + exact ⟨_, _, _, _, rfl, hpeel, hcount.2, + hsimEq.symm, rfl⟩ + · cases body with + | var k varName varInfo => + by_cases hk : k < consumed.toUInt64 + · simp only [hclosed, Bool.false_eq_true, if_false, hk, + if_true, Option.some.injEq] at hplan + subst plan + have hconsumedLt : consumed < UInt64.size := by + have hbodySize := KExpr.size_pos + (.var k varName varInfo : KExpr .anon) + have hbig := hsim.2.2.2.1 + simp only [Array.size_reverse, hprefixSize] at hbig + omega + have hconsumedNat : consumed.toUInt64.toNat = consumed := by + rw [toNat_toUInt64_cheapBeta] + exact Nat.mod_eq_of_lt hconsumedLt + have hkNat : k.toNat < consumed := by + have := UInt64.lt_iff_toNat_lt.mp hk + rwa [hconsumedNat] at this + have hkPrefix : + k.toNat < (args.extract 0 consumed).reverse.size := by + simpa only [Array.size_reverse, hprefixSize] using hkNat + have hselected : + (args.extract 0 consumed).reverse[k.toNat]! = + args[consumed - k.toNat - 1]! := by + rw [getElem!_pos + (args.extract 0 consumed).reverse k.toNat hkPrefix, + Array.getElem_reverse] + have hsourceIndex : consumed - k.toNat - 1 < args.size := + by omega + rw [getElem!_pos args (consumed - k.toNat - 1) + hsourceIndex, + Array.getElem_extract] + congr 1 + omega + have hprefixSize64 : + (args.extract 0 consumed).reverse.size.toUInt64.toNat = + consumed := by + rw [toNat_toUInt64_cheapBeta] + simp only [Array.size_reverse, hprefixSize] + exact Nat.mod_eq_of_lt hconsumedLt + have hkWindow : + (k ≥ (0 : UInt64) && + k < 0 + + (args.extract 0 consumed).reverse.size.toUInt64) = + true := by + apply Bool.and_eq_true_iff.mpr + constructor + · exact decide_eq_true (UInt64.le_iff_toNat_le.mpr + (Nat.zero_le _)) + · exact decide_eq_true (UInt64.lt_iff_toNat_lt.mpr + (by + rw [UInt64.toNat_add, UInt64.toNat_zero, + hprefixSize64, Nat.zero_add, + Nat.mod_eq_of_lt hconsumedLt] + exact hkNat)) + have hselectedConstructed := hsim.2.1 k.toNat (by + simpa only [Array.size_reverse, hprefixSize] using hkNat) + have hsimEq : + KExpr.simulSubstSpec (.var k varName varInfo) + (args.extract 0 consumed).reverse 0 = + args[consumed - k.toNat - 1]! := by + rw [KExpr.simulSubstSpec, if_pos hkWindow, + UInt64.sub_zero, + KExpr.liftSpec_zero hselectedConstructed, hselected] + exact ⟨_, _, _, _, rfl, hpeel, hcount.2, + hsimEq.symm, rfl⟩ + · simp [hclosed, hk] at hplan + | fvar | sort | const | app | lam | all | letE | prj | nat | + str => + simp [hclosed] at hplan + | var | fvar | sort | const | app | all | letE | prj | nat | str => + cases hplan + | var | fvar | sort | const | lam | all | letE | prj | nat | str => + cases hplan + +/-- Cheap beta reduction preserves the Theory meaning of a structurally +translated source. A successful plan is discharged by K1's constructive +multi-beta theorem; an absent plan is reflexive. -/ +theorem KExpr.cheapBetaReduceResult_meaning + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) {Delta : KVLCtx} + (hDelta : KVLCtx.WF world.venv uvars Delta) + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hbounds : WalkerRequest.Bounds (.cheapBeta source)) : + WhnfMeaning trProj world uvars Delta source + (KExpr.cheapBetaReduceResult source) := by + cases hplan : cheapBetaPlan? source with + | none => + rw [KExpr.cheapBetaReduceResult, hplan] + exact WhnfMeaning.refl hsource + (hsource.wf world.venvWF.ordered theory.literalWF + theory.projections.wf hDelta) + | some plan => + rw [KExpr.cheapBetaReduceResult, hplan] + obtain ⟨head, body, args, consumed, hspine, hpeel, hcount, + hbase, htrailing⟩ := cheapBetaPlan?_simul hplan hbounds + have htyped := RecM.trAppSpine_of_collectSpine hsource hspine + obtain ⟨headV, hheadTr, hsuffix⟩ := htyped.toSuffix + have hprefixList : + (args.extract 0 consumed).toList = + args.toList.take consumed := by + simp only [Array.toList_extract, List.extract_eq_take_drop, + List.drop_zero, Nat.sub_zero] + have htrailingList : + (args.extract consumed args.size).toList = + args.toList.drop consumed := by + rw [Array.toList_extract] + simp only [List.extract_eq_take_drop] + have hargsLength : args.toList.length = args.size := by simp + have hdropLength : + (args.toList.drop consumed).length = + args.size - consumed := by + rw [List.length_drop, hargsLength] + rw [← hdropLength] + exact List.take_length + obtain ⟨middleV, hprefix, htrailingSuffix⟩ := + hsuffix.splitAt consumed (by simpa using hcount) + rw [← hprefixList] at hprefix + rw [← htrailingList] at htrailingSuffix + have hpeelCert := RecM.BetaPeel.of_peelLamsN head args.toList + rw [show args.toList.length = args.size by simp, hpeel] at hpeelCert + dsimp only at hpeelCert + rw [← hprefixList] at hpeelCert + have hsimBounds := hbounds.cheapBeta_simul hspine hpeel + obtain ⟨reducedV, hreducedTr, hmiddleReduced⟩ := + RecM.betaPrefixMeaning trProj world theory hDelta hheadTr + hpeelCert.1 hprefix hsimBounds + rw [← htrailing] at htrailingSuffix + obtain ⟨finalV, hfinalTr, hsourceFinal⟩ := + htrailingSuffix.rebase world.venvWF hDelta hreducedTr + hmiddleReduced + refine ⟨sourceV, finalV, hsource, ?_, hsourceFinal⟩ + change TrKExprS world.venv uvars world.nameOf trProj Delta + (plan.trailing.foldl KExpr.mkApp plan.base) finalV + rw [hbase] + exact hfinalTr + +namespace KExpr.CheapBetaReach + +@[simp] theorem source (e : KExpr .anon) : CheapBetaReach e e := by + simp [CheapBetaReach] + +theorem of_plan {source : KExpr .anon} {plan : CheapBetaPlan .anon} + (hplan : cheapBetaPlan? source = some plan) {x : KExpr .anon} + (hx : x ∈ cheapBetaChainList plan.base plan.trailing) : + CheapBetaReach source x := by + simp [CheapBetaReach, hplan, hx] + +end KExpr.CheapBetaReach + +/-- The pure result of an application-chain plan occurs in its exact finite +candidate list. -/ +theorem cheapBetaChainList_result_mem (base : KExpr .anon) : + ∀ trailing : List (KExpr .anon), + trailing.foldl KExpr.mkApp base ∈ cheapBetaChainList base trailing + | [] => by simp [cheapBetaChainList] + | arg :: trailing => by + simp only [List.foldl_cons, cheapBetaChainList, List.mem_cons] + exact Or.inr (cheapBetaChainList_result_mem + (KExpr.mkApp base arg) trailing) + +theorem cheapBetaChainList_base_mem (base : KExpr .anon) + (trailing : List (KExpr .anon)) : + base ∈ cheapBetaChainList base trailing := by + cases trailing <;> simp [cheapBetaChainList] + +namespace KExpr.CheapBetaReach + +theorem result (source : KExpr .anon) : + CheapBetaReach source (KExpr.cheapBetaReduceResult source) := by + cases hplan : cheapBetaPlan? source with + | none => + simp [KExpr.cheapBetaReduceResult, hplan, KExpr.CheapBetaReach] + | some plan => + rw [KExpr.cheapBetaReduceResult, hplan] + exact of_plan hplan + (cheapBetaChainList_result_mem plan.base plan.trailing) + +end KExpr.CheapBetaReach + +/-- Execute one selected application chain exactly. Every candidate offered +to the intern table is drawn from `cheapBetaChainList`; collision freedom +therefore returns the anonymous expression itself rather than a colliding +resident. -/ +theorem internAppChain_spec + {support : RunSupport} (hcollision : support.CollisionFree) + {base : KExpr .anon} {trailing : List (KExpr .anon)} + (hreach : ∀ x, x ∈ cheapBetaChainList base trailing → support x) + (it : InternTable .anon) (hwf : it.WF) + (hcover : support.CoversIntern it) : + (internAppChain base trailing it).1 = + trailing.foldl KExpr.mkApp base ∧ + (internAppChain base trailing it).2.WF ∧ + support.CoversIntern (internAppChain base trailing it).2 := by + induction trailing generalizing base it with + | nil => + exact ⟨rfl, hwf, hcover⟩ + | cons arg trailing ih => + let candidate := KExpr.mkApp base arg + have hcandidate : support candidate := + hreach candidate (by + simp only [cheapBetaChainList, List.mem_cons] + exact Or.inr (cheapBetaChainList_base_mem candidate trailing)) + have hintern := TcM.internExpr_support_spec hcollision hcandidate + it hwf hcover + rcases hintern with ⟨hcanon, hwf', hcover'⟩ + have htail : ∀ x, + x ∈ cheapBetaChainList candidate trailing → support x := by + intro x hx + exact hreach x (by + simp only [cheapBetaChainList, List.mem_cons] + exact Or.inr hx) + have hrest := ih htail (it.internExpr candidate).2 hwf' hcover' + change + (internAppChain (it.internExpr candidate).1 trailing + (it.internExpr candidate).2).1 = + (arg :: trailing).foldl KExpr.mkApp base ∧ + (internAppChain (it.internExpr candidate).1 trailing + (it.internExpr candidate).2).2.WF ∧ + support.CoversIntern + (internAppChain (it.internExpr candidate).1 trailing + (it.internExpr candidate).2).2 + rw [hcanon] + simpa only [List.foldl_cons] using hrest + +/-- InternM-level exactness and support preservation for the whole +peephole reducer. -/ +theorem cheapBetaReduce_spec + {support : RunSupport} (hcollision : support.CollisionFree) + {source : KExpr .anon} + (hreach : ∀ x, KExpr.CheapBetaReach source x → support x) + (it : InternTable .anon) (hwf : it.WF) + (hcover : support.CoversIntern it) : + (cheapBetaReduce source it).1 = KExpr.cheapBetaReduceResult source ∧ + (cheapBetaReduce source it).2.WF ∧ + support.CoversIntern (cheapBetaReduce source it).2 := by + cases hplan : cheapBetaPlan? source with + | none => + rw [cheapBetaReduce, hplan] + change source = KExpr.cheapBetaReduceResult source ∧ + it.WF ∧ support.CoversIntern it + simpa [KExpr.cheapBetaReduceResult, hplan] using + (show source = source ∧ it.WF ∧ support.CoversIntern it from + ⟨rfl, hwf, hcover⟩) + | some plan => + have hchain : ∀ x, + x ∈ cheapBetaChainList plan.base plan.trailing → support x := + fun x hx => hreach x (KExpr.CheapBetaReach.of_plan hplan hx) + simpa [cheapBetaReduce, KExpr.cheapBetaReduceResult, hplan, + CheapBetaPlan.result] using + internAppChain_spec hcollision hchain it hwf hcover + +/-- Finite callback resources for cheap beta at any supported recursive +inference result. The source quantifier ranges over a finite `RunSupport`, +so this remains a finite closure obligation. -/ +structure CheapBetaResources (support : RunSupport) : Prop where + reach : ∀ {source : KExpr .anon}, support source → ∀ x, + KExpr.CheapBetaReach source x → support x + bounds : ∀ {source : KExpr .anon}, support source → + WalkerRequest.Bounds (.cheapBeta source) + +namespace CheapBetaResources + +/-- Request-independent execution rule used when `source` is returned by a +recursive callback and therefore is not statically named in the enclosing +execution certificate. -/ +theorem whnf_wf + {support : RunSupport} (hresources : CheapBetaResources support) + (hcollision : support.CollisionFree) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {source : KExpr .anon} + (hsource : support source) {s : TcState .anon} : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.runIntern (cheapBetaReduce source)) + (fun result after => + result = KExpr.cheapBetaReduceResult source ∧ + support result ∧ InternUpdateFrame s after) := by + have hreach := hresources.reach hsource + apply TcM.WF.mono + (TcM.runIntern_whnf_wf (fun it hwf hcover => + cheapBetaReduce_spec hcollision hreach it hwf hcover)) + · intro result after hpost + rcases hpost with ⟨rfl, hframe⟩ + exact ⟨rfl, hreach _ (KExpr.CheapBetaReach.result source), hframe⟩ + · intro _ _ herror + exact herror + +end CheapBetaResources + +namespace RunAssumptions + +/-- The audited request-list form used by inference branches. -/ +theorem cheapBeta_whnf_wf + {alpha : Type} {initial : TcState .anon} + {program : TcM .anon alpha} {requests : List WalkerRequest} + {support : RunSupport} + (h : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {source : KExpr .anon} + (hmem : WalkerRequest.cheapBeta source ∈ requests) + {s : TcState .anon} : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.runIntern (cheapBetaReduce source)) + (fun result after => + result = KExpr.cheapBetaReduceResult source ∧ + support result ∧ InternUpdateFrame s after) := by + have hreach : ∀ x, KExpr.CheapBetaReach source x → support x := + (h.coverage.requests _ hmem).expr + apply TcM.WF.mono + (TcM.runIntern_whnf_wf (fun it hwf hcover => + cheapBetaReduce_spec h.collisionFree hreach it hwf hcover)) + · intro result after hpost + rcases hpost with ⟨rfl, hframe⟩ + refine ⟨rfl, ?_, hframe⟩ + exact hreach _ (KExpr.CheapBetaReach.result source) + · intro _ _ herror + exact herror + +end RunAssumptions + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/Constants.lean b/Ix/Tc/Verify/Infer/Constants.lean new file mode 100644 index 000000000..67f4a2def --- /dev/null +++ b/Ix/Tc/Verify/Infer/Constants.lean @@ -0,0 +1,233 @@ +import Ix.Tc.Verify.Infer.LeafCases +import Ix.Tc.Verify.Whnf.Delta.StableCache + +/-! +# Constant inference + +This module verifies required constant lookup, universe-arity checking, and +type instantiation. The trusted world currently retains only `RawExprRel` +for declaration types; inference needs the stronger typed `TrKExprS` +relation. `TrustedConstTypes` names that boundary explicitly so the final K2 +closure must derive it from declaration admission rather than silently +upgrading raw syntax correspondence. +-/ + +namespace Ix.Tc + +namespace TcM + +/-- A successful optional constant lookup returns a value that is installed +in the successful post-state. -/ +theorem tryGetConst_loaded_wf {I : TcState .anon → Prop} + (hfault : LazyFaultPreserves I) (id : KId .anon) (s : TcState .anon) : + TcM.WF I s (TcM.tryGetConst id) + (fun found after => ∀ c, found = some c → + after.env.get? id = some c) := by + unfold TcM.tryGetConst + apply TcM.WF.bind + (Q₁ := fun read after => read = after) + (TcM.WF.get fun _ => rfl) + intro read before hread + subst read + split + · next c hget => + exact TcM.WF.pure fun _ result hresult => by + cases hresult + exact hget + · apply TcM.WF.bind + (Q₁ := fun read after => read = after) + (TcM.WF.get fun _ => rfl) + intro read beforeFault hread + subst read + apply TcM.WF.bind + (Q₁ := fun _ _ => True) + (TcM.lazyIngressAddr_wf hfault id.addr beforeFault) + intro _ afterFault _ + apply TcM.WF.bind + (Q₁ := fun read after => read = after) + (TcM.WF.get fun _ => rfl) + intro read after hread + subst read + split + · next c hget => + exact TcM.WF.pure fun _ result hresult => by + cases hresult + exact hget + · split + · exact TcM.WF.throw fun _ => trivial + · exact TcM.WF.pure fun _ result hresult => by + cases hresult + +/-- Required lookup has the same installed-result property; the optional +miss is converted to the production `unknownConst` error. -/ +theorem getConst_loaded_wf {I : TcState .anon → Prop} + (hfault : LazyFaultPreserves I) (id : KId .anon) (s : TcState .anon) : + TcM.WF I s (TcM.getConst id) + (fun c after => after.env.get? id = some c) := by + unfold TcM.getConst + apply TcM.WF.bind (TcM.tryGetConst_loaded_wf hfault id s) + intro found after hfound + cases found with + | none => exact TcM.WF.throw fun _ => trivial + | some c => exact TcM.WF.pure fun _ => hfound c rfl + +end TcM + +/-- Typed declaration-type evidence missing from the current raw trusted +catalog interface. K2 closure must construct this for every trusted +constant that a supported run can infer. -/ +def TrustedConstTypes (trProj : RawProjRel) (world : VerifyWorld) : Prop := + ∀ {id : KId .anon} {c : KConst .anon}, + world.trusted id → world.catalog id = some c → + ∃ name ci, + TrustedConstRel trProj world id c name ci ∧ + TrKExprS world.venv ci.uvars world.nameOf trProj [] c.ty ci.type + +/-- Finite universe-walker census and its two level-resource obligations for +every supported constant syntax that can reach the uncached dispatcher. -/ +def ConstInferCensus (world : VerifyWorld) (support : RunSupport) + (requests : List WalkerRequest) : Prop := + ∀ {id : KId .anon} {us : Array (KUniv .anon)} + {info : ExprInfo .anon} {c : KConst .anon}, + support (.const id us info) → world.catalog id = some c → + WalkerRequest.instUniv c.ty us ∈ requests ∧ + DeltaInstantiationResources us c.ty + +namespace TrustedConstRel + +/-- Instantiate the structurally translated type of one trusted constant in +the caller's universe and mixed context. The empty-array fast path is +handled separately because production deliberately skips the walker there. -/ +theorem instantiatedType + {trProj : RawProjRel} {world : VerifyWorld} + {id : KId .anon} {c : KConst .anon} {name : Lean.Name} + {ci : Lean4Lean.VConstant} + (h : TrustedConstRel trProj world id c name ci) + (htype : TrKExprS world.venv ci.uvars world.nameOf trProj [] + c.ty ci.type) + {uvars : Nat} (theory : WhnfTheory trProj world uvars) + {us : Array (KUniv .anon)} {result : KExpr .anon} + (hus : ∀ level ∈ us, (KUniv.toVLevel level).WF uvars) + (harity : us.size = ci.uvars) + (hspec : KExpr.instantiateUnivParamsSpec c.ty us = .ok result) + (resources : DeltaInstantiationResources us c.ty) + {Delta : KVLCtx} (hDelta : KVLCtx.WF world.venv uvars Delta) : + TrKExpr world.venv uvars world.nameOf trProj Delta result + (ci.type.instL (us.toList.map KUniv.toVLevel)) := by + by_cases hempty : us.isEmpty + · have husEmpty : us = #[] := Array.empty_of_isEmpty hempty + subst us + have hresult : result = c.ty := by + simpa [KExpr.instantiateUnivParamsSpec] using hspec.symm + subst result + have hzero : ci.uvars = 0 := by + simpa using harity.symm + have htype0 : + TrKExprS world.venv 0 world.nameOf trProj [] c.ty ci.type := by + simpa only [hzero] using htype + have htypeU : + TrKExprS world.venv uvars world.nameOf trProj [] c.ty ci.type := + htype0.monoU (Nat.zero_le uvars) (by trivial) + have htypeDelta : + TrKExprS world.venv uvars world.nameOf trProj Delta c.ty ci.type := by + simpa only [KVLCtx.appendOuter] using + htypeU.weakRight world.venvWF.ordered theory.literalWF + theory.projections (by trivial) Delta + obtain ⟨sort, hciType⟩ := h.wf + have hciLevels : ci.type.LevelWF 0 := by + have hlevels := hciType.levelWF (by trivial) + simpa only [hzero] using hlevels.1 + have hinst : ci.type.instL [] = ci.type := by + simpa [Lean4Lean.VLevel.params] using hciLevels.instL_id + simpa [hinst] using + htypeDelta.trKExpr world.venvWF.ordered theory.literalWF + theory.projections.wf hDelta + · have hspec' : KExpr.instUnivSpec c.ty us = .ok result := by + simpa [KExpr.instantiateUnivParamsSpec, hempty] using hspec + have hresult := + TrKExprS.instL world.venvWF theory.literalWF theory.projections + hus harity.symm htype (by trivial) hspec' + resources.addrFaithful resources.levelSize + simpa only [KVLCtx.instL, KVLCtx.appendOuter] using + hresult.weakRight world.venvWF.ordered theory.literalWF + theory.projections (by trivial) Delta + +end TrustedConstRel + +namespace RecM + +/-- The complete non-recursive constant branch: trusted lazy lookup, exact +arity check, request-certified universe instantiation, and Theory typing of +the source constant by the instantiated declaration type. -/ +theorem inferUncached_const_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {inferRec : KExpr .anon → RecM .anon (KExpr .anon)} + {inferOnly : Bool} {id : KId .anon} + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {sourceV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hreferences : RecM.TrustedReferences world support) + (htypes : TrustedConstTypes trProj world) + (hcensus : ConstInferCensus world support requests) + (hsourceSupport : support (.const id us info)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.const id us info) sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (inferUncached inferRec inferOnly (.const id us info)) + (fun ty _ => support ty ∧ + InferPost trProj world uvars Delta sourceV ty) := by + cases hsource with + | const hname hlookup hus harity => + rename_i sourceName sourceCi + unfold inferUncached + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.getConst_loaded_wf hfault id s) + intro c after hget + rcases hget with ⟨hI, hloaded⟩ + have hcatalog : world.catalog id = some c := + hI.1.core.loaded hloaded + have htrusted : world.trusted id := by + apply hreferences hsourceSupport + rfl + obtain ⟨resolvedName, ci, hrel, htype⟩ := + htypes htrusted hcatalog + have hnameEq := Option.some.inj (hrel.nameEq.symm.trans hname) + cases hnameEq + have hciEq := Option.some.inj (hrel.lookup.symm.trans hlookup) + cases hciEq + have hcheck : c.lvls.toNat = us.size := by + exact hrel.uvars.trans harity.symm + have hcheckNe : (c.lvls.toNat != us.size) = false := by + simp [hcheck] + simp only [hcheckNe, Bool.false_eq_true, if_false, pure_bind] + obtain ⟨hmem, resources⟩ := hcensus hsourceSupport hcatalog + apply RecM.WF.mono + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.instantiateUnivParams_whnf_wf hrun.collisionFree + (hrun.coverage.instUniv hmem)) + · intro result final hresult + rcases hresult with ⟨hIfinal, hspec, hresultSupport⟩ + refine ⟨hresultSupport, + sourceCi.type.instL (us.toList.map KUniv.toVLevel), ?_, ?_⟩ + · exact hrel.instantiatedType htype theory hus harity hspec + resources hIfinal.2.1.wf + · exact Lean4Lean.VEnv.HasType.const hlookup + (by + intro level hlevel + obtain ⟨source, hsourceLevel, rfl⟩ := List.mem_map.1 hlevel + exact hus source (by simpa using hsourceLevel)) + (by simpa using harity) + · intro _ _ _ + trivial + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/Dispatcher.lean b/Ix/Tc/Verify/Infer/Dispatcher.lean new file mode 100644 index 000000000..5642ebc49 --- /dev/null +++ b/Ix/Tc/Verify/Infer/Dispatcher.lean @@ -0,0 +1,170 @@ +import Ix.Tc.Verify.Infer.Applications +import Ix.Tc.Verify.Infer.Constants +import Ix.Tc.Verify.Infer.ForallTypes +import Ix.Tc.Verify.Infer.LambdaTypes +import Ix.Tc.Verify.Infer.LeafCases +import Ix.Tc.Verify.Infer.LetTypes +import Ix.Tc.Verify.Infer.Literals +import Ix.Tc.Verify.Infer.ProjectionTypes + +/-! +# Uncached inference dispatcher + +This module assembles the constructor-local inference proofs into one +exhaustive contract for the production `inferUncached` dispatcher. The +assembly context contains finite-run support, walker, and catalog resources; +it does not contain a semantic result callback for the dispatcher itself. + +The legacy de Bruijn-variable request is indexed by the concrete entry state. +Its resource is consequently guarded by the complete state invariant, unlike +the syntax-only census facts. This avoids requiring facts about arbitrary +invalid states merely to state recursive inference closure. +-/ + +namespace Ix.Tc + +/-- State-indexed resources for the legacy de Bruijn-variable inference +branch. The translated source establishes that the lookup is in range; this +resource records the finite walker request and the arithmetic bound needed by +the verified lift. -/ +def VariableInferenceResources (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (requests : List WalkerRequest) (uvars : Nat) : Prop := + forall {Delta : KVLCtx} {s : TcState .anon} {idx : UInt64} + {name : Mode.anon.F Name} {info : ExprInfo .anon}, + WhnfStateInv .noAccel semantics trProj world support uvars Delta s -> + support (.var idx name info) -> + WalkerRequest.lift + s.ctx[s.ctx.size - 1 - idx.toNat]! (idx + 1) 0 ∈ requests /\ + Delta.bvars + + s.ctx[s.ctx.size - 1 - idx.toNat]!.size < UInt64.size + +/-- Syntax-directed finite support needed by lambda, forall, let, and sort +inference. Each premise restricts the obligation to a source already present +in the finite run support. -/ +structure SyntaxInferenceResources (support : RunSupport) : Prop where + sortResult : forall {u : KUniv .anon} {info : ExprInfo .anon}, + support (.sort u info) -> support (KExpr.mkSort (KUniv.mkSucc u)) + lambda : forall {name : Mode.anon.F Name} + {bi : Mode.anon.F Lean.BinderInfo} {ty body : KExpr .anon} + {info : ExprInfo .anon}, + support (.lam name bi ty body info) -> + support ty /\ BinderOpeningResources support name body /\ + LambdaResultSupport support ty + forallE : forall {name : Mode.anon.F Name} + {bi : Mode.anon.F Lean.BinderInfo} {ty body : KExpr .anon} + {info : ExprInfo .anon}, + support (.all name bi ty body info) -> + support ty /\ BinderOpeningResources support name body + letE : forall {name : Mode.anon.F Name} {ty val body : KExpr .anon} + {nondep : Bool} {info : ExprInfo .anon}, + support (.letE name ty val body nondep info) -> + support ty /\ support val /\ BinderOpeningResources support name body + +namespace UncachedInference + +/-- All shared resources needed to assemble the concrete constructor proofs. +Projection helper execution is supplied through its concrete context, whose +only semantic boundary is `ProjectionInference.DeclarationOracle`. -/ +structure Context + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Type where + projection : ProjectionInference.Context initial program requests semantics + trProj world support uvars + variables : VariableInferenceResources semantics trProj world support + requests uvars + fvars : forall Delta : KVLCtx, + RecM.FVarInferSafety .noAccel semantics trProj world support uvars Delta + structural : SyntaxInferenceResources support + references : RecM.TrustedReferences world support + constTypes : TrustedConstTypes trProj world + constants : ConstInferCensus world support requests + literals : LiteralInferContext world support + applications : ApplicationInferCensus support requests + cheapBeta : CheapBetaResources support + abstraction : SingletonAbstractionResources support + forallResults : ForallResultSupport support + projectionValues : ProjectionValueSupport support + +end UncachedInference + +namespace RecM + +/-- Exhaustive correctness of the production uncached syntax dispatcher. +Every successful result remains in finite run support and is a Theory type of +the translated source; every partial error preserves the complete checker +invariant through the constructor-local `RecM.WF` proofs. -/ +theorem inferUncached_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (context : UncachedInference.Context initial program requests semantics + trProj world support uvars) + {Delta : KVLCtx} {s : TcState .anon} {inferOnly : Bool} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (inferUncached inferCall inferOnly source) + (fun result _ => support result /\ + InferPost trProj world uvars Delta sourceV result) := by + cases source with + | var idx name info => + intro methods hmethods hI + obtain ⟨hrequest, hbound⟩ := + context.variables hI hsourceSupport + exact (RecM.inferUncached_var_wf context.projection.run + context.projection.theory hsource hrequest hbound) methods hmethods hI + | fvar fv name info => + exact RecM.inferUncached_fvar_wf context.projection.theory + (context.fvars Delta) hsource + | sort u info => + exact RecM.inferUncached_sort_wf context.projection.theory + context.projection.run.collisionFree + (context.structural.sortResult hsourceSupport) hsource + | const id levels info => + exact RecM.inferUncached_const_wf context.projection.run + context.projection.theory (context.projection.fault Delta) + context.references context.constTypes context.constants + hsourceSupport hsource + | app f a info => + exact RecM.inferUncached_app_wf context.projection.run + context.projection.theory context.projection.whnf + context.projection.components context.applications hsourceSupport + hsource + | lam name bi ty body info => + obtain ⟨hty, hbinder, hresult⟩ := + context.structural.lambda hsourceSupport + exact RecM.inferUncached_lam_wf context.projection.run + context.projection.theory context.projection.whnf + context.projection.sorts context.cheapBeta context.abstraction + hresult hty hbinder hsource + | all name bi ty body info => + obtain ⟨hty, hbinder⟩ := context.structural.forallE hsourceSupport + exact RecM.inferUncached_all_wf context.projection.run + context.projection.theory context.projection.whnf + context.projection.sorts context.forallResults hty hbinder hsource + | letE name ty val body nondep info => + obtain ⟨hty, hval, hbinder⟩ := context.structural.letE hsourceSupport + exact RecM.inferUncached_let_wf context.projection.run + context.projection.theory context.projection.whnf + context.projection.sorts context.abstraction + context.projection.substitution context.cheapBeta hty hval hbinder + hsource + | prj structId field val info => + exact RecM.inferUncached_prj_wf context.projectionValues + context.projection.wf hsourceSupport hsource + | nat n blob info => + exact RecM.inferUncached_nat_wf context.literals + context.projection.theory hsource + | str value blob info => + exact RecM.inferUncached_str_wf context.literals + context.projection.theory hsource + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/ForallTypes.lean b/Ix/Tc/Verify/Infer/ForallTypes.lean new file mode 100644 index 000000000..efe4228c5 --- /dev/null +++ b/Ix/Tc/Verify/Infer/ForallTypes.lean @@ -0,0 +1,158 @@ +import Ix.Tc.Verify.Infer.SortTypes +import Ix.Tc.Verify.Infer.BinderScopes + +/-! +# Forall inference + +This module verifies the production `forall` inference branch. It composes +recursive domain/body inference, direct sort exposure, operational binder +opening and cleanup, the simplifying universe `imax` constructor, and final +expression interning. +-/ + +namespace Ix.Tc + +/-- Finite result closure for `forall` inference. The premise ranges only +over the finite universe support of the run, rather than over all levels. -/ +def ForallResultSupport (support : RunSupport) : Prop := + ∀ {u1 u2 : KUniv .anon}, support.univ u1 → support.univ u2 → + support (KExpr.mkSort (KUniv.mkIMax u1 u2)) + +namespace RecM + +/-- Once the binder is open, infer its body type, expose its sort, and +construct the result sort. The semantic postcondition is already stated in +the outer context; only the state invariant remains under the tagged fvar +until `withLctxScope` closes it. -/ +private theorem inferForallTail_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {fv : FVarId} {deps : List FVarId} + {tyV bodyV input1 : Lean4Lean.VExpr} {bodyOpen : KExpr .anon} + {u1 : KUniv .anon} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hresources : SortComponentResources support) + (hresults : ForallResultSupport support) + (hcollision : support.CollisionFree) + (htySort : world.venv.HasType uvars Delta.toCtx tyV + (.sort u1.toVLevel)) + (hu1 : SortView world support uvars Delta input1 u1) + (hbodySupport : support bodyOpen) + (hbodyTr : TrKExprS world.venv uvars world.nameOf trProj + ((some (fv, deps), .vlam tyV) :: Delta) bodyOpen bodyV) : + RecM.WF .noAccel semantics trProj world support uvars + ((some (fv, deps), .vlam tyV) :: Delta) s + (do + let bodyTy ← inferCall bodyOpen + let u2 ← ensureSortDirect bodyTy + TcM.intern (.mkSort (.mkIMax u1 u2))) + (fun result _ => support result ∧ + InferPost trProj world uvars Delta (.forallE tyV bodyV) result) := by + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.inferCall_wf hbodySupport hbodyTr) + intro bodyTy afterBody hbodyPost + rcases hbodyPost with + ⟨_, hbodyTySupport, bodyTyV, hbodyTyTr, hbodyTy⟩ + apply RecM.WF.bind + (RecM.WF.withInv <| + RecM.ensureSortDirect_wf hwhnf hresources hbodyTySupport hbodyTyTr) + intro u2 afterSort hu2Post + rcases hu2Post with ⟨hISort, hu2⟩ + have hresultSupport := hresults hu1.rootSupport hu2.rootSupport + apply RecM.WF.mono + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf hcollision hresultSupport) + · intro result final hresult + rcases hresult with ⟨hIfinal, rfl, _⟩ + refine ⟨hresultSupport, + .sort (KUniv.mkIMax u1 u2).toVLevel, ?_, ?_⟩ + · exact (TrKExprS.sort + (KUniv.toVLevel_mkIMax_wf hu1.levelWF hu2.levelWF)).trKExpr + world.venvWF.ordered theory.literalWF theory.projections.wf + hIfinal.2.1.wf.1 + · have hbodySort : world.venv.HasType uvars + (tyV :: Delta.toCtx) bodyV (.sort u2.toVLevel) := by + simpa [KVLCtx.toCtx] using + hbodyTy.defeqU_r world.venvWF hIfinal.2.1.wf hu2.inputEq + have hforall : world.venv.HasType uvars Delta.toCtx + (.forallE tyV bodyV) (.sort (.imax u1.toVLevel u2.toVLevel)) := + Lean4Lean.VEnv.HasType.forallE htySort (by simpa using hbodySort) + have hlevelEq := hu1.mkIMax_equiv hcollision hu2 + have hsortEq : world.venv.IsDefEqU uvars Delta.toCtx + (.sort (.imax u1.toVLevel u2.toVLevel)) + (.sort (KUniv.mkIMax u1 u2).toVLevel) := by + refine ⟨_, .sortDF ?_ ?_ ?_⟩ + · exact ⟨hu1.levelWF, hu2.levelWF⟩ + · exact KUniv.toVLevel_mkIMax_wf hu1.levelWF hu2.levelWF + · exact hlevelEq.symm + exact hforall.defeqU_r world.venvWF hIfinal.2.1.wf.1 hsortEq + · intro _ _ _ + trivial + +/-- Complete production `forall` branch. All continuation errors are +cleaned back to the outer local context, while a successful result realizes +the Theory forall typing rule at the smart-constructor `imax`. -/ +theorem inferUncached_all_wf + {alpha : Type} {initial : TcState .anon} + {program : TcM .anon alpha} {requests : List WalkerRequest} + {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {uvars : Nat} {Delta : KVLCtx} + {s : TcState .anon} {inferOnly : Bool} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body : KExpr .anon} {info : ExprInfo .anon} + {sourceV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hresources : SortComponentResources support) + (hresults : ForallResultSupport support) + (htySupport : support ty) + (hbinder : BinderOpeningResources support name body) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.all name bi ty body info) sourceV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (inferUncached inferCall inferOnly (.all name bi ty body info)) + (fun result _ => support result ∧ + InferPost trProj world uvars Delta sourceV result) := by + cases hsource with + | all htyType hbodyType htyTr hbodyTr => + rename_i tyV bodyV + unfold inferUncached + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.inferCall_wf htySupport htyTr) + intro tyTy afterTy htyPost + rcases htyPost with + ⟨_, htyTySupport, tyTyV, htyTyTr, htyTy⟩ + apply RecM.WF.bind + (RecM.WF.withInv <| + RecM.ensureSortDirect_wf hwhnf hresources htyTySupport htyTyTr) + intro u1 afterSort hu1Post + rcases hu1Post with ⟨hISort, hu1⟩ + have htySort : world.venv.HasType uvars Delta.toCtx + tyV (.sort u1.toVLevel) := + htyTy.defeqU_r world.venvWF hISort.2.1.wf.toCtx hu1.inputEq + apply RecM.withLctxScope_openBinder_wf + (layer := .noAccel) (semantics := semantics) (trProj := trProj) + (world := world) (uvars := uvars) (Delta := Delta) + (s := afterSort) (bi := bi) + (k := fun bodyOpen _ => do + let bodyTy ← inferCall bodyOpen + let u2 ← ensureSortDirect bodyTy + TcM.intern (.mkSort (.mkIMax u1 u2))) + (Qinner := fun result _ => support result ∧ + InferPost trProj world uvars Delta (.forallE tyV bodyV) result) + (Qouter := fun result _ => support result ∧ + InferPost trProj world uvars Delta (.forallE tyV bodyV) result) + htyTr htyType hbodyTr hrun.collisionFree hbinder + · intro bodyOpen fv after hfv hbodyEq hbodyOpenSupport hbodyOpenTr + exact inferForallTail_wf theory hwhnf hresources hresults + hrun.collisionFree htySort hu1 hbodyOpenSupport hbodyOpenTr + · intro result after hresult + exact hresult + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/FunctionTypes.lean b/Ix/Tc/Verify/Infer/FunctionTypes.lean new file mode 100644 index 000000000..bc62597b0 --- /dev/null +++ b/Ix/Tc/Verify/Infer/FunctionTypes.lean @@ -0,0 +1,106 @@ +import Ix.Tc.Verify.Infer.Callbacks + +/-! +# Function-type exposure for inference + +Application inference first turns the inferred function type into a concrete +Pi. This module proves that the syntactic fast path and the direct-WHNF +fallback expose the same semantic view, while retaining finite support for +the returned domain and codomain. +-/ + +namespace Ix.Tc + +/-- Finite-support descent needed after a supported Pi is exposed. Run +support is intentionally not globally constructor-closed. -/ +def ForallComponentSupport (support : RunSupport) : Prop := + forall {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {dom cod : KExpr .anon} {info : ExprInfo .anon}, + support (.all name bi dom cod info) -> support dom /\ support cod + +/-- Semantic result of exposing a concrete Pi. The final equality connects +the caller's quotient translation of the original inferred type to the exact +structural translations of the returned concrete components. -/ +def ForallView (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) (Delta : KVLCtx) + (inputV : Lean4Lean.VExpr) (dom cod : KExpr .anon) : Prop := + exists domV codV, + support dom /\ support cod /\ + world.venv.IsType uvars Delta.toCtx domV /\ + world.venv.IsType uvars (domV :: Delta.toCtx) codV /\ + TrKExprS world.venv uvars world.nameOf trProj Delta dom domV /\ + TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam domV) :: Delta) cod codV /\ + world.venv.IsDefEqU uvars Delta.toCtx inputV (.forallE domV codV) + +namespace RecM + +private theorem ensureForallWhnf_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} {input : KExpr .anon} + {inputCoreV inputV : Lean4Lean.VExpr} + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hinputSupport : support input) + (hinputCore : TrKExprS world.venv uvars world.nameOf trProj Delta input + inputCoreV) + (hinputEq : world.venv.IsDefEqU uvars Delta.toCtx inputCoreV inputV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (ensureForallWhnf input) + (fun result _ => ForallView trProj world support uvars Delta inputV + result.1 result.2) := by + unfold ensureForallWhnf + apply RecM.WF.bind (hwhnf hinputSupport hinputCore) + intro reduced after hred + rcases hred with + ⟨hreducedSupport, reducedV, hreducedTr, hcoreReduced⟩ + cases reduced <;> simp only + case all name bi dom cod info => + apply RecM.WF.pure + intro hI + obtain ⟨hdomSupport, hcodSupport⟩ := hcomponents hreducedSupport + cases hreducedTr with + | all hdomType hcodType hdomTr hcodTr => + exact ⟨_, _, hdomSupport, hcodSupport, hdomType, hcodType, + hdomTr, hcodTr, + hinputEq.symm.trans world.venvWF hI.2.1.wf.toCtx + hcoreReduced⟩ + all_goals + exact RecM.WF.throw fun _ => trivial + +/-- Both production paths through `ensureForallDirect` return a supported +concrete Pi whose structural Theory view is definitionally equal to the +caller's translation of the input type. -/ +theorem ensureForallDirect_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} {input : KExpr .anon} + {inputV : Lean4Lean.VExpr} + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hinputSupport : support input) + (hinput : TrKExpr world.venv uvars world.nameOf trProj Delta input + inputV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (ensureForallDirect input) + (fun result _ => ForallView trProj world support uvars Delta inputV + result.1 result.2) := by + obtain ⟨inputCoreV, hinputCore, hinputEq⟩ := hinput + cases input <;> simp only [ensureForallDirect] + case all name bi dom cod info => + apply RecM.WF.pure + intro _ + obtain ⟨hdomSupport, hcodSupport⟩ := hcomponents hinputSupport + cases hinputCore with + | all hdomType hcodType hdomTr hcodTr => + exact ⟨_, _, hdomSupport, hcodSupport, hdomType, hcodType, + hdomTr, hcodTr, hinputEq.symm⟩ + all_goals + exact + (ensureForallWhnf_wf (s := s) hwhnf hcomponents hinputSupport + hinputCore hinputEq) + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/LambdaTypes.lean b/Ix/Tc/Verify/Infer/LambdaTypes.lean new file mode 100644 index 000000000..f543138d0 --- /dev/null +++ b/Ix/Tc/Verify/Infer/LambdaTypes.lean @@ -0,0 +1,228 @@ +import Ix.Tc.Verify.Infer.CheapBeta +import Ix.Tc.Verify.Infer.BinderClosing +import Ix.Tc.Verify.Infer.SortTypes +import Ix.Tc.Verify.Whnf.Iota.ArgumentExecution + +/-! +# Lambda inference + +This module verifies the production lambda branch: optional domain-sort +validation, fresh-fvar binder opening, recursive body inference, cheap beta, +singleton abstraction, anonymous Pi reconstruction, and scoped cleanup. +-/ + +namespace Ix.Tc + +/-- Finite closure for the anonymous Pi nodes produced from supported body +types. The body argument ranges only over the finite run support. -/ +def LambdaResultSupport (support : RunSupport) (ty : KExpr .anon) : Prop := + ∀ {body : KExpr .anon}, support body → + support (KExpr.mkAll RecM.anonN RecM.anonBi ty body) + +namespace RecM + +/-- Infer and close the type of an already-open lambda body. The checker +invariant remains in the tagged fvar context until `withLctxScope` returns, +while the semantic result is stated in the original de Bruijn context. -/ +private theorem inferLambdaTail_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {fv : FVarId} {deps : List FVarId} + {ty bodyOpen : KExpr .anon} {tyV bodyV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hcheap : CheapBetaResources support) + (habstract : SingletonAbstractionResources support) + (hresults : LambdaResultSupport support ty) + (hcollision : support.CollisionFree) + (htyType : world.venv.IsType uvars Delta.toCtx tyV) + (htyTr : TrKExprS world.venv uvars world.nameOf trProj Delta ty tyV) + (hbodySupport : support bodyOpen) + (hbodyTr : TrKExprS world.venv uvars world.nameOf trProj + ((some (fv, deps), .vlam tyV) :: Delta) bodyOpen bodyV) : + RecM.WF .noAccel semantics trProj world support uvars + ((some (fv, deps), .vlam tyV) :: Delta) s + (do + let bodyTy ← inferCall bodyOpen + let bodyTy ← TcM.runIntern (cheapBetaReduce bodyTy) + let abstracted ← TcM.runIntern (abstractFVars bodyTy #[fv]) + TcM.intern (.mkAll anonN anonBi ty abstracted)) + (fun result _ => support result ∧ + InferPost trProj world uvars Delta (.lam tyV bodyV) result) := by + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.inferCall_wf hbodySupport hbodyTr) + intro bodyTy afterBody hbodyPost + rcases hbodyPost with + ⟨hIBody, hbodyTySupport, bodyTyV, hbodyTyTr, hbodyTy⟩ + obtain ⟨bodyTyCoreV, hbodyTyCoreTr, hbodyTyEq⟩ := hbodyTyTr + have hcheapMeaning := KExpr.cheapBetaReduceResult_meaning theory + hIBody.2.1.wf hbodyTyCoreTr (hcheap.bounds hbodyTySupport) + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + hcheap.whnf_wf hcollision hbodyTySupport) + intro reduced afterCheap hcheapPost + rcases hcheapPost with + ⟨hICheap, rfl, hreducedSupport, _⟩ + have hreducedQ := WhnfMeaning.resultQuot theory hICheap.2.1.wf + (⟨bodyTyCoreV, hbodyTyCoreTr, hbodyTyEq⟩ : + TrKExpr world.venv uvars world.nameOf trProj + ((some (fv, deps), .vlam tyV) :: Delta) bodyTy bodyTyV) + hcheapMeaning + obtain ⟨reducedV, hreducedTr, hreducedEq⟩ := hreducedQ + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + habstract.close_whnf_wf hcollision hreducedSupport hreducedTr) + intro abstracted afterAbstract habstractPost + rcases habstractPost with + ⟨hIAbstract, rfl, habstractedSupport, _, habstractedTr⟩ + have hresultSupport := hresults habstractedSupport + apply RecM.WF.mono + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf hcollision hresultSupport) + · intro result final hresult + rcases hresult with ⟨hIFinal, rfl, _⟩ + have hDelta : KVLCtx.WF world.venv uvars Delta := + hIFinal.2.1.wf.1 + have hbodyTyType : world.venv.IsType uvars + (tyV :: Delta.toCtx) bodyTyV := by + simpa [KVLCtx.toCtx] using + hbodyTy.isType world.venvWF.ordered hIFinal.2.1.wf.toCtx + have htyQ := htyTr.trKExpr world.venvWF.ordered + theory.literalWF theory.projections.wf hDelta + have habstractedQ : TrKExpr world.venv uvars world.nameOf trProj + ((none, .vlam tyV) :: Delta) + (KExpr.abstractFVarsResult + (KExpr.cheapBetaReduceResult bodyTy) #[fv]) bodyTyV := + ⟨reducedV, habstractedTr, hreducedEq⟩ + have hresultTr : TrKExpr world.venv uvars world.nameOf trProj Delta + (KExpr.mkAll anonN anonBi ty + (KExpr.abstractFVarsResult + (KExpr.cheapBetaReduceResult bodyTy) #[fv])) + (.forallE tyV bodyTyV) := + TrKExpr.all world.venvWF theory.literalWF theory.projections + hDelta htyType hbodyTyType htyQ habstractedQ + obtain ⟨u, htySort⟩ := htyType + have hbodyTy' : world.venv.HasType uvars + (tyV :: Delta.toCtx) bodyV bodyTyV := by + simpa [KVLCtx.toCtx] using hbodyTy + exact ⟨hresultSupport, .forallE tyV bodyTyV, hresultTr, + Lean4Lean.VEnv.HasType.lam htySort hbodyTy'⟩ + · intro _ _ _ + trivial + +/-- Scope the shared lambda tail through the production binder-opening +helper. Factoring this once avoids elaborating the large callback contract +independently in the full and infer-only dispatcher paths. -/ +private theorem inferLambdaScoped_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body : KExpr .anon} {tyV bodyV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hcheap : CheapBetaResources support) + (habstract : SingletonAbstractionResources support) + (hresults : LambdaResultSupport support ty) + (hcollision : support.CollisionFree) + (htyType : world.venv.IsType uvars Delta.toCtx tyV) + (htyTr : TrKExprS world.venv uvars world.nameOf trProj Delta ty tyV) + (hbodyTr : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam tyV) :: Delta) body bodyV) + (hbinder : BinderOpeningResources support name body) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (withLctxScope do + let (bodyOpen, fv) ← TcM.openBinder name bi ty body + let bodyTy ← inferCall bodyOpen + let bodyTy ← TcM.runIntern (cheapBetaReduce bodyTy) + let abstracted ← TcM.runIntern (abstractFVars bodyTy #[fv]) + TcM.intern (.mkAll anonN anonBi ty abstracted)) + (fun result _ => support result ∧ + InferPost trProj world uvars Delta (.lam tyV bodyV) result) := by + apply RecM.withLctxScope_openBinder_wf + (layer := .noAccel) (semantics := semantics) (trProj := trProj) + (world := world) (uvars := uvars) (Delta := Delta) (s := s) + (bi := bi) + (k := fun bodyOpen fv => do + let bodyTy ← inferCall bodyOpen + let bodyTy ← TcM.runIntern (cheapBetaReduce bodyTy) + let abstracted ← TcM.runIntern (abstractFVars bodyTy #[fv]) + TcM.intern (.mkAll anonN anonBi ty abstracted)) + (Qinner := fun result _ => support result ∧ + InferPost trProj world uvars Delta (.lam tyV bodyV) result) + (Qouter := fun result _ => support result ∧ + InferPost trProj world uvars Delta (.lam tyV bodyV) result) + htyTr htyType hbodyTr hcollision hbinder + · intro bodyOpen fv after hfv hbodyEq hbodyOpenSupport hbodyOpenTr + subst fv + exact inferLambdaTail_wf + (semantics := semantics) (trProj := trProj) (world := world) + (support := support) (uvars := uvars) (Delta := Delta) + (s := after) (fv := ⟨s.env.nextFVarId⟩) (deps := Delta.fvars) + (ty := ty) (tyV := tyV) (bodyV := bodyV) + theory hcheap habstract hresults hcollision htyType htyTr + hbodyOpenSupport hbodyOpenTr + · intro result after hresult + exact hresult + +/- Complete production lambda branch. Full mode validates the domain as a +type; infer-only mode skips that validation. Both paths use the same +fresh-fvar opening, semantic closing, and anonymous Pi result. -/ +theorem inferUncached_lam_wf + {alpha : Type} {initial : TcState .anon} + {program : TcM .anon alpha} {requests : List WalkerRequest} + {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {uvars : Nat} {Delta : KVLCtx} + {s : TcState .anon} {inferOnly : Bool} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body : KExpr .anon} {info : ExprInfo .anon} + {sourceV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hsorts : SortComponentResources support) + (hcheap : CheapBetaResources support) + (habstract : SingletonAbstractionResources support) + (hresults : LambdaResultSupport support ty) + (htySupport : support ty) + (hbinder : BinderOpeningResources support name body) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.lam name bi ty body info) sourceV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (inferUncached inferCall inferOnly (.lam name bi ty body info)) + (fun result _ => support result ∧ + InferPost trProj world uvars Delta sourceV result) := by + cases hsource with + | lam htyType htyTr hbodyTr => + rename_i tyV bodyV + cases inferOnly with + | false => + unfold inferUncached + simp only [Bool.not_false, if_true] + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.inferCall_wf htySupport htyTr) + intro tyTy afterTy htyPost + rcases htyPost with + ⟨_, htyTySupport, tyTyV, htyTyTr, _⟩ + apply RecM.WF.bind + (RecM.WF.withInv <| + RecM.ensureSortDirect_wf hwhnf hsorts htyTySupport htyTyTr) + intro _ afterSort hsortPost + rcases hsortPost with ⟨hISort, _⟩ + exact inferLambdaScoped_wf + (semantics := semantics) (trProj := trProj) (world := world) + (support := support) (uvars := uvars) (Delta := Delta) + (s := afterSort) theory hcheap habstract hresults + hrun.collisionFree htyType htyTr hbodyTr hbinder + | true => + unfold inferUncached + simp only [Bool.not_true] + exact inferLambdaScoped_wf + (semantics := semantics) (trProj := trProj) (world := world) + (support := support) (uvars := uvars) (Delta := Delta) + (s := s) theory hcheap habstract hresults hrun.collisionFree + htyType htyTr hbodyTr hbinder + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/LeafCases.lean b/Ix/Tc/Verify/Infer/LeafCases.lean new file mode 100644 index 000000000..3043f4a54 --- /dev/null +++ b/Ix/Tc/Verify/Infer/LeafCases.lean @@ -0,0 +1,210 @@ +import Ix.Tc.Verify.Infer.CacheShell + +/-! +# Non-recursive inference cases + +This module verifies the syntax-directed inference branches that do not call +the recursive inference or definitional-equality methods. Keeping these +proofs separate makes the semantic boundary explicit: each branch must +produce a supported concrete type together with a Theory typing derivation. +-/ + +namespace Ix.Tc + +namespace TcM + +/-- Exact successful execution of the legacy bound-variable lookup once its +array bound and verified lift execution are known. -/ +theorem lookupVar_eval {idx : UInt64} {ty result : KExpr .anon} + {s s' : TcState .anon} + (hidx : idx.toNat < s.ctx.size) + (hty : s.ctx[s.ctx.size - 1 - idx.toNat]! = ty) + (hlift : TcM.runIntern (lift ty (idx + 1) 0) s = .ok result s') : + TcM.lookupVar idx s = .ok result s' := by + unfold TcM.lookupVar + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only + rw [if_neg (by omega)] + simp only [pure_bind] + rw [hty] + exact hlift + +end TcM + +namespace RecM + +/-- Runtime safety required by production's unchanged free-variable type +return. A declaration type may have been stored at an older mixed-context +depth; closing it over legacy de Bruijn variables is what makes the omitted +lift semantically valid. -/ +def FVarInferSafety (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) : Prop := + ∀ {s : TcState .anon} {fv : FVarId} {d : LocalDecl .anon}, + WhnfStateInv layer semantics trProj world support uvars Delta s → + s.lctx.find? fv = some d → + support d.ty ∧ KExpr.Constructed d.ty ∧ d.ty.lbr = 0 ∧ + Delta.bvars + d.ty.size < UInt64.size + +/-- Inferring a sort returns the next sort, preserves the complete checker +invariant, and realizes the Theory's sort typing rule. -/ +theorem inferUncached_sort_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {inferRec : KExpr .anon → RecM .anon (KExpr .anon)} + {inferOnly : Bool} {u : KUniv .anon} {info : ExprInfo .anon} + {sourceV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hcollision : support.CollisionFree) + (hresultSupport : support (KExpr.mkSort (KUniv.mkSucc u))) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.sort u info) sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (inferUncached inferRec inferOnly (.sort u info)) + (fun ty _ => support ty ∧ + InferPost trProj world uvars Delta sourceV ty) := by + cases hsource with + | sort hu => + unfold inferUncached + apply RecM.WF.mono + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf hcollision hresultSupport) + · intro result after hresult + rcases hresult with ⟨hI, rfl, _⟩ + refine ⟨hresultSupport, ?_⟩ + refine ⟨.sort (KUniv.toVLevel (KUniv.mkSucc u)), ?_, ?_⟩ + · exact (TrKExprS.sort (KUniv.toVLevel_mkSucc_wf hu)).trKExpr + world.venvWF.ordered theory.literalWF theory.projections.wf + hI.2.1.wf + · simpa only [KUniv.toVLevel_mkSucc] using + (Lean4Lean.VEnv.HasType.sort hu) + · intro _ _ _ + trivial + +/-- Legacy variables are inferred by lifting the stored concrete type to the +current depth. Context reconciliation identifies that lifted expression +with the variable's Theory type. -/ +theorem inferUncached_var_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {inferRec : KExpr .anon → RecM .anon (KExpr .anon)} + {inferOnly : Bool} {idx : UInt64} {name : Mode.anon.F Name} + {info : ExprInfo .anon} {sourceV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.var idx name info) sourceV) + (hmem : WalkerRequest.lift + s.ctx[s.ctx.size - 1 - idx.toNat]! (idx + 1) 0 ∈ requests) + (hbig : Delta.bvars + + s.ctx[s.ctx.size - 1 - idx.toNat]!.size < UInt64.size) : + RecM.WF layer semantics trProj world support uvars Delta s + (inferUncached inferRec inferOnly (.var idx name info)) + (fun ty _ => support ty ∧ + InferPost trProj world uvars Delta sourceV ty) := by + cases hsource with + | var hfind => + unfold inferUncached + apply RecM.WF.liftTcM + intro hI + have hidx : idx.toNat < s.ctx.size := by + rw [← hI.2.1.bvars_eq] + exact KVLCtx.find?_inl_lt hfind + let level := s.ctx.size - 1 - idx.toNat + let ty := s.ctx[level]! + have hlevel : level < s.ctx.size := by + dsimp only [level] + omega + have htyOpt : s.ctx[level]? = some ty := by + apply getElem?_eq_some_iff.mpr + exact ⟨hlevel, by simp only [ty, getElem!_pos s.ctx level hlevel]⟩ + have hletLevel : level < s.letVals.size := by + rw [← hI.2.1.size_eq] + exact hlevel + let ov := s.letVals[level]! + have hov : s.letVals[level]? = some ov := by + apply getElem?_eq_some_iff.mpr + exact ⟨hletLevel, + by simp only [ov, getElem!_pos s.letVals level hletLevel]⟩ + have hmem' : WalkerRequest.lift ty (idx + 1) 0 ∈ requests := by + simpa only [ty, level] using hmem + obtain ⟨after, hlift, hIafter, _⟩ := + hrun.lift_whnf_eval hmem' hI + have hlookup : TcM.lookupVar idx s = + .ok (KExpr.liftSpec ty (idx + 1) 0) after := by + apply TcM.lookupVar_eval hidx + · rfl + · exact hlift + rw [hlookup] + refine ⟨hIafter, ?_, ?_⟩ + · exact hrun.coverage.lift hmem' _ + (KExpr.LiftReach.spec (idx + 1) ty 0) + · have hsz : s.ctx.size < UInt64.size := by + rw [← hI.2.1.bvars_eq] + omega + obtain ⟨sourceV', typeV, hfind', hresult⟩ := + hI.2.1.lookupVar world.venvWF.ordered theory.projections + hidx hsz (by simpa only [level, ty] using htyOpt) + (by simpa only [level, ov] using hov) + (by simpa only [ty, level] using hbig) + rw [hfind] at hfind' + cases hfind' + refine ⟨_, ?_, + hI.2.1.wf.find?_wf world.venvWF.ordered hfind⟩ + exact TrKExprS.trKExpr world.venvWF.ordered theory.literalWF + theory.projections.wf + (by simpa only [ty, level] using hresult) hIafter.2.1.wf + +/-- A free variable returns its stored declaration type. The explicit +`FVarInferSafety` premise is the production-specific reason that returning +the type unchanged remains valid in an interleaved bvar/fvar context. -/ +theorem inferUncached_fvar_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {inferRec : KExpr .anon → RecM .anon (KExpr .anon)} + {inferOnly : Bool} {fv : FVarId} {name : Mode.anon.F Name} + {info : ExprInfo .anon} {sourceV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hsafe : FVarInferSafety layer semantics trProj world support uvars + Delta) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.fvar fv name info) sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (inferUncached inferRec inferOnly (.fvar fv name info)) + (fun ty _ => support ty ∧ + InferPost trProj world uvars Delta sourceV ty) := by + cases hsource with + | fvar hsourceFind => + unfold inferUncached + apply RecM.WF.bind + (Q₁ := fun read after => read = s ∧ after = s) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro read after hread + rcases hread with ⟨rfl, rfl⟩ + cases hfind : after.lctx.find? fv with + | none => + exact RecM.WF.throw fun _ => trivial + | some d => + apply RecM.WF.pure + intro hI + obtain ⟨hsupport, hcon, hclosed, hbig⟩ := hsafe hI hfind + obtain ⟨sourceV', typeV, hfind', htype⟩ := + hI.2.1.lctxFindType world.venvWF.ordered theory.projections + hfind hcon hclosed hbig + rw [hsourceFind] at hfind' + cases hfind' + refine ⟨hsupport, _, ?_, + hI.2.1.wf.find?_wf world.venvWF.ordered hsourceFind⟩ + exact htype.trKExpr world.venvWF.ordered theory.literalWF + theory.projections.wf hI.2.1.wf + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/LetScopes.lean b/Ix/Tc/Verify/Infer/LetScopes.lean new file mode 100644 index 000000000..082cabaf8 --- /dev/null +++ b/Ix/Tc/Verify/Infer/LetScopes.lean @@ -0,0 +1,262 @@ +import Ix.Tc.Verify.Infer.BinderScopes + +/-! +# Operational let scopes for inference + +`openLet` shares allocation and binder instantiation with `openBinder`, but +pushes an `ldecl` and translates to a Theory `vlet`. Keeping its proof +separate makes that semantic distinction visible at the API boundary. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace TcM + +/-- Opening a translated let either fails before changing the semantic +context, or returns its freshly tagged body under a `vlet` frame. -/ +theorem openLet_scope + {support : RunSupport} + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {name : Mode.anon.F Name} + {ty val body : KExpr .anon} {tyV valV bodyV : VExpr} + (hty : TrKExprS world.venv uvars world.nameOf trProj Delta ty tyV) + (hval : TrKExprS world.venv uvars world.nameOf trProj Delta val valV) + (hvalType : world.venv.HasType uvars Delta.toCtx valV tyV) + (hbody : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlet tyV valV) :: Delta) body bodyV) + (hcollision : support.CollisionFree) + (hresources : BinderOpeningResources support name body) : + WhnfStateInv layer semantics trProj world support uvars Delta s → + match TcM.openLet name ty val body s with + | .ok (bodyOpen, fvId) after => + fvId = ⟨s.env.nextFVarId⟩ ∧ + bodyOpen = KExpr.instantiateRevSpec body + #[.mkFVar ⟨s.env.nextFVarId⟩ name] 0 ∧ + WhnfStateInv layer semantics trProj world support uvars + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet tyV valV) :: Delta) after ∧ + support bodyOpen ∧ + TrKExprS world.venv uvars world.nameOf trProj + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet tyV valV) :: Delta) bodyOpen bodyV + | .error _ after => + WhnfStateInv layer semantics trProj world support uvars Delta after ∧ + after = s := by + intro hI + have hfreshPost := (TcM.freshFVarId_wf (s := s) + (layer := layer) (semantics := semantics) (trProj := trProj) + (world := world) (support := support) (uvars := uvars) + (Delta := Delta)) hI + cases hfreshRun : TcM.freshFVarId (m := .anon) s with + | error err afterFresh => + rw [hfreshRun] at hfreshPost + simp only at hfreshPost + have hafter : afterFresh = s := hfreshPost.2.2 + subst afterFresh + have hopenError : TcM.openLet name ty val body s = .error err s := by + unfold TcM.openLet + change EStateM.bind (TcM.freshFVarId (m := .anon)) _ s = _ + unfold EStateM.bind + rw [hfreshRun] + rw [hopenError] + exact ⟨hfreshPost.1, rfl⟩ + | ok fvId afterFresh => + rw [hfreshRun] at hfreshPost + simp only at hfreshPost + rcases hfreshPost.2 with ⟨hfvId, hafterFresh, hnext⟩ + subst fvId + subst afterFresh + let fv : KExpr .anon := .mkFVar ⟨s.env.nextFVarId⟩ name + obtain ⟨afterIntern, hinternRun, hIIntern, hInternFrame⟩ := + TcM.intern_whnf_eval hcollision + (hresources.fvarSupport ⟨s.env.nextFVarId⟩) hfreshPost.1 + let pushState : TcState .anon → TcState .anon := fun state => + {state with lctx := + state.lctx.push ⟨s.env.nextFVarId⟩ (.ldecl name ty val)} + let afterPush : TcState .anon := pushState afterIntern + have hkernelPush : + KernelStateWF semantics trProj world support afterPush := by + exact { + core := hIIntern.1.core.of_env_eq rfl + internSupport := by simpa [afterPush] using hIIntern.1.internSupport + caches := by simpa [afterPush] using hIIntern.1.caches + equivalences := by + simpa [afterPush, pushState] using hIIntern.1.equivalences } + have hIPush : WhnfStateInv layer semantics trProj world support uvars + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet tyV valV) :: Delta) afterPush := by + apply hI.openFVar hkernelPush + (TrKLocalDecl.vlet (nm := name) hty hval hvalType) + (by intro x hx; exact hx) + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.ctx hInternFrame + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.letVals hInternFrame + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.numLetBindings hInternFrame + · have hlctx : afterIntern.lctx = s.lctx := by + simpa [InternUpdateFrame] using + congrArg TcState.lctx hInternFrame + simp [afterPush, pushState, hlctx] + · have hnextEq : afterIntern.env.nextFVarId = + s.env.freshFVarId.2.nextFVarId := by + simpa [InternUpdateFrame] using congrArg + (fun state : TcState .anon => state.env.nextFVarId) + hInternFrame + simpa [afterPush, pushState, hnextEq] using hnext + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.prims hInternFrame + · simpa [afterPush, InternUpdateFrame] using + congrArg TcState.noAccel hInternFrame + have hopenBound := hresources.instRevBounds ⟨s.env.nextFVarId⟩ + have hbodyOpenTr := hbody.openFVarZero + (fv := ⟨s.env.nextFVarId⟩) (deps := Delta.fvars) (name := name) + hI.2.1.nextFVarId_fresh (by simpa using hopenBound.2.2) + have hbodyOpenSupport : support + (KExpr.instantiateRevSpec body #[fv] 0) := + hresources.instRevSupport ⟨s.env.nextFVarId⟩ _ + (KExpr.InstRevReach.spec ..) + obtain ⟨afterOpen, hopenRun, hIOpen, hOpenFrame⟩ := + instRev_whnf_eval_of_resources hcollision hopenBound + (hresources.instRevSupport ⟨s.env.nextFVarId⟩) hIPush + have hopenSuccess : TcM.openLet name ty val body s = + .ok (KExpr.instantiateRevSpec body #[fv] 0, + ⟨s.env.nextFVarId⟩) afterOpen := by + unfold TcM.openLet + change EStateM.bind (TcM.freshFVarId (m := .anon)) _ s = _ + unfold EStateM.bind + rw [hfreshRun] + simp only + change EStateM.bind (TcM.intern fv) _ _ = _ + unfold EStateM.bind + rw [hinternRun] + simp only + change EStateM.bind + (modify pushState : TcM .anon PUnit) _ afterIntern = _ + unfold EStateM.bind + rw [show (modify pushState : TcM .anon PUnit) afterIntern = + EStateM.Result.ok () afterPush from rfl] + simp only + change EStateM.bind + (TcM.runIntern (instantiateRev body #[fv])) _ afterPush = _ + unfold EStateM.bind + rw [hopenRun] + rfl + rw [hopenSuccess] + refine ⟨rfl, rfl, hIOpen, ?_, ?_⟩ + · simpa [fv] using hbodyOpenSupport + · simpa [fv] using hbodyOpenTr + +end TcM + +namespace RecM + +/-- Compose verified let opening with an arbitrary continuation and close +the tagged local on both continuation success and continuation error. -/ +theorem withLctxScope_openLet_wf + {beta : Type} {support : RunSupport} + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {name : Mode.anon.F Name} + {ty val body : KExpr .anon} {tyV valV bodyV : VExpr} + (hty : TrKExprS world.venv uvars world.nameOf trProj Delta ty tyV) + (hval : TrKExprS world.venv uvars world.nameOf trProj Delta val valV) + (hvalType : world.venv.HasType uvars Delta.toCtx valV tyV) + (hbody : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlet tyV valV) :: Delta) body bodyV) + (hcollision : support.CollisionFree) + (hresources : BinderOpeningResources support name body) + {k : KExpr .anon → FVarId → RecM .anon beta} + {Qinner Qouter : beta → TcState .anon → Prop} + (hk : ∀ {bodyOpen fv after}, + fv = ⟨s.env.nextFVarId⟩ → + bodyOpen = KExpr.instantiateRevSpec body + #[.mkFVar ⟨s.env.nextFVarId⟩ name] 0 → + support bodyOpen → + TrKExprS world.venv uvars world.nameOf trProj + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet tyV valV) :: Delta) bodyOpen bodyV → + RecM.WF layer semantics trProj world support uvars + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet tyV valV) :: Delta) after (k bodyOpen fv) Qinner) + (hclose : ∀ result after, Qinner result after → + Qouter result + {after with lctx := after.lctx.truncate s.lctx.size}) : + RecM.WF layer semantics trProj world support uvars Delta s + (withLctxScope do + let (bodyOpen, fv) ← TcM.openLet name ty val body + k bodyOpen fv) + Qouter := by + intro methods hmethods hI + rw [RecM.withLctxScope_eq] + have hopenPost := TcM.openLet_scope hty hval hvalType hbody + hcollision hresources hI + cases hopenRun : TcM.openLet name ty val body s with + | error err afterOpen => + rw [hopenRun] at hopenPost + simp only at hopenPost + rcases hopenPost with ⟨hIOpen, hafterOpen⟩ + have hscopedError : + (do + let (bodyOpen, fv) ← + (liftM (TcM.openLet name ty val body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods s = .error err afterOpen := by + change EStateM.bind (TcM.openLet name ty val body) + (fun opened => (k opened.1 opened.2).run methods) s = _ + unfold EStateM.bind + rw [hopenRun] + rw [hscopedError] + subst afterOpen + simp only [LocalContext.truncate_size] + exact ⟨hIOpen, trivial⟩ + | ok opened afterOpen => + rcases opened with ⟨bodyOpen, fv⟩ + rw [hopenRun] at hopenPost + simp only at hopenPost + rcases hopenPost with + ⟨hfv, hbodyEq, hIOpen, hbodySupport, hbodyTr⟩ + have htail := hk hfv hbodyEq hbodySupport hbodyTr + methods hmethods hIOpen + cases htailRun : (k bodyOpen fv).run methods afterOpen with + | ok result after => + rw [htailRun] at htail + simp only at htail + have hscopedSuccess : + (do + let (bodyOpen, fv) ← + (liftM (TcM.openLet name ty val body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods s = .ok result after := by + change EStateM.bind (TcM.openLet name ty val body) + (fun opened => (k opened.1 opened.2).run methods) s = _ + unfold EStateM.bind + rw [hopenRun] + exact htailRun + rw [hscopedSuccess] + exact ⟨hI.closeFVarAtEntry htail.1, hclose _ _ htail.2⟩ + | error tailErr after => + rw [htailRun] at htail + simp only at htail + have hscopedError : + (do + let (bodyOpen, fv) ← + (liftM (TcM.openLet name ty val body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods s = .error tailErr after := by + change EStateM.bind (TcM.openLet name ty val body) + (fun opened => (k opened.1 opened.2).run methods) s = _ + unfold EStateM.bind + rw [hopenRun] + exact htailRun + rw [hscopedError] + exact ⟨hI.closeFVarAtEntry htail.1, trivial⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/LetTypes.lean b/Ix/Tc/Verify/Infer/LetTypes.lean new file mode 100644 index 000000000..fe98e4165 --- /dev/null +++ b/Ix/Tc/Verify/Infer/LetTypes.lean @@ -0,0 +1,228 @@ +import Ix.Tc.Verify.Infer.LetScopes +import Ix.Tc.Verify.Infer.BinderClosing +import Ix.Tc.Verify.Infer.Substitution +import Ix.Tc.Verify.Infer.CheapBeta +import Ix.Tc.Verify.Infer.SortTypes +import Ix.Tc.Verify.Whnf.Iota.ArgumentExecution + +/-! +# Let inference + +This module verifies domain/value validation, let-fvar opening, recursive +body inference, singleton abstraction, eager value substitution, cheap beta, +and scoped cleanup for the production `letE` branch. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Infer the type of an opened let body and eliminate the temporary let +binder from that type before returning to the outer context. -/ +private theorem inferLetTail_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {fv : FVarId} {deps : List FVarId} + {val bodyOpen : KExpr .anon} + {tyV valV bodyV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (habstract : SingletonAbstractionResources support) + (hsubst : SubstitutionResources support) + (hcheap : CheapBetaResources support) + (hcollision : support.CollisionFree) + (hvalSupport : support val) + (hvalTr : TrKExprS world.venv uvars world.nameOf trProj Delta val valV) + (hbodySupport : support bodyOpen) + (hbodyTr : TrKExprS world.venv uvars world.nameOf trProj + ((some (fv, deps), .vlet tyV valV) :: Delta) bodyOpen bodyV) : + RecM.WF .noAccel semantics trProj world support uvars + ((some (fv, deps), .vlet tyV valV) :: Delta) s + (do + let bodyTy ← inferCall bodyOpen + let abstracted ← TcM.runIntern (abstractFVars bodyTy #[fv]) + let result ← TcM.runIntern (subst abstracted val 0) + TcM.runIntern (cheapBetaReduce result)) + (fun result _ => support result ∧ + InferPost trProj world uvars Delta bodyV result) := by + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.inferCall_wf hbodySupport hbodyTr) + intro bodyTy afterBody hbodyPost + rcases hbodyPost with + ⟨hIBody, hbodyTySupport, bodyTyV, hbodyTyTr, hbodyTy⟩ + obtain ⟨bodyTyCoreV, hbodyTyCoreTr, hbodyTyEq⟩ := hbodyTyTr + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + habstract.close_whnf_wf hcollision hbodyTySupport hbodyTyCoreTr) + intro abstracted afterAbstract habstractPost + rcases habstractPost with + ⟨hIAbstract, rfl, habstractedSupport, _, habstractedTr⟩ + have hsubstBounds := hsubst.bounds (depth := 0) + habstractedSupport hvalSupport + obtain ⟨_, hvalCon, _, _, hsubstBig⟩ := hsubstBounds + have hsubstTr : TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.substSpec + (KExpr.abstractFVarsResult bodyTy #[fv]) val 0) bodyTyCoreV := + TrKExprS.inst_let_lbr world.venvWF.ordered + theory.projections.weakN hvalCon habstractedTr hvalTr (by + simpa using hsubstBig) + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + hsubst.whnf_wf hcollision habstractedSupport hvalSupport) + intro substituted afterSubst hsubstPost + rcases hsubstPost with ⟨hISubst, rfl, hsubstitutedSupport, _⟩ + have hsubstitutedQ : TrKExpr world.venv uvars world.nameOf trProj Delta + (KExpr.substSpec + (KExpr.abstractFVarsResult bodyTy #[fv]) val 0) bodyTyV := + ⟨bodyTyCoreV, hsubstTr, hbodyTyEq⟩ + have hcheapMeaning := KExpr.cheapBetaReduceResult_meaning theory + hISubst.2.1.wf.1 hsubstTr (hcheap.bounds hsubstitutedSupport) + apply RecM.WF.mono + (RecM.WF.withInv <| RecM.WF.liftTcM <| + hcheap.whnf_wf hcollision hsubstitutedSupport) + · intro result final hresult + rcases hresult with ⟨hIFinal, rfl, hresultSupport, _⟩ + have hresultQ := WhnfMeaning.resultQuot theory hIFinal.2.1.wf.1 + hsubstitutedQ hcheapMeaning + have hbodyTy' : world.venv.HasType uvars Delta.toCtx bodyV bodyTyV := by + simpa [KVLCtx.toCtx] using hbodyTy + exact ⟨hresultSupport, bodyTyV, hresultQ, hbodyTy'⟩ + · intro _ _ _ + trivial + +/-- Scope the shared let tail through the production `openLet` helper. -/ +private theorem inferLetScoped_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {name : Mode.anon.F Name} + {ty val body : KExpr .anon} {tyV valV bodyV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (habstract : SingletonAbstractionResources support) + (hsubst : SubstitutionResources support) + (hcheap : CheapBetaResources support) + (hcollision : support.CollisionFree) + (hvalSupport : support val) + (htyTr : TrKExprS world.venv uvars world.nameOf trProj Delta ty tyV) + (hvalTr : TrKExprS world.venv uvars world.nameOf trProj Delta val valV) + (hvalType : world.venv.HasType uvars Delta.toCtx valV tyV) + (hbodyTr : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlet tyV valV) :: Delta) body bodyV) + (hbinder : BinderOpeningResources support name body) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (withLctxScope do + let (bodyOpen, fv) ← TcM.openLet name ty val body + let bodyTy ← inferCall bodyOpen + let abstracted ← TcM.runIntern (abstractFVars bodyTy #[fv]) + let result ← TcM.runIntern (subst abstracted val 0) + TcM.runIntern (cheapBetaReduce result)) + (fun result _ => support result ∧ + InferPost trProj world uvars Delta bodyV result) := by + apply RecM.withLctxScope_openLet_wf + (layer := .noAccel) (semantics := semantics) (trProj := trProj) + (world := world) (uvars := uvars) (Delta := Delta) (s := s) + (k := fun bodyOpen fv => do + let bodyTy ← inferCall bodyOpen + let abstracted ← TcM.runIntern (abstractFVars bodyTy #[fv]) + let result ← TcM.runIntern (subst abstracted val 0) + TcM.runIntern (cheapBetaReduce result)) + (Qinner := fun result _ => support result ∧ + InferPost trProj world uvars Delta bodyV result) + (Qouter := fun result _ => support result ∧ + InferPost trProj world uvars Delta bodyV result) + htyTr hvalTr hvalType hbodyTr hcollision hbinder + · intro bodyOpen fv after hfv hbodyEq hbodyOpenSupport hbodyOpenTr + subst fv + exact inferLetTail_wf + (semantics := semantics) (trProj := trProj) (world := world) + (support := support) (uvars := uvars) (Delta := Delta) + (s := after) (fv := ⟨s.env.nextFVarId⟩) (deps := Delta.fvars) + (val := val) (tyV := tyV) (valV := valV) + (bodyV := bodyV) theory habstract hsubst hcheap hcollision + hvalSupport hvalTr hbodyOpenSupport hbodyOpenTr + · intro result after hresult + exact hresult + +/- Complete production let branch. -/ +theorem inferUncached_let_wf + {alpha : Type} {initial : TcState .anon} + {program : TcM .anon alpha} {requests : List WalkerRequest} + {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {uvars : Nat} {Delta : KVLCtx} + {s : TcState .anon} {inferOnly : Bool} + {name : Mode.anon.F Name} + {ty val body : KExpr .anon} {nondep : Bool} {info : ExprInfo .anon} + {sourceV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hsorts : SortComponentResources support) + (habstract : SingletonAbstractionResources support) + (hsubst : SubstitutionResources support) + (hcheap : CheapBetaResources support) + (htySupport : support ty) + (hvalSupport : support val) + (hbinder : BinderOpeningResources support name body) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.letE name ty val body nondep info) sourceV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (inferUncached inferCall inferOnly + (.letE name ty val body nondep info)) + (fun result _ => support result ∧ + InferPost trProj world uvars Delta sourceV result) := by + cases hsource with + | letE hvalType htyTr hvalTr hbodyTr => + rename_i tyV valV + cases inferOnly with + | false => + unfold inferUncached + simp only [Bool.not_false, if_true] + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.inferCall_wf htySupport htyTr) + intro tyTy afterTy htyPost + rcases htyPost with + ⟨_, htyTySupport, tyTyV, htyTyTr, _⟩ + apply RecM.WF.bind + (RecM.WF.withInv <| + RecM.ensureSortDirect_wf hwhnf hsorts htyTySupport htyTyTr) + intro _ afterSort hsortPost + rcases hsortPost with ⟨hISort, _⟩ + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.inferCall_wf hvalSupport hvalTr) + intro valTy afterVal hvalPost + rcases hvalPost with + ⟨_, hvalTySupport, valTyV, hvalTyTr, _⟩ + obtain ⟨valTyCoreV, hvalTyCoreTr, _⟩ := hvalTyTr + apply RecM.WF.bind + (RecM.isDefEqCall_wf hvalTySupport htySupport + hvalTyCoreTr htyTr) + intro equal afterEq hequal + cases equal with + | false => + simp only [Bool.not_false, if_true] + apply RecM.WF.bind + (Q₁ := fun _ _ => False) + (RecM.WF.throw fun _ => trivial) + intro _ _ impossible + exact impossible.elim + | true => + simp only [Bool.not_true] + exact inferLetScoped_wf + (semantics := semantics) (trProj := trProj) (world := world) + (support := support) (uvars := uvars) (Delta := Delta) + (s := afterEq) theory habstract hsubst hcheap + hrun.collisionFree hvalSupport htyTr hvalTr hvalType + hbodyTr hbinder + | true => + unfold inferUncached + simp only [Bool.not_true] + exact inferLetScoped_wf + (semantics := semantics) (trProj := trProj) (world := world) + (support := support) (uvars := uvars) (Delta := Delta) + (s := s) theory habstract hsubst hcheap hrun.collisionFree + hvalSupport htyTr hvalTr hvalType hbodyTr hbinder + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/Literals.lean b/Ix/Tc/Verify/Infer/Literals.lean new file mode 100644 index 000000000..bd2f87e65 --- /dev/null +++ b/Ix/Tc/Verify/Infer/Literals.lean @@ -0,0 +1,179 @@ +import Ix.Tc.Verify.Infer.Constants + +/-! +# Literal inference + +The concrete checker represents literals directly, but inference returns the +`Nat` or `String` constant selected by the runtime primitive table. The source +translation's `ContainsLits` premise proves the literal is meaningful; it does +not by itself identify the runtime table entry or prove that the selected type +constant accepts an empty universe array. Those representation obligations +are therefore exposed explicitly below. +-/ + +namespace Ix.Tc + +/-- Exact Theory interpretation of the two primitive-table entries read by +literal inference. Trust and address-to-name agreement come from +`PrimitiveIdAgrees`; the arity fields prevent an empty universe array from +being accepted merely because a name happened to match. -/ +structure LiteralPrimitiveTableAgrees (world : VerifyWorld) + (prims : Primitives .anon) : Prop where + nat : PrimitiveIdAgrees world prims.nat ``Nat + string : PrimitiveIdAgrees world prims.string ``String + natArity : forall {ci}, world.venv.constants ``Nat = some ci -> + ci.uvars = 0 + stringArity : forall {ci}, world.venv.constants ``String = some ci -> + ci.uvars = 0 + +namespace LiteralPrimitiveTableAgrees + +/-- The runtime Nat result has the exact closed Theory translation. -/ +theorem nat_tr + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {prims : Primitives .anon} + (hcatalog : TrustedCatalogRel trProj world) + (htable : LiteralPrimitiveTableAgrees world prims) : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkConst prims.nat #[]) Lean4Lean.VExpr.nat := by + rw [KExpr.mkConst_shape] + obtain ⟨ci, hlookup⟩ := htable.nat.contains hcatalog + simpa [Lean4Lean.VExpr.nat, htable.natArity hlookup] using + (TrKExprS.const (Δ := Delta) (uvars := uvars) + htable.nat.2 hlookup (by simp) (by simp [htable.natArity hlookup])) + +/-- The runtime String result has the exact closed Theory translation. -/ +theorem string_tr + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {prims : Primitives .anon} + (hcatalog : TrustedCatalogRel trProj world) + (htable : LiteralPrimitiveTableAgrees world prims) : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkConst prims.string #[]) Lean4Lean.VExpr.string := by + rw [KExpr.mkConst_shape] + obtain ⟨ci, hlookup⟩ := htable.string.contains hcatalog + simpa [Lean4Lean.VExpr.string, htable.stringArity hlookup] using + (TrKExprS.const (Δ := Delta) (uvars := uvars) + htable.string.2 hlookup (by simp) + (by simp [htable.stringArity hlookup])) + +end LiteralPrimitiveTableAgrees + +/-- Run-scoped resources for the two literal branches. Generated-support +fields are restricted to canonical production primitive tables, so they do +not make a finite run support artificially contain every possible KId. -/ +structure LiteralInferContext (world : VerifyWorld) + (support : RunSupport) : Prop where + table : forall (prims : Primitives .anon), prims.CanonicalAnon -> + LiteralPrimitiveTableAgrees world prims + theoryPrimitives : world.venv.HasPrimitives + collisionFree : support.CollisionFree + natResult : forall (prims : Primitives .anon), prims.CanonicalAnon -> + support (KExpr.mkConst prims.nat #[]) + stringResult : forall (prims : Primitives .anon), prims.CanonicalAnon -> + support (KExpr.mkConst prims.string #[]) + +namespace RecM + +/-- A concrete Nat literal infers the runtime Nat constant, preserving the +complete no-acceleration invariant. -/ +theorem inferUncached_nat_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {inferRec : KExpr .anon -> RecM .anon (KExpr .anon)} + {inferOnly : Bool} {n : Nat} {blob : Address} + {info : ExprInfo .anon} {sourceV : Lean4Lean.VExpr} + (context : LiteralInferContext world support) + (theory : WhnfTheory trProj world uvars) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.nat n blob info) sourceV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (inferUncached inferRec inferOnly (.nat n blob info)) + (fun ty _ => support ty /\ + InferPost trProj world uvars Delta sourceV ty) := by + cases hsource with + | nat hcontains => + unfold inferUncached + apply RecM.WF.bind (RecM.WF.withInv (prims_wf (s := s))) + intro runtimePrims afterRead hread + rcases hread with ⟨hI, hprims, hafterRead⟩ + subst afterRead + have hcanonical : runtimePrims.CanonicalAnon := by + rw [hprims] + exact hI.noAccel_primitives + have hsupport := context.natResult runtimePrims hcanonical + have htable := context.table runtimePrims hcanonical + have hcatalog := hI.1.core.trustedCatalog + apply RecM.WF.mono + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf context.collisionFree hsupport) + · intro result final hresult + rcases hresult with ⟨hIfinal, rfl, _⟩ + refine ⟨hsupport, Lean4Lean.VExpr.nat, ?_, ?_⟩ + · exact (htable.nat_tr hcatalog).trKExpr + world.venvWF.ordered theory.literalWF theory.projections.wf + hIfinal.2.1.wf + · have htype0 : world.venv.HasType uvars [] + (.natLit n) Lean4Lean.VExpr.nat := by + simpa using + (Lean4Lean.TrExprS.natLit + (Us := List.replicate uvars Lean.Name.anonymous) (Δ := []) + context.theoryPrimitives hcontains n).2 + exact htype0.weak0 world.venvWF (Γ := Delta.toCtx) + · intro _ _ _ + trivial + +/-- A concrete String literal infers the runtime String constant. The source +typing is the full Lean4Lean literal construction, including `Char.ofNat` and +`String.ofList`; the returned type is still the primitive `String` entry. -/ +theorem inferUncached_str_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {inferRec : KExpr .anon -> RecM .anon (KExpr .anon)} + {inferOnly : Bool} {value : String} {blob : Address} + {info : ExprInfo .anon} {sourceV : Lean4Lean.VExpr} + (context : LiteralInferContext world support) + (theory : WhnfTheory trProj world uvars) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.str value blob info) sourceV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (inferUncached inferRec inferOnly (.str value blob info)) + (fun ty _ => support ty /\ + InferPost trProj world uvars Delta sourceV ty) := by + cases hsource with + | str hcontains => + unfold inferUncached + apply RecM.WF.bind (RecM.WF.withInv (prims_wf (s := s))) + intro runtimePrims afterRead hread + rcases hread with ⟨hI, hprims, hafterRead⟩ + subst afterRead + have hcanonical : runtimePrims.CanonicalAnon := by + rw [hprims] + exact hI.noAccel_primitives + have hsupport := context.stringResult runtimePrims hcanonical + have htable := context.table runtimePrims hcanonical + have hcatalog := hI.1.core.trustedCatalog + apply RecM.WF.mono + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf context.collisionFree hsupport) + · intro result final hresult + rcases hresult with ⟨hIfinal, rfl, _⟩ + refine ⟨hsupport, Lean4Lean.VExpr.string, ?_, ?_⟩ + · exact (htable.string_tr hcatalog).trKExpr + world.venvWF.ordered theory.literalWF theory.projections.wf + hIfinal.2.1.wf + · have htype0 : world.venv.HasType uvars [] + (.trLiteral (.strVal value)) Lean4Lean.VExpr.string := by + simpa [Lean4Lean.VExpr.string] using + (Lean4Lean.TrExprS.trLiteral world.venvWF.ordered + (Us := List.replicate uvars Lean.Name.anonymous) (Δ := []) + context.theoryPrimitives (.strVal value) hcontains).2 + exact htype0.weak0 world.venvWF (Γ := Delta.toCtx) + · intro _ _ _ + trivial + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/ProjectionClassification.lean b/Ix/Tc/Verify/Infer/ProjectionClassification.lean new file mode 100644 index 000000000..4f098350d --- /dev/null +++ b/Ix/Tc/Verify/Infer/ProjectionClassification.lean @@ -0,0 +1,198 @@ +import Init.Data.Range.Lemmas +import Ix.Tc.Verify.Infer.Constants +import Ix.Tc.Verify.Infer.ProjectionTelescope +import Ix.Tc.Verify.Whnf.StructEta.RecursionClassifier + +/-! +# Projection result-sort classification + +`inductiveAppIsProp` scans a declaration telescope without pushing its +binders into the runtime local context. Successive bodies can therefore +contain loose de Bruijn variables even though the original declaration type +is closed. This module proves the helper's state and finite-walker closure +against an explicit state-only WHNF callback contract; it does not pretend +those intermediate bodies have a structural translation in the caller's +context. +-/ + +namespace Ix.Tc + +/-- The exact universe-instantiation request selected when the classifier's +lookup returns the catalogued inductive declaration. Other declaration +kinds reject before invoking the walker. -/ +def ProjectionInductiveInstantiationRequest + (world : VerifyWorld) (requests : List WalkerRequest) + (indId : KId .anon) (levels : Array (KUniv .anon)) : Prop := + ∀ {c}, world.catalog indId = some c → + match c with + | .indc (ty := ty) .. => + WalkerRequest.instUniv ty levels ∈ requests + | _ => True + +namespace RecM + +/-- State-only WHNF authority for the loose declaration bodies traversed by +the classifier. This is intentionally separate from `DirectWhnf.WFAt`, +whose semantic contract requires a translation in the runtime context. -/ +def ProjectionWhnfPreservesAt + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) : Prop := + ∀ (input : KExpr .anon) (s : TcState .anon), + RecM.WF layer semantics trProj world support uvars Delta s + (whnf input) (fun _ _ => True) + +/-- One exact declaration-binder callback preserves the checker invariant on +success and error. -/ +theorem inductiveAppBinderStep_state_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + (hwhnf : ProjectionWhnfPreservesAt layer semantics trProj world support + uvars Delta) + (current : KExpr .anon) (s : TcState .anon) : + RecM.WF layer semantics trProj world support uvars Delta s + (inductiveAppBinderStep current) (fun _ _ => True) := by + unfold inductiveAppBinderStep + apply RecM.WF.bind (hwhnf current s) + intro reduced after _ + cases reduced <;> simp only + case all => exact RecM.WF.pure fun _ => trivial + all_goals exact RecM.WF.throw fun _ => trivial + +/-- List-normalized declaration-binder scan. -/ +theorem inductiveAppBindersList_state_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + (hwhnf : ProjectionWhnfPreservesAt layer semantics trProj world support + uvars Delta) : + ∀ (indices : List Nat) (current : KExpr .anon) (s : TcState .anon), + RecM.WF layer semantics trProj world support uvars Delta s + (forIn (m := RecM .anon) indices current + (fun _ current => inductiveAppBinderStep current)) + (fun _ _ => True) + | [], current, s => by + rw [List.forIn_nil] + exact RecM.WF.pure fun _ => trivial + | _ :: indices, current, s => by + rw [List.forIn_cons] + apply RecM.WF.bind + (inductiveAppBinderStep_state_wf hwhnf current s) + intro action after _ + cases action with + | done result => exact RecM.WF.pure fun _ => trivial + | yield next => + exact inductiveAppBindersList_state_wf hwhnf indices next after + +/-- The production range wrapper has the same state closure as its +list-normalized traversal. -/ +theorem inductiveAppBinders_state_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + (hwhnf : ProjectionWhnfPreservesAt layer semantics trProj world support + uvars Delta) + (binders : Nat) (current : KExpr .anon) (s : TcState .anon) : + RecM.WF layer semantics trProj world support uvars Delta s + (inductiveAppBinders binders current) (fun _ _ => True) := by + unfold inductiveAppBinders + rw [_root_.Std.Legacy.Range.forIn_eq_forIn_range'] + exact inductiveAppBindersList_state_wf hwhnf _ current s + +/-- `ensureSortDirect` needs only the state-only callback contract when no +semantic result is requested. Its syntactic sort path is pure; every other +path delegates once to WHNF and then either returns the exposed level or +rejects. -/ +private theorem ensureSortDirect_state_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + (hwhnf : ProjectionWhnfPreservesAt layer semantics trProj world support + uvars Delta) + (input : KExpr .anon) (s : TcState .anon) : + RecM.WF layer semantics trProj world support uvars Delta s + (ensureSortDirect input) (fun _ _ => True) := by + cases input <;> simp only [ensureSortDirect] + case sort => exact RecM.WF.pure fun _ => trivial + all_goals + unfold ensureSortWhnf + simp only [pure_bind] + apply RecM.WF.bind (hwhnf _ s) + intro reduced after _ + cases reduced <;> simp only + case sort => exact RecM.WF.pure fun _ => trivial + all_goals exact RecM.WF.throw fun _ => trivial + +/-- The post-telescope sort classifier preserves state across both WHNF +calls, direct-sort success, non-sort rejection, and the final Boolean test. -/ +theorem inductiveAppResultIsProp_state_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + (hwhnf : ProjectionWhnfPreservesAt layer semantics trProj world support + uvars Delta) + (resultTy : KExpr .anon) (s : TcState .anon) : + RecM.WF layer semantics trProj world support uvars Delta s + (inductiveAppResultIsProp resultTy) (fun _ _ => True) := by + unfold inductiveAppResultIsProp + apply RecM.WF.bind (hwhnf resultTy s) + intro sortTy afterWhnf _ + apply RecM.WF.bind + (ensureSortDirect_state_wf hwhnf sortTy afterWhnf) + intro level afterSort _ + exact RecM.WF.pure fun _ => trivial + +/-- Complete state/resource closure of `inductiveAppIsProp`: lazy lookup is +tied to the immutable catalog, universe instantiation is request-certified, +the declaration telescope is scanned exhaustively, and every partial error +preserves the caller's invariant. -/ +theorem inductiveAppIsProp_state_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {indId : KId .anon} {levels : Array (KUniv .anon)} {binders : Nat} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hwhnf : ProjectionWhnfPreservesAt layer semantics trProj world support + uvars Delta) + (hrequest : ProjectionInductiveInstantiationRequest world requests indId + levels) : + RecM.WF layer semantics trProj world support uvars Delta s + (inductiveAppIsProp indId levels binders) (fun _ _ => True) := by + unfold inductiveAppIsProp + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.tryGetConst_loaded_wf hfault indId s) + intro found afterLookup hfound + rcases hfound with ⟨hI, hloaded⟩ + cases found with + | none => exact RecM.WF.throw fun _ => trivial + | some c => + cases c <;> simp only + case indc name levelParams lvls params indices isUnsafe block memberIdx + ty ctors leanAll => + have hcatalog : world.catalog indId = some + (.indc name levelParams lvls params indices isUnsafe block + memberIdx ty ctors leanAll) := + hI.1.core.loaded (hloaded _ rfl) + have hmem : WalkerRequest.instUniv ty levels ∈ requests := by + simpa [ProjectionInductiveInstantiationRequest] using + hrequest hcatalog + apply RecM.WF.bind + (RecM.WF.liftTcM <| + TcM.instantiateUnivParams_whnf_wf hrun.collisionFree + (hrun.coverage.instUniv hmem)) + intro instantiated afterInst _ + apply RecM.WF.bind + (inductiveAppBinders_state_wf hwhnf binders instantiated afterInst) + intro resultTy afterBinders _ + exact inductiveAppResultIsProp_state_wf hwhnf resultTy afterBinders + all_goals exact RecM.WF.throw fun _ => trivial + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/ProjectionTelescope.lean b/Ix/Tc/Verify/Infer/ProjectionTelescope.lean new file mode 100644 index 000000000..50e07fe9b --- /dev/null +++ b/Ix/Tc/Verify/Infer/ProjectionTelescope.lean @@ -0,0 +1,707 @@ +import Init.Data.Range.Lemmas +import Ix.Tc.Verify.Infer.LetTypes +import Ix.Tc.Verify.Infer.FunctionTypes + +/-! +# Projection telescope exposure + +Projection inference repeatedly peels constructor and inductive telescopes. +Production uses a syntactic `all` fast path and otherwise invokes the ordinary +WHNF reducer. This module proves that both paths expose the same supported +Theory forall view; the diagnostic string affects only the error payload. +-/ + +namespace Ix.Tc + +/-- A concrete argument is admissible for every supported Π view that the +production peeler may expose from `inputV`. The universal formulation avoids +choosing a particular structural translation before WHNF has run; translation +uniqueness makes all successful views definitionally coherent. -/ +def ProjectionArgumentFits (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) (Delta : KVLCtx) + (inputV : Lean4Lean.VExpr) (arg : KExpr .anon) : Prop := + ∀ {dom cod : KExpr .anon} {domV codV : Lean4Lean.VExpr}, + support dom → support cod → + world.venv.IsType uvars Delta.toCtx domV → + world.venv.IsType uvars (domV :: Delta.toCtx) codV → + TrKExprS world.venv uvars world.nameOf trProj Delta dom domV → + TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam domV) :: Delta) cod codV → + world.venv.IsDefEqU uvars Delta.toCtx inputV (.forallE domV codV) → + ∃ argV, + TrKExprS world.venv uvars world.nameOf trProj Delta arg argV ∧ + world.venv.HasType uvars Delta.toCtx argV domV + +namespace RecM + +/-- Both paths through `peelProjForall` return a supported concrete Π whose +structural components denote a forall definitionally equal to the input +type. All helper errors preserve the complete no-acceleration invariant. -/ +theorem peelProjForall_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} {input : KExpr .anon} + {inputV : Lean4Lean.VExpr} {err : String} + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hinputSupport : support input) + (hinput : TrKExpr world.venv uvars world.nameOf trProj Delta input + inputV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (peelProjForall input err) + (fun result _ => ForallView trProj world support uvars Delta inputV + result.1 result.2) := by + obtain ⟨inputCoreV, hinputCore, hinputEq⟩ := hinput + cases input <;> simp only [peelProjForall] + case all name bi dom cod info => + apply RecM.WF.pure + intro _ + obtain ⟨hdomSupport, hcodSupport⟩ := hcomponents hinputSupport + cases hinputCore with + | all hdomType hcodType hdomTr hcodTr => + exact ⟨_, _, hdomSupport, hcodSupport, hdomType, hcodType, + hdomTr, hcodTr, hinputEq.symm⟩ + all_goals + simp only [pure_bind] + apply RecM.WF.bind (hwhnf hinputSupport hinputCore) + intro reduced after hred + rcases hred with + ⟨hreducedSupport, reducedV, hreducedTr, hcoreReduced⟩ + cases reduced <;> simp only + case all name bi dom cod info => + apply RecM.WF.pure + intro hI + obtain ⟨hdomSupport, hcodSupport⟩ := + hcomponents hreducedSupport + cases hreducedTr with + | all hdomType hcodType hdomTr hcodTr => + exact ⟨_, _, hdomSupport, hcodSupport, hdomType, hcodType, + hdomTr, hcodTr, + hinputEq.symm.trans world.venvWF hI.2.1.wf.toCtx + hcoreReduced⟩ + all_goals + exact RecM.WF.throw fun _ => trivial + +/-- Substitute one pre-certified argument into an already exposed Π body. +This is the semantic core shared by constructor parameters and preceding +fields; callers remain responsible for proving that the concrete argument is +the one production actually selected. -/ +private theorem substProjForallBody_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {inputV : Lean4Lean.VExpr} {dom body arg : KExpr .anon} + (theory : WhnfTheory trProj world uvars) + (hsubst : SubstitutionResources support) + (hcollision : support.CollisionFree) + (hview : ForallView trProj world support uvars Delta inputV dom body) + (hargSupport : support arg) + (hfits : ProjectionArgumentFits trProj world support uvars Delta + inputV arg) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (TcM.runIntern (subst body arg 0)) + (fun result _ => support result ∧ + ∃ resultV, + TrKExpr world.venv uvars world.nameOf trProj Delta result + resultV) := by + rcases hview with + ⟨domV, bodyV, hdomSupport, hbodySupport, hdomType, hbodyType, + hdomTr, hbodyTr, hinputEq⟩ + obtain ⟨argV, hargTr, hargType⟩ := + hfits hdomSupport hbodySupport hdomType hbodyType hdomTr hbodyTr + hinputEq + have hbounds := hsubst.bounds (depth := 0) hbodySupport hargSupport + have hresultTr : TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.substSpec body arg 0) (bodyV.inst argV) := + TrKExprS.instN_lbr world.venvWF.ordered theory.projections.weakN + theory.projections.instN hbounds.2.1 hargTr hargType hbodyTr + (.zero : KVLCtx.KInstN Delta argV domV 0 0 + ((none, .vlam domV) :: Delta) Delta) + rfl hbounds.2.2.2.2 + apply RecM.WF.mono + (RecM.WF.withInv <| RecM.WF.liftTcM <| + hsubst.whnf_wf hcollision hbodySupport hargSupport) + · intro result final hpost + rcases hpost with ⟨hIfinal, rfl, hresultSupport, _⟩ + exact ⟨hresultSupport, bodyV.inst argV, + hresultTr.trKExpr world.venvWF.ordered theory.literalWF + theory.projections.wf hIfinal.2.1.wf⟩ + · intro _ _ _ + trivial + +/-- One successful constructor-parameter step: expose a Π, validate the +pre-certified argument against that view, and execute production's dependent +substitution. The returned concrete type remains supported and has a Theory +translation for the next telescope iteration. -/ +private theorem instantiateProjParamBody_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {current arg : KExpr .anon} {currentV : Lean4Lean.VExpr} + {err : String} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hsubst : SubstitutionResources support) + (hcollision : support.CollisionFree) + (hcurrentSupport : support current) + (hargSupport : support arg) + (hcurrent : TrKExpr world.venv uvars world.nameOf trProj Delta current + currentV) + (hfits : ProjectionArgumentFits trProj world support uvars Delta + currentV arg) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (do + let (_, body) ← peelProjForall current err + TcM.runIntern (subst body arg 0)) + (fun result _ => support result ∧ + ∃ resultV, + TrKExpr world.venv uvars world.nameOf trProj Delta result + resultV) := by + apply RecM.WF.bind + (RecM.peelProjForall_wf hwhnf hcomponents hcurrentSupport hcurrent) + intro exposed afterPeel hview + rcases exposed with ⟨dom, body⟩ + exact substProjForallBody_wf theory hsubst hcollision hview hargSupport + hfits + +/-- The named production parameter step has exactly the semantic body above +and always yields the substituted telescope to the surrounding range loop. -/ +theorem instantiateProjParamStep_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {args : Array (KExpr .anon)} {i : Nat} (hidx : i < args.size) + {current : KExpr .anon} {currentV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hsubst : SubstitutionResources support) + (hcollision : support.CollisionFree) + (hcurrentSupport : support current) + (hargSupport : support args[i]) + (hcurrent : TrKExpr world.venv uvars world.nameOf trProj Delta current + currentV) + (hfits : ProjectionArgumentFits trProj world support uvars Delta + currentV args[i]) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (instantiateProjParamStep args i current) + (fun action _ => match action with + | .done result | .yield result => + support result ∧ ∃ resultV, + TrKExpr world.venv uvars world.nameOf trProj Delta result + resultV) := by + have hstep : + instantiateProjParamStep args i current = + ((do + let (_, body) ← peelProjForall current + "projection: expected forall in ctor type" + TcM.runIntern (subst body args[i] 0)) >>= fun result => + pure (.yield result)) := by + funext methods state + unfold instantiateProjParamStep + simp [hidx, bind_pure_comp] + rw [hstep] + apply RecM.WF.bind + (instantiateProjParamBody_wf theory hwhnf hcomponents hsubst hcollision + hcurrentSupport hargSupport hcurrent hfits) + intro result after hpost + exact RecM.WF.pure fun _ => hpost + +/-- Execution-indexed semantic input for a finite constructor-parameter +telescope. Each entry certifies exactly the array access and Π application +performed by the corresponding production iteration. The continuation is +parametric in the concrete substituted result, so this plan cannot choose or +replace any intermediate produced by `subst`. -/ +def ProjectionParameterPlan + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (args : Array (KExpr .anon)) : + List Nat → Lean4Lean.VExpr → Prop + | [], _ => True + | i :: indices, currentV => + ∃ hidx : i < args.size, + support (args[i]'hidx) ∧ + ProjectionArgumentFits trProj world support uvars Delta currentV + (args[i]'hidx) ∧ + ∀ {next : KExpr .anon} {nextV : Lean4Lean.VExpr}, + support next → + TrKExpr world.venv uvars world.nameOf trProj Delta next nextV → + ProjectionParameterPlan trProj world support uvars Delta args + indices nextV + +/-- List-normalized form of the production parameter loop. Every successful +iteration yields the exact substituted type to the tail; errors from Π +exposure or substitution retain the complete no-acceleration invariant. -/ +theorem instantiateProjParamsList_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hsubst : SubstitutionResources support) + (hcollision : support.CollisionFree) + {args : Array (KExpr .anon)} : + ∀ (indices : List Nat) {current : KExpr .anon} + {currentV : Lean4Lean.VExpr} {s : TcState .anon}, + support current → + TrKExpr world.venv uvars world.nameOf trProj Delta current currentV → + ProjectionParameterPlan trProj world support uvars Delta args indices + currentV → + RecM.WF .noAccel semantics trProj world support uvars Delta s + (forIn (m := RecM .anon) indices current + (instantiateProjParamStep args)) + (fun result _ => support result ∧ + ∃ resultV, + TrKExpr world.venv uvars world.nameOf trProj Delta result + resultV) + | [], current, currentV, s, hcurrentSupport, hcurrent, _ => by + rw [List.forIn_nil] + exact RecM.WF.pure fun _ => + ⟨hcurrentSupport, currentV, hcurrent⟩ + | i :: indices, current, currentV, s, hcurrentSupport, hcurrent, + hplan => by + rcases hplan with + ⟨hidx, hargSupport, hfits, htail⟩ + rw [List.forIn_cons] + apply RecM.WF.bind + (instantiateProjParamStep_wf hidx theory hwhnf hcomponents hsubst + hcollision hcurrentSupport hargSupport hcurrent hfits) + intro action after hpost + cases action with + | done result => + exact RecM.WF.pure fun _ => hpost + | yield next => + rcases hpost with ⟨hnextSupport, nextV, hnext⟩ + exact instantiateProjParamsList_wf theory hwhnf hcomponents hsubst + hcollision indices hnextSupport hnext + (htail hnextSupport hnext) + +/-- The exact production range loop, reduced to the verified list fold above. +The plan mentions the normalized range explicitly, making both the number and +order of parameter substitutions auditable. -/ +theorem instantiateProjParams_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hsubst : SubstitutionResources support) + (hcollision : support.CollisionFree) + {args : Array (KExpr .anon)} {numParams : Nat} + {ctorTy : KExpr .anon} {ctorTyV : Lean4Lean.VExpr} + (hctorSupport : support ctorTy) + (hctor : TrKExpr world.venv uvars world.nameOf trProj Delta ctorTy + ctorTyV) + (hplan : ProjectionParameterPlan trProj world support uvars Delta args + (List.range' + ([0:numParams] : _root_.Std.Legacy.Range).start + ([0:numParams] : _root_.Std.Legacy.Range).size + ([0:numParams] : _root_.Std.Legacy.Range).step) + ctorTyV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (instantiateProjParams args numParams ctorTy) + (fun result _ => support result ∧ + ∃ resultV, + TrKExpr world.venv uvars world.nameOf trProj Delta result + resultV) := by + unfold instantiateProjParams + rw [_root_.Std.Legacy.Range.forIn_eq_forIn_range'] + exact instantiateProjParamsList_wf theory hwhnf hcomponents hsubst + hcollision _ hctorSupport hctor hplan + +/-- The requested Theory projection has the domain exposed by every +supported Π view of the current constructor-field telescope. -/ +def ProjectionFieldResultFits + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (inputV projectedV : Lean4Lean.VExpr) : + Prop := + ∀ {dom body : KExpr .anon} {domV bodyV : Lean4Lean.VExpr}, + support dom → support body → + world.venv.IsType uvars Delta.toCtx domV → + world.venv.IsType uvars (domV :: Delta.toCtx) bodyV → + TrKExprS world.venv uvars world.nameOf trProj Delta dom domV → + TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam domV) :: Delta) body bodyV → + world.venv.IsDefEqU uvars Delta.toCtx inputV (.forallE domV bodyV) → + world.venv.HasType uvars Delta.toCtx projectedV domV + +/-- Semantic inputs for exactly one production field iteration. The +selected branch certifies the resulting projection type. A preceding branch +certifies only the concrete projection node that production interns and +substitutes; it cannot choose the subsequent telescope result. -/ +structure ProjectionFieldStepPlan + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (structId : KId .anon) + (field : UInt64) (val : KExpr .anon) (projectedV : Lean4Lean.VExpr) + (i : Nat) (currentV : Lean4Lean.VExpr) : Prop where + selected : i = field.toNat → + ProjectionFieldResultFits trProj world support uvars Delta currentV + projectedV + preceding : i ≠ field.toNat → + support (KExpr.mkPrj structId i.toUInt64 val) ∧ + ProjectionArgumentFits trProj world support uvars Delta currentV + (KExpr.mkPrj structId i.toUInt64 val) + +/-- Success postcondition that distinguishes the stopping field from an +intermediate telescope yielded to the surrounding traversal. -/ +def ProjectionFieldActionPost + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (projectedV : Lean4Lean.VExpr) : + ForInStep (KExpr .anon) → Prop + | .done result => + support result ∧ InferPost trProj world uvars Delta projectedV result + | .yield next => + support next ∧ ∃ nextV, + TrKExpr world.venv uvars world.nameOf trProj Delta next nextV + +/-- Recursive inference followed by the direct sort exposure used by both +Prop-elimination guards. The result is intentionally forgotten here: branch +soundness needs the callback and helper state contracts, while the pure guard +decides only whether execution continues or throws. -/ +private theorem inferProjectionFieldSort_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {dom : KExpr .anon} {domV : Lean4Lean.VExpr} + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hsorts : SortComponentResources support) + (hdomSupport : support dom) + (hdom : TrKExprS world.venv uvars world.nameOf trProj Delta dom domV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (do + let fieldSortTy ← inferCall dom + ensureSortDirect fieldSortTy) + (fun _ _ => True) := by + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.inferCall_wf hdomSupport hdom) + intro fieldSortTy after hpost + rcases hpost with + ⟨_, hfieldSortSupport, fieldSortV, hfieldSortTr, _⟩ + exact RecM.WF.mono + (RecM.ensureSortDirect_wf hwhnf hsorts hfieldSortSupport hfieldSortTr) + (fun _ _ _ => trivial) (fun _ _ _ => trivial) + +/-- A selected field returns the exact concrete domain exposed by production, +with the requested Theory projection typed by that domain. -/ +private theorem finishSelectedProjectionField_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {inputV projectedV : Lean4Lean.VExpr} + {dom body : KExpr .anon} + (theory : WhnfTheory trProj world uvars) + (hview : ForallView trProj world support uvars Delta inputV dom body) + (hfits : ProjectionFieldResultFits trProj world support uvars Delta + inputV projectedV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (pure (.done dom)) + (fun action _ => + ProjectionFieldActionPost trProj world support uvars Delta projectedV + action) := by + apply RecM.WF.pure + intro hI + rcases hview with + ⟨domV, bodyV, hdomSupport, hbodySupport, hdomType, hbodyType, + hdomTr, hbodyTr, hinputEq⟩ + refine ⟨hdomSupport, domV, ?_, ?_⟩ + · exact hdomTr.trKExpr world.venvWF.ordered theory.literalWF + theory.projections.wf hI.2.1.wf + · exact hfits hdomSupport hbodySupport hdomType hbodyType hdomTr hbodyTr + hinputEq + +/-- A preceding field interns the exact projection node and substitutes it +through the exposed dependent body. Both intern and substitution errors keep +their partial states inside the full checker invariant. -/ +private theorem finishPrecedingProjectionField_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {structId : KId .anon} {i : Nat} {val : KExpr .anon} + {inputV projectedV : Lean4Lean.VExpr} + {dom body : KExpr .anon} + (theory : WhnfTheory trProj world uvars) + (hsubst : SubstitutionResources support) + (hcollision : support.CollisionFree) + (hview : ForallView trProj world support uvars Delta inputV dom body) + (hprojSupport : support (KExpr.mkPrj structId i.toUInt64 val)) + (hfits : ProjectionArgumentFits trProj world support uvars Delta inputV + (KExpr.mkPrj structId i.toUInt64 val)) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (do + let proj ← TcM.intern (KExpr.mkPrj structId i.toUInt64 val) + let result ← TcM.runIntern (subst body proj 0) + pure (.yield result)) + (fun action _ => + ProjectionFieldActionPost trProj world support uvars Delta projectedV + action) := by + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf hcollision hprojSupport) + intro proj afterIntern hintern + rcases hintern with ⟨_, rfl, _⟩ + apply RecM.WF.bind + (substProjForallBody_wf theory hsubst hcollision hview hprojSupport + hfits) + intro result afterSubst hresult + exact RecM.WF.pure fun _ => hresult + +/-- Complete contract for one production field step. It covers the selected +and preceding branches, both Prop guards, recursive inference and direct WHNF +errors, exact projection interning, and dependent substitution. -/ +theorem inferProjFieldStep_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {structId : KId .anon} {field : UInt64} {val current : KExpr .anon} + {isPropStruct : Bool} {i : Nat} + {currentV projectedV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hsorts : SortComponentResources support) + (hsubst : SubstitutionResources support) + (hcollision : support.CollisionFree) + (hcurrentSupport : support current) + (hcurrent : TrKExpr world.venv uvars world.nameOf trProj Delta current + currentV) + (hplan : ProjectionFieldStepPlan trProj world support uvars Delta + structId field val projectedV i currentV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (inferProjFieldStep structId field val isPropStruct i current) + (fun action _ => + ProjectionFieldActionPost trProj world support uvars Delta projectedV + action) := by + unfold inferProjFieldStep + apply RecM.WF.bind + (RecM.peelProjForall_wf hwhnf hcomponents hcurrentSupport hcurrent) + intro exposed afterPeel hview + rcases exposed with ⟨dom, body⟩ + simp only + rcases hview with + ⟨domV, bodyV, hdomSupport, hbodySupport, hdomType, hbodyType, + hdomTr, hbodyTr, hinputEq⟩ + have hview : ForallView trProj world support uvars Delta currentV dom body := + ⟨domV, bodyV, hdomSupport, hbodySupport, hdomType, hbodyType, + hdomTr, hbodyTr, hinputEq⟩ + have hdomSupport' : support dom := by simpa using hdomSupport + have hdomTr' : + TrKExprS world.venv uvars world.nameOf trProj Delta dom domV := by + simpa using hdomTr + split + · rename_i hselected + have hi : i = field.toNat := eq_of_beq hselected + have hresult : ProjectionFieldResultFits trProj world support uvars Delta + currentV projectedV := hplan.selected hi + cases isPropStruct with + | false => + simp only [Bool.false_eq_true, if_false] + exact finishSelectedProjectionField_wf theory hview hresult + | true => + simp only [if_true, pure_bind] + rw [← bind_assoc] + apply RecM.WF.bind + (inferProjectionFieldSort_wf hwhnf hsorts hdomSupport' hdomTr') + intro fieldLevel afterSort _ + split + · exact RecM.WF.throw fun _ => trivial + · exact finishSelectedProjectionField_wf theory hview hresult + · rename_i hnotSelected + have hi : i ≠ field.toNat := fun heq => + hnotSelected (beq_iff_eq.mpr heq) + obtain ⟨hprojSupport, hfits⟩ := hplan.preceding hi + cases isPropStruct with + | false => + simp only [Bool.false_eq_true, if_false] + exact finishPrecedingProjectionField_wf theory hsubst hcollision + hview hprojSupport hfits + | true => + simp only [if_true, pure_bind] + rw [← bind_assoc] + apply RecM.WF.bind + (inferProjectionFieldSort_wf hwhnf hsorts hdomSupport' hdomTr') + intro fieldLevel afterSort _ + split + · exact RecM.WF.throw fun _ => trivial + · exact finishPrecedingProjectionField_wf theory hsubst hcollision + hview hprojSupport hfits + +/-- The semantic plan for a field-index suffix. Only a yielded concrete +telescope activates the continuation; a selected field terminates the +production fold immediately. -/ +def ProjectionFieldPlan + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (structId : KId .anon) + (field : UInt64) (val : KExpr .anon) (projectedV : Lean4Lean.VExpr) : + List Nat → Lean4Lean.VExpr → Prop + | [], _ => True + | i :: indices, currentV => + ProjectionFieldStepPlan trProj world support uvars Delta structId field + val projectedV i currentV ∧ + ∀ {next : KExpr .anon} {nextV : Lean4Lean.VExpr}, + support next → + TrKExpr world.venv uvars world.nameOf trProj Delta next nextV → + ProjectionFieldPlan trProj world support uvars Delta structId field + val projectedV indices nextV + +/-- Final semantic state of the early-return accumulator generated by Lean's +`for` elaboration. `some` carries a selected field type; `none` carries the +last yielded telescope and will be rejected by production as unreachable. -/ +def ProjectionFieldLoopPost + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (projectedV : Lean4Lean.VExpr) : + Option (KExpr .anon) × KExpr .anon → Prop + | (some result, _) => + support result ∧ InferPost trProj world uvars Delta projectedV result + | (none, current) => + support current ∧ ∃ currentV, + TrKExpr world.venv uvars world.nameOf trProj Delta current currentV + +/-- Lift one named field step into the production loop accumulator, recording +whether it stops with `some` or yields `none` and a new telescope. -/ +private theorem inferProjFieldLoopStep_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {structId : KId .anon} {field : UInt64} {val current : KExpr .anon} + {isPropStruct : Bool} {i : Nat} + {currentV projectedV : Lean4Lean.VExpr} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hsorts : SortComponentResources support) + (hsubst : SubstitutionResources support) + (hcollision : support.CollisionFree) + (hcurrentSupport : support current) + (hcurrent : TrKExpr world.venv uvars world.nameOf trProj Delta current + currentV) + (hplan : ProjectionFieldStepPlan trProj world support uvars Delta + structId field val projectedV i currentV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (inferProjFieldsLoopStep structId field val isPropStruct i + ((none : Option (KExpr .anon)), current)) + (fun action _ => match action with + | .done pair => + ∃ result, + pair = (some result, current) ∧ + support result ∧ + InferPost trProj world uvars Delta projectedV result + | .yield pair => + ∃ next nextV, + pair = (none, next) ∧ + support next ∧ + TrKExpr world.venv uvars world.nameOf trProj Delta next + nextV) := by + unfold inferProjFieldsLoopStep + apply RecM.WF.bind + (inferProjFieldStep_wf theory hwhnf hcomponents hsorts hsubst hcollision + hcurrentSupport hcurrent hplan) + intro action after hpost + cases action with + | done result => + exact RecM.WF.pure fun _ => ⟨result, rfl, hpost⟩ + | yield next => + rcases hpost with ⟨hnextSupport, nextV, hnext⟩ + exact RecM.WF.pure fun _ => + ⟨next, nextV, rfl, hnextSupport, hnext⟩ + +/-- List-normalized proof of the production field fold. A `.done` action +returns immediately; a `.yield` action passes the exact substituted +telescope and its semantic-plan continuation to the remaining indices. -/ +theorem inferProjFieldsList_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hsorts : SortComponentResources support) + (hsubst : SubstitutionResources support) + (hcollision : support.CollisionFree) + {structId : KId .anon} {field : UInt64} {val : KExpr .anon} + {isPropStruct : Bool} {projectedV : Lean4Lean.VExpr} : + ∀ (indices : List Nat) {current : KExpr .anon} + {currentV : Lean4Lean.VExpr} {s : TcState .anon}, + support current → + TrKExpr world.venv uvars world.nameOf trProj Delta current currentV → + ProjectionFieldPlan trProj world support uvars Delta structId field val + projectedV indices currentV → + RecM.WF .noAccel semantics trProj world support uvars Delta s + (forIn (m := RecM .anon) indices + ((none : Option (KExpr .anon)), current) + (inferProjFieldsLoopStep structId field val isPropStruct)) + (fun pair _ => + ProjectionFieldLoopPost trProj world support uvars Delta projectedV + pair) + | [], current, currentV, s, hcurrentSupport, hcurrent, _ => by + rw [List.forIn_nil] + exact RecM.WF.pure fun _ => + ⟨hcurrentSupport, currentV, hcurrent⟩ + | i :: indices, current, currentV, s, hcurrentSupport, hcurrent, + hplan => by + rcases hplan with ⟨hstepPlan, htail⟩ + rw [List.forIn_cons] + apply RecM.WF.bind + (inferProjFieldLoopStep_wf theory hwhnf hcomponents hsorts hsubst + hcollision hcurrentSupport hcurrent hstepPlan) + intro action after hpost + cases action with + | done pair => + rcases hpost with ⟨result, rfl, hresult⟩ + exact RecM.WF.pure fun _ => hresult + | yield pair => + rcases hpost with + ⟨next, nextV, rfl, hnextSupport, hnext⟩ + exact inferProjFieldsList_wf theory hwhnf hcomponents hsorts hsubst + hcollision indices hnextSupport hnext + (htail hnextSupport hnext) + +/-- The exact production field traversal, including Lean's generated +early-return accumulator and the final unreachable error when no index stops +the range. Successful results are supported concrete types of the requested +Theory projection. -/ +theorem inferProjFields_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hsorts : SortComponentResources support) + (hsubst : SubstitutionResources support) + (hcollision : support.CollisionFree) + {structId : KId .anon} {field : UInt64} {val ctorTy : KExpr .anon} + {isPropStruct : Bool} {ctorTyV projectedV : Lean4Lean.VExpr} + (hctorSupport : support ctorTy) + (hctor : TrKExpr world.venv uvars world.nameOf trProj Delta ctorTy + ctorTyV) + (hplan : ProjectionFieldPlan trProj world support uvars Delta structId + field val projectedV + (List.range' + ([0:field.toNat + 1] : _root_.Std.Legacy.Range).start + ([0:field.toNat + 1] : _root_.Std.Legacy.Range).size + ([0:field.toNat + 1] : _root_.Std.Legacy.Range).step) + ctorTyV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (inferProjFields structId field val isPropStruct ctorTy) + (fun result _ => support result ∧ + InferPost trProj world uvars Delta projectedV result) := by + unfold inferProjFields + rw [_root_.Std.Legacy.Range.forIn_eq_forIn_range'] + apply RecM.WF.bind + (inferProjFieldsList_wf (structId := structId) (field := field) + (val := val) (isPropStruct := isPropStruct) (projectedV := projectedV) + (s := s) theory hwhnf hcomponents hsorts hsubst hcollision _ + hctorSupport hctor hplan) + intro pair after hpost + rcases pair with ⟨found, current⟩ + cases found with + | none => + exact RecM.WF.throw fun _ => trivial + | some result => + exact RecM.WF.pure fun _ => hpost + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/ProjectionTypes.lean b/Ix/Tc/Verify/Infer/ProjectionTypes.lean new file mode 100644 index 000000000..4013597ad --- /dev/null +++ b/Ix/Tc/Verify/Infer/ProjectionTypes.lean @@ -0,0 +1,383 @@ +import Ix.Tc.Verify.Infer.ProjectionClassification + +/-! +# Projection inference + +The syntax dispatcher first infers the projected value and then delegates to +`inferProj`. Unlike ordinary syntax cases, soundness of that helper is not a +consequence of `TrProjOK`: the latter only states closure, well-formedness, +uniqueness, and context transport for the abstract projection relation. It +does not connect the production inductive/constructor lookup algorithm to the +Theory type of a selected projection. + +This module therefore isolates that remaining semantic boundary explicitly. +`ProjectionInference.WF` is the dispatcher-facing contract for `inferProj`; +`ProjectionInference.Context.wf` below constructs it from the concrete helper +proof and the narrow declaration/projection oracle. The dispatcher theorem +proves all surrounding behavior—child support, the recursive value-inference +edge, error propagation, and composition with the helper—without treating a +successful helper execution as semantic evidence by itself. +-/ + +namespace Ix.Tc + +/-- Finite child coverage for a supported projection source. Run support is +finite and intentionally not closed under arbitrary syntax descent. -/ +def ProjectionValueSupport (support : RunSupport) : Prop := + ∀ {structId : KId .anon} {field : UInt64} {val : KExpr .anon} + {info : ExprInfo .anon}, + support (.prj structId field val info) → support val + +/-- Finite support for the head and arguments returned by the production +application-spine collector. -/ +def ProjectionSpineSupport (support : RunSupport) : Prop := + ∀ {source head : KExpr .anon} {args : Array (KExpr .anon)}, + support source → source.collectSpine = (head, args) → + support head ∧ ∀ arg, arg ∈ args.toList → support arg + +/-- Universe-walker requests selected by a supported projection inference. +The first request instantiates the inductive declaration for its Prop check; +the second instantiates the sole constructor returned by the exact catalog +lookup. -/ +def ProjectionInferenceCensus (world : VerifyWorld) (support : RunSupport) + (requests : List WalkerRequest) : Prop := + ∀ {source : KExpr .anon} {id : KId .anon} + {levels : Array (KUniv .anon)} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} {c : KConst .anon}, + support source → + source.collectSpine = (.const id levels info, args) → + world.catalog id = some c → + match c with + | .indc (ty := indTy) (ctors := ctors) .. => + WalkerRequest.instUniv indTy levels ∈ requests ∧ + ∀ {ctorId : KId .anon} {ctor : KConst .anon}, + ctors[0]? = some ctorId → + world.catalog ctorId = some ctor → + WalkerRequest.instUniv ctor.ty levels ∈ requests + | _ => True + +namespace ProjectionInference + +/-- Semantic plan for the exact constructor type selected by production. +The universe walker chooses `instantiated`; the parameter loop chooses every +substituted intermediate; this plan can only interpret those concrete +results, not replace them. -/ +structure ConstructorTypingPlan + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (structId : KId .anon) + (field : UInt64) (val : KExpr .anon) + (projectedV : Lean4Lean.VExpr) (args : Array (KExpr .anon)) + (levels : Array (KUniv .anon)) (numParams : Nat) + (ctorTy : KExpr .anon) : Prop where + instantiated : ∀ {instantiated : KExpr .anon}, + KExpr.instantiateUnivParamsSpec ctorTy levels = .ok instantiated → + ∃ instantiatedV, + TrKExpr world.venv uvars world.nameOf trProj Delta instantiated + instantiatedV ∧ + RecM.ProjectionParameterPlan trProj world support uvars Delta args + (List.range' + ([0:numParams] : _root_.Std.Legacy.Range).start + ([0:numParams] : _root_.Std.Legacy.Range).size + ([0:numParams] : _root_.Std.Legacy.Range).step) + instantiatedV ∧ + ∀ {parameterized : KExpr .anon} + {parameterizedV : Lean4Lean.VExpr}, + support parameterized → + TrKExpr world.venv uvars world.nameOf trProj Delta parameterized + parameterizedV → + RecM.ProjectionFieldPlan trProj world support uvars Delta structId field + val projectedV + (List.range' + ([0:field.toNat + 1] : _root_.Std.Legacy.Range).start + ([0:field.toNat + 1] : _root_.Std.Legacy.Range).size + ([0:field.toNat + 1] : _root_.Std.Legacy.Range).step) + parameterizedV + +/-- The irreducible semantic boundary between the concrete catalog layout +and the abstract Theory projection relation. Every premise is evidence +already established by the production path: the inferred value type's exact +spine, address agreement, both immutable catalog entries, sole-constructor +selection, and the source projection witness. -/ +def DeclarationOracle (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta : KVLCtx} {structId headId : KId .anon} {field : UInt64} + {val : KExpr .anon} {valV projectedV valTyV reducedTyV : Lean4Lean.VExpr} + {structName : Lean.Name} {levels : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {args : Array (KExpr .anon)} + {indName : Mode.anon.F Name} + {indLevelParams : Mode.anon.F (Array Name)} + {indLvls indParams indIndices : UInt64} {indUnsafe : Bool} + {indBlock : KId .anon} {indMemberIdx : UInt64} + {indTy : KExpr .anon} {ctors : Array (KId .anon)} + {indLeanAll : Mode.anon.F (Array (KId .anon))} + {ctorId : KId .anon} {ctor : KConst .anon}, + world.nameOf structId.addr = some structName → + TrKExprS world.venv uvars world.nameOf trProj Delta val valV → + trProj Delta.toCtx structName field.toNat valV projectedV → + world.venv.HasType uvars Delta.toCtx valV valTyV → + world.venv.IsDefEqU uvars Delta.toCtx valTyV reducedTyV → + RecM.TrAppSpine world.venv uvars world.nameOf trProj Delta + (.const headId levels headInfo) args.toList reducedTyV → + headId.addr = structId.addr → + world.catalog headId = some + (.indc indName indLevelParams indLvls indParams indIndices indUnsafe + indBlock indMemberIdx indTy ctors indLeanAll) → + ctors.size = 1 → + ctors[0]? = some ctorId → + world.catalog ctorId = some ctor → + ConstructorTypingPlan trProj world support uvars Delta structId field val + projectedV args levels indParams.toNat ctor.ty + +/-- Dispatcher-facing operational and semantic contract for the production +`inferProj` helper. The source projection evidence supplies both the resolved +structure name and the abstract Theory projection witness. A successful +helper result must remain in finite support and type that projected Theory +expression; every error must preserve the full checker invariant. + +`Context.wf` constructs this contract below. Its one semantic premise is the +narrow `DeclarationOracle`, rather than an assertion that `TrProjOK` alone is +strong enough to justify projection inference. -/ +def WF (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : Prop := + ∀ {Delta : KVLCtx} {s : TcState .anon} + {structId : KId .anon} {field : UInt64} {val valTy : KExpr .anon} + {valV projectedV : Lean4Lean.VExpr} {structName : Lean.Name}, + world.nameOf structId.addr = some structName → + TrKExprS world.venv uvars world.nameOf trProj Delta val valV → + trProj Delta.toCtx structName field.toNat valV projectedV → + support valTy → + InferPost trProj world uvars Delta valV valTy → + RecM.WF .noAccel semantics trProj world support uvars Delta s + (RecM.inferProj structId field val valTy) + (fun result _ => support result ∧ + InferPost trProj world uvars Delta projectedV result) + +/-- Complete concrete resources for projection inference at one universe +count. Only `oracle` is semantic; the remaining fields are finite execution, +support, state, and already-verified helper contracts. -/ +structure Context + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Type where + run : RunAssumptions initial program requests support + theory : WhnfTheory trProj world uvars + whnf : DirectWhnf.WFAt semantics trProj world support uvars + components : ForallComponentSupport support + sorts : SortComponentResources support + substitution : SubstitutionResources support + fault : ∀ Delta : KVLCtx, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) + classifier : ∀ Delta : KVLCtx, + RecM.ProjectionWhnfPreservesAt .noAccel semantics trProj world support + uvars Delta + spines : ProjectionSpineSupport support + census : ProjectionInferenceCensus world support requests + oracle : DeclarationOracle trProj world support uvars + +end ProjectionInference + +namespace RecM + +/-- Concrete production proof of `inferProj`, relative only to the finite +run census, the loose-binder state callback, and the declaration/projection +semantic oracle isolated above. -/ +theorem inferProj_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {uvars : Nat} {Delta : KVLCtx} + {s : TcState .anon} {structId : KId .anon} {field : UInt64} + {val valTy : KExpr .anon} {valV projectedV : Lean4Lean.VExpr} + {structName : Lean.Name} + (theory : WhnfTheory trProj world uvars) + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hcomponents : ForallComponentSupport support) + (hsorts : SortComponentResources support) + (hsubst : SubstitutionResources support) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (hclassifier : ProjectionWhnfPreservesAt .noAccel semantics trProj world + support uvars Delta) + (hspines : ProjectionSpineSupport support) + (hcensus : ProjectionInferenceCensus world support requests) + (horacle : ProjectionInference.DeclarationOracle trProj world support + uvars) + (hname : world.nameOf structId.addr = some structName) + (hval : TrKExprS world.venv uvars world.nameOf trProj Delta val valV) + (hproj : trProj Delta.toCtx structName field.toNat valV projectedV) + (hvalTySupport : support valTy) + (hvalTy : InferPost trProj world uvars Delta valV valTy) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (inferProj structId field val valTy) + (fun result _ => support result ∧ + InferPost trProj world uvars Delta projectedV result) := by + rcases hvalTy with ⟨valTyV, hvalTyTr, hvalType⟩ + obtain ⟨valTyCoreV, hvalTyCore, hvalTyCoreEq⟩ := hvalTyTr + unfold inferProj + apply RecM.WF.bind + (RecM.WF.withInv <| hwhnf hvalTySupport hvalTyCore) + intro reducedTy afterWhnf hreduced + rcases hreduced with + ⟨hI, hreducedSupport, reducedTyV, hreducedTr, hreduceEq⟩ + rcases hspine : reducedTy.collectSpine with ⟨head, args⟩ + have hvalTyReduced : world.venv.IsDefEqU uvars Delta.toCtx valTyV + reducedTyV := + hvalTyCoreEq.symm.trans world.venvWF hI.2.1.wf hreduceEq + have hspineSupport := hspines hreducedSupport hspine + have hspineTr := RecM.trAppSpine_of_collectSpine hreducedTr hspine + cases head with + | const headId levels headInfo => + by_cases haddr : headId.addr = structId.addr + · have haddrTest : (headId.addr != structId.addr) = false := by + simp [haddr] + simp only [haddrTest, Bool.false_eq_true, if_false] + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.tryGetConst_loaded_wf hfault headId afterWhnf) + intro foundInd afterInd hfoundInd + rcases hfoundInd with ⟨hIInd, hloadedInd⟩ + cases foundInd with + | none => exact RecM.WF.throw fun _ => trivial + | some indEntry => + cases indEntry <;> simp only + case pos.some.indc indName indLevelParams indLvls indParams indIndices + indUnsafe indBlock indMemberIdx indTy ctors indLeanAll => + have hcatalogInd : world.catalog headId = some + (.indc indName indLevelParams indLvls indParams indIndices + indUnsafe indBlock indMemberIdx indTy ctors indLeanAll) := + hIInd.1.core.loaded (hloadedInd _ rfl) + obtain ⟨hindRequest, hctorRequest⟩ := + hcensus hreducedSupport hspine hcatalogInd + simp only [pure_bind] + by_cases hctorCount : ctors.size = 1 + · have hcountTest : (ctors.size != 1) = false := by + simp [hctorCount] + simp only [hcountTest, Bool.false_eq_true, if_false] + have hclassRequest : + ProjectionInductiveInstantiationRequest world requests + headId levels := by + intro c hcatalog + have hc : c = + .indc indName indLevelParams indLvls indParams + indIndices indUnsafe indBlock indMemberIdx indTy ctors + indLeanAll := + Option.some.inj (hcatalog.symm.trans hcatalogInd) + subst c + exact hindRequest + apply RecM.WF.bind + (inductiveAppIsProp_state_wf hrun hfault hclassifier + hclassRequest) + intro isPropStruct afterClass _ + generalize hctorId : ctors[0]! = ctorId + have hctorGet : ctors[0]? = some ctorId := by + grind + apply RecM.WF.bind + (RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.tryGetConst_loaded_wf hfault ctorId afterClass) + intro foundCtor afterCtor hfoundCtor + rcases hfoundCtor with ⟨hICtor, hloadedCtor⟩ + cases foundCtor with + | none => exact RecM.WF.throw fun _ => trivial + | some ctor => + have hcatalogCtor : world.catalog ctorId = some ctor := + hICtor.1.core.loaded (hloadedCtor _ rfl) + have hctorMem := + hctorRequest hctorGet hcatalogCtor + apply RecM.WF.bind + (RecM.WF.liftTcM <| + TcM.instantiateUnivParams_whnf_wf + hrun.collisionFree + (hrun.coverage.instUniv hctorMem)) + intro instantiated afterInst hinstantiated + rcases hinstantiated with + ⟨hinstantiatedSpec, hinstantiatedSupport⟩ + have hctorPlan := horacle hname hval hproj hvalType + hvalTyReduced hspineTr haddr hcatalogInd hctorCount + hctorGet hcatalogCtor + obtain ⟨instantiatedV, hinstantiatedTr, hparams, + hfields⟩ := + hctorPlan.instantiated hinstantiatedSpec + apply RecM.WF.bind + (instantiateProjParams_wf theory hwhnf hcomponents + hsubst hrun.collisionFree hinstantiatedSupport + hinstantiatedTr hparams) + intro parameterized afterParams hparameterized + rcases hparameterized with + ⟨hparameterizedSupport, parameterizedV, + hparameterizedTr⟩ + exact inferProjFields_wf theory hwhnf hcomponents hsorts + hsubst hrun.collisionFree hparameterizedSupport + hparameterizedTr + (hfields hparameterizedSupport hparameterizedTr) + · have hcountTest : (ctors.size != 1) = true := by + simp [hctorCount] + simp only [hcountTest, if_true] + exact RecM.WF.throw fun _ => trivial + all_goals exact RecM.WF.throw fun _ => trivial + · have haddrTest : (headId.addr != structId.addr) = true := by + simp [haddr] + simp only [haddrTest, if_true] + exact RecM.WF.throw fun _ => trivial + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact RecM.WF.throw fun _ => trivial + +end RecM + +namespace ProjectionInference + +/-- The concrete context constructs the former whole-helper obligation. -/ +theorem Context.wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (context : Context initial program requests semantics trProj world support + uvars) : + WF semantics trProj world support uvars := by + intro Delta s structId field val valTy valV projectedV structName + hname hval hproj hvalTySupport hvalTy + exact RecM.inferProj_wf context.run context.theory context.whnf + context.components context.sorts context.substitution + (context.fault Delta) (context.classifier Delta) context.spines + context.census context.oracle hname hval hproj hvalTySupport hvalTy + +end ProjectionInference + +namespace RecM + +/-- Complete projection case of the uncached inference dispatcher, relative +to the dispatcher-facing `inferProj` contract constructed above. -/ +theorem inferUncached_prj_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} {inferOnly : Bool} + {structId : KId .anon} {field : UInt64} {val : KExpr .anon} + {info : ExprInfo .anon} {sourceV : Lean4Lean.VExpr} + (hinputs : ProjectionValueSupport support) + (hprojection : ProjectionInference.WF semantics trProj world support + uvars) + (hsourceSupport : support (.prj structId field val info)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.prj structId field val info) sourceV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (inferUncached inferCall inferOnly (.prj structId field val info)) + (fun result _ => support result ∧ + InferPost trProj world uvars Delta sourceV result) := by + cases hsource with + | prj hname hvalTr hproj => + unfold inferUncached + apply RecM.WF.bind + (RecM.WF.withInv <| + RecM.inferCall_wf (hinputs hsourceSupport) hvalTr) + intro valTy afterValue hvaluePost + rcases hvaluePost with + ⟨_, hvalTySupport, valTyV, hvalTyTr, hvalType⟩ + exact hprojection hname hvalTr hproj hvalTySupport + ⟨valTyV, hvalTyTr, hvalType⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/ScopedLocals.lean b/Ix/Tc/Verify/Infer/ScopedLocals.lean new file mode 100644 index 000000000..05d5b0013 --- /dev/null +++ b/Ix/Tc/Verify/Infer/ScopedLocals.lean @@ -0,0 +1,241 @@ +import Ix.Tc.Verify.Infer.Callbacks + +/-! +# Scoped local contexts for inference + +Binder inference temporarily extends the concrete local context. The +production `withLctxScope` combinator removes that extension on both success +and failure. This module connects the operational cleanup to the ghost +context used by the verification invariant. +-/ + +namespace Ix.Tc + +@[simp] theorem LocalContext.truncate_size (lctx : LocalContext m) : + lctx.truncate lctx.size = lctx := by + simp [LocalContext.truncate, LocalContext.size] + +namespace KEnv + +/-- A successful checked allocation advances the concrete fvar counter +strictly. The explicit bound is exactly the guard in `TcM.freshFVarId`. -/ +theorem freshFVarId_next (env : KEnv .anon) + (hbound : env.nextFVarId.toNat + 1 < UInt64.size) : + env.nextFVarId.toNat < env.freshFVarId.2.nextFVarId.toNat := by + simp only [KEnv.freshFVarId] + rw [UInt64.toNat_add] + have hone : (1 : UInt64).toNat = 1 := by decide + rw [hone, Nat.mod_eq_of_lt] + · omega + · simpa [UInt64.size] using hbound + +end KEnv + +namespace RunAssumptions + +/-- The verified binder-opening walker preserves the complete reducer +invariant. Its only state effect is intern-table growth. -/ +theorem instRev_whnf_wf {alpha : Type} {initial : TcState .anon} + {program : TcM .anon alpha} {requests : List WalkerRequest} + {support : RunSupport} + (h : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {body : KExpr .anon} + {fvars : Array (KExpr .anon)} + (hmem : WalkerRequest.instRev body fvars ∈ requests) + {s : TcState .anon} : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.runIntern (instantiateRev body fvars)) + (fun result after => + result = KExpr.instantiateRevSpec body fvars 0 ∧ + InternUpdateFrame s after) := + TcM.runIntern_whnf_wf fun _ hwf hsupport => + h.instRev_spec hmem hwf hsupport + +/-- Executable form of `instRev_whnf_wf`. -/ +theorem instRev_whnf_eval {alpha : Type} {initial : TcState .anon} + {program : TcM .anon alpha} {requests : List WalkerRequest} + {support : RunSupport} + (h : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {body : KExpr .anon} + {fvars : Array (KExpr .anon)} + (hmem : WalkerRequest.instRev body fvars ∈ requests) + {s : TcState .anon} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) : + ∃ after, + TcM.runIntern (instantiateRev body fvars) s = + .ok (KExpr.instantiateRevSpec body fvars 0) after ∧ + WhnfStateInv layer semantics trProj world support uvars Delta after ∧ + InternUpdateFrame s after := + TcM.runIntern_whnf_eval + (fun _ hwf hsupport => h.instRev_spec hmem hwf hsupport) hI + +end RunAssumptions + +namespace WhnfStateInv + +/-- Advancing only the fvar mint counter preserves the outer semantic state. +The strict bound ensures the counter has not wrapped. -/ +theorem advanceFVarCounter + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + (h : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hbound : s.env.nextFVarId.toNat + 1 < UInt64.size) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with env := s.env.freshFVarId.2} := by + rcases h with ⟨hkernel, hctx, hlayer⟩ + have hnext := s.env.freshFVarId_next hbound + refine ⟨?_, hctx.of_fields_eq rfl rfl rfl rfl + (Nat.le_of_lt hnext), ?_⟩ + · exact { + core := hkernel.core.of_consts_eq rfl (by + simpa [KEnv.freshFVarId] using hkernel.core.intern) + internSupport := by + simpa [KEnv.freshFVarId] using hkernel.internSupport + caches := by + intro entry hentry + apply hkernel.caches + cases hentry <;> constructor <;> assumption + equivalences := hkernel.equivalences } + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer + +/-- Fuse the counter advance, declaration push, and ghost-context extension. +The target kernel invariant is supplied separately because interning the fvar +may grow the intern table between the initial state and the push. -/ +theorem openFVar + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {before after : TcState .anon} + {d : LocalDecl .anon} {vd : Lean4Lean.VLocalDecl} + {deps : List FVarId} + (hbefore : WhnfStateInv layer semantics trProj world support uvars + Delta before) + (hkernel : KernelStateWF semantics trProj world support after) + (htr : TrKLocalDecl world.venv uvars world.nameOf trProj Delta d vd) + (hdeps : deps ⊆ Delta.fvars) + (hctx : after.ctx = before.ctx) + (hlet : after.letVals = before.letVals) + (hnum : after.numLetBindings = before.numLetBindings) + (hlctx : after.lctx = + before.lctx.push ⟨before.env.nextFVarId⟩ d) + (hnext : before.env.nextFVarId.toNat < + after.env.nextFVarId.toNat) + (hprims : after.prims = before.prims) + (hnoAccel : after.noAccel = before.noAccel) : + WhnfStateInv layer semantics trProj world support uvars + ((some (⟨before.env.nextFVarId⟩, deps), vd) :: Delta) after := by + refine ⟨hkernel, hbefore.2.1.openFVar htr hdeps hctx hlet hnum hlctx + hnext, ?_⟩ + cases layer <;> + simpa [WhnfLayer.StateOK, hprims, hnoAccel] using hbefore.2.2 + +/-- Closing one tagged ghost local and truncating the matching concrete local +context preserves the complete reducer state invariant. -/ +theorem closeFVar + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {fv : FVarId} {deps : List FVarId} + {vd : Lean4Lean.VLocalDecl} {saved : Nat} + (h : WhnfStateInv layer semantics trProj world support uvars + ((some (fv, deps), vd) :: Delta) s) + (hsaved : saved = Delta.fvars.length) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with lctx := s.lctx.truncate saved} := by + rcases h with ⟨hkernel, hctx, hlayer⟩ + refine ⟨?_, hctx.closeFVar hsaved, ?_⟩ + · exact { + core := hkernel.core.of_env_eq rfl + internSupport := hkernel.internSupport + caches := hkernel.caches + equivalences := hkernel.equivalences } + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer + +/-- Restore the concrete local-context depth saved at entry to a one-fvar +scope. The outer invariant supplies the equality between that concrete +depth and the outer ghost fvar count. -/ +theorem closeFVarAtEntry + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {before after : TcState .anon} + {fv : FVarId} {deps : List FVarId} + {vd : Lean4Lean.VLocalDecl} + (hbefore : WhnfStateInv layer semantics trProj world support uvars + Delta before) + (hafter : WhnfStateInv layer semantics trProj world support uvars + ((some (fv, deps), vd) :: Delta) after) : + WhnfStateInv layer semantics trProj world support uvars Delta + {after with lctx := after.lctx.truncate before.lctx.size} := by + apply hafter.closeFVar + simpa only [LocalContext.size] using hbefore.2.1.fvars_length.symm + +end WhnfStateInv + +namespace TcM + +/-- Checked fvar allocation either returns the old counter and advances it +strictly, or reports exhaustion without changing state. Both outcomes +preserve the outer reducer invariant. -/ +theorem freshFVarId_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.freshFVarId (m := .anon)) + (fun fv after => + fv = ⟨s.env.nextFVarId⟩ ∧ + after = {s with env := s.env.freshFVarId.2} ∧ + s.env.nextFVarId.toNat < after.env.nextFVarId.toNat) + (fun err after => + err = .other "free-variable id space exhausted" ∧ after = s) := by + intro hI + by_cases hbound : s.env.nextFVarId.toNat + 1 < UInt64.size + · simp only [TcM.freshFVarId, hbound, ↓reduceIte, KEnv.freshFVarId] + refine ⟨hI.advanceFVarCounter hbound, trivial, trivial, ?_⟩ + exact s.env.freshFVarId_next hbound + · simp only [TcM.freshFVarId, hbound, ↓reduceIte] + exact ⟨hI, trivial, trivial⟩ + +end TcM + +namespace RecM + +/-- Exact operational equation for `withLctxScope`: the body runs first, then +the local context is restored to its entry length without discarding any +other state changes, regardless of whether the body succeeds or fails. -/ +theorem withLctxScope_eq (x : RecM .anon α) + (methods : Methods .anon) (s : TcState .anon) : + (withLctxScope x).run methods s = + match x.run methods s with + | .ok value after => + .ok value {after with lctx := after.lctx.truncate s.lctx.size} + | .error err after => + .error err {after with lctx := after.lctx.truncate s.lctx.size} := by + unfold withLctxScope + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only + unfold tryFinally + change EStateM.map (fun pair : α × PUnit => pair.1) + (tryFinally' (x.run methods) (fun _ => + (modify (fun after : TcState .anon => + {after with lctx := after.lctx.truncate s.lctx.size}) : + TcM .anon PUnit))) s = _ + unfold EStateM.map MonadFinally.tryFinally' EStateM.instMonadFinally + cases hrun : x.run methods s with + | ok value after => + simp only [hrun] + rfl + | error err after => + simp only [hrun] + rfl + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/SortTypes.lean b/Ix/Tc/Verify/Infer/SortTypes.lean new file mode 100644 index 000000000..ad66c499a --- /dev/null +++ b/Ix/Tc/Verify/Infer/SortTypes.lean @@ -0,0 +1,139 @@ +import Ix.Tc.Verify.Infer.Callbacks + +/-! +# Sort exposure for inference + +Lambda, forall, and let inference validate types by exposing the universe of +an inferred type. This module proves the syntactic sort fast path and the +direct-WHNF fallback against one shared semantic view. +-/ + +namespace Ix.Tc + +/-- Finite descent resources for a supported concrete sort. Smart universe +constructors compare addresses throughout their argument subtrees and use +`UInt64` offsets, so support of the enclosing expression alone is not enough +to justify them. -/ +def SortComponentResources (support : RunSupport) : Prop := + ∀ {u : KUniv .anon} {info : ExprInfo .anon}, + support (.sort u info) → + u.size < UInt64.size ∧ + ∀ x, KUniv.Sub x u → support.univ x + +/-- Semantic and finite-resource result of exposing a sort. The view +connects the caller's quotient translation to the selected Theory sort and +retains exactly the subtree support needed by later smart constructors. -/ +structure SortView (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (inputV : Lean4Lean.VExpr) + (result : KUniv .anon) : Prop where + sizeBound : result.size < UInt64.size + subtermSupport : ∀ x, KUniv.Sub x result → support.univ x + levelWF : result.toVLevel.WF uvars + inputEq : world.venv.IsDefEqU uvars Delta.toCtx inputV + (.sort result.toVLevel) + +theorem SortView.rootSupport + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {inputV : Lean4Lean.VExpr} {result : KUniv .anon} + (h : SortView world support uvars Delta inputV result) : + support.univ result := + h.subtermSupport result .refl + +namespace SortView + +/-- The simplifying concrete `mkIMax` denotes Theory `imax`. Every address +comparison made by the smart constructor is covered by the two finite +subterm footprints retained in the sort views. -/ +theorem mkIMax_equiv + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {DeltaA DeltaB : KVLCtx} {inputA inputB : Lean4Lean.VExpr} + {a b : KUniv .anon} + (hcf : support.CollisionFree) + (ha : SortView world support uvars DeltaA inputA a) + (hb : SortView world support uvars DeltaB inputB b) : + (KUniv.mkIMax a b).toVLevel ≈ + .imax a.toVLevel b.toVLevel := by + apply KUniv.toVLevel_mkIMax + · intro x y hx hy + apply hcf.univ.addrFaithful + · rcases hx with hx | hx + · exact ha.subtermSupport x hx + · exact hb.subtermSupport x hx + · rcases hy with hy | hy + · exact ha.subtermSupport y hy + · exact hb.subtermSupport y hy + · exact ha.sizeBound + · exact hb.sizeBound + +end SortView + +namespace RecM + +private theorem ensureSortWhnf_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} {input : KExpr .anon} + {inputCoreV inputV : Lean4Lean.VExpr} + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hresources : SortComponentResources support) + (hinputSupport : support input) + (hinputCore : TrKExprS world.venv uvars world.nameOf trProj Delta input + inputCoreV) + (hinputEq : world.venv.IsDefEqU uvars Delta.toCtx inputCoreV inputV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (ensureSortWhnf input) + (fun result _ => SortView world support uvars Delta inputV result) := by + unfold ensureSortWhnf + apply RecM.WF.bind (hwhnf hinputSupport hinputCore) + intro reduced after hred + rcases hred with + ⟨hreducedSupport, reducedV, hreducedTr, hcoreReduced⟩ + cases reduced <;> simp only + case sort result info => + cases hreducedTr with + | sort hlevel => + obtain ⟨hsize, hsubterms⟩ := hresources hreducedSupport + exact RecM.WF.pure fun hI => + { sizeBound := hsize + subtermSupport := hsubterms + levelWF := hlevel + inputEq := hinputEq.symm.trans world.venvWF hI.2.1.wf.toCtx + hcoreReduced } + all_goals + exact RecM.WF.throw fun _ => trivial + +/-- Both production paths through `ensureSortDirect` return a well-formed +universe whose Theory sort is definitionally equal to the caller's input +translation. -/ +theorem ensureSortDirect_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} {input : KExpr .anon} + {inputV : Lean4Lean.VExpr} + (hwhnf : DirectWhnf.WFAt semantics trProj world support uvars) + (hresources : SortComponentResources support) + (hinputSupport : support input) + (hinput : TrKExpr world.venv uvars world.nameOf trProj Delta input + inputV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (ensureSortDirect input) + (fun result _ => SortView world support uvars Delta inputV result) := by + obtain ⟨inputCoreV, hinputCore, hinputEq⟩ := hinput + cases input <;> simp only [ensureSortDirect] + case sort result info => + apply RecM.WF.pure + intro _ + obtain ⟨hsize, hsubterms⟩ := hresources hinputSupport + cases hinputCore with + | sort hlevel => + exact { + sizeBound := hsize + subtermSupport := hsubterms + levelWF := hlevel + inputEq := hinputEq.symm } + all_goals + exact ensureSortWhnf_wf hwhnf hresources hinputSupport hinputCore hinputEq + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer/Substitution.lean b/Ix/Tc/Verify/Infer/Substitution.lean new file mode 100644 index 000000000..c3308fc95 --- /dev/null +++ b/Ix/Tc/Verify/Infer/Substitution.lean @@ -0,0 +1,60 @@ +import Ix.Tc.Verify.Infer.Callbacks + +/-! +# Recursive-result substitution resources + +Let inference substitutes a fixed value into a type returned by a recursive +callback. Since that body is dynamic, this module exposes the walker through +a finite support closure rather than static request-list membership. +-/ + +namespace Ix.Tc + +/-- Finite operational and arithmetic closure for substitution over +supported inputs. -/ +structure SubstitutionResources (support : RunSupport) : Prop where + reach : ∀ {body arg : KExpr .anon} {depth : UInt64}, + support body → support arg → ∀ x, + KExpr.SubstReach arg body depth x → support x + bounds : ∀ {body arg : KExpr .anon} {depth : UInt64}, + support body → support arg → + WalkerRequest.Bounds (.subst body arg depth) + +namespace SubstitutionResources + +/-- Request-independent execution of the production substitution walker. -/ +theorem whnf_wf + {support : RunSupport} (hresources : SubstitutionResources support) + (hcollision : support.CollisionFree) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {body arg : KExpr .anon} {depth : UInt64} + (hbodySupport : support body) (hargSupport : support arg) + {s : TcState .anon} : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.runIntern (subst body arg depth)) + (fun result after => + result = KExpr.substSpec body arg depth ∧ + support result ∧ InternUpdateFrame s after) := by + have hbounds := hresources.bounds (depth := depth) + hbodySupport hargSupport + obtain ⟨hbody, harg, hcut, hargsz, _⟩ := hbounds + have hreach := hresources.reach (depth := depth) + hbodySupport hargSupport + apply TcM.WF.mono + (TcM.runIntern_whnf_wf (fun it hwf hcover => by + have post := Ix.Tc.subst_spec hcollision.expr hbody harg hcut hargsz + hreach hwf hcover.expr + exact ⟨post.1, post.2.1, + hcover.of_expr_univs post.2.2 + (subst_preservesUnivs body arg depth it)⟩)) + · intro result after hpost + rcases hpost with ⟨rfl, hframe⟩ + exact ⟨rfl, hreach _ (KExpr.SubstReach.spec arg body depth), hframe⟩ + · intro _ _ herror + exact herror + +end SubstitutionResources + +end Ix.Tc diff --git a/Ix/Tc/Verify/InferDefEq/Closure.lean b/Ix/Tc/Verify/InferDefEq/Closure.lean new file mode 100644 index 000000000..58527e9ed --- /dev/null +++ b/Ix/Tc/Verify/InferDefEq/Closure.lean @@ -0,0 +1,69 @@ +import Ix.Tc.Verify.DefEq.Closure +import Ix.Tc.Verify.Infer.CacheSoundness + +/-! +# Recursive inference and definitional-equality closure + +Inference and definitional equality are the two non-WHNF fields of the +production method table. This module proves their simultaneous fixed- +universe induction step: both fields may call a strictly smaller method table, +and neither proof assumes the next table is already sound. +-/ + +namespace Ix.Tc + +/-- Concrete resources for the inference and DefEq fields of one production +method-table layer. The shared proposition context fixes the suffix model, +cache semantics, and universe count for both fields. -/ +structure InferDefEqClosureContext + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) + {trProj : RawProjRel} {world : VerifyWorld} (support : RunSupport) + (proposition : PropositionClassifierContext trProj world support) + (eligible : KId .anon → Prop) where + inference : UncachedInference.Context initial program requests + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars + defEq : RecM.DefEqClosureResources support proposition eligible + +namespace InferDefEqClosureContext + +/-- Assemble both non-WHNF fields for one unfolded production method table. +Recursive calls are justified exclusively by the supplied predecessor-table +contract. -/ +theorem layer + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {proposition : PropositionClassifierContext trProj world support} + {eligible : KId .anon → Prop} + (context : InferDefEqClosureContext initial program requests support + proposition eligible) + (methods : Methods .anon) + (hmethods : Methods.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars methods) : + Methods.InferDefEqLayerWFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars methods where + infer := context.inference.nextInfer_wf methods hmethods + isDefEq := context.defEq.nextDefEq_wf methods hmethods + +/-- Headline fixed-universe closure for the inference/DefEq pair. -/ +theorem closedAt + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {proposition : PropositionClassifierContext trProj world support} + {eligible : KId .anon → Prop} + (context : InferDefEqClosureContext initial program requests support + proposition eligible) : + Methods.InferDefEqClosedAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars := by + intro methods hmethods + exact context.layer methods hmethods + +end InferDefEqClosureContext + +end Ix.Tc diff --git a/Ix/Tc/Verify/Knot.lean b/Ix/Tc/Verify/Knot.lean new file mode 100644 index 000000000..d18bdccfd --- /dev/null +++ b/Ix/Tc/Verify/Knot.lean @@ -0,0 +1,356 @@ +import Ix.Tc.Verify.Whnf + +/-! +# Verification of the recursive method knot + +The production checker ties six mutually recursive entry points through a +finite method table. This file isolates the non-circular proof shape: + +* `Methods.next methods` is exactly one production method-table layer whose + recursive calls use `methods`; +* `Methods.LayerWF methods` is the semantic obligation for that one layer; +* `Methods.Closed` says a well-formed smaller table proves the next layer; +* `methodsOut_wf` and `methodsN_wf` close every finite approximation; and +* `TcM.runRec_wf` transports a reader-level proof to the public knot runner. + +The remaining K2 work is therefore deliberately visible in `Methods.Closed`: +K1 supplies the four WHNF fields and K2 supplies inference and definitional +equality. No theorem below assumes the recursive table is already closed. +-/ + +namespace Ix.Tc + +namespace Methods + +/-- One unfolded production method-table layer. Keeping this constructor +named prevents proofs from depending on the presentation of `methodsN`. -/ +def next (methods : Methods m) : Methods m where + whnf e := (RecM.whnf e).run methods + whnfCore e := (RecM.whnfCore e).run methods + whnfMode e mode := (RecM.whnfWithNatSuccMode e mode).run methods + whnfCoreFlags e flags := (RecM.whnfCoreWithFlags e flags).run methods + infer e := (RecM.infer e).run methods + isDefEq a b := (RecM.isDefEq a b).run methods + +/-- Semantic obligation for one unfolded method-table layer at the universe +count of the active checker run. -/ +def LayerWFAt (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (methods : Methods .anon) : Prop := + Methods.WFAt layer semantics trProj world support uvars (next methods) + +/-- K1's four fields for one unfolded method-table layer at a fixed universe +count. This is the closure shape used by universe-indexed WHNF and unfold +cache semantics. -/ +structure WhnfLayerWFAt (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (methods : Methods .anon) : Prop where + whnf : ∀ {Delta s e sourceV}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV → + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((RecM.whnf e).run methods) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + whnfCore : ∀ {Delta s e sourceV}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV → + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((RecM.whnfCore e).run methods) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + whnfMode : ∀ {Delta s e sourceV} {mode : NatSuccMode}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV → + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((RecM.whnfWithNatSuccMode e mode).run methods) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + whnfCoreFlags : ∀ {Delta s e sourceV} {flags : WhnfFlags}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV → + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((RecM.whnfCoreWithFlags e flags).run methods) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + +/-- K2's two fields for one unfolded method-table layer at a fixed universe +count. -/ +structure InferDefEqLayerWFAt (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (methods : Methods .anon) : Prop where + infer : ∀ {Delta s e sourceV}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV → + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((RecM.infer e).run methods) + (fun ty _ => support ty ∧ + InferPost trProj world uvars Delta sourceV ty) + isDefEq : ∀ {Delta s a b va vb}, + support a → + support b → + TrKExprS world.venv uvars world.nameOf trProj Delta a va → + TrKExprS world.venv uvars world.nameOf trProj Delta b vb → + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((RecM.isDefEq a b).run methods) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx va vb) + +/-- The fixed-universe K1 and K2 records assemble the exact next layer. -/ +theorem LayerWFAt.of_parts + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hwhnf : + WhnfLayerWFAt layer semantics trProj world support uvars methods) + (hinfer : + InferDefEqLayerWFAt layer semantics trProj world support uvars methods) : + LayerWFAt layer semantics trProj world support uvars methods := by + refine ⟨?_, ?_, ?_, ?_, ?_, ?_⟩ + · exact hwhnf.whnf + · exact hwhnf.whnfCore + · exact hwhnf.whnfMode + · exact hwhnf.whnfCoreFlags + · exact hinfer.infer + · exact hinfer.isDefEq + +/-- Exact fixed-universe induction step for the six-method knot. -/ +def ClosedAt (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ methods, + Methods.WFAt layer semantics trProj world support uvars methods → + LayerWFAt layer semantics trProj world support uvars methods + +/-- K1's fixed-universe closure obligation, independent of construction of +the two K2 fields. -/ +def WhnfClosedAt (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ methods, + Methods.WFAt layer semantics trProj world support uvars methods → + WhnfLayerWFAt layer semantics trProj world support uvars methods + +/-- K2's fixed-universe closure obligation. -/ +def InferDefEqClosedAt (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : Prop := + ∀ methods, + Methods.WFAt layer semantics trProj world support uvars methods → + InferDefEqLayerWFAt layer semantics trProj world support uvars methods + +theorem ClosedAt.of_parts + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hwhnf : + WhnfClosedAt layer semantics trProj world support uvars) + (hinfer : + InferDefEqClosedAt layer semantics trProj world support uvars) : + ClosedAt layer semantics trProj world support uvars := by + intro methods hmethods + exact LayerWFAt.of_parts (hwhnf methods hmethods) + (hinfer methods hmethods) + +/-- Semantic obligation for one unfolded layer over a fixed smaller table. -/ +def LayerWF (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (methods : Methods .anon) : Prop := + Methods.WF layer semantics trProj world support (next methods) + +/-- K1's four fields for one unfolded method-table layer. -/ +structure WhnfLayerWF (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (methods : Methods .anon) : Prop where + whnf : ∀ {uvars Delta s e sourceV}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((RecM.whnf e).run methods) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + whnfCore : ∀ {uvars Delta s e sourceV}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((RecM.whnfCore e).run methods) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + whnfMode : ∀ {uvars Delta s e sourceV} {mode : NatSuccMode}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((RecM.whnfWithNatSuccMode e mode).run methods) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + whnfCoreFlags : ∀ {uvars Delta s e sourceV} {flags : WhnfFlags}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((RecM.whnfCoreWithFlags e flags).run methods) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + +/-- K2's two fields for one unfolded method-table layer. -/ +structure InferDefEqLayerWF (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) + (methods : Methods .anon) : Prop where + infer : ∀ {uvars Delta s e sourceV}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((RecM.infer e).run methods) + (fun ty _ => support ty ∧ + InferPost trProj world uvars Delta sourceV ty) + isDefEq : ∀ {uvars Delta s a b va vb}, + support a → + support b → + TrKExprS world.venv uvars world.nameOf trProj Delta a va → + TrKExprS world.venv uvars world.nameOf trProj Delta b vb → + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((RecM.isDefEq a b).run methods) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx va vb) + +/-- The independently proved K1 and K2 fields assemble the exact next-layer +record; no field may use the table it is currently proving. -/ +theorem LayerWF.of_parts {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {methods : Methods .anon} + (hwhnf : WhnfLayerWF layer semantics trProj world support methods) + (hinfer : InferDefEqLayerWF layer semantics trProj world support methods) : + LayerWF layer semantics trProj world support methods := by + refine ⟨?_, ?_, ?_, ?_, ?_, ?_⟩ + · exact hwhnf.whnf + · exact hwhnf.whnfCore + · exact hwhnf.whnfMode + · exact hwhnf.whnfCoreFlags + · exact hinfer.infer + · exact hinfer.isDefEq + +/-- The exact induction step required to tie the recursive knot. -/ +def Closed (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) : Prop := + ∀ methods, Methods.WF layer semantics trProj world support methods → + LayerWF layer semantics trProj world support methods + +/-- K1 closure obligation, separate from inference and def-eq. -/ +def WhnfClosed (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) : Prop := + ∀ methods, Methods.WF layer semantics trProj world support methods → + WhnfLayerWF layer semantics trProj world support methods + +/-- K2 closure obligation, assuming only the smaller table's six contracts. -/ +def InferDefEqClosed (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) : Prop := + ∀ methods, Methods.WF layer semantics trProj world support methods → + InferDefEqLayerWF layer semantics trProj world support methods + +theorem Closed.of_parts {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (hwhnf : WhnfClosed layer semantics trProj world support) + (hinfer : InferDefEqClosed layer semantics trProj world support) : + Closed layer semantics trProj world support := by + intro methods hmethods + exact LayerWF.of_parts (hwhnf methods hmethods) (hinfer methods hmethods) + +/-- The exhausted table changes no state, so it satisfies every method +contract through the permitted error branch. -/ +theorem methodsOut_wf (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) : + Methods.WF layer semantics trProj world support + (methodsOut : Methods .anon) := by + constructor <;> intros <;> + exact TcM.WF.throw (fun _ => trivial) + +/-- Each successor approximation is definitionally one `Methods.next` layer. -/ +@[simp] theorem methodsN_succ (n : Nat) : + (methodsN (m := .anon) (n + 1)) = next (methodsN n) := rfl + +/-- Closure of one layer proves every finite production approximation. -/ +theorem methodsN_wf {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (hclosed : Closed layer semantics trProj world support) (n : Nat) : + Methods.WF layer semantics trProj world support + (methodsN (m := .anon) n) := by + induction n with + | zero => exact methodsOut_wf layer semantics trProj world support + | succ n ih => + simpa [LayerWF, Nat.succ_eq_add_one] using hclosed (methodsN n) ih + +/-- The exhausted table satisfies the fixed-universe method contract. -/ +theorem methodsOut_wfAt + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) : + Methods.WFAt layer semantics trProj world support uvars + (methodsOut : Methods .anon) := + Methods.WF.atUvars + (methodsOut_wf layer semantics trProj world support) uvars + +/-- Fixed-universe closure proves every finite production approximation. -/ +theorem methodsN_wfAt + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} + (hclosed : ClosedAt layer semantics trProj world support uvars) + (n : Nat) : + Methods.WFAt layer semantics trProj world support uvars + (methodsN (m := .anon) n) := by + induction n with + | zero => + exact methodsOut_wfAt layer semantics trProj world support uvars + | succ n ih => + simpa [LayerWFAt, Nat.succ_eq_add_one] using + hclosed (methodsN n) ih + +end Methods + +namespace TcM + +/-- A reader-level proof valid for every semantically closed table applies to +the concrete finite table selected by the current production state. -/ +theorem runRec_wf {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} {x : RecM .anon α} + {Q : α → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (hclosed : Methods.Closed layer semantics trProj world support) + (hx : RecM.WF layer semantics trProj world support uvars Δ s x Q E) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s + (TcM.runRec x) Q E := by + simpa [TcM.runRec] using + hx (methodsN s.recFuel.toNat) + (Methods.WF.atUvars + (Methods.methodsN_wf hclosed s.recFuel.toNat) uvars) + +/-- Fixed-universe knot closure transports a reader-level proof to the +concrete finite method table selected by the production state. -/ +theorem runRec_wfAt + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {x : RecM .anon α} {Q : α → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (hclosed : + Methods.ClosedAt layer semantics trProj world support uvars) + (hx : + RecM.WF layer semantics trProj world support uvars Delta s x Q E) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.runRec x) Q E := by + simpa [TcM.runRec] using + hx (methodsN s.recFuel.toNat) + (Methods.methodsN_wfAt hclosed s.recFuel.toNat) + +end TcM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Monad.lean b/Ix/Tc/Verify/Monad.lean index 9b01b4dd5..a6ba44ed7 100644 --- a/Ix/Tc/Verify/Monad.lean +++ b/Ix/Tc/Verify/Monad.lean @@ -58,6 +58,27 @@ theorem mono {I : TcState m → Prop} {Q Q' : α → TcState m → Prop} | .ok a s' => rw [hxs] at this; exact ⟨this.1, hq _ _ this.2⟩ | .error e s' => rw [hxs] at this; exact ⟨this.1, he _ _ this.2⟩ +/-- Retain the concrete execution equation selected by either outcome of a +verified computation. Semantic boundaries use this strengthening to ensure +that an external certificate is tied to the value production actually +computed, without granting that certificate any state authority. -/ +theorem with_run_eq {I : TcState m → Prop} {s : TcState m} {x : TcM m α} + {Q : α → TcState m → Prop} + {E : TcError m → TcState m → Prop} + (hx : TcM.WF I s x Q E) : + TcM.WF I s x + (fun value after => Q value after ∧ x s = .ok value after) + (fun err after => E err after ∧ x s = .error err after) := by + intro hI + have hpost := hx hI + cases hrun : x s with + | ok value after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, rfl⟩ + | error err after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, rfl⟩ + theorem bind {I : TcState m → Prop} {Q₁ : α → TcState m → Prop} {Q₂ : β → TcState m → Prop} {E : TcError m → TcState m → Prop} {x : TcM m α} {f : α → TcM m β} @@ -104,6 +125,70 @@ theorem tryCatch {I : TcState m → Prop} {Q : α → TcState m → Prop} rw [hxs] at hres exact hh e s' hres.2 hres.1 +/-- Exact non-backtracking equation for an `EStateM` finalizer. The +finalizer always runs after the body; a finalizer error supersedes either +body outcome, while a successful finalizer retains the body's payload. -/ +private theorem tryFinally_eq + (x : TcM m α) (finalizer : TcM m β) (s : TcState m) : + tryFinally x finalizer s = + match x s with + | .ok a after => + match finalizer after with + | .ok _ final => .ok a final + | .error err final => .error err final + | .error err after => + match finalizer after with + | .ok _ final => .error err final + | .error cleanupErr final => .error cleanupErr final := by + unfold tryFinally + change EStateM.map (fun x : α × β => x.1) + (tryFinally' x (fun _ => finalizer)) s = _ + unfold EStateM.map MonadFinally.tryFinally' EStateM.instMonadFinally + cases hrun : x s <;> + simp only [hrun] <;> + cases hcleanup : finalizer _ <;> + rfl + +/-- A state-independent success fact survives an invariant-preserving +`finally` action. Both body and finalizer errors retain the invariant; the +error payload remains intentionally unconstrained. -/ +theorem tryFinally_const + {I : TcState m → Prop} {s : TcState m} + {x : TcM m α} {finalizer : TcM m β} {Q : α → Prop} + (hx : TcM.WF I s x (fun a _ => Q a)) + (hfinalizer : ∀ s', TcM.WF I s' finalizer (fun _ _ => True)) : + TcM.WF I s (tryFinally x finalizer) (fun a _ => Q a) := by + intro hI + have hbody := hx hI + rw [tryFinally_eq] + cases hrun : x s with + | ok a after => + rw [hrun] at hbody + simp only + have hfinal := hfinalizer after hbody.1 + cases hcleanup : finalizer after with + | ok _ final => + rw [hcleanup] at hfinal + simp only + exact ⟨hfinal.1, hbody.2⟩ + | error err final => + rw [hcleanup] at hfinal + simp only + exact ⟨hfinal.1, trivial⟩ + | error err after => + rw [hrun] at hbody + simp only + have hfinal := hfinalizer after hbody.1 + cases hcleanup : finalizer after with + | ok _ final => + rw [hcleanup] at hfinal + simp only + exact ⟨hfinal.1, trivial⟩ + | error cleanupErr final => + rw [hcleanup] at hfinal + simp only + exact ⟨hfinal.1, trivial⟩ + theorem get {I : TcState m → Prop} {Q : TcState m → TcState m → Prop} {E : TcError m → TcState m → Prop} (h : I s → Q s s) : TcM.WF I s (get : TcM m (TcState m)) Q E := diff --git a/Ix/Tc/Verify/NatFixture.lean b/Ix/Tc/Verify/NatFixture.lean index 37e79037e..17bdd1a3f 100644 --- a/Ix/Tc/Verify/NatFixture.lean +++ b/Ix/Tc/Verify/NatFixture.lean @@ -1,5 +1,6 @@ import Ix.Tc.Verify.Run import Ix.Tc.Verify.Whnf +import Ix.Tc.Verify.Whnf.Structural.BetaBoundary /-! # G2a ambient-Nat fixture @@ -80,7 +81,7 @@ def succConcrete : KConst .anon := def goodConcrete : KConst .anon := .axio () () false 0 natRef -/-- Deliberately untrusted recursor-shaped catalog entry used by the K1e +/-- Deliberately untrusted recursor-shaped catalog entry used by the projection/iota branch adversarial execution fixture. Its rule is operationally consumable, but it has no `nameOf` entry and is never added to the trusted log. -/ def iotaResult : KExpr .anon := .const zeroId #[] (info iotaAddress) @@ -91,6 +92,10 @@ def iotaRule : RecRule .anon := def iotaConcrete : KConst .anon := .recr () () false false 0 0 0 0 0 natId 0 natRef #[iotaRule] () +def iotaInfo : IotaInfo .anon := + { k := false, params := 0, motives := 0, minors := 0, indices := 0, + majorIdx := 0, rules := #[iotaRule], lvls := 0 } + def catalog : Catalog := fun id => if id == natId then some natConcrete else if id == zeroId then some zeroConcrete @@ -357,8 +362,9 @@ theorem succRaw : RawInductiveConstRel natEnv nameOf RawProjRel.none · exact RawExprRel.const nameOf_nat natEnv_nat rfl /-- A real model of the G2a assumption boundary. This particular block has -no recursor declaration, so `recursorFacts` is vacuous; any later block that -contains a `.recr` entry must supply its Theory defeq witnesses explicitly. -/ +no recursor declaration, so `recursorFacts` and `recursorPatterns` are +vacuous; any later block that contains a `.recr` entry must supply both its +Theory equation and exact iota-pattern witnesses explicitly. -/ def oracle : InductiveOracle RawProjRel.none catalog nameOf (fun _ => False) VEnv.empty where members := members @@ -390,6 +396,18 @@ def oracle : InductiveOracle RawProjRel.none catalog nameOf · rw [catalog_succ] at hcatalog cases hcatalog exact False.elim hrule + recursorPatterns := by + intro id c ruleIndex rule hmember hcatalog hrule + rcases hmember with rfl | rfl | rfl + · rw [catalog_nat] at hcatalog + cases hcatalog + exact False.elim hrule + · rw [catalog_zero] at hcatalog + cases hcatalog + exact False.elim hrule + · rw [catalog_succ] at hcatalog + cases hcatalog + exact False.elim hrule def worldNat : VerifyWorld where catalog := catalog @@ -994,6 +1012,7 @@ theorem freshKernelStateWF (prims : Primitives .anon) : (state prims) := by apply KernelStateWF.of_no_cache_entries (stateWF prims) · exact (checkSupport prims).initial + · rfl · intro entry simpa [state] using loadedEnv_noCacheEntries entry @@ -1015,25 +1034,65 @@ theorem whnfLeafTheoryWF : VExpr.WF worldGood.venv 0 [] (.sort .zero) := ⟨_, VEnv.HasType.sort trivial⟩ -/-- The concrete ambient-Nat state inhabits the full K1 invariant with -acceleration disabled. -/ +/-- The concrete ambient-Nat state inhabits the syntax-directed K1 fixture +layer with acceleration disabled. Its primitive table remains intentionally +parametric; production closure uses `productionNoAccelStateInv` below. -/ theorem noAccelStateInv (prims : Primitives .anon) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 [] (noAccelState prims) := by refine ⟨?_, ?_, rfl⟩ · have h := freshKernelStateWF prims - refine ⟨?_, ?_, ?_⟩ + refine ⟨?_, ?_, ?_, ?_⟩ · exact h.core.of_env_eq rfl · simpa [noAccelState] using h.internSupport · simpa [noAccelState] using h.caches + · simpa [noAccelState] using h.equivalences · apply CtxRecon.empty <;> rfl +/-- WHNF layer policy retains the old primitive reduction witness only in the explicitly structural layer: +two arbitrary primitive tables leave every semantic/cache/context field +identical. This layer may test syntax-directed branches but cannot close the +production reducer oracle. -/ +theorem structuralInvariant_does_not_bind_primitives + (left right : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support + 0 [] (noAccelState left) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support + 0 [] (noAccelState right) ∧ + (noAccelState left).env = (noAccelState right).env ∧ + (noAccelState left).ctx = (noAccelState right).ctx ∧ + (noAccelState left).letVals = (noAccelState right).letVals ∧ + (noAccelState left).lctx = (noAccelState right).lctx ∧ + (noAccelState left).prims = left ∧ + (noAccelState right).prims = right := by + exact ⟨noAccelStateInv left, noAccelStateInv right, + rfl, rfl, rfl, rfl, rfl, rfl⟩ + +/-- The real no-acceleration layer is inhabited by the production anon table. +This is the state-level primitive ingress fact used by subsequent active +reducer proofs. -/ +theorem productionNoAccelStateInv : + WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support + 0 [] (noAccelState Primitives.ofAnonAddrs) := by + have h := noAccelStateInv Primitives.ofAnonAddrs + exact ⟨h.1, h.2.1, rfl, Primitives.ofAnonAddrs_canonical⟩ + +/-- Any non-production primitive table is rejected by the production layer, +even though the weaker structural fixture invariant still accepts it. -/ +theorem noAccelInvariant_rejects_mismatched_primitives + (prims : Primitives .anon) + (hne : ¬prims.CanonicalAnon) : + ¬WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support + 0 [] (noAccelState prims) := by + intro h + exact hne h.noAccel_primitives + /-- A real Nat-containing state instantiates the first conditional `RecM.whnf` theorem. This branch returns before any cache, fuel, native, or recursive-method operation, but still preserves the complete K1 invariant on both EStateM outcomes. -/ theorem whnfLeaf_noAccel_wf (prims : Primitives .anon) : - RecM.WF .noAccel whnfSemantics RawProjRel.none worldGood support 0 [] + RecM.WF .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 [] (noAccelState prims) (RecM.whnf whnfLeafExpr) (fun result _ => WhnfPost RawProjRel.none worldGood 0 [] (.sort .zero) result) := @@ -1041,9 +1100,9 @@ theorem whnfLeaf_noAccel_wf (prims : Primitives .anon) : /-- Non-vacuity package for the first no-acceleration algorithmic slice. -/ theorem whnfLeaf_noAccel_acceptance (prims : Primitives .anon) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 [] (noAccelState prims) ∧ - RecM.WF .noAccel whnfSemantics RawProjRel.none worldGood support 0 [] + RecM.WF .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 [] (noAccelState prims) (RecM.whnf whnfLeafExpr) (fun result _ => WhnfPost RawProjRel.none worldGood 0 [] (.sort .zero) result) := @@ -1058,8 +1117,9 @@ theorem warmCoreWF (prims : Primitives .anon) : theorem warmKernelStateWF (prims : Primitives .anon) : KernelStateWF whnfSemantics RawProjRel.none worldGood support (warmState prims) := by - refine ⟨warmCoreWF prims, ?_, warmCache_worldTransport⟩ - simpa [warmState, warmEnv, state] using (checkSupport prims).initial + refine ⟨warmCoreWF prims, ?_, warmCache_worldTransport, ?_⟩ + · simpa [warmState, warmEnv, state] using (checkSupport prims).initial + · exact EquivManager.WF.empty /-- The real warm state computes the certified key and its empty semantic context is represented by the fixture's closed-key model. -/ @@ -1073,10 +1133,11 @@ theorem warmKey_matches (prims : Primitives .anon) : simp [TcM.whnfKey, TcM.ctxAddrForLbr, supportExpr_lbr, warmKey] rfl -theorem warmStateInvAccelerated (prims : Primitives .anon) : +theorem warmStateInvAccelerated : WhnfStateInv .accelerated whnfSemantics RawProjRel.none worldGood support - 0 [] (warmState prims) := by - exact ⟨warmKernelStateWF prims, (warmKey_matches prims).1, trivial⟩ + 0 [] (warmState Primitives.ofAnonAddrs) := by + exact ⟨warmKernelStateWF _, (warmKey_matches _).1, + Primitives.ofAnonAddrs_canonical⟩ /-- The generic key-frame theorem is inhabited by the real warm Nat state. Because `supportExpr` is closed, its representation premise follows from the @@ -1091,9 +1152,11 @@ theorem warmKey_matches_wf (prims : Primitives .anon) : (warmState prims) [] supportExpr key ∧ ContextKeyFrame (warmState prims) s') := by have hrep : ∀ key s', + CtxRecon worldGood.venv whnfContextKeys.uvars worldGood.nameOf + RawProjRel.none (warmState prims) [] → TcM.whnfKey supportExpr (warmState prims) = .ok key s' → - whnfContextKeys.Represents key.2 [] := by - intro key s' hrun + whnfContextKeys.Represents supportExpr.lbr key.2 [] := by + intro key s' _ hrun have hexact := TcM.whnfKey_closed (s := warmState prims) supportExpr_lbr rw [hexact] at hrun @@ -1200,7 +1263,7 @@ constant immediately, in both full and cheap modes, while preserving the no-acceleration state invariant. -/ theorem whnfCoreConst_noAccel_wf (prims : Primitives .anon) (flags : WhnfFlags) : - RecM.WF .noAccel whnfSemantics RawProjRel.none worldGood support 0 [] + RecM.WF .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 [] (noAccelState prims) (RecM.whnfCoreWithFlags supportExpr flags) (fun result _ => WhnfPost RawProjRel.none worldGood 0 [] (.const natName []) result) := @@ -1208,9 +1271,9 @@ theorem whnfCoreConst_noAccel_wf (prims : Primitives .anon) theorem whnfCoreConst_noAccel_acceptance (prims : Primitives .anon) (flags : WhnfFlags) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 [] (noAccelState prims) ∧ - RecM.WF .noAccel whnfSemantics RawProjRel.none worldGood support 0 [] + RecM.WF .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 [] (noAccelState prims) (RecM.whnfCoreWithFlags supportExpr flags) (fun result _ => WhnfPost RawProjRel.none worldGood 0 [] (.const natName []) result) := @@ -1227,12 +1290,39 @@ theorem betaIdentityMeaning : betaTy_tr betaBody_tr betaArg_tr betaA_type betaBody_type betaArg_type decide +/-- The concrete identity body has coherent variable metadata. -/ +theorem betaBody_constructed : KExpr.Constructed betaBody := by + unfold betaBody + exact .var (by decide) + /-- The concrete beta argument is smart-constructor coherent, which makes lifting it by zero syntactically exact. -/ theorem betaArg_constructed : KExpr.Constructed betaArg := by unfold betaArg exact .const +/-- Substitution's operational seam is inhabited by the ambient Nat identity redex: +the production transient helper returns the verified substitution spec and +leaves the complete typechecker state untouched. -/ +theorem betaIotaArgRun (methods : Methods .anon) (s : TcState .anon) : + (RecM.applyIotaArg betaLam betaArg true).run methods s = + .ok (KExpr.substSpec betaBody betaArg 0) s := by + unfold betaLam + rw [KExpr.mkLam_shape] + exact RecM.applyIotaArg_true_lam_run methods s _ _ _ _ _ _ + betaBody_constructed betaArg_constructed (by decide) + +/-- The exact non-interning term returned by that production branch carries +the same Theory beta meaning as the verified pure substitution result. -/ +theorem betaNoInternMeaning : + WhnfMeaning RawProjRel.none worldGood 0 [] betaSource + (substNoIntern betaBody betaArg 0) := by + unfold betaSource betaLam + rw [KExpr.mkApp_shape, KExpr.mkLam_shape] + exact WhnfMeaning.betaNoIntern (RawProjRel.none_ok worldGood.venv 0) + betaTy_tr betaBody_tr betaArg_tr betaA_type betaBody_type betaArg_type + betaBody_constructed betaArg_constructed (by decide) + /-- On the identity body, production's singleton simultaneous substitution is exactly the single-substitution result used by the Theory beta theorem. -/ theorem betaSimulSpec : @@ -1327,12 +1417,12 @@ theorem betaCoreUncached_eval (prims : Primitives .anon) · exact betaWalker_eval prims · simpa [betaSimulResult] using betaSimulLeaf -/-- K1c acceptance package: the concrete production execution preserves the +/-- interning frame acceptance package: the concrete production execution preserves the inhabited no-acceleration invariant, and its exact syntactic result has the Theory beta meaning proved above. -/ theorem betaCoreUncached_acceptance (prims : Primitives .anon) (flags : WhnfFlags) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 [] (noAccelState prims) ∧ (RecM.whnfCoreWithFlagsUncached betaSource flags).run betaHarnessMethods (noAccelState prims) = @@ -1341,7 +1431,7 @@ theorem betaCoreUncached_acceptance (prims : Primitives .anon) ⟨noAccelStateInv prims, betaCoreUncached_eval prims flags, betaResultMeaning⟩ -/-! ### K1d legacy de-Bruijn zeta witness -/ +/-! ### zeta reduction legacy de-Bruijn zeta witness -/ /-- One legacy let frame whose stored Nat.zero value is inlined by the translation context exactly as production `lookupLetVal` returns it. -/ @@ -1371,11 +1461,11 @@ theorem bvarZetaCtxRecon (prims : Primitives .anon) : simpa [bvarZetaState, noAccelState] using hrec theorem bvarZetaStateInv (prims : Primitives .anon) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 bvarZetaCtx (bvarZetaState prims) := by have hbase := noAccelStateInv prims exact ⟨⟨hbase.1.core.of_env_eq rfl, - hbase.1.internSupport, hbase.1.caches⟩, + hbase.1.internSupport, hbase.1.caches, hbase.1.equivalences⟩, bvarZetaCtxRecon prims, rfl⟩ theorem bvarZetaLiftSpec : @@ -1432,7 +1522,7 @@ theorem bvarZetaCoreUncachedEval (prims : Primitives .anon) theorem bvarZetaAcceptance (prims : Primitives .anon) (flags : WhnfFlags) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 bvarZetaCtx (bvarZetaState prims) ∧ (RecM.whnfCoreWithFlagsUncached betaBody flags).run betaHarnessMethods (bvarZetaState prims) = .ok betaArg (bvarZetaState prims) ∧ @@ -1440,7 +1530,7 @@ theorem bvarZetaAcceptance (prims : Primitives .anon) ⟨bvarZetaStateInv prims, bvarZetaCoreUncachedEval prims flags, bvarZetaMeaning prims⟩ -/-! ### K1d let-bound fvar zeta witness -/ +/-! ### zeta reduction let-bound fvar zeta witness -/ def fvarZetaId : FVarId := ⟨0⟩ @@ -1486,17 +1576,18 @@ theorem fvarZetaCtxRecon (prims : Primitives .anon) : simp [fvarZetaState, fvarZetaId] theorem fvarZetaStateInv (prims : Primitives .anon) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 fvarZetaCtx (fvarZetaState prims) := by have hbase := noAccelStateInv prims refine ⟨?_, fvarZetaCtxRecon prims, rfl⟩ - refine ⟨?_, ?_, ?_⟩ + refine ⟨?_, ?_, ?_, ?_⟩ · exact hbase.1.core.of_consts_eq (by rfl) (by simpa [fvarZetaState] using hbase.1.core.intern) · simpa [fvarZetaState] using hbase.1.internSupport · intro entry hentry apply hbase.1.caches cases hentry <;> (constructor; assumption) + · simpa [fvarZetaState] using hbase.1.equivalences /-- The real bounded structural-WHNF driver resolves a let-valued fvar and returns its closed Nat.zero value without changing checker state. -/ @@ -1524,7 +1615,7 @@ theorem fvarZetaMeaning (prims : Primitives .anon) : theorem fvarZetaAcceptance (prims : Primitives .anon) (flags : WhnfFlags) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 fvarZetaCtx (fvarZetaState prims) ∧ (RecM.whnfCoreWithFlagsUncached fvarZetaSource flags).run betaHarnessMethods (fvarZetaState prims) = @@ -1534,7 +1625,7 @@ theorem fvarZetaAcceptance (prims : Primitives .anon) ⟨fvarZetaStateInv prims, fvarZetaCoreUncachedEval prims flags, fvarZetaMeaning prims⟩ -/-! ### K1e adversarial projection witness -/ +/-! ### projection/iota branch adversarial projection witness -/ /-- A constructor application that the syntax-directed projection helper can index even though `Nat` is not admitted as a structure projection in this @@ -1598,11 +1689,11 @@ theorem projectionReduceEval (prims : Primitives .anon) : (RecM.tryProjReduce natId 0 projectionValue).run betaHarnessMethods (noAccelState prims) = .ok (some betaArg) (noAccelState prims) := by - unfold RecM.tryProjReduce projectionValue + rw [RecM.tryProjReduce_eq, RecM.tryProjPrepare_eq] + unfold projectionValue rw [KExpr.mkApp_shape, KExpr.mkConst_shape] - simp only [KExpr.collectSpine] rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] - simp only [KExpr.collectSpine.go] + unfold RecM.tryProjReduceTail rw [ReaderT.run_bind] change EStateM.bind (ReaderT.run @@ -1614,6 +1705,7 @@ theorem projectionReduceEval (prims : Primitives .anon) : rw [RecM.tryReduceFinValDecidableRec_noAccel rfl] simp only rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + simp only [KExpr.collectSpine, KExpr.collectSpine.go] rw [ReaderT.run_bind, ReaderT.run_monadLift] change EStateM.bind (TcM.tryGetConst succId) _ (noAccelState prims) = _ unfold EStateM.bind @@ -1642,7 +1734,7 @@ theorem projectionCoreEval (prims : Primitives .anon) /-- With `RawProjRel.none`, no projection source has a Theory translation. The successful execution above therefore cannot be promoted to -`WhnfMeaning`; the generic K1e theorem's source-translation premise is +`WhnfMeaning`; the generic projection/iota branch theorem's source-translation premise is essential. -/ theorem projectionSource_not_translated : ¬∃ sourceV, @@ -1656,7 +1748,7 @@ theorem projectionSource_not_translated : theorem projectionAdversarialWitness (prims : Primitives .anon) (flags : WhnfFlags) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 [] (noAccelState prims) ∧ (RecM.whnfCoreWithFlagsUncached projectionSource flags).run betaHarnessMethods (noAccelState prims) = @@ -1667,7 +1759,7 @@ theorem projectionAdversarialWitness (prims : Primitives .anon) ⟨noAccelStateInv prims, projectionCoreEval prims flags, projectionSource_not_translated⟩ -/-! ### K1e adversarial iota witness -/ +/-! ### projection/iota branch adversarial iota witness -/ def iotaPrims (prims : Primitives .anon) : Primitives .anon := { prims with natZero := zeroId } @@ -1679,12 +1771,19 @@ def iotaState (prims : Primitives .anon) : TcState .anon := def iotaHead : KExpr .anon := KExpr.mkConst iotaId #[] () def iotaSource : KExpr .anon := KExpr.mkApp iotaHead iotaResult +/-! NatLiteral runs the same deliberately untrusted operational recursor with a +literal major. The expanded zero constructor has production-computed +metadata, so it is kept distinct from the rule's adversarial RHS above. -/ +def iotaNatZero : KExpr .anon := RecM.natExprFromValue 0 +def iotaNatCtor : KExpr .anon := KExpr.mkConst zeroId #[] +def iotaNatSource : KExpr .anon := KExpr.mkApp iotaHead iotaNatZero + theorem iotaStateInv (prims : Primitives .anon) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support 0 [] (iotaState prims) := by have hbase := noAccelStateInv (iotaPrims prims) refine ⟨?_, ?_, rfl⟩ - · refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ · have hcat : worldGood.catalog iotaId = some iotaConcrete := by exact catalog_iota simpa [iotaState] using hbase.1.core.load hcat @@ -1692,6 +1791,7 @@ theorem iotaStateInv (prims : Primitives .anon) : · intro entry hentry apply hbase.1.caches cases hentry <;> (constructor; assumption) + · simpa [iotaState] using hbase.1.equivalences · apply CtxRecon.empty <;> rfl theorem iotaGetRec (prims : Primitives .anon) : @@ -1775,1225 +1875,4557 @@ theorem iotaInstantiateRule (prims : Primitives .anon) : .ok iotaResult (iotaState prims) := by rfl -/-- Exact execution of the real iota helper on the untrusted recursor-shaped -catalog entry. All parameter/motive/minor/field/trailing loops are empty, -but recursor lookup, major cleanup/WHNF, constructor lookup, and universe -instantiation are the production operations. -/ -theorem iotaTryEval (prims : Primitives .anon) (flags : WhnfFlags) : - (RecM.tryIotaWithFlags iotaSource flags).run betaHarnessMethods - (iotaState prims) = .ok (some iotaResult) (iotaState prims) := by - unfold RecM.tryIotaWithFlags iotaSource iotaHead - rw [KExpr.mkApp_shape, KExpr.mkConst_shape] - simp only [KExpr.collectSpine, KExpr.collectSpine.go] +theorem iotaApplyRule (prims : Primitives .anon) : + (RecM.applyIotaRule iotaRule #[] iotaInfo #[iotaResult] #[] 0 false).run + betaHarnessMethods (iotaState prims) = + .ok iotaResult (iotaState prims) := by + unfold RecM.applyIotaRule rw [ReaderT.run_bind, ReaderT.run_monadLift] - change EStateM.bind (TcM.tryGetConst iotaId) _ (iotaState prims) = _ - unfold EStateM.bind - rw [iotaGetRec] - simp [iotaConcrete, iotaRule] - change EStateM.bind - (ReaderT.run (RecM.cleanupNatOffsetMajor iotaResult) - betaHarnessMethods) _ (iotaState prims) = _ + change EStateM.bind (TcM.instantiateUnivParams iotaRule.rhs #[]) _ + (iotaState prims) = _ unfold EStateM.bind - rw [iotaCleanup] - simp only [Option.getD] - cases hcheap : flags.cheapRec <;> - simp only [Bool.false_eq_true, ↓reduceIte] - all_goals - rw [ReaderT.run_bind] - change EStateM.bind _ _ (iotaState prims) = _ - unfold EStateM.bind - have hmajor := iotaMajorWhnf prims flags - simp only [hcheap, Bool.false_eq_true, ↓reduceIte] at hmajor - rw [hmajor] - simp only - rw [iotaResult] - simp only + rw [iotaInstantiateRule] + rfl + +theorem iotaApplyCtor (prims : Primitives .anon) : + (RecM.tryApplyIotaCtor iotaInfo #[] #[iotaResult] #[] 0 0 false).run + betaHarnessMethods (iotaState prims) = + .ok (some iotaResult) (iotaState prims) := by + exact (RecM.TryApplyIotaCtorSuccessTrace.mk rfl rfl (by decide) + (iotaApplyRule prims)).eval + +theorem iotaCleanupOfNatValue (prims : Primitives .anon) + (e : KExpr .anon) (value : Nat) + (hextract : extractNatValue e (iotaPrims prims) = some value) : + (RecM.cleanupNatOffsetMajor e).run betaHarnessMethods + (iotaState prims) = .ok none (iotaState prims) := by + have heval : + (RecM.evalNatOffsetLiteral e 0).run betaHarnessMethods + (iotaState prims) = .ok (some value) (iotaState prims) := by + unfold RecM.evalNatOffsetLiteral RecM.evalNatOffsetLiteralFuel rw [ReaderT.run_bind] change EStateM.bind - (ReaderT.run - (RecM.cleanupNatOffsetMajor - (.const zeroId #[] (info iotaAddress))) - betaHarnessMethods) _ (iotaState prims) = _ + (ReaderT.run RecM.prims betaHarnessMethods) _ (iotaState prims) = _ unfold EStateM.bind - have hcleanup := iotaCleanup prims - rw [iotaResult] at hcleanup - rw [hcleanup] + rw [show ReaderT.run RecM.prims betaHarnessMethods (iotaState prims) = + .ok (iotaPrims prims) (iotaState prims) from rfl] simp only - simp only [KExpr.collectSpine.go] - rw [ReaderT.run_bind, ReaderT.run_monadLift] - change EStateM.bind (TcM.tryGetConst zeroId) _ (iotaState prims) = _ - unfold EStateM.bind - rw [iotaGetZero] - simp [zeroConcrete] - have hinst := iotaInstantiateRule prims - simp only [iotaRule] at hinst - rw [iotaResult] at hinst - show EStateM.map _ _ (iotaState prims) = _ - unfold EStateM.map - rw [hinst] + rw [hextract] + rfl + unfold RecM.cleanupNatOffsetMajor + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (RecM.evalNatOffsetLiteral e 0) betaHarnessMethods) _ + (iotaState prims) = _ + unfold EStateM.bind + rw [heval] + rfl -theorem iotaStepEval (prims : Primitives .anon) (flags : WhnfFlags) : - (RecM.whnfCoreWithFlagsStep iotaSource flags).run betaHarnessMethods +theorem iotaNatCleanup (prims : Primitives .anon) : + (RecM.cleanupNatOffsetMajor iotaNatZero).run betaHarnessMethods + (iotaState prims) = .ok none (iotaState prims) := by + apply iotaCleanupOfNatValue prims iotaNatZero 0 + unfold iotaNatZero RecM.natExprFromValue extractNatValue extractNatLit + rw [KExpr.mkNat_shape] + +theorem iotaNatCtorCleanup (prims : Primitives .anon) : + (RecM.cleanupNatOffsetMajor iotaNatCtor).run betaHarnessMethods + (iotaState prims) = .ok none (iotaState prims) := by + apply iotaCleanupOfNatValue prims iotaNatCtor 0 + unfold iotaNatCtor extractNatValue extractNatLit + rw [KExpr.mkConst_shape] + simp [iotaPrims] + +theorem iotaNatMajorWhnf (prims : Primitives .anon) (flags : WhnfFlags) : + (if flags.cheapRec then + (RecM.whnfCoreFlagsRec iotaNatZero flags).run betaHarnessMethods + (iotaState prims) + else (RecM.whnfRec iotaNatZero).run betaHarnessMethods + (iotaState prims)) = .ok iotaNatZero (iotaState prims) := by + cases flags.cheapRec <;> + simp [RecM.whnfCoreFlagsRec, RecM.whnfRec, betaHarnessMethods] <;> rfl + +theorem iotaNatZeroExpand (prims : Primitives .anon) : + (RecM.natToConstructor 0).run betaHarnessMethods (iotaState prims) = + .ok iotaNatCtor (iotaState prims) := by + simpa [iotaNatCtor, iotaState, iotaPrims, noAccelState, state] using + (RecM.natToConstructor_zero betaHarnessMethods (iotaState prims)) + +theorem iotaNatSuccExpand (prims : Primitives .anon) (predecessor : Nat) : + (RecM.natToConstructor (predecessor + 1)).run betaHarnessMethods + (iotaState prims) = + .ok (KExpr.mkApp (KExpr.mkConst prims.natSucc #[]) + (RecM.natExprFromValue predecessor)) (iotaState prims) := by + simpa [iotaState, iotaPrims, noAccelState, state] using + (RecM.natToConstructor_succ betaHarnessMethods (iotaState prims) + predecessor) + +theorem iotaNatApplyRule (prims : Primitives .anon) : + (RecM.applyIotaRule iotaRule #[] iotaInfo #[iotaNatZero] #[] 0 true).run + betaHarnessMethods (iotaState prims) = + .ok iotaResult (iotaState prims) := by + unfold RecM.applyIotaRule + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.instantiateUnivParams iotaRule.rhs #[]) _ + (iotaState prims) = _ + unfold EStateM.bind + rw [iotaInstantiateRule] + rfl + +theorem iotaNatApplyCtor (prims : Primitives .anon) : + (RecM.tryApplyIotaCtor iotaInfo #[] #[iotaNatZero] #[] 0 0 true).run + betaHarnessMethods (iotaState prims) = + .ok (some iotaResult) (iotaState prims) := by + exact (RecM.TryApplyIotaCtorSuccessTrace.mk rfl rfl (by decide) + (iotaNatApplyRule prims)).eval + +/-- Inhabited NatLiteral path: a literal zero survives the major callback, expands +to the active `Nat.zero` constructor, and executes the selected rule with +transient application semantics. -/ +theorem iotaNatTryEval (prims : Primitives .anon) (flags : WhnfFlags) : + (RecM.tryIotaWithFlags iotaNatSource flags).run betaHarnessMethods + (iotaState prims) = .ok (some iotaResult) (iotaState prims) := by + apply RecM.tryIotaWithFlags_natCtor + (recId := iotaId) (recUs := #[]) (spine := #[iotaNatZero]) + (recursor := iotaConcrete) (recr := iotaInfo) + (major := iotaNatZero) (value := 0) + (blob := KExpr.natBlob 0) (ctorMajor := iotaNatCtor) + (ctorId := zeroId) (ctorUs := #[]) (ctorArgs := #[]) + (ctor := zeroConcrete) (cidx := 0) (ctorFields := 0) + · unfold iotaNatSource iotaHead + rw [KExpr.mkApp_shape, KExpr.mkConst_shape] + rfl + · exact iotaGetRec prims + · rfl + · decide + · rfl + · rfl + · exact iotaNatCleanup prims + · exact iotaNatMajorWhnf prims flags + · exact iotaNatZeroExpand prims + · unfold iotaNatCtor + exact .const + · exact iotaNatCtorCleanup prims + · unfold iotaNatCtor + rw [KExpr.mkConst_shape] + rfl + · exact iotaGetZero prims + · rfl + · exact iotaNatApplyCtor prims + +theorem iotaNatStepEval (prims : Primitives .anon) (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsStep iotaNatSource flags).run betaHarnessMethods (iotaState prims) = .ok (.next iotaResult) (iotaState prims) := by - unfold iotaSource iotaHead + unfold iotaNatSource iotaHead rw [KExpr.mkApp_shape, KExpr.mkConst_shape] apply RecM.whnfCoreWithFlagsStep_iota (recId := iotaId) (us := #[]) (headInfo := (KExpr.mkConst iotaId #[] ()).info) - (args := #[iotaResult]) + (args := #[iotaNatZero]) · simp [KExpr.collectSpine, KExpr.collectSpine.go] · rfl · change Bool.not ((KExpr.mkConst iotaId #[] ()).info.addr == (KExpr.mkConst iotaId #[] ()).info.addr) = false rw [beq_self_eq_true] rfl - · exact iotaTryEval prims flags + · exact iotaNatTryEval prims flags -theorem iotaCoreEval (prims : Primitives .anon) (flags : WhnfFlags) : - (RecM.whnfCoreWithFlagsUncached iotaSource flags).run +theorem iotaNatCoreEval (prims : Primitives .anon) (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsUncached iotaNatSource flags).run betaHarnessMethods (iotaState prims) = .ok iotaResult (iotaState prims) := by apply RecM.whnfCoreWithFlagsUncached_nextLeaf - · exact iotaStepEval prims flags + · exact iotaNatStepEval prims flags · exact .const -theorem nameOf_iota_none : nameOf iotaAddress = none := by - rfl +/-! ### StringLiteral inhabited empty-String preprocessing path -/ -theorem iotaHead_not_translated : - ¬∃ headV, - TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] - iotaHead headV := by - rintro ⟨headV, hhead⟩ - unfold iotaHead at hhead - rw [KExpr.mkConst_shape] at hhead - cases hhead with - | const hname _ _ _ => - change nameOf iotaAddress = some _ at hname - rw [nameOf_iota_none] at hname - contradiction +def iotaStringCtorAddress : Address := address 15 +def iotaStringCtorId : KId .anon := ⟨iotaStringCtorAddress, ()⟩ -theorem iotaSource_not_translated : - ¬∃ sourceV, - TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] - iotaSource sourceV := by - rintro ⟨sourceV, hsource⟩ - unfold iotaSource at hsource - rw [KExpr.mkApp_shape] at hsource - cases hsource with - | app _ _ hhead _ => exact iotaHead_not_translated ⟨_, hhead⟩ +/-- Operational constructor metadata for the generated `String.ofList` head. +The zero field count keeps this deliberately untrusted fixture focused on +String preprocessing; ordinary nonzero-field execution is inhabited by the +ConstructorDispatch multi-argument fixture. -/ +def iotaStringCtorConcrete : KConst .anon := + .ctor () () false 0 natId 0 0 0 natRef -theorem iotaAdversarialWitness (prims : Primitives .anon) - (flags : WhnfFlags) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support - 0 [] (iotaState prims) ∧ - (RecM.whnfCoreWithFlagsUncached iotaSource flags).run - betaHarnessMethods (iotaState prims) = - .ok iotaResult (iotaState prims) ∧ - ¬∃ sourceV, - TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] - iotaSource sourceV := - ⟨iotaStateInv prims, iotaCoreEval prims flags, - iotaSource_not_translated⟩ +def iotaStringPrims : Primitives .anon := + { iotaPrims Primitives.ofAnonAddrs with stringOfList := iotaStringCtorId } -/-! ### K1f structural-loop composition witness -/ +def iotaStringState : TcState .anon := + let base := iotaState iotaStringPrims + { base with env := base.env.insert iotaStringCtorId iotaStringCtorConcrete } -/-- Literal closure for this finite ambient world. Nat literals are typed by -the installed `Nat.zero`/`Nat.succ` constants; String literal support is -provably absent. -/ -theorem structuralNatLit_type (n : Nat) : - worldGood.venv.HasType 0 [] (VExpr.natLit n) (.const natName []) := by - induction n with - | zero => - simpa [VExpr.natLit, VExpr.natZero, zeroName] using betaArg_type - | succ n ih => - have hsucc : worldGood.venv.HasType 0 [] (.const succName []) - (.forallE (.const natName []) (.const natName [])) := by - exact Lean4Lean.VEnv.HasType.const (env := worldGood.venv) - (U := 0) (Γ := []) (ci := succConstant) (ls := []) - (by simpa [worldGood, goodEnv, goodName, succName] using natEnv_succ) - (by intro l hl; simp at hl) rfl - simpa [VExpr.natLit, VExpr.natSucc, succName] using - Lean4Lean.VEnv.HasType.app hsucc ih +def iotaStringMajor : KExpr .anon := KExpr.mkStrLit "" -/-- The finite Nat world supplies the uniform literal/projection facts needed -to compose arbitrary structural trace meanings. -/ -def structuralWhnfTheory : WhnfTheory RawProjRel.none worldGood 0 where - literalWF := by - intro literal hliteral - cases literal with - | natVal n => exact ⟨_, structuralNatLit_type n⟩ - | strVal value => - simp [Lean4Lean.VEnv.ContainsLits, Lean4Lean.VEnv.contains, - worldGood, goodEnv, natEnv, natEnv₂, natEnv₁, goodName, - natName, zeroName, succName] at hliteral - projections := RawProjRel.none_ok worldGood.venv 0 +def iotaStringNil : KExpr .anon := + KExpr.mkApp + (KExpr.mkConst iotaStringPrims.listNil #[KUniv.mkZero]) + (KExpr.mkConst iotaStringPrims.charType #[]) -/-- Translation of the closed beta redex, used as the value stored in the -let-bound fvar below. -/ -theorem structuralBetaSource_tr : - TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] - betaSource - (.app (.lam (.const natName []) (.bvar 0)) (.const zeroName [])) := by - rw [betaSource, betaLam, KExpr.mkApp_shape, KExpr.mkLam_shape] - exact .app (Lean4Lean.VEnv.HasType.lam betaA_type betaBody_type) - betaArg_type (.lam ⟨_, betaA_type⟩ betaTy_tr betaBody_tr) betaArg_tr +def iotaStringCtor : KExpr .anon := + KExpr.mkApp (KExpr.mkConst iotaStringCtorId #[]) iotaStringNil -theorem structuralBetaSource_type : - worldGood.venv.HasType 0 [] - (.app (.lam (.const natName []) (.bvar 0)) (.const zeroName [])) - (.const natName []) := by - simpa using Lean4Lean.VEnv.HasType.app - (Lean4Lean.VEnv.HasType.lam betaA_type betaBody_type) betaArg_type +def iotaStringSource : KExpr .anon := KExpr.mkApp iotaHead iotaStringMajor -theorem structuralBetaSource_constructed : KExpr.Constructed betaSource := by - unfold betaSource betaLam betaBody - exact .app (.lam supportExpr_constructed (.var (by decide))) - betaArg_constructed +/-- The new production induction seam is inhabited at the empty character +list without touching state. Fixed String setup/final interns remain an +explicit later helper-closure obligation. -/ +theorem iotaStringEmptyFold (charOfNat cons : KExpr .anon) : + (RecM.strLitListToConstructor charOfNat cons [] iotaStringNil).run + betaHarnessMethods iotaStringState = + .ok iotaStringNil iotaStringState := + RecM.strLitListToConstructor_empty _ _ _ _ _ -theorem structuralBetaSource_closed : betaSource.lbr = 0 := by +/-- The post-WHNF fixture callback makes the generated String spine converge +to the already loaded zero constructor under either recursive policy. The +fixture starts at `tryIotaAfterMajorWhnf`, so this does not interfere with an +earlier major callback. -/ +def iotaStringHarnessMethods : Methods .anon where + whnf := fun _ => pure iotaResult + whnfCore := fun e => pure e + whnfMode := fun e _ => pure e + whnfCoreFlags := fun _ _ => pure iotaResult + infer := fun e => pure e + isDefEq := fun _ _ => pure false + +theorem iotaStringExpand : + ∃ strCtor s', + (RecM.strLitToConstructor "").run iotaStringHarnessMethods + iotaStringState = + .ok strCtor s' ∧ + InternUpdateFrame iotaStringState s' := + RecM.strLitToConstructor_success_frame _ _ _ + +theorem iotaStringCallback (flags : WhnfFlags) + (strCtor : KExpr .anon) (s : TcState .anon) : + (if flags.cheapRec then + (RecM.whnfCoreFlagsRec strCtor flags).run iotaStringHarnessMethods s + else (RecM.whnfRec strCtor).run iotaStringHarnessMethods s) = + .ok iotaResult s := by + cases flags.cheapRec <;> + simp [RecM.whnfCoreFlagsRec, RecM.whnfRec, + iotaStringHarnessMethods] <;> rfl + +theorem iotaStringCleanup : + (RecM.cleanupNatOffsetMajor iotaStringMajor).run + iotaStringHarnessMethods iotaStringState = + .ok none iotaStringState := by + unfold iotaStringMajor KExpr.mkStrLit + rw [KExpr.mkStr_shape] + exact RecM.cleanupNatOffsetMajor_str _ _ _ _ _ + +/-- String expansion may grow the intern table, but it cannot disturb the +constructor catalog used by the following ordinary-iota dispatch. -/ +theorem iotaStringGetZeroOfFrame {s' : TcState .anon} + (hframe : InternUpdateFrame iotaStringState s') : + TcM.tryGetConst zeroId s' = .ok (some zeroConcrete) s' := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s' = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s' = .ok s' s' from rfl] + simp only + have hconsts : s'.env.consts = iotaStringState.env.consts := by + simpa [InternUpdateFrame] using + congrArg (fun st : TcState .anon => st.env.consts) hframe + have hneString : iotaStringCtorId ≠ zeroId := by + intro h + exact address_ne (a := 15) (b := 11) (by decide) + (congrArg KId.addr h) + have hneIota : iotaId ≠ zeroId := by + intro h + exact address_ne (a := 14) (b := 11) (by decide) + (congrArg KId.addr h) + have hinitial : iotaStringState.env.get? zeroId = some zeroConcrete := by + simp only [iotaStringState, KEnv.get?, KEnv.insert, + Std.HashMap.getElem?_insert] + split + · next h => exact False.elim (hneString (eq_of_beq h)) + · simp only [iotaState, KEnv.insert] + rw [Std.HashMap.getElem?_insert] + split + · next h => exact False.elim (hneIota (eq_of_beq h)) + · simpa [noAccelState, state] using loadedEnv_zero_k1e + have hget : s'.env.get? zeroId = iotaStringState.env.get? zeroId := by + unfold KEnv.get? + rw [hconsts] + rw [hget, hinitial] rfl -/-- A let-bound fvar whose value is itself the beta redex. Production must -therefore take two `.next` transitions before reaching the constant leaf. -/ -def structuralLoopSource : KExpr .anon := KExpr.mkFVar fvarZetaId () +/-- The deliberately nullary fixture rule is state-preserving for every +post-expansion state; its right-hand side has no universes to instantiate. -/ +theorem iotaStringApplyRule (s : TcState .anon) : + (RecM.applyIotaRule iotaRule #[] iotaInfo #[iotaStringMajor] #[] 0 false).run + iotaStringHarnessMethods s = .ok iotaResult s := by + unfold RecM.applyIotaRule + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.instantiateUnivParams iotaRule.rhs #[]) _ s = _ + unfold EStateM.bind + rw [show TcM.instantiateUnivParams iotaRule.rhs #[] s = + .ok iotaResult s from rfl] + rfl -def structuralLoopCtx : KVLCtx := - [(some (fvarZetaId, []), - .vlet (.const natName []) - (.app (.lam (.const natName []) (.bvar 0)) (.const zeroName [])))] +theorem iotaStringApplyCtor (s : TcState .anon) : + (RecM.tryApplyIotaCtor iotaInfo #[] #[iotaStringMajor] #[] 0 0 false).run + iotaStringHarnessMethods s = .ok (some iotaResult) s := by + exact (RecM.TryApplyIotaCtorSuccessTrace.mk rfl rfl (by decide) + (iotaStringApplyRule s)).eval + +/-- Inhabited StringLiteral post-WHNF path: the empty String is expanded through the +real intern-heavy helper, normalized under either callback policy, recognized +as the loaded zero constructor, and dispatched with `transient = false`. -/ +theorem iotaStringAfterEval (flags : WhnfFlags) : + ∃ s', + (RecM.tryIotaAfterMajorWhnf flags iotaId iotaInfo #[] + #[iotaStringMajor] iotaStringMajor).run iotaStringHarnessMethods + iotaStringState = .ok (some iotaResult) s' := by + obtain ⟨strCtor, sStr, hstr, hframe⟩ := iotaStringExpand + have hlookup := iotaStringGetZeroOfFrame hframe + have hdispatch : + (RecM.tryIotaCtorOrStructEta iotaId iotaInfo #[] + #[iotaStringMajor] iotaResult false).run iotaStringHarnessMethods sStr = + .ok (some iotaResult) sStr := by + apply RecM.tryIotaCtorOrStructEta_regular + (ctorId := zeroId) (ctorUs := #[]) (ctorArgs := #[]) + (ctor := zeroConcrete) (cidx := 0) (ctorFields := 0) + · unfold iotaResult + rfl + · exact hlookup + · rfl + · exact iotaStringApplyCtor sStr + refine ⟨sStr, ?_⟩ + have hcleanup := iotaStringCleanup + unfold iotaStringMajor KExpr.mkStrLit at hcleanup ⊢ + rw [KExpr.mkStr_shape] at hcleanup ⊢ + exact RecM.tryIotaAfterMajorWhnf_str + (flags := flags) hcleanup hstr + (iotaStringCallback flags strCtor sStr) hdispatch -def structuralLoopState (prims : Primitives .anon) : TcState .anon := - let base := noAccelState prims - { base with - env := { base.env with nextFVarId := 1 } - lctx := base.lctx.push fvarZetaId - (.ldecl () supportExpr betaSource) } +/-! ### ConstructorSynthesis inhabited K-synthesis path -/ -theorem structuralLoopFind (prims : Primitives .anon) : - (structuralLoopState prims).lctx.find? fvarZetaId = - some (.ldecl () supportExpr betaSource) := by - simp [structuralLoopState, noAccelState, LocalContext.find?, - LocalContext.push, fvarZetaId] +def kMajorAddress : Address := address 16 +def kMajorId : KId .anon := ⟨kMajorAddress, ()⟩ -theorem structuralLoopCtxRecon (prims : Primitives .anon) : - CtxRecon worldGood.venv 0 worldGood.nameOf RawProjRel.none - (structuralLoopState prims) structuralLoopCtx := by - refine { - size_eq := rfl - recon := ?_ - lwf := ?_ - incr := by - simp [structuralLoopState, noAccelState, state, LocalContext.push] - fresh := ?_ - lets := rfl } - · have hrec : - CtxRecon' worldGood.venv 0 worldGood.nameOf RawProjRel.none - [] [(fvarZetaId, .ldecl () supportExpr betaSource)] - structuralLoopCtx := - .fvar .nil - (.vlet betaTy_tr structuralBetaSource_tr structuralBetaSource_type) - (by simp) - simpa [structuralLoopState, noAccelState, LocalContext.push] using hrec - · apply LocalContext.WF.push .empty - simp [fvarZetaId] - · intro p hp - simp [structuralLoopState, noAccelState, state, LocalContext.push] at hp - subst p - simp [structuralLoopState, fvarZetaId] - -theorem structuralLoopStateInv (prims : Primitives .anon) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support - 0 structuralLoopCtx (structuralLoopState prims) := by - have hbase := noAccelStateInv prims - refine ⟨?_, structuralLoopCtxRecon prims, rfl⟩ - refine ⟨?_, ?_, ?_⟩ - · exact hbase.1.core.of_consts_eq (by rfl) (by - simpa [structuralLoopState] using hbase.1.core.intern) - · simpa [structuralLoopState] using hbase.1.internSupport - · intro entry hentry - apply hbase.1.caches - cases hentry <;> (constructor; assumption) +def kMajor : KExpr .anon := KExpr.mkConst kMajorId #[] -/-- First local meaning: fvar zeta exposes the closed beta redex. -/ -theorem structuralLoopSourceMeaning (prims : Primitives .anon) : - WhnfMeaning RawProjRel.none worldGood 0 structuralLoopCtx - structuralLoopSource betaSource := by - unfold structuralLoopSource - rw [KExpr.mkFVar_shape] - apply WhnfMeaning.zetaFVar (structuralLoopCtxRecon prims) - (RawProjRel.none_ok worldGood.venv 0) - (structuralLoopFind prims) structuralBetaSource_constructed - structuralBetaSource_closed - decide +def kMajorConcrete : KConst .anon := + .axio () () false 0 natRef -theorem structuralLoopTy_tr : - TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none - structuralLoopCtx supportExpr (.const natName []) := by - rw [supportExpr_eq_mkConst, KExpr.mkConst_shape] - exact .const (ci := natConstant) nameOf_nat - (by simpa [worldGood, goodEnv, goodName, natName] using natEnv_nat) - (by intro l hl; simp at hl) rfl +/-- A single major premise is enough for production's bounded inductive-head +scan because this K-like fixture has no parameters, motives, minors, or +indices before the major. -/ +def kRecType : KExpr .anon := + .all () () natRef natRef (info kMajorAddress) -theorem structuralLoopBody_tr : - TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none - ((none, .vlam (.const natName [])) :: structuralLoopCtx) - betaBody (.bvar 0) := by - rw [betaBody, KExpr.mkVar_shape] - exact .var rfl +def kIotaConcrete : KConst .anon := + .recr () () true false 0 0 0 0 0 natId 0 kRecType #[iotaRule] () -theorem structuralLoopArg_tr : - TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none - structuralLoopCtx betaArg (.const zeroName []) := by - rw [betaArg, KExpr.mkConst_shape] - exact .const (ci := zeroConstant) nameOf_zero - (by simpa [worldGood, goodEnv, goodName, zeroName] using natEnv_zero) - (by intro l hl; simp at hl) rfl +def kIotaInfo : IotaInfo .anon := + { k := true, params := 0, motives := 0, minors := 0, indices := 0, + majorIdx := 0, rules := #[iotaRule], lvls := 0 } -theorem structuralLoopA_type : - worldGood.venv.HasType 0 structuralLoopCtx.toCtx (.const natName []) - (.sort (.succ .zero)) := by - simpa [structuralLoopCtx] using betaA_type +def kIotaState : TcState .anon := + let base := noAccelState (iotaPrims Primitives.ofAnonAddrs) + let withRec := { base with env := base.env.insert iotaId kIotaConcrete } + { withRec with env := withRec.env.insert kMajorId kMajorConcrete } -theorem structuralLoopBody_type : - worldGood.venv.HasType 0 - ((.const natName []) :: structuralLoopCtx.toCtx) (.bvar 0) - (.const natName []) := by - simpa [structuralLoopCtx] using betaBody_type +def kIotaSource : KExpr .anon := KExpr.mkApp iotaHead kMajor +def kSynthCtor : KExpr .anon := KExpr.mkConst zeroId #[] -theorem structuralLoopArg_type : - worldGood.venv.HasType 0 structuralLoopCtx.toCtx (.const zeroName []) - (.const natName []) := by - simpa [structuralLoopCtx] using betaArg_type +def kIotaAfterIntern : TcState .anon := + { kIotaState with env := { kIotaState.env with + intern := (internExprM kSynthCtor kIotaState.env.intern).2 } } -/-- Second local meaning: beta reduces the exposed identity application to -`Nat.zero` in the same mixed context. -/ -theorem structuralLoopBetaMeaning : - WhnfMeaning RawProjRel.none worldGood 0 structuralLoopCtx - betaSource betaArg := by - rw [← betaSimulResult] - unfold betaSource betaLam - rw [KExpr.mkApp_shape, KExpr.mkLam_shape] - apply WhnfMeaning.betaSimul - · apply WhnfMeaning.beta (RawProjRel.none_ok worldGood.venv 0) - structuralLoopTy_tr structuralLoopBody_tr structuralLoopArg_tr - structuralLoopA_type structuralLoopBody_type structuralLoopArg_type - decide - · exact betaSimulSpec +/-- The harness models exactly the predecessor method-table facts consumed by +K synthesis: both the arbitrary major and the generated nullary constructor +have type `Nat`, WHNF is already reached, and their types are definitionally +equal. -/ +def kIotaHarnessMethods : Methods .anon where + whnf := fun e => pure e + whnfCore := fun e => pure e + whnfMode := fun e _ => pure e + whnfCoreFlags := fun e _ => pure e + infer := fun _ => pure natRef + isDefEq := fun _ _ => pure true + +theorem kIotaIntern : + TcM.intern kSynthCtor kIotaState = + .ok kSynthCtor kIotaAfterIntern := by + unfold kIotaAfterIntern TcM.intern TcM.runIntern internExprM + have hempty : kIotaState.env.intern.exprs[kSynthCtor.internKey]? = none := by + have hloaded : loadedEnv.intern.exprs = + ({} : Std.HashMap Address (KExpr .anon)) := by + rfl + simp [kIotaState, noAccelState, state, KEnv.insert, hloaded] + simp only [InternTable.internExpr, hempty] + +theorem kIotaMajorInfer : + (RecM.tryOptional (RecM.inferOnlyRec kMajor)).run + kIotaHarnessMethods kIotaState = + .ok (some natRef) kIotaState := by + rfl -theorem structuralLoopLeafMeaning : - WhnfMeaning RawProjRel.none worldGood 0 structuralLoopCtx - betaArg betaArg := by - apply WhnfMeaning.refl structuralLoopArg_tr - exact ⟨_, structuralLoopArg_type⟩ +theorem kIotaMajorWhnf : + (RecM.tryOptional (RecM.whnfRec natRef)).run + kIotaHarnessMethods kIotaState = + .ok (some natRef) kIotaState := by + rfl -theorem structuralLoopFVarStep (prims : Primitives .anon) - (flags : WhnfFlags) : - (RecM.whnfCoreWithFlagsStep structuralLoopSource flags).run - betaHarnessMethods (structuralLoopState prims) = - .ok (.next betaSource) (structuralLoopState prims) := by - unfold structuralLoopSource - rw [KExpr.mkFVar_shape] - exact RecM.whnfCoreWithFlagsStep_fvarZeta (structuralLoopFind prims) +theorem kIotaGetRec : + TcM.tryGetConst iotaId kIotaState = + .ok (some kIotaConcrete) kIotaState := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ kIotaState = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) kIotaState = + .ok kIotaState kIotaState from rfl] + simp only + have hne : kMajorId ≠ iotaId := by + intro h + exact address_ne (a := 16) (b := 14) (by decide) + (congrArg KId.addr h) + have henv : kIotaState.env.get? iotaId = some kIotaConcrete := by + simp only [kIotaState, KEnv.get?, KEnv.insert, + Std.HashMap.getElem?_insert] + split + · next h => exact False.elim (hne (eq_of_beq h)) + · simp + rw [henv] + rfl -theorem structuralLoopWalkerEval (prims : Primitives .anon) : - TcM.runIntern (simulSubst betaBody #[betaArg] 0) - (structuralLoopState prims) = - .ok betaArg (structuralLoopState prims) := by - unfold TcM.runIntern - rw [betaWalker_intern] +theorem kIotaGetNat : + TcM.tryGetConst natId kIotaState = + .ok (some natConcrete) kIotaState := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ kIotaState = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) kIotaState = + .ok kIotaState kIotaState from rfl] + simp only + have hmajor : kMajorId ≠ natId := by + intro h + exact address_ne (a := 16) (b := 10) (by decide) + (congrArg KId.addr h) + have hrec : iotaId ≠ natId := by + intro h + exact address_ne (a := 14) (b := 10) (by decide) + (congrArg KId.addr h) + have henv : kIotaState.env.get? natId = some natConcrete := by + simp only [kIotaState, KEnv.get?, KEnv.insert, + Std.HashMap.getElem?_insert] + split + · next h => exact False.elim (hmajor (eq_of_beq h)) + · split + · next h => exact False.elim (hrec (eq_of_beq h)) + · change loadedEnv.get? natId = some natConcrete + exact loadedEnv_nat + rw [henv] + rfl -theorem structuralLoopBetaStep (prims : Primitives .anon) - (flags : WhnfFlags) : - (RecM.whnfCoreWithFlagsStep betaSource flags).run betaHarnessMethods - (structuralLoopState prims) = - .ok (.next betaArg) (structuralLoopState prims) := by - unfold betaSource betaLam - rw [KExpr.mkApp_shape, KExpr.mkLam_shape] - simpa [betaSimulResult] using - (RecM.whnfCoreWithFlagsStep_betaOne - (methods := betaHarnessMethods) (s := structuralLoopState prims) - (flags := flags) (hhead := rfl) - (hwalk := structuralLoopWalkerEval prims)) +theorem kIotaMajorInductive : + (RecM.tryOptional (RecM.getMajorInductiveId kRecType 0)).run + kIotaHarnessMethods kIotaState = .ok (some natId) kIotaState := by + have hzero : (0 : UInt64).toNat = 0 := by decide + have hget : + (RecM.getMajorInductiveId kRecType 0).run + kIotaHarnessMethods kIotaState = .ok natId kIotaState := by + rw [RecM.scratch_getMajorInductiveId_run] + apply RecM.scratch_tryFinally_ok + · rw [hzero] + simp only [RecM.peelMajorForalls, pure_bind] + unfold RecM.scanMajorInductive + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (RecM.whnfRec kRecType) kIotaHarnessMethods) _ + kIotaState = _ + unfold EStateM.bind + rw [show (RecM.whnfRec kRecType).run kIotaHarnessMethods kIotaState = + .ok kRecType kIotaState from rfl] + simp only + change EStateM.bind (TcM.tryGetConst natId) _ kIotaState = _ + unfold EStateM.bind + rw [kIotaGetNat] + rfl + · rfl + exact RecM.tryOptional_success hget -theorem structuralLoopLeafStep (prims : Primitives .anon) - (flags : WhnfFlags) : - (RecM.whnfCoreWithFlagsStep betaArg flags).run betaHarnessMethods - (structuralLoopState prims) = - .ok (.done betaArg) (structuralLoopState prims) := - RecM.whnfCoreWithFlagsStep_leaf .const flags +theorem kIotaCtorInfer : + (RecM.tryOptional (RecM.inferOnlyRec kSynthCtor)).run + kIotaHarnessMethods kIotaAfterIntern = + .ok (some natRef) kIotaAfterIntern := by + rfl -/-- Three exact iterations at production fuel: fvar-zeta, beta, then leaf. -The trace carries the same fixed world/context invariant throughout. -/ -theorem structuralLoopTrace (prims : Primitives .anon) - (flags : WhnfFlags) : - RecM.WhnfCoreTrace .noAccel whnfSemantics RawProjRel.none worldGood - support 0 structuralLoopCtx betaHarnessMethods flags maxWhnfFuel.toNat - structuralLoopSource (structuralLoopState prims) betaArg - (structuralLoopState prims) := by - rw [show maxWhnfFuel.toNat = 10000 by rfl] - refine .next (structuralLoopStateInv prims) - (structuralLoopFVarStep prims flags) (structuralLoopStateInv prims) - (structuralLoopSourceMeaning prims) ?_ - refine .next (structuralLoopStateInv prims) - (structuralLoopBetaStep prims flags) (structuralLoopStateInv prims) - structuralLoopBetaMeaning ?_ - exact .done (structuralLoopStateInv prims) - (structuralLoopLeafStep prims flags) (structuralLoopStateInv prims) - structuralLoopLeafMeaning +theorem kIotaAttemptStats : + TcM.bumpStats + (fun st : TcState .anon => + { st with kSynthAttempts := st.kSynthAttempts + 1 }) + kIotaAfterIntern = .ok () kIotaAfterIntern := by + exact TcM.bumpStats_disabled rfl _ -/-- Inhabited K1f acceptance: the real bounded driver executes more than one -`.next`, preserves the full invariant, and obtains the end-to-end meaning by -transitive composition rather than by asserting source/result equality. -/ -theorem structuralLoopAcceptance (prims : Primitives .anon) - (flags : WhnfFlags) : - (RecM.whnfCoreWithFlagsUncached structuralLoopSource flags).run - betaHarnessMethods (structuralLoopState prims) = - .ok betaArg (structuralLoopState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood support - 0 structuralLoopCtx (structuralLoopState prims) ∧ - WhnfMeaning RawProjRel.none worldGood 0 structuralLoopCtx - structuralLoopSource betaArg := by - have h := (structuralLoopTrace prims flags).uncached_acceptance - structuralWhnfTheory - exact ⟨h.1, h.2.1, h.2.2.2⟩ +theorem kIotaTypeDefEq : + (RecM.callIsDefEq natRef natRef).run kIotaHarnessMethods + kIotaAfterIntern = .ok true kIotaAfterIntern := by + rfl -/-- Adversarial fuel boundary: the same source at zero fuel throws before -consulting the step function, and therefore cannot have a semantic trace. -/ -theorem structuralLoopZeroFuel (prims : Primitives .anon) - (flags : WhnfFlags) : - (RecM.runBounded - (fun cur => RecM.whnfCoreWithFlagsStep cur flags) 0 - structuralLoopSource).run betaHarnessMethods (structuralLoopState prims) = - .error .maxRecDepth (structuralLoopState prims) ∧ - ¬RecM.WhnfCoreTrace .noAccel whnfSemantics RawProjRel.none worldGood - support 0 structuralLoopCtx betaHarnessMethods flags 0 - structuralLoopSource (structuralLoopState prims) betaArg - (structuralLoopState prims) := - ⟨rfl, RecM.WhnfCoreTrace.no_zero⟩ +def kIotaCandidateTrace : + RecM.VerifyKSynthCandidateSuccessTrace kIotaHarnessMethods natRef zeroId + #[] #[] 0 kIotaState kSynthCtor kIotaAfterIntern where + ctorHead := kSynthCtor + ctorTy := natRef + sCtorHead := kIotaAfterIntern + sCtorApp := kIotaAfterIntern + sCtorTy := kIotaAfterIntern + sAttempt := kIotaAfterIntern + ctorHeadIntern := kIotaIntern + ctorApps := by rfl + ctorInfer := kIotaCtorInfer + attemptStats := kIotaAttemptStats + typeDefEq := kIotaTypeDefEq + +theorem kIotaCandidate : + (RecM.verifyKSynthCandidate natRef zeroId #[] #[] 0).run + kIotaHarnessMethods kIotaState = + .ok (some kSynthCtor) kIotaAfterIntern := + kIotaCandidateTrace.eval + +def kIotaSynthTrace : + RecM.SynthCtorWhenKSuccessTrace kIotaHarnessMethods kMajor iotaId + kIotaInfo #[] kIotaState kSynthCtor kIotaAfterIntern where + majorTy := natRef + majorTyW := natRef + tyHeadId := natId + tyUs := #[] + tyHeadInfo := natRef.info + tyArgs := #[] + recursor := kIotaConcrete + recursorTy := kRecType + indId := natId + ctorId := zeroId + indLvls := 0 + indParams := 0 + indIndices := 0 + indUnsafe := false + indBlock := natId + indMemberIdx := 0 + indTy := natType + ctors := #[zeroId, succId] + sMajorTy := kIotaState + sMajorTyW := kIotaState + sRecursor := kIotaState + sInductive := kIotaState + sIndLookup := kIotaState + levelArity := by decide + majorInfer := kIotaMajorInfer + majorWhnf := kIotaMajorWhnf + majorSpine := by + unfold natRef + rfl + recursorLookup := kIotaGetRec + recursorType := rfl + majorInductive := kIotaMajorInductive + sameInductive := rfl + inductiveLookup := kIotaGetNat + firstCtor := rfl + candidate := kIotaCandidate + +theorem kIotaSynth : + (RecM.synthCtorWhenK kMajor iotaId kIotaInfo #[]).run + kIotaHarnessMethods kIotaState = + .ok (some kSynthCtor) kIotaAfterIntern := + kIotaSynthTrace.eval + +theorem kIotaInternFrame : + InternUpdateFrame kIotaState kIotaAfterIntern := by + rfl -/-! ### K1g outer structural-WHNF cache composition witness -/ +theorem kIotaSynthCleanup : + (RecM.cleanupNatOffsetMajor kSynthCtor).run kIotaHarnessMethods + kIotaAfterIntern = .ok none kIotaAfterIntern := by + have hextract : + extractNatValue kSynthCtor (iotaPrims Primitives.ofAnonAddrs) = some 0 := by + unfold kSynthCtor + rw [KExpr.mkConst_shape] + unfold extractNatValue extractNatLit + simp [iotaPrims] + have heval : + (RecM.evalNatOffsetLiteral kSynthCtor 0).run kIotaHarnessMethods + kIotaAfterIntern = .ok (some 0) kIotaAfterIntern := by + unfold RecM.evalNatOffsetLiteral RecM.evalNatOffsetLiteralFuel + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run RecM.prims kIotaHarnessMethods) _ kIotaAfterIntern = _ + unfold EStateM.bind + rw [show ReaderT.run RecM.prims kIotaHarnessMethods kIotaAfterIntern = + .ok (iotaPrims Primitives.ofAnonAddrs) kIotaAfterIntern from rfl] + simp only + rw [hextract] + rfl + unfold RecM.cleanupNatOffsetMajor + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (RecM.evalNatOffsetLiteral kSynthCtor 0) + kIotaHarnessMethods) _ kIotaAfterIntern = _ + unfold EStateM.bind + rw [heval] + rfl -/-- The outer-cache fixture supports both the beta redex used as its key and -the reduced constant stored as its value. Universal cache validity below -covers either supported source if their addresses happen to collide. -/ -def coreCacheSupport : RunSupport where - expr e := e = betaSource ∨ e = betaArg - exprFinite := ⟨[betaSource, betaArg], by - intro e he - rcases he with rfl | rfl <;> simp⟩ - univ _ := False - univFinite := FiniteSupport.empty +theorem kIotaSynthWhnf (flags : WhnfFlags) : + (if flags.cheapRec then + (RecM.whnfCoreFlagsRec kSynthCtor flags).run kIotaHarnessMethods + kIotaAfterIntern + else (RecM.whnfRec kSynthCtor).run kIotaHarnessMethods + kIotaAfterIntern) = .ok kSynthCtor kIotaAfterIntern := by + cases flags.cheapRec <;> + simp [RecM.whnfCoreFlagsRec, RecM.whnfRec, + kIotaHarnessMethods] <;> rfl -def coreCacheKey : Address × Address := - (betaSource.addr, emptyCtxAddr) +theorem kIotaGetZeroAfter : + TcM.tryGetConst zeroId kIotaAfterIntern = + .ok (some zeroConcrete) kIotaAfterIntern := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ + kIotaAfterIntern = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) kIotaAfterIntern = + .ok kIotaAfterIntern kIotaAfterIntern from rfl] + simp only + have hconsts : kIotaAfterIntern.env.consts = kIotaState.env.consts := by + simpa [InternUpdateFrame] using + congrArg (fun st : TcState .anon => st.env.consts) kIotaInternFrame + have hmajor : kMajorId ≠ zeroId := by + intro h + exact address_ne (a := 16) (b := 11) (by decide) + (congrArg KId.addr h) + have hrec : iotaId ≠ zeroId := by + intro h + exact address_ne (a := 14) (b := 11) (by decide) + (congrArg KId.addr h) + have hinitial : kIotaState.env.get? zeroId = some zeroConcrete := by + simp only [kIotaState, KEnv.get?, KEnv.insert, + Std.HashMap.getElem?_insert] + split + · next h => exact False.elim (hmajor (eq_of_beq h)) + · split + · next h => exact False.elim (hrec (eq_of_beq h)) + · change loadedEnv.get? zeroId = some zeroConcrete + exact loadedEnv_zero_k1e + have hget : + kIotaAfterIntern.env.get? zeroId = kIotaState.env.get? zeroId := by + unfold KEnv.get? + rw [hconsts] + rw [hget, hinitial] + rfl -private theorem betaArg_references {id : KId .anon} - (h : betaArg.References id) : id = zeroId := by - change zeroId = id at h - exact h.symm +theorem kIotaApplyRule : + (RecM.applyIotaRule iotaRule #[] kIotaInfo #[kMajor] #[] 0 false).run + kIotaHarnessMethods kIotaAfterIntern = + .ok iotaResult kIotaAfterIntern := by + unfold RecM.applyIotaRule + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.instantiateUnivParams iotaRule.rhs #[]) _ + kIotaAfterIntern = _ + unfold EStateM.bind + rw [show TcM.instantiateUnivParams iotaRule.rhs #[] kIotaAfterIntern = + .ok iotaResult kIotaAfterIntern from rfl] + rfl -private theorem betaSource_references {id : KId .anon} - (h : betaSource.References id) : id = natId ∨ id = zeroId := by - unfold betaSource betaLam at h - rw [KExpr.mkApp_shape, KExpr.mkLam_shape] at h - change (supportExpr.References id ∨ betaBody.References id) ∨ - betaArg.References id at h - rcases h with (h | h) | h - · change natId = id at h - exact .inl h.symm - · rw [betaBody, KExpr.mkVar_shape] at h - exact False.elim h - · exact .inr (betaArg_references h) +theorem kIotaApplyCtor : + (RecM.tryApplyIotaCtor kIotaInfo #[] #[kMajor] #[] 0 0 false).run + kIotaHarnessMethods kIotaAfterIntern = + .ok (some iotaResult) kIotaAfterIntern := by + exact (RecM.TryApplyIotaCtorSuccessTrace.mk rfl rfl (by decide) + kIotaApplyRule).eval + +/-- Inhabited ConstructorSynthesis path: the arbitrary major is assigned `Nat`, synthesis +selects `Nat.zero`, and the resulting constructor is dispatched by the real +iota helper. The sole state change is constructor interning. -/ +theorem kIotaTryEval (flags : WhnfFlags) : + (RecM.tryIotaWithFlags kIotaSource flags).run kIotaHarnessMethods + kIotaState = .ok (some iotaResult) kIotaAfterIntern := by + apply RecM.tryIotaWithFlags_kCtor + (recId := iotaId) (recUs := #[]) (spine := #[kMajor]) + (recursor := kIotaConcrete) (recr := kIotaInfo) + (major := kMajor) (synthesized := kSynthCtor) + (majorWhnf := kSynthCtor) + (ctorId := zeroId) (ctorUs := #[]) (ctorArgs := #[]) + (ctor := zeroConcrete) (cidx := 0) (ctorFields := 0) + · unfold kIotaSource iotaHead + rw [KExpr.mkApp_shape, KExpr.mkConst_shape] + rfl + · exact kIotaGetRec + · rfl + · decide + · rfl + · rfl + · exact kIotaSynth + · exact kIotaSynthCleanup + · exact kIotaSynthWhnf flags + · unfold kSynthCtor + exact .const + · exact kIotaSynthCleanup + · unfold kSynthCtor + rfl + · exact kIotaGetZeroAfter + · rfl + · exact kIotaApplyCtor -theorem betaArgMeaning : - WhnfMeaning RawProjRel.none worldGood 0 [] betaArg betaArg := by - exact WhnfMeaning.refl betaArg_tr ⟨_, betaArg_type⟩ - -private theorem coreCacheReferencesAuthorized (kind : ExprCacheKind) : - (CacheEntry.expr kind coreCacheKey betaArg).ReferencesAuthorized - (CacheAuthority.stable worldGood) coreCacheSupport := by - intro id href - left - change CacheEntry.SourceReferences coreCacheSupport betaSource.addr id ∨ - betaArg.References id at href - rcases href with href | href - · obtain ⟨e, he, haddr, heref⟩ := href - change e = betaSource ∨ e = betaArg at he - rcases he with rfl | rfl - · rcases betaSource_references heref with rfl | rfl - · exact nat_trusted_good - · exact zero_trusted_good - · have hid := betaArg_references heref - subst id - exact zero_trusted_good - · have hid := betaArg_references href - subst id - exact zero_trusted_good +theorem kIotaStepEval (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsStep kIotaSource flags).run kIotaHarnessMethods + kIotaState = .ok (.next iotaResult) kIotaAfterIntern := by + unfold kIotaSource iotaHead + rw [KExpr.mkApp_shape, KExpr.mkConst_shape] + apply RecM.whnfCoreWithFlagsStep_iota + (recId := iotaId) (us := #[]) + (headInfo := (KExpr.mkConst iotaId #[] ()).info) + (args := #[kMajor]) + · simp [KExpr.collectSpine, KExpr.collectSpine.go] + · rfl + · change Bool.not ((KExpr.mkConst iotaId #[] ()).info.addr == + (KExpr.mkConst iotaId #[] ()).info.addr) = false + rw [beq_self_eq_true] + rfl + · exact kIotaTryEval flags -/-- The validity proof is deliberately collision-robust: both supported -expressions that could inhabit the address key have the required meaning. -/ -private theorem coreCacheWhnfValid (kind : ExprCacheKind) - (hkind : kind = .whnfCore ∨ kind = .whnfCoreCheap) : - WhnfCacheValid whnfContextKeys RawProjRel.none - CacheSemantics.blockErrorsOnly (CacheAuthority.stable worldGood) - coreCacheSupport (.expr kind coreCacheKey betaArg) := by - rcases hkind with rfl | rfl <;> - intro source hsource haddr Δ hctx - all_goals - change source = betaSource ∨ source = betaArg at hsource - rcases hsource with rfl | rfl - · have hΔ : Δ = [] := by - simpa [whnfContextKeys, coreCacheKey] using hctx.2 - subst Δ - exact betaResultMeaning - · have hΔ : Δ = [] := by - simpa [whnfContextKeys, coreCacheKey] using hctx.2 - subst Δ - exact betaArgMeaning +theorem kIotaCoreEval (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsUncached kIotaSource flags).run + kIotaHarnessMethods kIotaState = .ok iotaResult kIotaAfterIntern := by + apply RecM.whnfCoreWithFlagsUncached_nextLeaf + · exact kIotaStepEval flags + · exact .const -theorem fullCoreProvenance : - CacheProvenance whnfSemantics (CacheAuthority.stable worldGood) - coreCacheSupport (.expr .whnfCore coreCacheKey betaArg) := by - refine ⟨?_, ?_, ?_⟩ - · exact ⟨⟨betaSource, .inl rfl, rfl⟩, .inr rfl⟩ - · exact coreCacheReferencesAuthorized .whnfCore - · exact coreCacheWhnfValid .whnfCore (.inl rfl) +/-! ### ConstructorSynthesisFallback inhabited K-synthesis fallback paths -/ -theorem cheapCoreProvenance : - CacheProvenance whnfSemantics (CacheAuthority.stable worldGood) - coreCacheSupport (.expr .whnfCoreCheap coreCacheKey betaArg) := by - refine ⟨?_, ?_, ?_⟩ - · exact ⟨⟨betaSource, .inl rfl, rfl⟩, .inr rfl⟩ - · exact coreCacheReferencesAuthorized .whnfCoreCheap - · exact coreCacheWhnfValid .whnfCoreCheap (.inr rfl) +/-- A callback that mutates recursive fuel and then fails. `inferOnlyRec` +must restore its policy flag, while `tryOptional` must retain the fuel +mutation. -/ +def kInferErrorMethods : Methods .anon := + { kIotaHarnessMethods with + infer := fun _ => do + modify fun s => { s with recFuel := s.recFuel - 1 } + throw .maxRecFuel } -theorem coreCacheFreshStateInv (prims : Primitives .anon) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (noAccelState prims) := by - refine ⟨?_, ?_, rfl⟩ - · apply KernelStateWF.of_no_cache_entries - · exact (stateWF prims).of_env_eq rfl - · constructor - · intro x hx - obtain ⟨a, ha⟩ := hx - simp [noAccelState, state, loadedEnv, KEnv.insert] at ha - · intro x hx - obtain ⟨a, ha⟩ := hx - simp [noAccelState, state, loadedEnv, KEnv.insert] at ha - · intro entry - simpa [noAccelState, state] using loadedEnv_noCacheEntries entry - · apply CtxRecon.empty <;> rfl +def kMajorInferErrorState : TcState .anon := + { kIotaState with recFuel := kIotaState.recFuel - 1 } -def fullCoreWarmState (prims : Primitives .anon) : TcState .anon := - let s := noAccelState prims - {s with env := {s.env with - whnfCoreCache := s.env.whnfCoreCache.insert coreCacheKey betaArg}} +def kCandidateInferErrorState : TcState .anon := + { kIotaAfterIntern with recFuel := kIotaAfterIntern.recFuel - 1 } -def bothCoreWarmState (prims : Primitives .anon) : TcState .anon := - let s := fullCoreWarmState prims - {s with env := {s.env with - whnfCoreCheapCache := s.env.whnfCoreCheapCache.insert coreCacheKey betaArg}} +theorem kMajorInferRawError : + (RecM.inferOnlyRec kMajor).run kInferErrorMethods kIotaState = + .error .maxRecFuel kMajorInferErrorState := by + rfl -theorem fullCoreWarmStateInv (prims : Primitives .anon) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (fullCoreWarmState prims) := by - exact RecM.WhnfCoreCacheUpdate.full_whnfStateInv - (coreCacheFreshStateInv prims) fullCoreProvenance +/-- The first K-synthesis callback error is swallowed, but its consumed fuel +is observable in the final state. -/ +theorem kMajorInferCaughtMiss : + (RecM.synthCtorWhenK kMajor iotaId kIotaInfo #[]).run + kInferErrorMethods kIotaState = .ok none kMajorInferErrorState := + RecM.synthCtorWhenK_majorInferError (by decide) kMajorInferRawError -theorem bothCoreWarmStateInv (prims : Primitives .anon) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (bothCoreWarmState prims) := by - exact RecM.WhnfCoreCacheUpdate.cheap_whnfStateInv - (fullCoreWarmStateInv prims) cheapCoreProvenance +theorem kCandidateInferRawError : + (RecM.inferOnlyRec kSynthCtor).run kInferErrorMethods kIotaAfterIntern = + .error .maxRecFuel kCandidateInferErrorState := by + rfl -theorem coreCacheKey_eval (s : TcState .anon) : - TcM.whnfKey betaSource s = .ok coreCacheKey s := by - simpa [coreCacheKey] using - (TcM.whnfKey_closed (s := s) structuralBetaSource_closed) +/-- Candidate inference fails after constructor interning. The fallback +therefore retains both the intern-table update and the callback's fuel use, +without incrementing either K-synthesis counter. -/ +theorem kCandidateInferCaughtMiss : + (RecM.verifyKSynthCandidate natRef zeroId #[] #[] 0).run + kInferErrorMethods kIotaState = + .ok none kCandidateInferErrorState := by + exact RecM.verifyKSynthCandidate_inferError kIotaIntern (by rfl) + kCandidateInferRawError + +/-- A DefEq callback with the same fuel mutation. This callback is outside +`tryOptional`, so its error must remain an error. -/ +def kDefEqErrorMethods : Methods .anon := + { kIotaHarnessMethods with + isDefEq := fun _ _ => do + modify fun s => { s with recFuel := s.recFuel - 1 } + throw .maxRecFuel } + +def kDefEqErrorState : TcState .anon := + { kIotaAfterIntern with recFuel := kIotaAfterIntern.recFuel - 1 } + +theorem kDefEqRawError : + (RecM.callIsDefEq natRef natRef).run kDefEqErrorMethods + kIotaAfterIntern = .error .maxRecFuel kDefEqErrorState := by + rfl -theorem coreCacheKey_matches (s : TcState .anon) - (hctx : CtxRecon worldGood.venv 0 worldGood.nameOf RawProjRel.none s []) : - whnfContextKeys.Matches RawProjRel.none worldGood s [] betaSource - coreCacheKey := by - refine ⟨hctx, ?_, ⟨s, coreCacheKey_eval s⟩⟩ - simp [whnfContextKeys, coreCacheKey] +theorem kDefEqCandidateError : + (RecM.verifyKSynthCandidate natRef zeroId #[] #[] 0).run + kDefEqErrorMethods kIotaState = + .error .maxRecFuel kDefEqErrorState := by + exact RecM.verifyKSynthCandidate_defEqError kIotaIntern (by rfl) + (by rfl) kIotaAttemptStats kDefEqRawError + +def kDefEqSelectionTrace : + RecM.SynthCtorWhenKSelectionTrace kDefEqErrorMethods kMajor iotaId + kIotaInfo #[] kIotaState where + majorTy := natRef + majorTyW := natRef + tyHeadId := natId + tyUs := #[] + tyHeadInfo := natRef.info + tyArgs := #[] + recursor := kIotaConcrete + recTy := kRecType + indId := natId + sInfer := kIotaState + sWhnf := kIotaState + sRec := kIotaState + sScan := kIotaState + levelArity := by decide + majorInfer := by rfl + majorWhnf := by rfl + majorSpine := by + unfold natRef + rfl + recursorLookup := kIotaGetRec + recursorType := rfl + majorInductive := by + change (RecM.tryOptional (RecM.getMajorInductiveId kRecType 0)).run + kDefEqErrorMethods kIotaState = .ok (some natId) kIotaState + have hzero : (0 : UInt64).toNat = 0 := by decide + have hget : + (RecM.getMajorInductiveId kRecType 0).run + kDefEqErrorMethods kIotaState = .ok natId kIotaState := by + rw [RecM.scratch_getMajorInductiveId_run] + apply RecM.scratch_tryFinally_ok + · rw [hzero] + simp only [RecM.peelMajorForalls, pure_bind] + unfold RecM.scanMajorInductive + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (RecM.whnfRec kRecType) kDefEqErrorMethods) _ + kIotaState = _ + unfold EStateM.bind + rw [show (RecM.whnfRec kRecType).run kDefEqErrorMethods kIotaState = + .ok kRecType kIotaState from rfl] + simp only + change EStateM.bind (TcM.tryGetConst natId) _ kIotaState = _ + unfold EStateM.bind + rw [kIotaGetNat] + rfl + · rfl + exact RecM.tryOptional_success hget + +/-- The same error that candidate verification exposes propagates through +the complete K-synthesis helper; it is not converted to fallback absence. -/ +theorem kDefEqSynthError : + (RecM.synthCtorWhenK kMajor iotaId kIotaInfo #[]).run + kDefEqErrorMethods kIotaState = + .error .maxRecFuel kDefEqErrorState := by + apply kDefEqSelectionTrace.selectedError (by rfl) kIotaGetNat rfl + exact kDefEqCandidateError + +/-- Malformed inductive catalog entry used to inhabit the reachable +empty-constructor fallback after the bounded major scan. -/ +def kEmptyNatConcrete : KConst .anon := + .indc () () 0 0 0 false natId 0 natType #[] () + +def kEmptyInductiveState : TcState .anon := + { kIotaState with env := kIotaState.env.insert natId kEmptyNatConcrete } + +theorem kEmptyGetRec : + TcM.tryGetConst iotaId kEmptyInductiveState = + .ok (some kIotaConcrete) kEmptyInductiveState := by + rw [TcM.tryGetConst_noLazy (by rfl)] + have hnat : natId ≠ iotaId := by + intro h + exact address_ne (a := 10) (b := 14) (by decide) + (congrArg KId.addr h) + have hbase : kIotaState.env.get? iotaId = some kIotaConcrete := by + have h := kIotaGetRec + rw [TcM.tryGetConst_noLazy (by rfl)] at h + exact (EStateM.Result.ok.inj h).1 + have hlookup : + kEmptyInductiveState.env.get? iotaId = kIotaState.env.get? iotaId := by + simp only [kEmptyInductiveState, KEnv.get?, KEnv.insert, + Std.HashMap.getElem?_insert] + split + · next h => exact False.elim (hnat (eq_of_beq h)) + · rfl + rw [hlookup, hbase] + +theorem kEmptyGetNat : + TcM.tryGetConst natId kEmptyInductiveState = + .ok (some kEmptyNatConcrete) kEmptyInductiveState := by + rw [TcM.tryGetConst_noLazy (by rfl)] + simp [kEmptyInductiveState, KEnv.get?, KEnv.insert] + +theorem kEmptyMajorInductive : + (RecM.tryOptional (RecM.getMajorInductiveId kRecType 0)).run + kIotaHarnessMethods kEmptyInductiveState = + .ok (some natId) kEmptyInductiveState := by + have hzero : (0 : UInt64).toNat = 0 := by decide + have hget : + (RecM.getMajorInductiveId kRecType 0).run + kIotaHarnessMethods kEmptyInductiveState = + .ok natId kEmptyInductiveState := by + rw [RecM.scratch_getMajorInductiveId_run] + apply RecM.scratch_tryFinally_ok + · rw [hzero] + simp only [RecM.peelMajorForalls, pure_bind] + unfold RecM.scanMajorInductive + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (RecM.whnfRec kRecType) kIotaHarnessMethods) _ + kEmptyInductiveState = _ + unfold EStateM.bind + rw [show (RecM.whnfRec kRecType).run kIotaHarnessMethods + kEmptyInductiveState = .ok kRecType kEmptyInductiveState from rfl] + simp only + change EStateM.bind (TcM.tryGetConst natId) _ kEmptyInductiveState = _ + unfold EStateM.bind + rw [kEmptyGetNat] + rfl + · rfl + exact RecM.tryOptional_success hget + +def kEmptySelectionTrace : + RecM.SynthCtorWhenKSelectionTrace kIotaHarnessMethods kMajor iotaId + kIotaInfo #[] kEmptyInductiveState where + majorTy := natRef + majorTyW := natRef + tyHeadId := natId + tyUs := #[] + tyHeadInfo := natRef.info + tyArgs := #[] + recursor := kIotaConcrete + recTy := kRecType + indId := natId + sInfer := kEmptyInductiveState + sWhnf := kEmptyInductiveState + sRec := kEmptyInductiveState + sScan := kEmptyInductiveState + levelArity := by decide + majorInfer := by rfl + majorWhnf := by rfl + majorSpine := by + unfold natRef + rfl + recursorLookup := kEmptyGetRec + recursorType := rfl + majorInductive := kEmptyMajorInductive + +/-- A scanned inductive with no constructors reaches the defensive silent +fallback without changing checker state. -/ +theorem kEmptyInductiveMiss : + (RecM.synthCtorWhenK kMajor iotaId kIotaInfo #[]).run + kIotaHarnessMethods kEmptyInductiveState = + .ok none kEmptyInductiveState := by + apply kEmptySelectionTrace.empty (by rfl) + exact kEmptyGetNat + +/-! ### StructEtaControl inhabited struct-eta paths -/ + +/-- A deliberately small non-recursive, one-constructor structure fixture. +The selected rule has one field, so success must intern both a projection and +its application rather than discharging only empty loops. -/ +def structEtaIndAddress : Address := address 17 +def structEtaCtorAddress : Address := address 18 +def structEtaRecAddress : Address := address 19 +def structEtaMajorAddress : Address := address 20 + +def structEtaIndId : KId .anon := ⟨structEtaIndAddress, ()⟩ +def structEtaCtorId : KId .anon := ⟨structEtaCtorAddress, ()⟩ +def structEtaRecId : KId .anon := ⟨structEtaRecAddress, ()⟩ +def structEtaMajorId : KId .anon := ⟨structEtaMajorAddress, ()⟩ + +def structEtaType : KExpr .anon := .sort oneLevel (info structEtaIndAddress) +def structEtaRef : KExpr .anon := + .const structEtaIndId #[] (info structEtaCtorAddress) +def structEtaMajor : KExpr .anon := + .const structEtaMajorId #[] (info structEtaMajorAddress) +def structEtaRhs : KExpr .anon := KExpr.mkConst succId #[] +def structEtaCtorType : KExpr .anon := + .all () () natRef structEtaRef (info structEtaCtorAddress) +def structEtaRecType : KExpr .anon := + .all () () structEtaRef natRef (info structEtaRecAddress) + +def structEtaInductive : KConst .anon := + .indc () () 0 0 0 false structEtaIndId 0 structEtaType + #[structEtaCtorId] () +def structEtaConstructor : KConst .anon := + .ctor () () false 0 structEtaIndId 0 0 1 structEtaCtorType +def structEtaMajorConst : KConst .anon := + .axio () () false 0 structEtaRef +def structEtaRule : RecRule .anon := + { ctor := (), fields := 1, rhs := structEtaRhs } +def structEtaRecursor : KConst .anon := + .recr () () false false 0 0 0 0 0 structEtaIndId 0 structEtaRecType + #[structEtaRule] () +def structEtaInfo : IotaInfo .anon := + { k := false, params := 0, motives := 0, minors := 0, indices := 0, + majorIdx := 0, rules := #[structEtaRule], lvls := 0 } + +/-- The cached `false` recursion result isolates StructEtaControl from the internals of +inductive recursion analysis while still running the real classifier. -/ +def structEtaState : TcState .anon := + let base := noAccelState (iotaPrims Primitives.ofAnonAddrs) + let withRec := { base with + env := base.env.insert structEtaRecId structEtaRecursor } + let withInd := { withRec with + env := withRec.env.insert structEtaIndId structEtaInductive } + let withCtor := { withInd with + env := withInd.env.insert structEtaCtorId structEtaConstructor } + let withMajor := { withCtor with + env := withCtor.env.insert structEtaMajorId structEtaMajorConst } + { withMajor with env := { withMajor.env with + isRecCache := withMajor.env.isRecCache.insert structEtaIndAddress false } } + +/-- Minimal predecessor callbacks for the operational fixture. The two +inference probes return a universe-bearing sort and WHNF is already reached. +This harness is intentionally not claimed to satisfy `Methods.WF`. -/ +def structEtaMethods : Methods .anon where + whnf := fun e => pure e + whnfCore := fun e => pure e + whnfMode := fun e _ => pure e + whnfCoreFlags := fun e _ => pure e + infer := fun _ => pure structEtaType + isDefEq := fun _ _ => pure true + +/-- Inhabited CallbackPrefix infer-only scope: the production callback observes the +enabled flag internally, returns the fixture type, and restores the caller's +flag without changing the remaining state. -/ +theorem structEtaInferOnlyRun : + (RecM.inferOnlyRec structEtaMajor).run structEtaMethods structEtaState = + .ok structEtaType structEtaState := by + rw [RecM.inferOnlyRec_run, TcM.withInferOnly_eq] + rfl -theorem betaTransientFalse (s : TcState .anon) : - (RecM.isTransientNatLiteralWork betaSource).run betaHarnessMethods s = - .ok false s := by - unfold RecM.isTransientNatLiteralWork RecM.isNatLiteralRecursorApp - unfold betaSource betaLam - rw [KExpr.mkApp_shape, KExpr.mkLam_shape] - simp [KExpr.collectSpine, KExpr.collectSpine.go] +/-- The same concrete callback through production's optional catch returns a +present value and retains the exact restored state. -/ +theorem structEtaOptionalInferOnlyRun : + (RecM.tryOptional (RecM.inferOnlyRec structEtaMajor)).run + structEtaMethods structEtaState = + .ok (some structEtaType) structEtaState := + RecM.tryOptional_success structEtaInferOnlyRun + +theorem structEtaGetRecursor : + TcM.tryGetConst structEtaRecId structEtaState = + .ok (some structEtaRecursor) structEtaState := by + rw [TcM.tryGetConst_noLazy (by rfl)] + have hmajor : structEtaMajorId ≠ structEtaRecId := by + intro h + exact address_ne (a := 20) (b := 19) (by decide) + (congrArg KId.addr h) + have hctor : structEtaCtorId ≠ structEtaRecId := by + intro h + exact address_ne (a := 18) (b := 19) (by decide) + (congrArg KId.addr h) + have hind : structEtaIndId ≠ structEtaRecId := by + intro h + exact address_ne (a := 17) (b := 19) (by decide) + (congrArg KId.addr h) + simp only [structEtaState, KEnv.get?, KEnv.insert, + Std.HashMap.getElem?_insert] + split + · next h => exact False.elim (hmajor (eq_of_beq h)) + · split + · next h => exact False.elim (hctor (eq_of_beq h)) + · split + · next h => exact False.elim (hind (eq_of_beq h)) + · simp + +theorem structEtaGetInductive : + TcM.tryGetConst structEtaIndId structEtaState = + .ok (some structEtaInductive) structEtaState := by + rw [TcM.tryGetConst_noLazy (by rfl)] + have hmajor : structEtaMajorId ≠ structEtaIndId := by + intro h + exact address_ne (a := 20) (b := 17) (by decide) + (congrArg KId.addr h) + have hctor : structEtaCtorId ≠ structEtaIndId := by + intro h + exact address_ne (a := 18) (b := 17) (by decide) + (congrArg KId.addr h) + simp only [structEtaState, KEnv.get?, KEnv.insert, + Std.HashMap.getElem?_insert] + split + · next h => exact False.elim (hmajor (eq_of_beq h)) + · split + · next h => exact False.elim (hctor (eq_of_beq h)) + · simp + +theorem structEtaGetMajor : + TcM.tryGetConst structEtaMajorId structEtaState = + .ok (some structEtaMajorConst) structEtaState := by + rw [TcM.tryGetConst_noLazy (by rfl)] + simp [structEtaState, KEnv.get?, KEnv.insert] + +theorem structEtaComputedNotRec (methods : Methods .anon) : + (RecM.computedIsRec structEtaIndId).run methods structEtaState = + .ok false structEtaState := by + have hcache : + structEtaState.env.isRecCache[structEtaIndId.addr]? = some false := by + simp [structEtaState, structEtaIndId] + unfold RecM.computedIsRec + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ structEtaState = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) structEtaState = + .ok structEtaState structEtaState from rfl] + simp only + rw [hcache] rfl -theorem betaWalker_eval_state (s : TcState .anon) : - TcM.runIntern (simulSubst betaBody #[betaArg] 0) s = .ok betaArg s := by - unfold TcM.runIntern - rw [betaWalker_intern] +theorem structEtaClassified (methods : Methods .anon) : + (RecM.isStructLike structEtaIndId).run methods structEtaState = + .ok true structEtaState := by + have h := RecM.isStructLike_shapeQualified structEtaGetInductive + (show ((0 : UInt64) != 0 || (#[structEtaCtorId]).size != 1) = false by + decide) + (structEtaComputedNotRec methods) + simpa using h + +theorem structEtaMajorInductive (methods : Methods .anon) + (hwhnf : (RecM.whnfRec structEtaRecType).run methods structEtaState = + .ok structEtaRecType structEtaState) : + (RecM.tryOptional (RecM.getMajorInductiveId structEtaRecType 0)).run + methods structEtaState = + .ok (some structEtaIndId) structEtaState := by + have hzero : (0 : UInt64).toNat = 0 := by decide + have hget : + (RecM.getMajorInductiveId structEtaRecType 0).run + methods structEtaState = + .ok structEtaIndId structEtaState := by + rw [RecM.scratch_getMajorInductiveId_run] + apply RecM.scratch_tryFinally_ok + · rw [hzero] + simp only [RecM.peelMajorForalls, pure_bind] + unfold RecM.scanMajorInductive + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (RecM.whnfRec structEtaRecType) methods) _ + structEtaState = _ + unfold EStateM.bind + rw [hwhnf] + simp only + change EStateM.bind (TcM.tryGetConst structEtaIndId) _ structEtaState = _ + unfold EStateM.bind + rw [structEtaGetInductive] + rfl + · rfl + exact RecM.tryOptional_success hget + +def structEtaSelectionTrace : + RecM.StructEtaSelectionTrace structEtaMethods structEtaRecId structEtaInfo + #[] #[structEtaMajor] structEtaState where + rule := structEtaRule + recursor := structEtaRecursor + recTy := structEtaRecType + indId := structEtaIndId + sRec := structEtaState + sScan := structEtaState + ruleCount := by decide + levelArity := by decide + selectedRule := rfl + recursorLookup := structEtaGetRecursor + recursorType := rfl + majorInductive := structEtaMajorInductive structEtaMethods (by rfl) + +def structEtaProbeTrace : + RecM.StructEtaProbeTrace structEtaMethods #[] #[structEtaMajor] + structEtaInfo structEtaRule structEtaIndId structEtaState where + majorTy := structEtaType + majorSort := structEtaType + majorSortW := structEtaType + sStruct := structEtaState + sMajorTy := structEtaState + sMajorSort := structEtaState + sMajorSortW := structEtaState + structLike := structEtaClassified structEtaMethods + majorInfer := by rfl + sortInfer := by rfl + sortWhnf := by rfl + +theorem structEtaInstantiate : + TcM.instantiateUnivParams structEtaRule.rhs #[] structEtaState = + .ok structEtaRhs structEtaState := by + rfl -theorem betaStep_state (s : TcState .anon) (flags : WhnfFlags) : - (RecM.whnfCoreWithFlagsStep betaSource flags).run betaHarnessMethods s = - .ok (.next betaArg) s := by - unfold betaSource betaLam - rw [KExpr.mkApp_shape, KExpr.mkLam_shape] - simpa [betaSimulResult] using - (RecM.whnfCoreWithFlagsStep_betaOne - (methods := betaHarnessMethods) (s := s) (flags := flags) - (hhead := rfl) (hwalk := betaWalker_eval_state s)) +/-! #### Rebuild exact finite rebuild witness -/ -theorem coreCacheTrace {s : TcState .anon} - (hI : WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] s) (flags : WhnfFlags) : - RecM.WhnfCoreTrace .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] betaHarnessMethods flags maxWhnfFuel.toNat - betaSource s betaArg s := by - rw [show maxWhnfFuel.toNat = 10000 by rfl] - refine .next hI (betaStep_state s flags) hI betaResultMeaning ?_ - exact .done hI (RecM.whnfCoreWithFlagsStep_leaf .const flags) hI - betaArgMeaning +/-- The one projection requested by the fixture's single struct field. -/ +def structEtaProjection : KExpr .anon := + KExpr.mkPrj structEtaIndId 0 structEtaMajor -theorem coreCacheFresh_fullMiss (prims : Primitives .anon) : - (noAccelState prims).env.whnfCoreCache[coreCacheKey]? = none := by - simp [noAccelState, state, loadedEnv, KEnv.insert, coreCacheKey] +/-- The exact accumulator after applying the selected rule RHS to that +projection. -/ +def structEtaRebuildResult : KExpr .anon := + KExpr.mkApp structEtaRhs structEtaProjection -theorem fullCoreWarm_hit (prims : Primitives .anon) : - (fullCoreWarmState prims).env.whnfCoreCache[coreCacheKey]? = - some betaArg := by - simp [fullCoreWarmState, coreCacheKey] +/-- Both direct intern requests made by the one-field rebuild, in production +order. -/ +def structEtaRebuildRequests : List WalkerRequest := + [.internExpr structEtaProjection, .internExpr structEtaRebuildResult] + +/-- Non-vacuous Rebuild certificate for the actual struct-eta fixture. Empty +prefix and trailing slices leave exactly the projection/application pair. -/ +def structEtaBuildRequests : + RecM.StructEtaBuildRequests structEtaRebuildRequests structEtaIndId + structEtaMajor structEtaRhs 1 #[] #[] structEtaRebuildResult := by + refine { + prefixResult := structEtaRhs + fieldsResult := structEtaRebuildResult + prefixCert := RecM.FinishAppRequests.nil structEtaRhs + fieldCert := ?_ + trailingCert := RecM.FinishAppRequests.nil structEtaRebuildResult } + apply RecM.StructEtaFieldRequests.cons + · simp [structEtaRebuildRequests, structEtaProjection] + · simp [structEtaRebuildRequests, structEtaProjection, + structEtaRebuildResult] + · simpa [structEtaProjection, structEtaRebuildResult] using + (RecM.StructEtaFieldRequests.nil + (requests := structEtaRebuildRequests) + (indId := structEtaIndId) (major := structEtaMajor) + 1 structEtaRebuildResult) + +/-- Inhabited successful StructEtaControl path. The existential post-state is genuine: +the one-field rule performs the production projection and application intern +requests, whose concrete table result is intentionally not assumed +collision-free by this operational fixture. -/ +theorem structEtaIotaSuccess : + ∃ result sf, + ∃ _ : RecM.StructEtaIotaSuccessTrace structEtaMethods structEtaRecId + structEtaInfo #[] #[structEtaMajor] structEtaState result sf, + (RecM.tryStructEtaIota structEtaRecId structEtaInfo #[] + #[structEtaMajor]).run structEtaMethods structEtaState = + .ok (some result) sf := by + obtain ⟨result, sf, hbuild⟩ := + RecM.finishStructEtaResult_total structEtaMethods structEtaState + structEtaIndId structEtaMajor structEtaRhs 1 #[] #[] + let trace : RecM.StructEtaIotaSuccessTrace structEtaMethods structEtaRecId + structEtaInfo #[] #[structEtaMajor] structEtaState result sf := + { selection := structEtaSelectionTrace + probes := structEtaProbeTrace + rhs := structEtaRhs + sInst := structEtaState + admissible := by rfl + instantiation := structEtaInstantiate + rebuild := by simpa using hbuild } + exact ⟨result, sf, trace, trace.eval⟩ + +/-- The final constructor dispatcher genuinely takes its non-constructor +constant fallthrough before the successful struct-eta path. -/ +theorem structEtaDispatchSuccess : + ∃ result sf, + (RecM.tryIotaCtorOrStructEta structEtaRecId structEtaInfo #[] + #[structEtaMajor] structEtaMajor false).run structEtaMethods + structEtaState = .ok (some result) sf := by + obtain ⟨result, sf, _, heta⟩ := structEtaIotaSuccess + refine ⟨result, sf, ?_⟩ + apply RecM.tryIotaCtorOrStructEta_notConstructor + (ctorId := structEtaMajorId) (ctorUs := #[]) (ctorArgs := #[]) + (entry := structEtaMajorConst) + · rfl + · exact structEtaGetMajor + · rfl + · exact heta + +/-- The complementary absent environment stops at the repeated recursor +lookup without mutating checker state. -/ +def structEtaAbsentState : TcState .anon := + let base := noAccelState (iotaPrims Primitives.ofAnonAddrs) + { base with env := { base.env with consts := {} } } + +theorem structEtaRecursorAbsent : + TcM.tryGetConst structEtaRecId structEtaAbsentState = + .ok none structEtaAbsentState := by + rw [TcM.tryGetConst_noLazy (by rfl)] + have henv : structEtaAbsentState.env.get? structEtaRecId = none := by + simp [structEtaAbsentState, KEnv.get?] + rw [henv] -theorem fullCoreWarm_cheapMiss (prims : Primitives .anon) : - (fullCoreWarmState prims).env.whnfCoreCheapCache[coreCacheKey]? = none := by - simp [fullCoreWarmState, noAccelState, state, loadedEnv, KEnv.insert, - coreCacheKey] +theorem structEtaIotaAbsent : + (RecM.tryStructEtaIota structEtaRecId structEtaInfo #[] + #[structEtaMajor]).run structEtaMethods structEtaAbsentState = + .ok none structEtaAbsentState := by + exact RecM.tryStructEtaIota_recursorMissing (by decide) + (by decide) structEtaRecursorAbsent + +/-- A mutating inference failure inhabits the caught-error path: its fuel +consumption remains observable even though struct eta reports absence. -/ +def structEtaInferErrorMethods : Methods .anon := + { structEtaMethods with infer := fun _ => do + modify fun s => { s with recFuel := s.recFuel - 1 } + throw .maxRecFuel } + +def structEtaInferErrorState : TcState .anon := + { structEtaState with recFuel := structEtaState.recFuel - 1 } + +theorem structEtaMajorInferRawError : + (RecM.inferOnlyRec structEtaMajor).run structEtaInferErrorMethods + structEtaState = .error .maxRecFuel structEtaInferErrorState := by + rfl -theorem bothCoreWarm_cheapHit (prims : Primitives .anon) : - (bothCoreWarmState prims).env.whnfCoreCheapCache[coreCacheKey]? = - some betaArg := by - simp [bothCoreWarmState, coreCacheKey] +def structEtaErrorSelectionTrace : + RecM.StructEtaSelectionTrace structEtaInferErrorMethods structEtaRecId + structEtaInfo #[] #[structEtaMajor] structEtaState where + rule := structEtaRule + recursor := structEtaRecursor + recTy := structEtaRecType + indId := structEtaIndId + sRec := structEtaState + sScan := structEtaState + ruleCount := by decide + levelArity := by decide + selectedRule := rfl + recursorLookup := structEtaGetRecursor + recursorType := rfl + majorInductive := structEtaMajorInductive structEtaInferErrorMethods (by rfl) + +theorem structEtaClassifiedWithErrorMethods : + (RecM.isStructLike structEtaIndId).run structEtaInferErrorMethods + structEtaState = .ok true structEtaState := by + exact structEtaClassified structEtaInferErrorMethods + +theorem structEtaIotaCaughtInferError : + (RecM.tryStructEtaIota structEtaRecId structEtaInfo #[] + #[structEtaMajor]).run structEtaInferErrorMethods structEtaState = + .ok none structEtaInferErrorState := by + apply structEtaErrorSelectionTrace.eval + exact RecM.tryStructEtaAfterInductive_majorInferError + structEtaClassifiedWithErrorMethods structEtaMajorInferRawError -/-- First full-policy call: the real outer entry point misses, executes its -certified beta trace, inserts the result, and preserves the invariant. -/ -theorem fullCoreColdAcceptance (prims : Primitives .anon) : - (RecM.whnfCoreWithFlags betaSource .FULL).run betaHarnessMethods - (noAccelState prims) = .ok betaArg (fullCoreWarmState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (noAccelState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (fullCoreWarmState prims) ∧ - WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by - simpa [whnfSemantics, fullCoreWarmState] using - (RecM.whnfCoreWithFlags_fullMiss_acceptance - (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) - structuralWhnfTheory (.direct RecM.WhnfCoreNonLeaf.app) rfl - (coreCacheKey_eval (noAccelState prims)) - (betaTransientFalse (noAccelState prims)) - (coreCacheFresh_fullMiss prims) - (coreCacheTrace (coreCacheFreshStateInv prims) .FULL) - fullCoreProvenance) +/-- Exact execution of the real iota helper on the untrusted recursor-shaped +catalog entry. All parameter/motive/minor/field/trailing loops are empty, +but recursor lookup, major cleanup/WHNF, constructor lookup, and universe +instantiation are the production operations. -/ +theorem iotaTryEval (prims : Primitives .anon) (flags : WhnfFlags) : + (RecM.tryIotaWithFlags iotaSource flags).run betaHarnessMethods + (iotaState prims) = .ok (some iotaResult) (iotaState prims) := by + apply RecM.tryIotaWithFlags_regularCtor + (recId := iotaId) (recUs := #[]) (spine := #[iotaResult]) + (recursor := iotaConcrete) (recr := iotaInfo) + (major := iotaResult) (majorWhnf := iotaResult) + (ctorId := zeroId) (ctorUs := #[]) (ctorArgs := #[]) + (ctor := zeroConcrete) (cidx := 0) (ctorFields := 0) + · unfold iotaSource iotaHead + rw [KExpr.mkApp_shape, KExpr.mkConst_shape] + rfl + · exact iotaGetRec prims + · rfl + · decide + · rfl + · rfl + · exact iotaCleanup prims + · exact iotaMajorWhnf prims flags + · unfold iotaResult + exact .const + · exact iotaCleanup prims + · unfold iotaResult + rfl + · exact iotaGetZero prims + · rfl + · exact iotaApplyCtor prims -/-- Second full-policy call: the inserted entry is consumed as a semantic -hit and the entire checker state remains unchanged. -/ -theorem fullCoreWarmAcceptance (prims : Primitives .anon) : - (RecM.whnfCoreWithFlags betaSource .FULL).run betaHarnessMethods - (fullCoreWarmState prims) = .ok betaArg (fullCoreWarmState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (fullCoreWarmState prims) ∧ - WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by - simpa [whnfSemantics] using - (RecM.whnfCoreWithFlags_fullHit_acceptance - (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) - (.direct RecM.WhnfCoreNonLeaf.app) rfl - (coreCacheKey_eval (fullCoreWarmState prims)) - (betaTransientFalse (fullCoreWarmState prims)) - (fullCoreWarm_hit prims) (fullCoreWarmStateInv prims) (.inl rfl) - (coreCacheKey_matches (fullCoreWarmState prims) - (fullCoreWarmStateInv prims).2.1)) +theorem iotaStepEval (prims : Primitives .anon) (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsStep iotaSource flags).run betaHarnessMethods + (iotaState prims) = .ok (.next iotaResult) (iotaState prims) := by + unfold iotaSource iotaHead + rw [KExpr.mkApp_shape, KExpr.mkConst_shape] + apply RecM.whnfCoreWithFlagsStep_iota + (recId := iotaId) (us := #[]) + (headInfo := (KExpr.mkConst iotaId #[] ()).info) + (args := #[iotaResult]) + · simp [KExpr.collectSpine, KExpr.collectSpine.go] + · rfl + · change Bool.not ((KExpr.mkConst iotaId #[] ()).info.addr == + (KExpr.mkConst iotaId #[] ()).info.addr) = false + rw [beq_self_eq_true] + rfl + · exact iotaTryEval prims flags + +theorem iotaCoreEval (prims : Primitives .anon) (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsUncached iotaSource flags).run + betaHarnessMethods (iotaState prims) = + .ok iotaResult (iotaState prims) := by + apply RecM.whnfCoreWithFlagsUncached_nextLeaf + · exact iotaStepEval prims flags + · exact .const + +theorem nameOf_iota_none : nameOf iotaAddress = none := by + rfl + +theorem iotaHead_not_translated : + ¬∃ headV, + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + iotaHead headV := by + rintro ⟨headV, hhead⟩ + unfold iotaHead at hhead + rw [KExpr.mkConst_shape] at hhead + cases hhead with + | const hname _ _ _ => + change nameOf iotaAddress = some _ at hname + rw [nameOf_iota_none] at hname + contradiction + +theorem iotaSource_not_translated : + ¬∃ sourceV, + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + iotaSource sourceV := by + rintro ⟨sourceV, hsource⟩ + unfold iotaSource at hsource + rw [KExpr.mkApp_shape] at hsource + cases hsource with + | app _ _ hhead _ => exact iotaHead_not_translated ⟨_, hhead⟩ + +theorem iotaAdversarialWitness (prims : Primitives .anon) + (flags : WhnfFlags) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support + 0 [] (iotaState prims) ∧ + (RecM.whnfCoreWithFlagsUncached iotaSource flags).run + betaHarnessMethods (iotaState prims) = + .ok iotaResult (iotaState prims) ∧ + ¬∃ sourceV, + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + iotaSource sourceV := + ⟨iotaStateInv prims, iotaCoreEval prims flags, + iotaSource_not_translated⟩ + +/-! ### structural trace structural-loop composition witness -/ + +/-- Literal closure for this finite ambient world. Nat literals are typed by +the installed `Nat.zero`/`Nat.succ` constants; String literal support is +provably absent. -/ +theorem structuralNatLit_type (n : Nat) : + worldGood.venv.HasType 0 [] (VExpr.natLit n) (.const natName []) := by + induction n with + | zero => + simpa [VExpr.natLit, VExpr.natZero, zeroName] using betaArg_type + | succ n ih => + have hsucc : worldGood.venv.HasType 0 [] (.const succName []) + (.forallE (.const natName []) (.const natName [])) := by + exact Lean4Lean.VEnv.HasType.const (env := worldGood.venv) + (U := 0) (Γ := []) (ci := succConstant) (ls := []) + (by simpa [worldGood, goodEnv, goodName, succName] using natEnv_succ) + (by intro l hl; simp at hl) rfl + simpa [VExpr.natLit, VExpr.natSucc, succName] using + Lean4Lean.VEnv.HasType.app hsucc ih + +/-- The finite Nat world supplies the uniform literal/projection facts needed +to compose arbitrary structural trace meanings. -/ +def structuralWhnfTheory : WhnfTheory RawProjRel.none worldGood 0 where + literalWF := by + intro literal hliteral + cases literal with + | natVal n => exact ⟨_, structuralNatLit_type n⟩ + | strVal value => + simp [Lean4Lean.VEnv.ContainsLits, Lean4Lean.VEnv.contains, + worldGood, goodEnv, natEnv, natEnv₂, natEnv₁, goodName, + natName, zeroName, succName] at hliteral + projections := RawProjRel.none_ok worldGood.venv 0 + +/-- Translation of the closed beta redex, used as the value stored in the +let-bound fvar below. -/ +theorem structuralBetaSource_tr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + betaSource + (.app (.lam (.const natName []) (.bvar 0)) (.const zeroName [])) := by + rw [betaSource, betaLam, KExpr.mkApp_shape, KExpr.mkLam_shape] + exact .app (Lean4Lean.VEnv.HasType.lam betaA_type betaBody_type) + betaArg_type (.lam ⟨_, betaA_type⟩ betaTy_tr betaBody_tr) betaArg_tr + +theorem structuralBetaSource_type : + worldGood.venv.HasType 0 [] + (.app (.lam (.const natName []) (.bvar 0)) (.const zeroName [])) + (.const natName []) := by + simpa using Lean4Lean.VEnv.HasType.app + (Lean4Lean.VEnv.HasType.lam betaA_type betaBody_type) betaArg_type + +theorem structuralBetaSource_constructed : KExpr.Constructed betaSource := by + unfold betaSource betaLam betaBody + exact .app (.lam supportExpr_constructed (.var (by decide))) + betaArg_constructed + +theorem structuralBetaSource_closed : betaSource.lbr = 0 := by + rfl + +/-- A let-bound fvar whose value is itself the beta redex. Production must +therefore take two `.next` transitions before reaching the constant leaf. -/ +def structuralLoopSource : KExpr .anon := KExpr.mkFVar fvarZetaId () + +def structuralLoopCtx : KVLCtx := + [(some (fvarZetaId, []), + .vlet (.const natName []) + (.app (.lam (.const natName []) (.bvar 0)) (.const zeroName [])))] + +def structuralLoopState (prims : Primitives .anon) : TcState .anon := + let base := noAccelState prims + { base with + env := { base.env with nextFVarId := 1 } + lctx := base.lctx.push fvarZetaId + (.ldecl () supportExpr betaSource) } + +theorem structuralLoopFind (prims : Primitives .anon) : + (structuralLoopState prims).lctx.find? fvarZetaId = + some (.ldecl () supportExpr betaSource) := by + simp [structuralLoopState, noAccelState, LocalContext.find?, + LocalContext.push, fvarZetaId] + +theorem structuralLoopCtxRecon (prims : Primitives .anon) : + CtxRecon worldGood.venv 0 worldGood.nameOf RawProjRel.none + (structuralLoopState prims) structuralLoopCtx := by + refine { + size_eq := rfl + recon := ?_ + lwf := ?_ + incr := by + simp [structuralLoopState, noAccelState, state, LocalContext.push] + fresh := ?_ + lets := rfl } + · have hrec : + CtxRecon' worldGood.venv 0 worldGood.nameOf RawProjRel.none + [] [(fvarZetaId, .ldecl () supportExpr betaSource)] + structuralLoopCtx := + .fvar .nil + (.vlet betaTy_tr structuralBetaSource_tr structuralBetaSource_type) + (by simp) + simpa [structuralLoopState, noAccelState, LocalContext.push] using hrec + · apply LocalContext.WF.push .empty + simp [fvarZetaId] + · intro p hp + simp [structuralLoopState, noAccelState, state, LocalContext.push] at hp + subst p + simp [structuralLoopState, fvarZetaId] + +theorem structuralLoopStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support + 0 structuralLoopCtx (structuralLoopState prims) := by + have hbase := noAccelStateInv prims + refine ⟨?_, structuralLoopCtxRecon prims, rfl⟩ + refine ⟨?_, ?_, ?_, ?_⟩ + · exact hbase.1.core.of_consts_eq (by rfl) (by + simpa [structuralLoopState] using hbase.1.core.intern) + · simpa [structuralLoopState] using hbase.1.internSupport + · intro entry hentry + apply hbase.1.caches + cases hentry <;> (constructor; assumption) + · simpa [structuralLoopState] using hbase.1.equivalences + +/-- First local meaning: fvar zeta exposes the closed beta redex. -/ +theorem structuralLoopSourceMeaning (prims : Primitives .anon) : + WhnfMeaning RawProjRel.none worldGood 0 structuralLoopCtx + structuralLoopSource betaSource := by + unfold structuralLoopSource + rw [KExpr.mkFVar_shape] + apply WhnfMeaning.zetaFVar (structuralLoopCtxRecon prims) + (RawProjRel.none_ok worldGood.venv 0) + (structuralLoopFind prims) structuralBetaSource_constructed + structuralBetaSource_closed + decide + +theorem structuralLoopTy_tr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none + structuralLoopCtx supportExpr (.const natName []) := by + rw [supportExpr_eq_mkConst, KExpr.mkConst_shape] + exact .const (ci := natConstant) nameOf_nat + (by simpa [worldGood, goodEnv, goodName, natName] using natEnv_nat) + (by intro l hl; simp at hl) rfl + +theorem structuralLoopBody_tr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none + ((none, .vlam (.const natName [])) :: structuralLoopCtx) + betaBody (.bvar 0) := by + rw [betaBody, KExpr.mkVar_shape] + exact .var rfl + +theorem structuralLoopArg_tr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none + structuralLoopCtx betaArg (.const zeroName []) := by + rw [betaArg, KExpr.mkConst_shape] + exact .const (ci := zeroConstant) nameOf_zero + (by simpa [worldGood, goodEnv, goodName, zeroName] using natEnv_zero) + (by intro l hl; simp at hl) rfl + +theorem structuralLoopA_type : + worldGood.venv.HasType 0 structuralLoopCtx.toCtx (.const natName []) + (.sort (.succ .zero)) := by + simpa [structuralLoopCtx] using betaA_type + +theorem structuralLoopBody_type : + worldGood.venv.HasType 0 + ((.const natName []) :: structuralLoopCtx.toCtx) (.bvar 0) + (.const natName []) := by + simpa [structuralLoopCtx] using betaBody_type + +theorem structuralLoopArg_type : + worldGood.venv.HasType 0 structuralLoopCtx.toCtx (.const zeroName []) + (.const natName []) := by + simpa [structuralLoopCtx] using betaArg_type + +/-- Second local meaning: beta reduces the exposed identity application to +`Nat.zero` in the same mixed context. -/ +theorem structuralLoopBetaMeaning : + WhnfMeaning RawProjRel.none worldGood 0 structuralLoopCtx + betaSource betaArg := by + rw [← betaSimulResult] + unfold betaSource betaLam + rw [KExpr.mkApp_shape, KExpr.mkLam_shape] + apply WhnfMeaning.betaSimul + · apply WhnfMeaning.beta (RawProjRel.none_ok worldGood.venv 0) + structuralLoopTy_tr structuralLoopBody_tr structuralLoopArg_tr + structuralLoopA_type structuralLoopBody_type structuralLoopArg_type + decide + · exact betaSimulSpec + +theorem structuralLoopLeafMeaning : + WhnfMeaning RawProjRel.none worldGood 0 structuralLoopCtx + betaArg betaArg := by + apply WhnfMeaning.refl structuralLoopArg_tr + exact ⟨_, structuralLoopArg_type⟩ + +theorem structuralLoopFVarStep (prims : Primitives .anon) + (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsStep structuralLoopSource flags).run + betaHarnessMethods (structuralLoopState prims) = + .ok (.next betaSource) (structuralLoopState prims) := by + unfold structuralLoopSource + rw [KExpr.mkFVar_shape] + exact RecM.whnfCoreWithFlagsStep_fvarZeta (structuralLoopFind prims) + +theorem structuralLoopWalkerEval (prims : Primitives .anon) : + TcM.runIntern (simulSubst betaBody #[betaArg] 0) + (structuralLoopState prims) = + .ok betaArg (structuralLoopState prims) := by + unfold TcM.runIntern + rw [betaWalker_intern] + +theorem structuralLoopBetaStep (prims : Primitives .anon) + (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsStep betaSource flags).run betaHarnessMethods + (structuralLoopState prims) = + .ok (.next betaArg) (structuralLoopState prims) := by + unfold betaSource betaLam + rw [KExpr.mkApp_shape, KExpr.mkLam_shape] + simpa [betaSimulResult] using + (RecM.whnfCoreWithFlagsStep_betaOne + (methods := betaHarnessMethods) (s := structuralLoopState prims) + (flags := flags) (hhead := rfl) + (hwalk := structuralLoopWalkerEval prims)) + +theorem structuralLoopLeafStep (prims : Primitives .anon) + (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsStep betaArg flags).run betaHarnessMethods + (structuralLoopState prims) = + .ok (.done betaArg) (structuralLoopState prims) := + RecM.whnfCoreWithFlagsStep_leaf .const flags + +/-- Three exact iterations at production fuel: fvar-zeta, beta, then leaf. +The trace carries the same fixed world/context invariant throughout. -/ +theorem structuralLoopTrace (prims : Primitives .anon) + (flags : WhnfFlags) : + RecM.WhnfCoreTrace .structuralNoAccel whnfSemantics RawProjRel.none worldGood + support 0 structuralLoopCtx betaHarnessMethods flags maxWhnfFuel.toNat + structuralLoopSource (structuralLoopState prims) betaArg + (structuralLoopState prims) := by + rw [show maxWhnfFuel.toNat = 10000 by rfl] + refine .next (structuralLoopStateInv prims) + (structuralLoopFVarStep prims flags) (structuralLoopStateInv prims) + (structuralLoopSourceMeaning prims) ?_ + refine .next (structuralLoopStateInv prims) + (structuralLoopBetaStep prims flags) (structuralLoopStateInv prims) + structuralLoopBetaMeaning ?_ + exact .done (structuralLoopStateInv prims) + (structuralLoopLeafStep prims flags) (structuralLoopStateInv prims) + structuralLoopLeafMeaning + +/-- Inhabited structural trace acceptance: the real bounded driver executes more than one +`.next`, preserves the full invariant, and obtains the end-to-end meaning by +transitive composition rather than by asserting source/result equality. -/ +theorem structuralLoopAcceptance (prims : Primitives .anon) + (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsUncached structuralLoopSource flags).run + betaHarnessMethods (structuralLoopState prims) = + .ok betaArg (structuralLoopState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood support + 0 structuralLoopCtx (structuralLoopState prims) ∧ + WhnfMeaning RawProjRel.none worldGood 0 structuralLoopCtx + structuralLoopSource betaArg := by + have h := (structuralLoopTrace prims flags).uncached_acceptance + structuralWhnfTheory + exact ⟨h.1, h.2.1, h.2.2.2⟩ + +/-- Adversarial fuel boundary: the same source at zero fuel throws before +consulting the step function, and therefore cannot have a semantic trace. -/ +theorem structuralLoopZeroFuel (prims : Primitives .anon) + (flags : WhnfFlags) : + (RecM.runBounded + (fun cur => RecM.whnfCoreWithFlagsStep cur flags) 0 + structuralLoopSource).run betaHarnessMethods (structuralLoopState prims) = + .error .maxRecDepth (structuralLoopState prims) ∧ + ¬RecM.WhnfCoreTrace .structuralNoAccel whnfSemantics RawProjRel.none worldGood + support 0 structuralLoopCtx betaHarnessMethods flags 0 + structuralLoopSource (structuralLoopState prims) betaArg + (structuralLoopState prims) := + ⟨rfl, RecM.WhnfCoreTrace.no_zero⟩ + +/-! ### structural cache outer structural-WHNF cache composition witness -/ + +/-- The outer-cache fixture supports both the beta redex used as its key and +the reduced constant stored as its value. Universal cache validity below +covers either supported source if their addresses happen to collide. -/ +def coreCacheSupport : RunSupport where + expr e := e = betaSource ∨ e = betaArg + exprFinite := ⟨[betaSource, betaArg], by + intro e he + rcases he with rfl | rfl <;> simp⟩ + univ _ := False + univFinite := FiniteSupport.empty + +def coreCacheKey : Address × Address := + (betaSource.addr, emptyCtxAddr) + +private theorem betaArg_references {id : KId .anon} + (h : betaArg.References id) : id = zeroId := by + change zeroId = id at h + exact h.symm + +private theorem betaSource_references {id : KId .anon} + (h : betaSource.References id) : id = natId ∨ id = zeroId := by + unfold betaSource betaLam at h + rw [KExpr.mkApp_shape, KExpr.mkLam_shape] at h + change (supportExpr.References id ∨ betaBody.References id) ∨ + betaArg.References id at h + rcases h with (h | h) | h + · change natId = id at h + exact .inl h.symm + · rw [betaBody, KExpr.mkVar_shape] at h + exact False.elim h + · exact .inr (betaArg_references h) + +theorem betaArgMeaning : + WhnfMeaning RawProjRel.none worldGood 0 [] betaArg betaArg := by + exact WhnfMeaning.refl betaArg_tr ⟨_, betaArg_type⟩ + +private theorem coreCacheReferencesAuthorized (kind : ExprCacheKind) : + (CacheEntry.expr kind coreCacheKey betaArg).ReferencesAuthorized + (CacheAuthority.stable worldGood) coreCacheSupport := by + intro id href + left + change CacheEntry.SourceReferences coreCacheSupport betaSource.addr id ∨ + betaArg.References id at href + rcases href with href | href + · obtain ⟨e, he, haddr, heref⟩ := href + change e = betaSource ∨ e = betaArg at he + rcases he with rfl | rfl + · rcases betaSource_references heref with rfl | rfl + · exact nat_trusted_good + · exact zero_trusted_good + · have hid := betaArg_references heref + subst id + exact zero_trusted_good + · have hid := betaArg_references href + subst id + exact zero_trusted_good + +/-- The validity proof is deliberately collision-robust: both supported +expressions that could inhabit the address key have the required meaning. -/ +private theorem coreCacheWhnfValid (kind : ExprCacheKind) + (hkind : kind = .whnfCore ∨ kind = .whnfCoreCheap) : + WhnfCacheValid whnfContextKeys RawProjRel.none + CacheSemantics.blockErrorsOnly (CacheAuthority.stable worldGood) + coreCacheSupport (.expr kind coreCacheKey betaArg) := by + rcases hkind with rfl | rfl <;> + intro source hsource haddr Δ hctx + all_goals + change source = betaSource ∨ source = betaArg at hsource + rcases hsource with rfl | rfl + · have hΔ : Δ = [] := by + simpa [whnfContextKeys, coreCacheKey] using hctx.2 + subst Δ + exact betaResultMeaning + · have hΔ : Δ = [] := by + simpa [whnfContextKeys, coreCacheKey] using hctx.2 + subst Δ + exact betaArgMeaning + +theorem fullCoreProvenance : + CacheProvenance whnfSemantics (CacheAuthority.stable worldGood) + coreCacheSupport (.expr .whnfCore coreCacheKey betaArg) := by + refine ⟨?_, ?_, ?_⟩ + · exact ⟨⟨betaSource, .inl rfl, rfl⟩, .inr rfl⟩ + · exact coreCacheReferencesAuthorized .whnfCore + · exact coreCacheWhnfValid .whnfCore (.inl rfl) + +theorem cheapCoreProvenance : + CacheProvenance whnfSemantics (CacheAuthority.stable worldGood) + coreCacheSupport (.expr .whnfCoreCheap coreCacheKey betaArg) := by + refine ⟨?_, ?_, ?_⟩ + · exact ⟨⟨betaSource, .inl rfl, rfl⟩, .inr rfl⟩ + · exact coreCacheReferencesAuthorized .whnfCoreCheap + · exact coreCacheWhnfValid .whnfCoreCheap (.inr rfl) + +theorem coreCacheFreshStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (noAccelState prims) := by + refine ⟨?_, ?_, rfl⟩ + · apply KernelStateWF.of_no_cache_entries + · exact (stateWF prims).of_env_eq rfl + · constructor + · intro x hx + obtain ⟨a, ha⟩ := hx + simp [noAccelState, state, loadedEnv, KEnv.insert] at ha + · intro x hx + obtain ⟨a, ha⟩ := hx + simp [noAccelState, state, loadedEnv, KEnv.insert] at ha + · rfl + · intro entry + simpa [noAccelState, state] using loadedEnv_noCacheEntries entry + · apply CtxRecon.empty <;> rfl + +def fullCoreWarmState (prims : Primitives .anon) : TcState .anon := + let s := noAccelState prims + {s with env := {s.env with + whnfCoreCache := s.env.whnfCoreCache.insert coreCacheKey betaArg}} + +def bothCoreWarmState (prims : Primitives .anon) : TcState .anon := + let s := fullCoreWarmState prims + {s with env := {s.env with + whnfCoreCheapCache := s.env.whnfCoreCheapCache.insert coreCacheKey betaArg}} + +theorem fullCoreWarmStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (fullCoreWarmState prims) := by + exact RecM.WhnfCoreCacheUpdate.full_whnfStateInv + (coreCacheFreshStateInv prims) fullCoreProvenance + +theorem bothCoreWarmStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (bothCoreWarmState prims) := by + exact RecM.WhnfCoreCacheUpdate.cheap_whnfStateInv + (fullCoreWarmStateInv prims) cheapCoreProvenance + +theorem coreCacheKey_eval (s : TcState .anon) : + TcM.whnfKey betaSource s = .ok coreCacheKey s := by + simpa [coreCacheKey] using + (TcM.whnfKey_closed (s := s) structuralBetaSource_closed) + +theorem coreCacheKey_matches (s : TcState .anon) + (hctx : CtxRecon worldGood.venv 0 worldGood.nameOf RawProjRel.none s []) : + whnfContextKeys.Matches RawProjRel.none worldGood s [] betaSource + coreCacheKey := by + refine ⟨hctx, ?_, ⟨s, coreCacheKey_eval s⟩⟩ + simp [whnfContextKeys, coreCacheKey, structuralBetaSource_closed] + +theorem betaTransientFalse (s : TcState .anon) : + (RecM.isTransientNatLiteralWork betaSource).run betaHarnessMethods s = + .ok false s := by + unfold RecM.isTransientNatLiteralWork RecM.isNatLiteralRecursorApp + unfold betaSource betaLam + rw [KExpr.mkApp_shape, KExpr.mkLam_shape] + simp [KExpr.collectSpine, KExpr.collectSpine.go] + +theorem betaWalker_eval_state (s : TcState .anon) : + TcM.runIntern (simulSubst betaBody #[betaArg] 0) s = .ok betaArg s := by + unfold TcM.runIntern + rw [betaWalker_intern] + +theorem betaStep_state (s : TcState .anon) (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsStep betaSource flags).run betaHarnessMethods s = + .ok (.next betaArg) s := by + unfold betaSource betaLam + rw [KExpr.mkApp_shape, KExpr.mkLam_shape] + simpa [betaSimulResult] using + (RecM.whnfCoreWithFlagsStep_betaOne + (methods := betaHarnessMethods) (s := s) (flags := flags) + (hhead := rfl) (hwalk := betaWalker_eval_state s)) + +theorem coreCacheTrace {s : TcState .anon} + (hI : WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] s) (flags : WhnfFlags) : + RecM.WhnfCoreTrace .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] betaHarnessMethods flags maxWhnfFuel.toNat + betaSource s betaArg s := by + rw [show maxWhnfFuel.toNat = 10000 by rfl] + refine .next hI (betaStep_state s flags) hI betaResultMeaning ?_ + exact .done hI (RecM.whnfCoreWithFlagsStep_leaf .const flags) hI + betaArgMeaning + +theorem coreCacheFresh_fullMiss (prims : Primitives .anon) : + (noAccelState prims).env.whnfCoreCache[coreCacheKey]? = none := by + simp [noAccelState, state, loadedEnv, KEnv.insert, coreCacheKey] + +theorem fullCoreWarm_hit (prims : Primitives .anon) : + (fullCoreWarmState prims).env.whnfCoreCache[coreCacheKey]? = + some betaArg := by + simp [fullCoreWarmState, coreCacheKey] + +theorem fullCoreWarm_cheapMiss (prims : Primitives .anon) : + (fullCoreWarmState prims).env.whnfCoreCheapCache[coreCacheKey]? = none := by + simp [fullCoreWarmState, noAccelState, state, loadedEnv, KEnv.insert, + coreCacheKey] + +theorem bothCoreWarm_cheapHit (prims : Primitives .anon) : + (bothCoreWarmState prims).env.whnfCoreCheapCache[coreCacheKey]? = + some betaArg := by + simp [bothCoreWarmState, coreCacheKey] + +/-- First full-policy call: the real outer entry point misses, executes its +certified beta trace, inserts the result, and preserves the invariant. -/ +theorem fullCoreColdAcceptance (prims : Primitives .anon) : + (RecM.whnfCoreWithFlags betaSource .FULL).run betaHarnessMethods + (noAccelState prims) = .ok betaArg (fullCoreWarmState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (noAccelState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (fullCoreWarmState prims) ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by + simpa [whnfSemantics, fullCoreWarmState] using + (RecM.whnfCoreWithFlags_fullMiss_acceptance + (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) + structuralWhnfTheory (.direct RecM.WhnfCoreNonLeaf.app) rfl + (coreCacheKey_eval (noAccelState prims)) + (betaTransientFalse (noAccelState prims)) + (coreCacheFresh_fullMiss prims) + (coreCacheTrace (coreCacheFreshStateInv prims) .FULL) + fullCoreProvenance) + +/-- Second full-policy call: the inserted entry is consumed as a semantic +hit and the entire checker state remains unchanged. -/ +theorem fullCoreWarmAcceptance (prims : Primitives .anon) : + (RecM.whnfCoreWithFlags betaSource .FULL).run betaHarnessMethods + (fullCoreWarmState prims) = .ok betaArg (fullCoreWarmState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (fullCoreWarmState prims) ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by + simpa [whnfSemantics] using + (RecM.whnfCoreWithFlags_fullHit_acceptance + (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) + (.direct RecM.WhnfCoreNonLeaf.app) rfl + (coreCacheKey_eval (fullCoreWarmState prims)) + (betaTransientFalse (fullCoreWarmState prims)) + (fullCoreWarm_hit prims) (fullCoreWarmStateInv prims) (.inl rfl) + (coreCacheKey_matches (fullCoreWarmState prims) + (fullCoreWarmStateInv prims).2.1)) /-- A full-policy entry is intentionally invisible to the cheap policy. The cheap call therefore runs its own trace and inserts into only its partition. -/ theorem cheapCorePolicyMissAcceptance (prims : Primitives .anon) : (RecM.whnfCoreWithFlags betaSource .DEF_EQ_CORE).run betaHarnessMethods (fullCoreWarmState prims) = .ok betaArg (bothCoreWarmState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (fullCoreWarmState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (bothCoreWarmState prims) ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by + simpa [whnfSemantics, bothCoreWarmState] using + (RecM.whnfCoreWithFlags_cheapMiss_acceptance + (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) + structuralWhnfTheory (.direct RecM.WhnfCoreNonLeaf.app) rfl + (coreCacheKey_eval (fullCoreWarmState prims)) + (betaTransientFalse (fullCoreWarmState prims)) + (fullCoreWarm_cheapMiss prims) + (coreCacheTrace (fullCoreWarmStateInv prims) .DEF_EQ_CORE) + cheapCoreProvenance) + +/-- Once the cheap partition is populated, its next call is also a +state-preserving semantic hit. -/ +theorem cheapCoreWarmAcceptance (prims : Primitives .anon) : + (RecM.whnfCoreWithFlags betaSource .DEF_EQ_CORE).run betaHarnessMethods + (bothCoreWarmState prims) = .ok betaArg (bothCoreWarmState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (bothCoreWarmState prims) ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by + simpa [whnfSemantics] using + (RecM.whnfCoreWithFlags_cheapHit_acceptance + (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) + (.direct RecM.WhnfCoreNonLeaf.app) rfl + (coreCacheKey_eval (bothCoreWarmState prims)) + (betaTransientFalse (bothCoreWarmState prims)) + (bothCoreWarm_cheapHit prims) (bothCoreWarmStateInv prims) (.inl rfl) + (coreCacheKey_matches (bothCoreWarmState prims) + (bothCoreWarmStateInv prims).2.1)) + +/-- Direct adversarial observation of the flag partition after only the full +call has warmed its map. -/ +theorem coreCachePolicyIsolation (prims : Primitives .anon) : + (fullCoreWarmState prims).env.whnfCoreCache[coreCacheKey]? = + some betaArg ∧ + (fullCoreWarmState prims).env.whnfCoreCheapCache[coreCacheKey]? = none := + ⟨fullCoreWarm_hit prims, fullCoreWarm_cheapMiss prims⟩ + +/-! ### outer WHNF driver no-delta/full-WHNF driver witness -/ + +theorem betaNoDeltaProjNone (prims : Primitives .anon) : + (RecM.tryProjAppReduce betaArg .FULL).run betaHarnessMethods + (fullCoreWarmState prims) = .ok none (fullCoreWarmState prims) := by + unfold RecM.tryProjAppReduce betaArg + rw [KExpr.mkConst_shape] + rfl + +theorem betaNoDeltaNatNone (prims : Primitives .anon) : + (RecM.tryReduceNatWithSuccMode betaArg .collapse).run betaHarnessMethods + (fullCoreWarmState prims) = .ok none (fullCoreWarmState prims) := by + unfold RecM.tryReduceNatWithSuccMode betaArg + rw [KExpr.mkConst_shape] + simp [KExpr.collectSpine, KExpr.collectSpine.go, RecM.prims] + rfl + +theorem betaNoDeltaStringNone (prims : Primitives .anon) : + (RecM.tryReduceString betaArg).run betaHarnessMethods + (fullCoreWarmState prims) = .ok none (fullCoreWarmState prims) := by + unfold RecM.tryReduceString betaArg + rw [KExpr.mkConst_shape] + rfl + +theorem fullCoreWarm_getZero (prims : Primitives .anon) : + TcM.tryGetConst zeroId (fullCoreWarmState prims) = + .ok (some zeroConcrete) (fullCoreWarmState prims) := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ + (fullCoreWarmState prims) = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) (fullCoreWarmState prims) = + .ok (fullCoreWarmState prims) (fullCoreWarmState prims) from rfl] + simp only + have henv : (fullCoreWarmState prims).env.get? zeroId = + some zeroConcrete := by + simpa [fullCoreWarmState, noAccelState, state] using loadedEnv_zero_k1e + rw [henv] + rfl + +theorem betaNoDeltaProjectionDefNone (prims : Primitives .anon) : + (RecM.tryReduceProjectionDefinition betaArg).run betaHarnessMethods + (fullCoreWarmState prims) = .ok none (fullCoreWarmState prims) := by + unfold RecM.tryReduceProjectionDefinition betaArg + rw [KExpr.mkConst_shape] + simp only [KExpr.collectSpine, KExpr.collectSpine.go] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.tryGetConst zeroId) _ (fullCoreWarmState prims) = _ + unfold EStateM.bind + rw [fullCoreWarm_getZero prims] + rfl + +theorem betaNoDeltaQuotNone (prims : Primitives .anon) : + (RecM.tryQuotReduce betaArg).run betaHarnessMethods + (fullCoreWarmState prims) = .ok none (fullCoreWarmState prims) := by + unfold RecM.tryQuotReduce betaArg + rw [KExpr.mkConst_shape] + simp [KExpr.collectSpine, KExpr.collectSpine.go, RecM.prims] + rfl + +/-- The no-delta driver consumes the already certified structural cache hit, +then checks every remaining reducer in production order before terminating. -/ +theorem betaNoDeltaStep (prims : Primitives .anon) : + (RecM.whnfNoDeltaImplStep .FULL .collapse betaSource).run + betaHarnessMethods (fullCoreWarmState prims) = + .ok (.done betaArg) (fullCoreWarmState prims) := by + apply RecM.whnfNoDeltaImplStep_ofCore (fullCoreWarmAcceptance prims).1 + apply RecM.whnfNoDeltaReducersStep_doneFull + · exact RecM.tryProjAppReduceFinished_none (betaNoDeltaProjNone prims) + · exact RecM.tryReduceBitvec_noAccel rfl betaArg + · exact betaNoDeltaNatNone prims + · exact RecM.tryReduceNative_noAccel rfl betaArg + · exact betaNoDeltaStringNone prims + · rfl + · exact betaNoDeltaProjectionDefNone prims + · exact betaNoDeltaQuotNone prims + +/-! #### ordered no-delta reduction ordered no-delta reducer witness -/ + +/-- Closed operational source for observing the precedence of the no-delta +reducer chain. The canonical primitive address is intentionally independent +of the small ambient catalog above, so this is a branch-order witness rather +than a Theory-translation claim; `betaNoDeltaStep` supplies the inhabited +semantic stuck-path witness. -/ +def noDeltaNatAddSource : KExpr .anon := + KExpr.mkApp + (KExpr.mkApp (.mkConst Primitives.ofAnonAddrs.natAdd #[]) + (RecM.natExprFromValue 2)) + (RecM.natExprFromValue 3) + +def noDeltaNatAddResult : KExpr .anon := + RecM.natExprFromValue 5 + +theorem noDeltaNatAddSpine : + noDeltaNatAddSource.collectSpine = + (.mkConst Primitives.ofAnonAddrs.natAdd #[], + #[RecM.natExprFromValue 2, RecM.natExprFromValue 3]) := by + unfold noDeltaNatAddSource + rw [KExpr.mkApp_shape] + unfold KExpr.collectSpine + rw [KExpr.collectSpine.go, KExpr.mkApp_shape, + KExpr.collectSpine.go, KExpr.mkConst_shape] + change + (KExpr.const Primitives.ofAnonAddrs.natAdd #[] + (KExpr.mkConst Primitives.ofAnonAddrs.natAdd #[]).info, + ((#[].push (RecM.natExprFromValue 3)).push + (RecM.natExprFromValue 2)).reverse) = _ + simp + +private theorem natAdd_ne_natSucc : + (Primitives.ofAnonAddrs.natAdd.addr == + Primitives.ofAnonAddrs.natSucc.addr) = false := by + native_decide + +private theorem natAdd_ne_natBeq : + (Primitives.ofAnonAddrs.natAdd.addr == + Primitives.ofAnonAddrs.natBeq.addr) = false := by + native_decide + +private theorem natAdd_ne_natBle : + (Primitives.ofAnonAddrs.natAdd.addr == + Primitives.ofAnonAddrs.natBle.addr) = false := by + native_decide + +theorem noDeltaNatAddIsArith : + (RecM.isNatBinArithAddr Primitives.ofAnonAddrs.natAdd.addr).run + betaHarnessMethods (noAccelState Primitives.ofAnonAddrs) = + .ok true (noAccelState Primitives.ofAnonAddrs) := by + unfold RecM.isNatBinArithAddr RecM.prims + rfl + +theorem noDeltaNatAddIsPred : + (RecM.isNatBinPredAddr Primitives.ofAnonAddrs.natAdd.addr).run + betaHarnessMethods (noAccelState Primitives.ofAnonAddrs) = + .ok false (noAccelState Primitives.ofAnonAddrs) := by + unfold RecM.isNatBinPredAddr RecM.prims + change EStateM.Result.ok + (Primitives.ofAnonAddrs.natAdd.addr == + Primitives.ofAnonAddrs.natBeq.addr || + Primitives.ofAnonAddrs.natAdd.addr == + Primitives.ofAnonAddrs.natBle.addr) + (noAccelState Primitives.ofAnonAddrs) = _ + rw [natAdd_ne_natBeq, natAdd_ne_natBle] + rfl + +theorem noDeltaNatArg (n : Nat) : + (RecM.whnfNatReducerArg (RecM.natExprFromValue n)).run + betaHarnessMethods (noAccelState Primitives.ofAnonAddrs) = + .ok (some (RecM.natExprFromValue n)) + (noAccelState Primitives.ofAnonAddrs) := by + unfold RecM.whnfNatReducerArg RecM.natExprFromValue + rw [KExpr.mkNat_shape] + rfl + +private theorem noDeltaNatExtract (n : Nat) : + extractNatLit (RecM.natExprFromValue n) Primitives.ofAnonAddrs = + some n := by + unfold extractNatLit RecM.natExprFromValue + rw [KExpr.mkNat_shape] + +private theorem noDeltaNatCompute : + computeNatBin Primitives.ofAnonAddrs.natAdd.addr + PrimAddrs.canonical 2 3 = some 5 := by + rfl + +theorem noDeltaNatAddProjectionMiss : + (RecM.tryProjAppReduce noDeltaNatAddSource .FULL).run + betaHarnessMethods (noAccelState Primitives.ofAnonAddrs) = + .ok none (noAccelState Primitives.ofAnonAddrs) := by + unfold RecM.tryProjAppReduce + rw [noDeltaNatAddSpine] + rfl + +theorem noDeltaNatAddReduction : + (RecM.tryReduceNatWithSuccMode noDeltaNatAddSource .collapse).run + betaHarnessMethods (noAccelState Primitives.ofAnonAddrs) = + .ok (some noDeltaNatAddResult) + (noAccelState Primitives.ofAnonAddrs) := by + unfold RecM.tryReduceNatWithSuccMode + rw [noDeltaNatAddSpine] + rw [KExpr.mkConst_shape] + rw [ReaderT.run_bind] + change EStateM.bind + (RecM.prims.run betaHarnessMethods) _ + (noAccelState Primitives.ofAnonAddrs) = _ + unfold EStateM.bind + rw [show RecM.prims.run betaHarnessMethods + (noAccelState Primitives.ofAnonAddrs) = + .ok Primitives.ofAnonAddrs + (noAccelState Primitives.ofAnonAddrs) from rfl] + simp only + rw [natAdd_ne_natSucc] + simp only [Bool.false_and, Bool.false_eq_true, if_false, pure_bind] + have hsize : ¬((#[RecM.natExprFromValue 2, + RecM.natExprFromValue 3] : Array (KExpr .anon)).size < 2) := by decide + simp only [hsize, if_false] + rw [ReaderT.run_bind] + change EStateM.bind + ((RecM.isNatBinArithAddr Primitives.ofAnonAddrs.natAdd.addr).run + betaHarnessMethods) _ (noAccelState Primitives.ofAnonAddrs) = _ + unfold EStateM.bind + rw [noDeltaNatAddIsArith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + ((RecM.isNatBinPredAddr Primitives.ofAnonAddrs.natAdd.addr).run + betaHarnessMethods) _ (noAccelState Primitives.ofAnonAddrs) = _ + unfold EStateM.bind + rw [noDeltaNatAddIsPred] + simp only [Bool.not_true, Bool.not_false, Bool.false_and, + Bool.false_eq_true, if_false, if_true] + rw [ReaderT.run_bind] + change EStateM.bind + ((RecM.whnfNatReducerArg (RecM.natExprFromValue 2)).run + betaHarnessMethods) _ (noAccelState Primitives.ofAnonAddrs) = _ + unfold EStateM.bind + rw [noDeltaNatArg] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + ((RecM.whnfNatReducerArg (RecM.natExprFromValue 3)).run + betaHarnessMethods) _ (noAccelState Primitives.ofAnonAddrs) = _ + unfold EStateM.bind + rw [noDeltaNatArg] + simp only + rw [noDeltaNatExtract, noDeltaNatExtract] + simp only + rw [noDeltaNatCompute] + simp [RecM.finishAppResult, noDeltaNatAddResult] + +/-! #### Nat suffix reduction arbitrary Nat suffix witness -/ + +/-- An intentionally over-applied Nat primitive. The third argument is not +consumed by `Nat.add`; production must rebuild it after reducing `2 + 3`. -/ +def noDeltaNatAddSuffixSource : KExpr .anon := + KExpr.mkApp noDeltaNatAddSource betaArg + +def noDeltaNatAddSuffixResult : KExpr .anon := + KExpr.mkApp noDeltaNatAddResult betaArg + +theorem noDeltaNatAddSuffixSpine : + noDeltaNatAddSuffixSource.collectSpine = + (.mkConst Primitives.ofAnonAddrs.natAdd #[], + #[RecM.natExprFromValue 2, RecM.natExprFromValue 3, betaArg]) := by + unfold noDeltaNatAddSuffixSource noDeltaNatAddSource + rw [KExpr.mkApp_shape] + unfold KExpr.collectSpine + rw [KExpr.collectSpine.go, KExpr.mkApp_shape, + KExpr.collectSpine.go, KExpr.mkApp_shape, + KExpr.collectSpine.go, KExpr.mkConst_shape] + change + (KExpr.const Primitives.ofAnonAddrs.natAdd #[] + (KExpr.mkConst Primitives.ofAnonAddrs.natAdd #[]).info, + (((#[].push betaArg).push (RecM.natExprFromValue 3)).push + (RecM.natExprFromValue 2)).reverse) = _ + simp + +/-- The sole dynamically rebuilt application is named in the finite request +list. Starting the fold at either original argument cannot inhabit this +certificate. -/ +def noDeltaNatAddSuffixRequests : List WalkerRequest := + [.internExpr noDeltaNatAddSuffixResult] + +theorem noDeltaNatAddSuffixFinishRequests : + RecM.FinishAppRequests noDeltaNatAddSuffixRequests + (#[RecM.natExprFromValue 2, RecM.natExprFromValue 3, betaArg].extract + 2 3).toList + noDeltaNatAddResult noDeltaNatAddSuffixResult := by + change RecM.FinishAppRequests noDeltaNatAddSuffixRequests [betaArg] + noDeltaNatAddResult noDeltaNatAddSuffixResult + apply RecM.FinishAppRequests.cons + · simp [noDeltaNatAddSuffixRequests, noDeltaNatAddSuffixResult] + · simpa [noDeltaNatAddSuffixResult] using + (RecM.FinishAppRequests.nil + (requests := noDeltaNatAddSuffixRequests) + noDeltaNatAddSuffixResult) + +private theorem noDeltaNatAddSuffixIntern : + ∃ s', TcM.intern noDeltaNatAddSuffixResult + (noAccelState Primitives.ofAnonAddrs) = + .ok noDeltaNatAddSuffixResult s' := by + unfold TcM.intern TcM.runIntern noDeltaNatAddSuffixResult + simp [internExprM, InternTable.internExpr, noAccelState, state, + loadedEnv, KEnv.insert] + +/-- Concrete Nat suffix reduction witness: the actual dispatcher reduces `(Nat.add 2 3) extra` +to `5 extra`, changes state only through the rebuilt application's intern, +and its successful execution admits the exhaustive general-spine trace. -/ +theorem noDeltaNatAddSuffixReduction : + ∃ s', + (RecM.tryReduceNatWithSuccMode noDeltaNatAddSuffixSource .collapse).run + betaHarnessMethods (noAccelState Primitives.ofAnonAddrs) = + .ok (some noDeltaNatAddSuffixResult) s' ∧ + RecM.NatSpineSuccessTrace betaHarnessMethods .collapse + noDeltaNatAddSuffixSource Primitives.ofAnonAddrs.natAdd #[] + (KExpr.mkConst Primitives.ofAnonAddrs.natAdd #[]).info + #[RecM.natExprFromValue 2, RecM.natExprFromValue 3, betaArg] + (RecM.natExprFromValue 2) (RecM.natExprFromValue 3) + (noAccelState Primitives.ofAnonAddrs) noDeltaNatAddSuffixResult s' := by + obtain ⟨s', hintern⟩ := noDeltaNatAddSuffixIntern + have hfinish : + (RecM.finishAppResult noDeltaNatAddResult + #[RecM.natExprFromValue 2, RecM.natExprFromValue 3, betaArg] 2).run + betaHarnessMethods (noAccelState Primitives.ofAnonAddrs) = + .ok noDeltaNatAddSuffixResult s' := + RecM.finishAppResult_one (by + simpa [noDeltaNatAddSuffixResult] using hintern) + have hrun := RecM.tryReduceNatWithSuccMode_binArithSuffixExact + (natSuccMode := .collapse) (result := 5) (suffix := #[betaArg]) + (us := #[]) + (headInfo := (KExpr.mkConst Primitives.ofAnonAddrs.natAdd #[]).info) + (args := #[RecM.natExprFromValue 2, RecM.natExprFromValue 3, betaArg]) + noDeltaNatAddSuffixSpine rfl rfl noDeltaNatAddIsArith + noDeltaNatAddIsPred (noDeltaNatArg 2) (noDeltaNatArg 3) + (noDeltaNatExtract 2) (noDeltaNatExtract 3) noDeltaNatCompute hfinish + exact ⟨s', hrun, + RecM.NatSpineSuccessTrace.complete (suffix := #[betaArg]) + noDeltaNatAddSuffixSpine rfl hrun⟩ + +/-- Nat suffix closure enriches the same observed success with its one finite suffix +request. In particular, the certificate starts rebuilding from `5`, not +from either consumed argument. -/ +theorem noDeltaNatAddSuffixCertifiedSuccess : + ∃ s', + RecM.NatSpineCertifiedSuccess noDeltaNatAddSuffixRequests + betaHarnessMethods .collapse noDeltaNatAddSuffixSource + Primitives.ofAnonAddrs.natAdd #[] + (KExpr.mkConst Primitives.ofAnonAddrs.natAdd #[]).info + #[RecM.natExprFromValue 2, RecM.natExprFromValue 3, betaArg] + (RecM.natExprFromValue 2) (RecM.natExprFromValue 3) + (noAccelState Primitives.ofAnonAddrs) + noDeltaNatAddSuffixResult s' := by + obtain ⟨s', hintern⟩ := noDeltaNatAddSuffixIntern + have hfinish : + (RecM.finishAppResult noDeltaNatAddResult + #[RecM.natExprFromValue 2, RecM.natExprFromValue 3, betaArg] 2).run + betaHarnessMethods (noAccelState Primitives.ofAnonAddrs) = + .ok noDeltaNatAddSuffixResult s' := + RecM.finishAppResult_one (by + simpa [noDeltaNatAddSuffixResult] using hintern) + refine ⟨s', .arithmetic noDeltaNatAddIsArith noDeltaNatAddIsPred + (noDeltaNatArg 2) (noDeltaNatArg 3) (noDeltaNatExtract 2) + (noDeltaNatExtract 3) noDeltaNatCompute hfinish ?_⟩ + simpa [noDeltaNatAddResult] using noDeltaNatAddSuffixFinishRequests + +/-- The universal-looking coverage interface remains execution-indexed: +determinism identifies any successful trace at this fixed source/state with +the single finitely certified run above. -/ +theorem noDeltaNatAddSuffixFinishCoverage : + RecM.NatSpineFinishCoverage noDeltaNatAddSuffixRequests + betaHarnessMethods .collapse noDeltaNatAddSuffixSource + Primitives.ofAnonAddrs.natAdd #[] + (KExpr.mkConst Primitives.ofAnonAddrs.natAdd #[]).info + #[RecM.natExprFromValue 2, RecM.natExprFromValue 3, betaArg] + (RecM.natExprFromValue 2) (RecM.natExprFromValue 3) + (noAccelState Primitives.ofAnonAddrs) := by + intro result s' trace + obtain ⟨certState, cert⟩ := noDeltaNatAddSuffixCertifiedSuccess + have htraceRun := trace.eval (suffix := #[betaArg]) + noDeltaNatAddSuffixSpine rfl + have hcertRun := cert.trace.eval (suffix := #[betaArg]) + noDeltaNatAddSuffixSpine rfl + have heq := htraceRun.symm.trans hcertRun + have hresultEq := Option.some.inj (EStateM.Result.ok.inj heq).1 + have hstateEq : s' = certState := (EStateM.Result.ok.inj heq).2 + subst result + subst s' + exact cert + +/-! #### successor-collapse loop successor-collapse witness -/ + +/-- Closed literal argument for the production successor loop. -/ +def succCollapseArg : KExpr .anon := RecM.natExprFromValue 2 + +/-- Exact one-argument canonical `Nat.succ` spine. -/ +def succCollapseSource : KExpr .anon := + KExpr.mkApp + (KExpr.mkConst Primitives.ofAnonAddrs.natSucc #[]) + succCollapseArg + +def succCollapseResult : KExpr .anon := RecM.natExprFromValue 3 + +theorem succCollapseSpine : + succCollapseSource.collectSpine = + (KExpr.mkConst Primitives.ofAnonAddrs.natSucc #[], + #[succCollapseArg]) := by + unfold succCollapseSource + rw [KExpr.mkApp_shape] + unfold KExpr.collectSpine + rw [KExpr.collectSpine.go, KExpr.mkConst_shape] + rfl + +/-- The linear-recognizer runs first and misses without invoking either +recursive callback on this literal argument. -/ +theorem succCollapseLinearMiss : + (RecM.tryReduceNatSuccLinearRec succCollapseArg 1).run + betaHarnessMethods (noAccelState Primitives.ofAnonAddrs) = + .ok none (noAccelState Primitives.ofAnonAddrs) := by + unfold RecM.tryReduceNatSuccLinearRec RecM.natRecLiteralParts + succCollapseArg RecM.natExprFromValue + rw [KExpr.mkNat_shape] + rfl + +/-- The fixture callback is state-pure and exposes the same literal. -/ +theorem succCollapseWhnf : + (RecM.whnfModeRec succCollapseArg .stuck).run + betaHarnessMethods (noAccelState Primitives.ofAnonAddrs) = + .ok succCollapseArg (noAccelState Primitives.ofAnonAddrs) := by + rfl + +theorem succCollapseExtract : + extractNatLit succCollapseArg Primitives.ofAnonAddrs = some 2 := by + unfold succCollapseArg RecM.natExprFromValue extractNatLit + rw [KExpr.mkNat_shape] + +/-- The named production step follows linear miss, callback success, then +literal hit and terminates before successor classification or memo writes. -/ +theorem succCollapseStep : + (RecM.tryReduceNatSuccIterStep + (succCollapseArg, 1, + #[(succCollapseArg.addr, emptyCtxAddr)])).run betaHarnessMethods + (noAccelState Primitives.ofAnonAddrs) = + .ok (.done (some succCollapseResult)) + (noAccelState Primitives.ofAnonAddrs) := by + apply RecM.tryReduceNatSuccIterStep_afterWhnf succCollapseLinearMiss + succCollapseWhnf + simpa [succCollapseResult] using + (RecM.tryReduceNatSuccAfterWhnf_literal + (methods := betaHarnessMethods) + (s := noAccelState Primitives.ofAnonAddrs) + (w := succCollapseArg) (offset := 1) + (visited := #[(succCollapseArg.addr, emptyCtxAddr)]) + (p := Primitives.ofAnonAddrs) rfl succCollapseExtract) + +theorem succCollapseKey : + TcM.whnfKey succCollapseArg (noAccelState Primitives.ofAnonAddrs) = + .ok (succCollapseArg.addr, emptyCtxAddr) + (noAccelState Primitives.ofAnonAddrs) := by + apply TcM.whnfKey_closed + rfl + +theorem succCollapseMemoMiss : + (noAccelState Primitives.ofAnonAddrs).env.natSuccStuck.contains + (succCollapseArg.addr, emptyCtxAddr) = false := by + simp [noAccelState, state, loadedEnv, KEnv.insert] + +/-- The real bounded driver executes one `.done` iteration from the exact +closed key and leaves the state—and in particular the stuck memo—unchanged. -/ +theorem succCollapseIter : + (RecM.tryReduceNatSuccIter succCollapseArg).run betaHarnessMethods + (noAccelState Primitives.ofAnonAddrs) = + .ok (some succCollapseResult) + (noAccelState Primitives.ofAnonAddrs) := by + rw [RecM.tryReduceNatSuccIter_entryMiss succCollapseKey + succCollapseMemoMiss] + rw [show maxWhnfFuel.toNat = 10000 by rfl] + rw [RecM.runBounded, ReaderT.run_bind] + change EStateM.bind + ((RecM.tryReduceNatSuccIterStep + (succCollapseArg, 1, #[(succCollapseArg.addr, emptyCtxAddr)])).run + betaHarnessMethods) _ (noAccelState Primitives.ofAnonAddrs) = _ + unfold EStateM.bind + rw [succCollapseStep] + rfl + +/-- End-to-end successor-collapse loop branch witness: canonical `Nat.succ 2` collapses to the +literal `3` through the production dispatcher, bounded loop, and callback +order, with no cache or intern mutation. -/ +theorem succCollapseReduction : + (RecM.tryReduceNatWithSuccMode succCollapseSource .collapse).run + betaHarnessMethods (noAccelState Primitives.ofAnonAddrs) = + .ok (some succCollapseResult) + (noAccelState Primitives.ofAnonAddrs) := by + apply RecM.tryReduceNatWithSuccMode_succ_collapse + (p := Primitives.ofAnonAddrs) (arg := succCollapseArg) + · exact succCollapseSpine + · rfl + · rfl + · exact succCollapseIter + +/-- The same concrete unary successor is an exact state-pure miss in the +internal stuck policy. This witnesses the branch used by recursive successor +normalization and guards against accidentally re-entering collapse mode. -/ +theorem succStuckReduction : + (RecM.tryReduceNatWithSuccMode succCollapseSource .stuck).run + betaHarnessMethods (noAccelState Primitives.ofAnonAddrs) = + .ok none (noAccelState Primitives.ofAnonAddrs) := by + exact RecM.tryReduceNatWithSuccMode_succ_stuck succCollapseSpine rfl rfl + +/-- Adversarial precedence witness: projection-app and BitVec miss, Nat.add +succeeds, and the production tail returns immediately. Any reordering that +moves Nat behind native/string/projection/quotient invalidates this exact +execution equation. -/ +theorem noDeltaNatBranchOrder : + (RecM.whnfNoDeltaReducersStep .FULL .collapse + noDeltaNatAddSource).run betaHarnessMethods + (noAccelState Primitives.ofAnonAddrs) = + .ok (.next noDeltaNatAddResult) + (noAccelState Primitives.ofAnonAddrs) := by + apply RecM.whnfNoDeltaReducersStep_nat + · exact RecM.tryProjAppReduceFinished_none + noDeltaNatAddProjectionMiss + · exact RecM.tryReduceBitvec_noAccel rfl noDeltaNatAddSource + · exact noDeltaNatAddReduction + +private theorem driverCacheWhnfValid (kind : ExprCacheKind) + (hkind : kind = .whnf ∨ kind = .whnfNoDelta ∨ + kind = .whnfNoDeltaCheap) : + WhnfCacheValid whnfContextKeys RawProjRel.none + CacheSemantics.blockErrorsOnly (CacheAuthority.stable worldGood) + coreCacheSupport (.expr kind coreCacheKey betaArg) := by + rcases hkind with rfl | rfl | rfl <;> + intro source hsource haddr Δ hctx + all_goals + change source = betaSource ∨ source = betaArg at hsource + rcases hsource with rfl | rfl + · have hΔ : Δ = [] := by + simpa [whnfContextKeys, coreCacheKey] using hctx.2 + subst Δ + exact betaResultMeaning + · have hΔ : Δ = [] := by + simpa [whnfContextKeys, coreCacheKey] using hctx.2 + subst Δ + exact betaArgMeaning + +theorem fullNoDeltaProvenance : + CacheProvenance whnfSemantics (CacheAuthority.stable worldGood) + coreCacheSupport (.expr .whnfNoDelta coreCacheKey betaArg) := by + refine ⟨?_, ?_, ?_⟩ + · exact ⟨⟨betaSource, .inl rfl, rfl⟩, .inr rfl⟩ + · exact coreCacheReferencesAuthorized .whnfNoDelta + · exact driverCacheWhnfValid .whnfNoDelta (.inr (.inl rfl)) + +theorem fullWhnfProvenance : + CacheProvenance whnfSemantics (CacheAuthority.stable worldGood) + coreCacheSupport (.expr .whnf coreCacheKey betaArg) := by + refine ⟨?_, ?_, ?_⟩ + · exact ⟨⟨betaSource, .inl rfl, rfl⟩, .inr rfl⟩ + · exact coreCacheReferencesAuthorized .whnf + · exact driverCacheWhnfValid .whnf (.inl rfl) + +def fullNoDeltaWarmState (prims : Primitives .anon) : TcState .anon := + let s := fullCoreWarmState prims + {s with env := {s.env with + whnfNoDeltaCache := s.env.whnfNoDeltaCache.insert coreCacheKey betaArg}} + +theorem fullNoDeltaWarmStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (fullNoDeltaWarmState prims) := by + exact RecM.WhnfDriverCacheUpdate.noDelta_whnfStateInv + (fullCoreWarmStateInv prims) fullNoDeltaProvenance + +theorem noDeltaTrace (prims : Primitives .anon) : + RecM.WhnfNoDeltaTrace .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] betaHarnessMethods .FULL .collapse + maxWhnfFuel.toNat betaSource (fullCoreWarmState prims) betaArg + (fullCoreWarmState prims) := by + rw [show maxWhnfFuel.toNat = 10000 by rfl] + exact .done (fullCoreWarmStateInv prims) (betaNoDeltaStep prims) + (fullCoreWarmStateInv prims) betaResultMeaning + +theorem fullCoreWarm_noDeltaMiss (prims : Primitives .anon) : + (fullCoreWarmState prims).env.whnfNoDeltaCache[coreCacheKey]? = none := by + simp [fullCoreWarmState, noAccelState, state, loadedEnv, KEnv.insert, + coreCacheKey] + +theorem fullNoDeltaWarm_hit (prims : Primitives .anon) : + (fullNoDeltaWarmState prims).env.whnfNoDeltaCache[coreCacheKey]? = + some betaArg := by + simp [fullNoDeltaWarmState, coreCacheKey] + +theorem fullNoDeltaWarm_cheapMiss (prims : Primitives .anon) : + (fullNoDeltaWarmState prims).env.whnfNoDeltaCheapCache[coreCacheKey]? = + none := by + simp [fullNoDeltaWarmState, fullCoreWarmState, noAccelState, state, + loadedEnv, KEnv.insert, coreCacheKey] + +theorem fullNoDeltaColdAcceptance (prims : Primitives .anon) : + (RecM.whnfNoDelta betaSource).run betaHarnessMethods + (fullCoreWarmState prims) = + .ok betaArg (fullNoDeltaWarmState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood coreCacheSupport 0 [] (fullCoreWarmState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (bothCoreWarmState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (fullNoDeltaWarmState prims) ∧ WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by - simpa [whnfSemantics, bothCoreWarmState] using - (RecM.whnfCoreWithFlags_cheapMiss_acceptance + simpa [RecM.whnfNoDelta, whnfSemantics, fullNoDeltaWarmState] using + (RecM.whnfNoDeltaImpl_fullMiss_acceptance (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) - structuralWhnfTheory (.direct RecM.WhnfCoreNonLeaf.app) rfl + structuralWhnfTheory (.direct RecM.WhnfDriverNonLeaf.app) rfl (coreCacheKey_eval (fullCoreWarmState prims)) (betaTransientFalse (fullCoreWarmState prims)) - (fullCoreWarm_cheapMiss prims) - (coreCacheTrace (fullCoreWarmStateInv prims) .DEF_EQ_CORE) - cheapCoreProvenance) + (fullCoreWarm_noDeltaMiss prims) (noDeltaTrace prims) rfl + fullNoDeltaProvenance) -/-- Once the cheap partition is populated, its next call is also a -state-preserving semantic hit. -/ -theorem cheapCoreWarmAcceptance (prims : Primitives .anon) : - (RecM.whnfCoreWithFlags betaSource .DEF_EQ_CORE).run betaHarnessMethods - (bothCoreWarmState prims) = .ok betaArg (bothCoreWarmState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (bothCoreWarmState prims) ∧ +theorem fullNoDeltaWarmAcceptance (prims : Primitives .anon) : + (RecM.whnfNoDelta betaSource).run betaHarnessMethods + (fullNoDeltaWarmState prims) = + .ok betaArg (fullNoDeltaWarmState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (fullNoDeltaWarmState prims) ∧ WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by - simpa [whnfSemantics] using - (RecM.whnfCoreWithFlags_cheapHit_acceptance + simpa [RecM.whnfNoDelta, whnfSemantics] using + (RecM.whnfNoDeltaImpl_fullHit_acceptance (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) - (.direct RecM.WhnfCoreNonLeaf.app) rfl - (coreCacheKey_eval (bothCoreWarmState prims)) - (betaTransientFalse (bothCoreWarmState prims)) - (bothCoreWarm_cheapHit prims) (bothCoreWarmStateInv prims) (.inl rfl) - (coreCacheKey_matches (bothCoreWarmState prims) - (bothCoreWarmStateInv prims).2.1)) + (.direct RecM.WhnfDriverNonLeaf.app) rfl + (coreCacheKey_eval (fullNoDeltaWarmState prims)) + (betaTransientFalse (fullNoDeltaWarmState prims)) + (fullNoDeltaWarm_hit prims) (fullNoDeltaWarmStateInv prims) (.inl rfl) + (coreCacheKey_matches (fullNoDeltaWarmState prims) + (fullNoDeltaWarmStateInv prims).2.1)) -/-- Direct adversarial observation of the flag partition after only the full -call has warmed its map. -/ -theorem coreCachePolicyIsolation (prims : Primitives .anon) : - (fullCoreWarmState prims).env.whnfCoreCache[coreCacheKey]? = +theorem noDeltaCachePolicyIsolation (prims : Primitives .anon) : + (fullNoDeltaWarmState prims).env.whnfNoDeltaCache[coreCacheKey]? = some betaArg ∧ - (fullCoreWarmState prims).env.whnfCoreCheapCache[coreCacheKey]? = none := - ⟨fullCoreWarm_hit prims, fullCoreWarm_cheapMiss prims⟩ + (fullNoDeltaWarmState prims).env.whnfNoDeltaCheapCache[coreCacheKey]? = + none := + ⟨fullNoDeltaWarm_hit prims, fullNoDeltaWarm_cheapMiss prims⟩ -/-! ### K1h no-delta/full-WHNF driver witness -/ +/-! #### Full-WHNF loop, outer cache, and fuel witness -/ -theorem betaNoDeltaProjNone (prims : Primitives .anon) : - (RecM.tryProjAppReduce betaArg .FULL).run betaHarnessMethods - (fullCoreWarmState prims) = .ok none (fullCoreWarmState prims) := by - unfold RecM.tryProjAppReduce betaArg - rw [KExpr.mkConst_shape] - rfl +/-- The exact state after a genuine outer full-WHNF cache miss has paid its +single recursive-fuel charge. -/ +def fullWhnfChargedState (prims : Primitives .anon) : TcState .anon := + let s := fullNoDeltaWarmState prims + {s with recFuel := s.recFuel - 1} -theorem betaNoDeltaNatNone (prims : Primitives .anon) : +theorem fullWhnfChargedStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (fullWhnfChargedState prims) := by + exact WhnfStateInv.of_semantic_fields_eq + (fullNoDeltaWarmStateInv prims) rfl rfl rfl rfl rfl rfl rfl rfl + +theorem fullWhnfPrefixCold (prims : Primitives .anon) : + (RecM.whnfWithNatSuccModePrefix betaSource).run betaHarnessMethods + (fullNoDeltaWarmState prims) = + .ok () (fullNoDeltaWarmState prims) := by + exact RecM.whnfWithNatSuccModePrefix_disabled rfl rfl + +theorem fullWhnfMissCharge (prims : Primitives .anon) : + (RecM.whnfWithNatSuccModeMissCharge : RecM .anon Unit).run + betaHarnessMethods (fullNoDeltaWarmState prims) = + .ok () (fullWhnfChargedState prims) := by + exact RecM.whnfWithNatSuccModeMissCharge_disabled rfl rfl + +/-- Fuel bookkeeping does not disturb the already populated no-delta cache. -/ +theorem fullWhnfCharged_noDeltaHit (prims : Primitives .anon) : + (RecM.whnfNoDeltaImpl betaSource .FULL .collapse).run + betaHarnessMethods (fullWhnfChargedState prims) = + .ok betaArg (fullWhnfChargedState prims) := by + rw [(RecM.WhnfDriverEntry.direct + (methods := betaHarnessMethods) (source := betaSource) + (s := fullWhnfChargedState prims) + RecM.WhnfDriverNonLeaf.app).noDelta_eval .FULL .collapse] + apply RecM.whnfNoDeltaImplNonLeaf_fullHit rfl + (coreCacheKey_eval (fullWhnfChargedState prims)) + (betaTransientFalse (fullWhnfChargedState prims)) + simp [fullWhnfChargedState, fullNoDeltaWarmState, coreCacheKey] + +theorem betaFullChargedNatNone (prims : Primitives .anon) : (RecM.tryReduceNatWithSuccMode betaArg .collapse).run betaHarnessMethods - (fullCoreWarmState prims) = .ok none (fullCoreWarmState prims) := by + (fullWhnfChargedState prims) = + .ok none (fullWhnfChargedState prims) := by unfold RecM.tryReduceNatWithSuccMode betaArg rw [KExpr.mkConst_shape] simp [KExpr.collectSpine, KExpr.collectSpine.go, RecM.prims] rfl -theorem betaNoDeltaStringNone (prims : Primitives .anon) : +theorem betaFullChargedStringNone (prims : Primitives .anon) : (RecM.tryReduceString betaArg).run betaHarnessMethods - (fullCoreWarmState prims) = .ok none (fullCoreWarmState prims) := by + (fullWhnfChargedState prims) = + .ok none (fullWhnfChargedState prims) := by unfold RecM.tryReduceString betaArg rw [KExpr.mkConst_shape] rfl -theorem fullCoreWarm_getZero (prims : Primitives .anon) : - TcM.tryGetConst zeroId (fullCoreWarmState prims) = - .ok (some zeroConcrete) (fullCoreWarmState prims) := by +/-- `betaArg` is a bare constant: the offset-stuck probe either rejects its +head outright or the collected spine has no arguments — `none` either way, +for any primitive address assignment. -/ +theorem betaFullChargedNatOffsetStuckNone (prims : Primitives .anon) : + (RecM.tryNatOffsetStuck betaArg).run betaHarnessMethods + (fullWhnfChargedState prims) = + .ok none (fullWhnfChargedState prims) := by + unfold RecM.tryNatOffsetStuck + rw [ReaderT.run_bind] + change EStateM.bind ((RecM.prims).run betaHarnessMethods) _ + (fullWhnfChargedState prims) = _ + unfold EStateM.bind + rw [show (RecM.prims (m := .anon)).run betaHarnessMethods + (fullWhnfChargedState prims) = + .ok prims (fullWhnfChargedState prims) from rfl] + simp only + cases hprobe : RecM.natOffsetStuckHead prims betaArg with + | false => rfl + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + unfold betaArg + rw [KExpr.mkConst_shape] + simp [KExpr.collectSpine, KExpr.collectSpine.go] + +theorem betaFullChargedGetZero (prims : Primitives .anon) : + TcM.tryGetConst zeroId (fullWhnfChargedState prims) = + .ok (some zeroConcrete) (fullWhnfChargedState prims) := by unfold TcM.tryGetConst change EStateM.bind (get : TcM .anon (TcState .anon)) _ - (fullCoreWarmState prims) = _ - unfold EStateM.bind - rw [show (get : TcM .anon (TcState .anon)) (fullCoreWarmState prims) = - .ok (fullCoreWarmState prims) (fullCoreWarmState prims) from rfl] + (fullWhnfChargedState prims) = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) + (fullWhnfChargedState prims) = + .ok (fullWhnfChargedState prims) (fullWhnfChargedState prims) from rfl] simp only - have henv : (fullCoreWarmState prims).env.get? zeroId = + have henv : (fullWhnfChargedState prims).env.get? zeroId = some zeroConcrete := by - simpa [fullCoreWarmState, noAccelState, state] using loadedEnv_zero_k1e + simpa [fullWhnfChargedState, fullNoDeltaWarmState, fullCoreWarmState, + noAccelState, state] using loadedEnv_zero_k1e rw [henv] rfl -theorem betaNoDeltaProjectionDefNone (prims : Primitives .anon) : - (RecM.tryReduceProjectionDefinition betaArg).run betaHarnessMethods - (fullCoreWarmState prims) = .ok none (fullCoreWarmState prims) := by - unfold RecM.tryReduceProjectionDefinition betaArg +theorem betaFullChargedTryDeltaNone (prims : Primitives .anon) : + (RecM.tryDeltaUnfold betaArg).run betaHarnessMethods + (fullWhnfChargedState prims) = + .ok none (fullWhnfChargedState prims) := by + unfold RecM.tryDeltaUnfold betaArg rw [KExpr.mkConst_shape] simp only [KExpr.collectSpine, KExpr.collectSpine.go] rw [ReaderT.run_bind] - change EStateM.bind (TcM.tryGetConst zeroId) _ (fullCoreWarmState prims) = _ + change EStateM.bind (TcM.tryGetConst zeroId) _ + (fullWhnfChargedState prims) = _ unfold EStateM.bind - rw [fullCoreWarm_getZero prims] + rw [betaFullChargedGetZero prims] rfl -theorem betaNoDeltaQuotNone (prims : Primitives .anon) : - (RecM.tryQuotReduce betaArg).run betaHarnessMethods - (fullCoreWarmState prims) = .ok none (fullCoreWarmState prims) := by - unfold RecM.tryQuotReduce betaArg +theorem betaFullChargedDeltaNone (prims : Primitives .anon) : + (RecM.deltaUnfoldOne betaArg).run betaHarnessMethods + (fullWhnfChargedState prims) = + .ok none (fullWhnfChargedState prims) := by + unfold RecM.deltaUnfoldOne + rw [ReaderT.run_bind] + change EStateM.bind + ((RecM.tryDeltaUnfold betaArg).run betaHarnessMethods) _ + (fullWhnfChargedState prims) = _ + unfold EStateM.bind + rw [betaFullChargedTryDeltaNone prims] + unfold betaArg rw [KExpr.mkConst_shape] - simp [KExpr.collectSpine, KExpr.collectSpine.go, RecM.prims] + change EStateM.bind (TcM.tryGetConst zeroId) _ + (fullWhnfChargedState prims) = _ + unfold EStateM.bind + rw [betaFullChargedGetZero prims] rfl -/-- The no-delta driver consumes the already certified structural cache hit, -then checks every remaining reducer in production order before terminating. -/ -theorem betaNoDeltaStep (prims : Primitives .anon) : - (RecM.whnfNoDeltaImplStep .FULL .collapse betaSource).run - betaHarnessMethods (fullCoreWarmState prims) = - .ok (.done betaArg) (fullCoreWarmState prims) := by - unfold RecM.whnfNoDeltaImplStep +/-- One full-WHNF iteration first consumes the certified no-delta hit, proves +the fresh cycle set cannot stop it, and then checks native, bitvector, Nat, +Decidable, String, offset-stuck, and delta reducers in their production +order. -/ +theorem betaFullWhnfStep (prims : Primitives .anon) : + (RecM.whnfWithNatSuccModeStep .collapse (betaSource, {})).run + betaHarnessMethods (fullWhnfChargedState prims) = + .ok (.done betaArg) (fullWhnfChargedState prims) := by + unfold RecM.whnfWithNatSuccModeStep rw [ReaderT.run_bind] change EStateM.bind - ((RecM.whnfCoreWithFlags betaSource .FULL).run betaHarnessMethods) _ - (fullCoreWarmState prims) = _ + ((RecM.whnfNoDeltaImpl betaSource .FULL .collapse).run + betaHarnessMethods) _ (fullWhnfChargedState prims) = _ unfold EStateM.bind - rw [(fullCoreWarmAcceptance prims).1] + rw [fullWhnfCharged_noDeltaHit prims] simp only + have hcycle : ({} : Std.HashSet Address).contains betaArg.addr = false := by + change ({} : Std.HashMap Address Unit).contains betaArg.addr = false + exact Std.HashMap.contains_empty + simp only [hcycle, Bool.false_eq_true, if_false, pure_bind] rw [ReaderT.run_bind] change EStateM.bind - ((RecM.tryProjAppReduce betaArg .FULL).run betaHarnessMethods) _ - (fullCoreWarmState prims) = _ + ((RecM.tryReduceNative betaArg).run betaHarnessMethods) _ + (fullWhnfChargedState prims) = _ unfold EStateM.bind - rw [betaNoDeltaProjNone prims] - simp only [pure_bind] + rw [RecM.tryReduceNative_noAccel rfl] + simp only rw [ReaderT.run_bind] change EStateM.bind ((RecM.tryReduceBitvec betaArg).run betaHarnessMethods) _ - (fullCoreWarmState prims) = _ + (fullWhnfChargedState prims) = _ unfold EStateM.bind rw [RecM.tryReduceBitvec_noAccel rfl] simp only rw [ReaderT.run_bind] change EStateM.bind - ((RecM.tryReduceNatWithSuccMode betaArg .collapse).run betaHarnessMethods) _ - (fullCoreWarmState prims) = _ + ((RecM.tryReduceNatWithSuccMode betaArg .collapse).run + betaHarnessMethods) _ (fullWhnfChargedState prims) = _ unfold EStateM.bind - rw [betaNoDeltaNatNone prims] + rw [betaFullChargedNatNone prims] simp only rw [ReaderT.run_bind] change EStateM.bind - ((RecM.tryReduceNative betaArg).run betaHarnessMethods) _ - (fullCoreWarmState prims) = _ + ((RecM.tryReduceDecidable betaArg).run betaHarnessMethods) _ + (fullWhnfChargedState prims) = _ unfold EStateM.bind - rw [RecM.tryReduceNative_noAccel rfl] + rw [RecM.tryReduceDecidable_noAccel rfl] simp only rw [ReaderT.run_bind] change EStateM.bind ((RecM.tryReduceString betaArg).run betaHarnessMethods) _ - (fullCoreWarmState prims) = _ + (fullWhnfChargedState prims) = _ unfold EStateM.bind - rw [betaNoDeltaStringNone prims] - simp [WhnfFlags.FULL, WhnfFlags.isFull] + rw [betaFullChargedStringNone prims] + simp only + rw [ReaderT.run_bind] change EStateM.bind - ((RecM.tryReduceProjectionDefinition betaArg).run betaHarnessMethods) _ - (fullCoreWarmState prims) = _ + ((RecM.tryNatOffsetStuck betaArg).run betaHarnessMethods) _ + (fullWhnfChargedState prims) = _ unfold EStateM.bind - rw [betaNoDeltaProjectionDefNone prims] + rw [betaFullChargedNatOffsetStuckNone prims] simp only rw [ReaderT.run_bind] change EStateM.bind - ((RecM.tryQuotReduce betaArg).run betaHarnessMethods) _ - (fullCoreWarmState prims) = _ + ((RecM.deltaUnfoldOne betaArg).run betaHarnessMethods) _ + (fullWhnfChargedState prims) = _ unfold EStateM.bind - rw [betaNoDeltaQuotNone prims] + rw [betaFullChargedDeltaNone prims] + rfl + +theorem fullWhnfTrace (prims : Primitives .anon) : + RecM.WhnfFullTrace .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] betaHarnessMethods .collapse + maxWhnfFuel.toNat (betaSource, {}) (fullWhnfChargedState prims) + betaArg (fullWhnfChargedState prims) := by + rw [show maxWhnfFuel.toNat = 10000 by rfl] + exact .done (fullWhnfChargedStateInv prims) (betaFullWhnfStep prims) + (fullWhnfChargedStateInv prims) betaResultMeaning + +/-! #### total-outcome boundary total-outcome boundary witnesses -/ + +/-- No-delta exhaustion happens before the first semantic step and cannot be + repackaged as a successful trace. -/ +theorem noDeltaZeroFuel (prims : Primitives .anon) : + (RecM.runBounded (RecM.whnfNoDeltaImplStep .FULL .collapse) 0 + betaSource).run betaHarnessMethods (fullCoreWarmState prims) = + .error .maxRecDepth (fullCoreWarmState prims) ∧ + ¬RecM.WhnfNoDeltaTrace .structuralNoAccel whnfSemantics RawProjRel.none + worldGood coreCacheSupport 0 [] betaHarnessMethods .FULL .collapse 0 + betaSource (fullCoreWarmState prims) betaArg + (fullCoreWarmState prims) := + ⟨rfl, RecM.WhnfNoDeltaTrace.no_zero⟩ + +/-- Full-WHNF has the same hostile zero-fuel boundary even though its loop + state also carries a cycle-detection set. -/ +theorem fullWhnfZeroFuel (prims : Primitives .anon) : + (RecM.runBounded (RecM.whnfWithNatSuccModeStep .collapse) 0 + (betaSource, {})).run betaHarnessMethods (fullWhnfChargedState prims) = + .error .maxRecDepth (fullWhnfChargedState prims) ∧ + ¬RecM.WhnfFullTrace .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] betaHarnessMethods .collapse 0 + (betaSource, {}) (fullWhnfChargedState prims) betaArg + (fullWhnfChargedState prims) := + ⟨rfl, RecM.WhnfFullTrace.no_zero⟩ + +/-- The loop-error contract does not identify method/fuel exhaustion + (`.maxRecFuel`) with bounded-loop exhaustion (`.maxRecDepth`). -/ +theorem whnfLoopErrorSeparation (prims : Primitives .anon) : + RecM.WhnfLoopError (fun _ _ => False) .maxRecDepth + (fullWhnfChargedState prims) ∧ + ¬RecM.WhnfLoopError (fun _ _ => False) .maxRecFuel + (fullWhnfChargedState prims) := by + constructor + · exact Or.inl rfl + · rintro (h | h) + · cases h + · exact h + +/-- The exact state after the full driver commits its semantic cache entry. -/ +def fullWhnfWarmState (prims : Primitives .anon) : TcState .anon := + let s := fullWhnfChargedState prims + {s with env := {s.env with + whnfCache := s.env.whnfCache.insert coreCacheKey betaArg}} + +theorem fullWhnfWarmStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (fullWhnfWarmState prims) := by + exact RecM.WhnfDriverCacheUpdate.full_whnfStateInv + (fullWhnfChargedStateInv prims) fullWhnfProvenance + +theorem fullWhnfCold_miss (prims : Primitives .anon) : + (fullNoDeltaWarmState prims).env.whnfCache[coreCacheKey]? = none := by + simp [fullNoDeltaWarmState, fullCoreWarmState, noAccelState, state, + loadedEnv, KEnv.insert, coreCacheKey] + +theorem fullWhnfWarm_hit (prims : Primitives .anon) : + (fullWhnfWarmState prims).env.whnfCache[coreCacheKey]? = + some betaArg := by + simp [fullWhnfWarmState, coreCacheKey] + +theorem fullWhnfPrefixWarm (prims : Primitives .anon) : + (RecM.whnfWithNatSuccModePrefix betaSource).run betaHarnessMethods + (fullWhnfWarmState prims) = .ok () (fullWhnfWarmState prims) := by + exact RecM.whnfWithNatSuccModePrefix_disabled rfl rfl + +/-- A cold public full-WHNF call pays one miss charge, executes its bounded +semantic trace, inserts the result, and preserves the complete invariant. -/ +theorem fullWhnfColdAcceptance (prims : Primitives .anon) : + (RecM.whnf betaSource).run betaHarnessMethods + (fullNoDeltaWarmState prims) = + .ok betaArg (fullWhnfWarmState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (fullWhnfChargedState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (fullWhnfWarmState prims) ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by + simpa [RecM.whnf, whnfSemantics, fullWhnfWarmState] using + (RecM.whnfWithNatSuccMode_miss_acceptance + (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) + structuralWhnfTheory (.direct RecM.WhnfDriverNonLeaf.app) + (fullWhnfPrefixCold prims) + (coreCacheKey_eval (fullNoDeltaWarmState prims)) + (betaTransientFalse (fullNoDeltaWarmState prims)) + (fullWhnfCold_miss prims) (fullWhnfMissCharge prims) + (fullWhnfTrace prims) rfl fullWhnfProvenance) + +/-- The next public call consumes the inserted entry as a semantic hit and +does not pay another fuel charge or mutate any checker state. -/ +theorem fullWhnfWarmAcceptance (prims : Primitives .anon) : + (RecM.whnf betaSource).run betaHarnessMethods + (fullWhnfWarmState prims) = + .ok betaArg (fullWhnfWarmState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + coreCacheSupport 0 [] (fullWhnfWarmState prims) ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by + simpa [RecM.whnf, whnfSemantics] using + (RecM.whnfWithNatSuccMode_hit_acceptance + (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) + (.direct RecM.WhnfDriverNonLeaf.app) (fullWhnfPrefixWarm prims) + (coreCacheKey_eval (fullWhnfWarmState prims)) + (betaTransientFalse (fullWhnfWarmState prims)) + (fullWhnfWarm_hit prims) (fullWhnfWarmStateInv prims) (.inl rfl) + (coreCacheKey_matches (fullWhnfWarmState prims) + (fullWhnfWarmStateInv prims).2.1)) + +/-- The cold outer miss consumes exactly one unit; cache insertion and the +subsequent warm hit consume none. -/ +theorem fullWhnfFuelDiscipline (prims : Primitives .anon) : + (fullNoDeltaWarmState prims).recFuel = maxRecFuel ∧ + (fullWhnfChargedState prims).recFuel = maxRecFuel - 1 ∧ + (fullWhnfWarmState prims).recFuel = maxRecFuel - 1 := by + simp [fullWhnfWarmState, fullWhnfChargedState, fullNoDeltaWarmState, + fullCoreWarmState, noAccelState, state] + +/-- The final state retains all three independently certified cache layers: +structural core, no-delta, and full WHNF. -/ +theorem fullWhnfCacheLayering (prims : Primitives .anon) : + (fullWhnfWarmState prims).env.whnfCache[coreCacheKey]? = some betaArg ∧ + (fullWhnfWarmState prims).env.whnfNoDeltaCache[coreCacheKey]? = + some betaArg ∧ + (fullWhnfWarmState prims).env.whnfCoreCache[coreCacheKey]? = + some betaArg := by + constructor + · exact fullWhnfWarm_hit prims + constructor <;> simp [fullWhnfWarmState, fullWhnfChargedState, + fullNoDeltaWarmState, fullCoreWarmState, coreCacheKey] + +/-! ### regular-binder fallback regular-binder fallback witnesses -/ + +/-- The fallback fixture includes both open variable forms as well as the + original support root used by the concrete state's intern invariant. -/ +def stuckSupport : RunSupport where + expr e := support e ∨ e = betaBody ∨ e = fvarZetaSource + exprFinite := ⟨[supportExpr, betaBody, fvarZetaSource], by + intro e he + rcases he with he | he | he + · change e = supportExpr at he + subst e + simp + · subst e + simp + · subst e + simp⟩ + univ := support.univ + univFinite := support.univFinite + +theorem support_le_stuckSupport : support ≤ stuckSupport := by + constructor + · intro e he + exact .inl he + · intro u hu + exact hu + +/-- A legacy bvar over a regular lambda frame. Its concrete `letVals` + entry is `none`, while the ghost context still resolves and translates + the variable normally. -/ +def bvarStuckCtx : KVLCtx := + [(none, .vlam (.const natName []))] + +def bvarStuckState (prims : Primitives .anon) : TcState .anon := + let base := noAccelState prims + { base with + ctx := #[supportExpr] + letVals := #[none] } + +theorem bvarStuckCtxRecon (prims : Primitives .anon) : + CtxRecon worldGood.venv 0 worldGood.nameOf RawProjRel.none + (bvarStuckState prims) bvarStuckCtx := by + refine { + size_eq := rfl + recon := ?_ + lwf := .empty + incr := by simp [bvarStuckState, noAccelState, state] + fresh := by simp [bvarStuckState, noAccelState, state] + lets := rfl } + have hrec : + CtxRecon' worldGood.venv 0 worldGood.nameOf RawProjRel.none + [(supportExpr, none)] [] bvarStuckCtx := + .bvar_lam .nil betaTy_tr ⟨_, betaA_type⟩ + simpa [bvarStuckState, noAccelState] using hrec + +theorem bvarStuckStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + stuckSupport 0 bvarStuckCtx (bvarStuckState prims) := by + have hbase := noAccelStateInv prims + refine ⟨?_, bvarStuckCtxRecon prims, rfl⟩ + apply KernelStateWF.of_no_cache_entries + · exact hbase.1.core.of_env_eq rfl + · exact hbase.1.internSupport.mono support_le_stuckSupport + · rfl + · intro entry + simpa [bvarStuckState, noAccelState, state] using + loadedEnv_noCacheEntries entry + +theorem bvarStuckLookup (prims : Primitives .anon) : + TcM.lookupLetVal 0 (bvarStuckState prims) = + .ok none (bvarStuckState prims) := by + unfold TcM.lookupLetVal + rfl + +theorem bvarStuckSource : + RecM.WhnfStep.Source RawProjRel.none worldGood stuckSupport 0 + bvarStuckCtx id betaBody := by + refine ⟨?_, .bvar 0, ?_⟩ + · exact .inr (.inl rfl) + · simpa [bvarStuckCtx] using betaBody_tr + +/-- Adversarial legacy-binder acceptance: the translated variable is + semantically meaningful but structurally stuck, and the complete step is + state-pure. -/ +theorem bvarStuckAcceptance (prims : Primitives .anon) + (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsStep betaBody flags).run betaHarnessMethods + (bvarStuckState prims) = + .ok (.done betaBody) (bvarStuckState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + stuckSupport 0 bvarStuckCtx (bvarStuckState prims) ∧ + RecM.WhnfStep.Meaning RawProjRel.none worldGood stuckSupport 0 + bvarStuckCtx id betaBody (.done betaBody) := by + unfold betaBody + rw [KExpr.mkVar_shape] + exact RecM.whnfCoreWithFlagsStep_varDone_acceptance structuralWhnfTheory + bvarStuckSource (bvarStuckStateInv prims) (bvarStuckLookup prims) + +/-- The fvar-side adversary uses a real regular local declaration, not a + missing id. Production must distinguish `.cdecl` from `.ldecl`. -/ +def fvarStuckCtx : KVLCtx := + [(some (fvarZetaId, []), .vlam (.const natName []))] + +def fvarStuckState (prims : Primitives .anon) : TcState .anon := + let base := noAccelState prims + { base with + env := { base.env with nextFVarId := 1 } + lctx := base.lctx.push fvarZetaId (.cdecl () () supportExpr) } + +theorem fvarStuckFind (prims : Primitives .anon) : + (fvarStuckState prims).lctx.find? fvarZetaId = + some (.cdecl () () supportExpr) := by + simp [fvarStuckState, noAccelState, LocalContext.find?, LocalContext.push, + fvarZetaId] + +theorem fvarStuckCtxRecon (prims : Primitives .anon) : + CtxRecon worldGood.venv 0 worldGood.nameOf RawProjRel.none + (fvarStuckState prims) fvarStuckCtx := by + refine { + size_eq := rfl + recon := ?_ + lwf := ?_ + incr := by + simp [fvarStuckState, noAccelState, state, LocalContext.push] + fresh := ?_ + lets := rfl } + · have hrec : + CtxRecon' worldGood.venv 0 worldGood.nameOf RawProjRel.none + [] [(fvarZetaId, .cdecl () () supportExpr)] fvarStuckCtx := + .fvar .nil (.vlam betaTy_tr ⟨_, betaA_type⟩) (by simp) + simpa [fvarStuckState, noAccelState, LocalContext.push] using hrec + · apply LocalContext.WF.push .empty + simp [fvarZetaId] + · intro p hp + simp [fvarStuckState, noAccelState, state, LocalContext.push] at hp + subst p + simp [fvarStuckState, fvarZetaId] + +theorem fvarStuckStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + stuckSupport 0 fvarStuckCtx (fvarStuckState prims) := by + have hbase := noAccelStateInv prims + refine ⟨?_, fvarStuckCtxRecon prims, rfl⟩ + apply KernelStateWF.of_no_cache_entries + · exact hbase.1.core.of_consts_eq (by rfl) (by + simpa [fvarStuckState] using hbase.1.core.intern) + · exact (by + simpa [fvarStuckState] using + hbase.1.internSupport.mono support_le_stuckSupport) + · rfl + · intro entry + intro hentry + apply loadedEnv_noCacheEntries entry + cases hentry <;> (constructor; assumption) + +theorem fvarStuckSource_tr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none + fvarStuckCtx fvarZetaSource (.bvar 0) := by + unfold fvarZetaSource + rw [KExpr.mkFVar_shape] + exact .fvar rfl + +theorem fvarStuckSource : + RecM.WhnfStep.Source RawProjRel.none worldGood stuckSupport 0 + fvarStuckCtx id fvarZetaSource := by + exact ⟨.inr (.inr rfl), _, fvarStuckSource_tr⟩ + +/-- Adversarial regular-fvar acceptance: the `.cdecl` lookup is present and + translated, yet no zeta reduction occurs. -/ +theorem fvarStuckAcceptance (prims : Primitives .anon) + (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsStep fvarZetaSource flags).run betaHarnessMethods + (fvarStuckState prims) = + .ok (.done fvarZetaSource) (fvarStuckState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + stuckSupport 0 fvarStuckCtx (fvarStuckState prims) ∧ + RecM.WhnfStep.Meaning RawProjRel.none worldGood stuckSupport 0 + fvarStuckCtx id fvarZetaSource (.done fvarZetaSource) := by + apply RecM.whnfCoreWithFlagsStep_fvarDone_acceptance structuralWhnfTheory + fvarStuckSource (fvarStuckStateInv prims) + intro declName ty val h + rw [fvarStuckFind prims] at h + cases h + +/-! ### stuck-reduction fallback projection and unchanged-head application fallbacks -/ + +/-- A well-typed constructor-headed application is not an iota redex. This +exercises the general application fallback with a non-lambda head and a real +argument spine. -/ +def appStuckHead : KExpr .anon := KExpr.mkConst succId #[] () +def appStuckSource : KExpr .anon := KExpr.mkApp appStuckHead betaArg + +def fallbackSupport : RunSupport where + expr e := stuckSupport e ∨ e = appStuckSource + exprFinite := stuckSupport.exprFinite.union + (FiniteSupport.singleton appStuckSource) + univ := stuckSupport.univ + univFinite := stuckSupport.univFinite + +theorem stuckSupport_le_fallbackSupport : stuckSupport ≤ fallbackSupport := by + exact ⟨fun _ h => .inl h, fun _ h => h⟩ + +theorem fallbackStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + fallbackSupport 0 [] (noAccelState prims) := by + have hbase := noAccelStateInv prims + refine ⟨?_, hbase.2.1, hbase.2.2⟩ + apply KernelStateWF.of_no_cache_entries + · exact hbase.1.core + · exact hbase.1.internSupport.mono + (RunSupport.le_trans support_le_stuckSupport + stuckSupport_le_fallbackSupport) + · rfl + · intro entry + simpa [noAccelState, state] using loadedEnv_noCacheEntries entry + +theorem appStuckHead_tr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + appStuckHead (.const succName []) := by + rw [appStuckHead, KExpr.mkConst_shape] + exact .const (ci := succConstant) nameOf_succ + (by simpa [worldGood, goodEnv, goodName, succName] using natEnv_succ) + (by intro l hl; simp at hl) rfl + +theorem appStuckHead_type : + worldGood.venv.HasType 0 [] (.const succName []) + (.forallE (.const natName []) (.const natName [])) := by + exact Lean4Lean.VEnv.HasType.const (env := worldGood.venv) + (U := 0) (Γ := []) (ci := succConstant) (ls := []) + (by simpa [worldGood, goodEnv, goodName, succName] using natEnv_succ) + (by intro l hl; simp at hl) rfl + +theorem appStuckHead_iotaNonLambda : IotaArgNonLambda appStuckHead := by + unfold appStuckHead + rw [KExpr.mkConst_shape] + exact .const + +theorem appStuckSource_tr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + appStuckSource + (.app (.const succName []) (.const zeroName [])) := by + rw [appStuckSource, KExpr.mkApp_shape] + exact .app appStuckHead_type betaArg_type appStuckHead_tr betaArg_tr + +/-- The transient non-lambda branch is inhabited by `Nat.succ Nat.zero`. +Production rebuilds the exact application without touching state, and the +result retains reflexive Theory meaning. -/ +theorem appStuckIotaTransient (methods : Methods .anon) (s : TcState .anon) : + (RecM.applyIotaArg appStuckHead betaArg true).run methods s = + .ok appStuckSource s ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] + appStuckSource appStuckSource := by + have h := RecM.applyIotaArg_true_nonlam_semantic + (sourceInfo := (KExpr.mkApp appStuckHead betaArg).info) + appStuckHead_iotaNonLambda methods s appStuckHead_type betaArg_type + appStuckHead_tr betaArg_tr + simpa [appStuckSource] using h + +theorem appStuckSourceWitness : + RecM.WhnfStep.Source RawProjRel.none worldGood fallbackSupport 0 [] + id appStuckSource := by + exact ⟨.inr rfl, _, appStuckSource_tr⟩ + +theorem appStuckSpine : + appStuckSource.collectSpine = (appStuckHead, #[betaArg]) := by + unfold appStuckSource appStuckHead + rw [KExpr.mkApp_shape, KExpr.mkConst_shape] rfl -private theorem driverCacheWhnfValid (kind : ExprCacheKind) - (hkind : kind = .whnf ∨ kind = .whnfNoDelta ∨ - kind = .whnfNoDeltaCheap) : - WhnfCacheValid whnfContextKeys RawProjRel.none - CacheSemantics.blockErrorsOnly (CacheAuthority.stable worldGood) - coreCacheSupport (.expr kind coreCacheKey betaArg) := by - rcases hkind with rfl | rfl | rfl <;> - intro source hsource haddr Δ hctx - all_goals - change source = betaSource ∨ source = betaArg at hsource - rcases hsource with rfl | rfl - · have hΔ : Δ = [] := by - simpa [whnfContextKeys, coreCacheKey] using hctx.2 - subst Δ - exact betaResultMeaning - · have hΔ : Δ = [] := by - simpa [whnfContextKeys, coreCacheKey] using hctx.2 - subst Δ - exact betaArgMeaning +theorem appStuckHeadWhnf (prims : Primitives .anon) (flags : WhnfFlags) : + betaHarnessMethods.whnfCoreFlags appStuckHead flags + (noAccelState prims) = + .ok appStuckHead (noAccelState prims) := rfl -theorem fullNoDeltaProvenance : - CacheProvenance whnfSemantics (CacheAuthority.stable worldGood) - coreCacheSupport (.expr .whnfNoDelta coreCacheKey betaArg) := by - refine ⟨?_, ?_, ?_⟩ - · exact ⟨⟨betaSource, .inl rfl, rfl⟩, .inr rfl⟩ - · exact coreCacheReferencesAuthorized .whnfNoDelta - · exact driverCacheWhnfValid .whnfNoDelta (.inr (.inl rfl)) +theorem appStuckHeadSelf : (appStuckHead != appStuckHead) = false := by + change Bool.not (appStuckHead.info.addr == appStuckHead.info.addr) = false + rw [beq_self_eq_true] + rfl -theorem fullWhnfProvenance : - CacheProvenance whnfSemantics (CacheAuthority.stable worldGood) - coreCacheSupport (.expr .whnf coreCacheKey betaArg) := by - refine ⟨?_, ?_, ?_⟩ - · exact ⟨⟨betaSource, .inl rfl, rfl⟩, .inr rfl⟩ - · exact coreCacheReferencesAuthorized .whnf - · exact driverCacheWhnfValid .whnf (.inl rfl) +theorem appStuckIota (prims : Primitives .anon) (flags : WhnfFlags) : + (RecM.tryIotaWithFlags appStuckSource flags).run betaHarnessMethods + (noAccelState prims) = + .ok none (noAccelState prims) := by + unfold RecM.tryIotaWithFlags appStuckSource appStuckHead + rw [KExpr.mkApp_shape, KExpr.mkConst_shape] + simp only [KExpr.collectSpine, KExpr.collectSpine.go] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst succId) _ (noAccelState prims) = _ + unfold EStateM.bind + rw [tryGetConst_succ_k1e] + rfl -def fullNoDeltaWarmState (prims : Primitives .anon) : TcState .anon := - let s := fullCoreWarmState prims - {s with env := {s.env with - whnfNoDeltaCache := s.env.whnfNoDeltaCache.insert coreCacheKey betaArg}} +/-- Non-vacuous application fallback acceptance: the source is translated +and well typed, but the constructor head is unchanged and iota misses. -/ +theorem appStuckAcceptance (prims : Primitives .anon) + (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsStep appStuckSource flags).run + betaHarnessMethods (noAccelState prims) = + .ok (.done appStuckSource) (noAccelState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + fallbackSupport 0 [] (noAccelState prims) ∧ + RecM.WhnfStep.Meaning RawProjRel.none worldGood fallbackSupport 0 [] + id appStuckSource (.done appStuckSource) := by + unfold appStuckSource at * + rw [KExpr.mkApp_shape] at * + apply RecM.whnfCoreWithFlagsStep_appUnchangedDone_acceptance + structuralWhnfTheory appStuckSourceWitness (fallbackStateInv prims) + appStuckSpine .const (appStuckHeadWhnf prims flags) + appStuckHeadSelf (appStuckIota prims flags) + +/-! The projection-miss fixture cannot use `RawProjRel.none`: that would make +its source-translation premise impossible. This identity interpretation is +nonempty and closed under every structural translation operation. -/ +namespace ProjectionFallback + +def projectionName : Lean.Name := `Ix.Tc.Verify.projectionFallback + +def projectionRel : RawProjRel := + fun _ _ _ value result => result = value + +theorem projectionRel_ok : + TrProjOK Lean4Lean.VEnv.empty 0 projectionRel := by + refine { + weakN := ?_ + instN := ?_ + wf := ?_ + uniq := ?_ + defeqDFC := ?_ + instL := ?_ } + · intro Γ Γ' n k s i e e' hlift hrel + subst e' + rfl + · intro Γ₀ e₀ A₀ k Γ₁ Γ s i e e' hinst hrel + subst e' + rfl + · intro Γ s i e e' hrel hwf + subst e' + exact hwf + · intro Γ₁ Γ₂ s i e₁ e₂ e₁' e₂' hctx h₁ h₂ hdefeq + subst e₁' + subst e₂' + exact hdefeq + · intro Γ₁ Γ₂ s i e₁ e₂ e' hctx hdefeq hrel + subst e' + exact ⟨e₂, rfl⟩ + · intro U' ls Γ s i e e' hlevels hrel + subst e' + rfl -theorem fullNoDeltaWarmStateInv (prims : Primitives .anon) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (fullNoDeltaWarmState prims) := by - exact RecM.WhnfDriverCacheUpdate.noDelta_whnfStateInv - (fullCoreWarmStateInv prims) fullNoDeltaProvenance +def world : VerifyWorld where + catalog := Catalog.empty + trusted := fun _ => False + venv := .empty + nameOf := fun addr => + if addr == AmbientNat.natAddress then some projectionName else none + venvWF := ⟨[], .empty⟩ + trustedCatalogued := fun h => False.elim h + +def value : KExpr .anon := KExpr.mkSort AmbientNat.zeroLevel +def source : KExpr .anon := KExpr.mkPrj AmbientNat.natId 0 value +def support : RunSupport := RunSupport.singleton source +def state : TcState .anon := + { TcState.ofEnvAnon ({} : KEnv .anon) with noAccel := true } + +theorem trustedCatalog : TrustedCatalogRel projectionRel world := by + exact TrustedCatalogLog.empty + +theorem stateCore : TcStateWF projectionRel state world := by + refine ⟨trustedCatalog, ?_, ?_⟩ + · exact LoadedAgrees.empty Catalog.empty + · exact InternTable.WF.empty -theorem noDeltaTrace (prims : Primitives .anon) : - RecM.WhnfNoDeltaTrace .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] betaHarnessMethods .FULL .collapse - maxWhnfFuel.toNat betaSource (fullCoreWarmState prims) betaArg - (fullCoreWarmState prims) := by - rw [show maxWhnfFuel.toNat = 10000 by rfl] - exact .done (fullCoreWarmStateInv prims) (betaNoDeltaStep prims) - (fullCoreWarmStateInv prims) betaResultMeaning +theorem stateInv : + WhnfStateInv .noAccel CacheSemantics.blockErrorsOnly projectionRel world + support 0 [] state := by + refine ⟨?_, ?_, rfl, Primitives.ofAnonAddrs_canonical⟩ + · apply KernelStateWF.of_no_cache_entries stateCore + · constructor + · intro x hx + obtain ⟨addr, haddr⟩ := hx + simp [state, TcState.ofEnvAnon] at haddr + · intro u hu + obtain ⟨addr, haddr⟩ := hu + simp [state, TcState.ofEnvAnon] at haddr + · rfl + · intro entry hentry + cases hentry <;> simp [state, TcState.ofEnvAnon] at * + · apply CtxRecon.empty <;> rfl -theorem fullCoreWarm_noDeltaMiss (prims : Primitives .anon) : - (fullCoreWarmState prims).env.whnfNoDeltaCache[coreCacheKey]? = none := by - simp [fullCoreWarmState, noAccelState, state, loadedEnv, KEnv.insert, - coreCacheKey] +def theory : WhnfTheory projectionRel world 0 where + literalWF := by + intro literal hliteral + cases literal <;> + simp [Lean4Lean.VEnv.ContainsLits, Lean4Lean.VEnv.contains, + Lean4Lean.VEnv.empty, world] + at hliteral + projections := projectionRel_ok + +theorem nameOf_projection : + world.nameOf AmbientNat.natAddress = some projectionName := by + simp [world] + +theorem value_tr : + TrKExprS world.venv 0 world.nameOf projectionRel [] value + (.sort .zero) := by + unfold value AmbientNat.zeroLevel + rw [KExpr.mkSort_shape] + exact .sort trivial + +theorem source_tr : + TrKExprS world.venv 0 world.nameOf projectionRel [] source + (.sort .zero) := by + unfold source + rw [KExpr.mkPrj_shape] + exact .prj nameOf_projection value_tr rfl -theorem fullNoDeltaWarm_hit (prims : Primitives .anon) : - (fullNoDeltaWarmState prims).env.whnfNoDeltaCache[coreCacheKey]? = - some betaArg := by - simp [fullNoDeltaWarmState, coreCacheKey] +theorem sourceWitness : + RecM.WhnfStep.Source projectionRel world support 0 [] id source := by + exact ⟨rfl, _, source_tr⟩ -theorem fullNoDeltaWarm_cheapMiss (prims : Primitives .anon) : - (fullNoDeltaWarmState prims).env.whnfNoDeltaCheapCache[coreCacheKey]? = - none := by - simp [fullNoDeltaWarmState, fullCoreWarmState, noAccelState, state, - loadedEnv, KEnv.insert, coreCacheKey] +theorem valueWhnf (flags : WhnfFlags) : + (if flags.cheapProj then + (RecM.whnfCoreFlagsRec value flags).run + AmbientNat.betaHarnessMethods state + else (RecM.whnfRec value).run AmbientNat.betaHarnessMethods state) = + .ok value state := by + cases flags.cheapProj <;> + simp [RecM.whnfCoreFlagsRec, RecM.whnfRec, + AmbientNat.betaHarnessMethods] <;> rfl + +theorem reduceMiss : + (RecM.tryProjReduce AmbientNat.natId 0 value).run + AmbientNat.betaHarnessMethods state = .ok none state := by + rw [RecM.tryProjReduce_eq, RecM.tryProjPrepare_eq] + unfold value + rw [KExpr.mkSort_shape] + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + unfold RecM.tryProjReduceTail + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (RecM.tryReduceFinValDecidableRec AmbientNat.natId 0 + (.sort AmbientNat.zeroLevel + (KExpr.mkSort AmbientNat.zeroLevel).info) #[]) + AmbientNat.betaHarnessMethods) _ state = _ + unfold EStateM.bind + rw [RecM.tryReduceFinValDecidableRec_noAccel rfl] + rfl -theorem fullNoDeltaColdAcceptance (prims : Primitives .anon) : - (RecM.whnfNoDelta betaSource).run betaHarnessMethods - (fullCoreWarmState prims) = - .ok betaArg (fullNoDeltaWarmState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (fullCoreWarmState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (fullNoDeltaWarmState prims) ∧ - WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by - simpa [RecM.whnfNoDelta, whnfSemantics, fullNoDeltaWarmState] using - (RecM.whnfNoDeltaImpl_fullMiss_acceptance - (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) - structuralWhnfTheory (.direct RecM.WhnfDriverNonLeaf.app) rfl - (coreCacheKey_eval (fullCoreWarmState prims)) - (betaTransientFalse (fullCoreWarmState prims)) - (fullCoreWarm_noDeltaMiss prims) (noDeltaTrace prims) rfl - fullNoDeltaProvenance) +/-- Non-vacuous projection fallback acceptance: the source translates under +the live projection relation, the value callback succeeds, and the production +helper nevertheless returns `none` without changing state. -/ +theorem acceptance (flags : WhnfFlags) : + (RecM.whnfCoreWithFlagsStep source flags).run + AmbientNat.betaHarnessMethods state = .ok (.done source) state ∧ + WhnfStateInv .noAccel CacheSemantics.blockErrorsOnly projectionRel world + support 0 [] state ∧ + RecM.WhnfStep.Meaning projectionRel world support 0 [] id source + (.done source) := by + unfold source at * + rw [KExpr.mkPrj_shape] at * + exact RecM.whnfCoreWithFlagsStep_projectionDone_acceptance theory + sourceWitness stateInv (valueWhnf flags) reduceMiss + +end ProjectionFallback + +/-! ### application rebuilding multi-beta and changed-head rebuilding -/ + +/-- A three-argument redex whose first two arguments feed two lambdas while +the third remains to be rebuilt. The body selects the outer function +argument, so production must reverse the consumed substitution vector: +`#[Nat.zero, Nat.succ]` maps `var 1` to `Nat.succ`. -/ +def multiBetaFunTy : KExpr .anon := + KExpr.mkAll () () supportExpr supportExpr +def multiBetaBody : KExpr .anon := KExpr.mkVar 1 () +def multiBetaInner : KExpr .anon := + KExpr.mkLam () () supportExpr multiBetaBody +def multiBetaLam : KExpr .anon := + KExpr.mkLam () () multiBetaFunTy multiBetaInner +def multiBetaSource : KExpr .anon := + KExpr.mkApp + (KExpr.mkApp (KExpr.mkApp multiBetaLam appStuckHead) betaArg) + betaArg + +set_option maxHeartbeats 800000 in +theorem multiBetaSpine : + multiBetaSource.collectSpine = + (multiBetaLam, #[appStuckHead, betaArg, betaArg]) := by + unfold multiBetaSource multiBetaLam + rw [KExpr.mkApp_shape, KExpr.mkApp_shape, KExpr.mkApp_shape] + rw [KExpr.mkLam_shape] + simp [KExpr.collectSpine, KExpr.collectSpine.go] -theorem fullNoDeltaWarmAcceptance (prims : Primitives .anon) : - (RecM.whnfNoDelta betaSource).run betaHarnessMethods - (fullNoDeltaWarmState prims) = - .ok betaArg (fullNoDeltaWarmState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (fullNoDeltaWarmState prims) ∧ - WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by - simpa [RecM.whnfNoDelta, whnfSemantics] using - (RecM.whnfNoDeltaImpl_fullHit_acceptance - (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) - (.direct RecM.WhnfDriverNonLeaf.app) rfl - (coreCacheKey_eval (fullNoDeltaWarmState prims)) - (betaTransientFalse (fullNoDeltaWarmState prims)) - (fullNoDeltaWarm_hit prims) (fullNoDeltaWarmStateInv prims) (.inl rfl) - (coreCacheKey_matches (fullNoDeltaWarmState prims) - (fullNoDeltaWarmStateInv prims).2.1)) +theorem multiBetaConsume : + RecM.consumeBetaLams multiBetaLam + #[appStuckHead, betaArg, betaArg] = + (multiBetaBody, #[appStuckHead, betaArg]) := by + unfold multiBetaLam multiBetaInner + rw [KExpr.mkLam_shape, KExpr.mkLam_shape] + rfl -theorem noDeltaCachePolicyIsolation (prims : Primitives .anon) : - (fullNoDeltaWarmState prims).env.whnfNoDeltaCache[coreCacheKey]? = - some betaArg ∧ - (fullNoDeltaWarmState prims).env.whnfNoDeltaCheapCache[coreCacheKey]? = - none := - ⟨fullNoDeltaWarm_hit prims, fullNoDeltaWarm_cheapMiss prims⟩ +/-- Exact argument-order witness for the real simultaneous-substitution +walker. Swapping the array entries would return `betaArg`, not +`appStuckHead`. -/ +theorem multiBetaWalker (it : InternTable .anon) : + simulSubst multiBetaBody #[betaArg, appStuckHead] 0 it = + (appStuckHead, it) := by + unfold multiBetaBody simulSubst + rw [KExpr.mkVar_lbr] + rw [KExpr.mkVar_shape] + have hlbr : + (KExpr.var 1 () (KExpr.mkVar (m := .anon) 1 ()).info).lbr = 2 := by + rw [← KExpr.mkVar_shape] + rfl + unfold runWalk simulSubstCached scratchGet? scratchInsert liftInternW lift + simp [stateM_bind, stateM_map, stateM_pure, hlbr] -/-! #### Full-WHNF loop, outer cache, and fuel witness -/ +theorem multiNatTr (Δ : KVLCtx) : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none Δ + supportExpr (.const natName []) := by + rw [supportExpr_eq_mkConst, KExpr.mkConst_shape] + exact .const (ci := natConstant) nameOf_nat + (by simpa [worldGood, goodEnv, goodName, natName] using natEnv_nat) + (by intro l hl; simp at hl) rfl -/-- The exact state after a genuine outer full-WHNF cache miss has paid its -single recursive-fuel charge. -/ -def fullWhnfChargedState (prims : Primitives .anon) : TcState .anon := - let s := fullNoDeltaWarmState prims - {s with recFuel := s.recFuel - 1} +theorem multiNatType (Γ : List Lean4Lean.VExpr) : + worldGood.venv.HasType 0 Γ (.const natName []) + (.sort (.succ .zero)) := by + exact Lean4Lean.VEnv.HasType.const (env := worldGood.venv) + (U := 0) (Γ := Γ) (ci := natConstant) (ls := []) + (by simpa [worldGood, goodEnv, goodName, natName] using natEnv_nat) + (by intro l hl; simp at hl) rfl -theorem fullWhnfChargedStateInv (prims : Primitives .anon) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (fullWhnfChargedState prims) := by - exact WhnfStateInv.of_semantic_fields_eq - (fullNoDeltaWarmStateInv prims) rfl rfl rfl rfl rfl rfl +theorem multiBetaFunTyTr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + multiBetaFunTy + (.forallE (.const natName []) (.const natName [])) := by + unfold multiBetaFunTy + rw [KExpr.mkAll_shape] + exact .all ⟨_, multiNatType []⟩ + ⟨_, multiNatType [(.const natName [])]⟩ + (multiNatTr []) + (multiNatTr [(none, .vlam (.const natName []))]) + +theorem multiBetaFunType (Γ : List Lean4Lean.VExpr) : + worldGood.venv.HasType 0 Γ + (.forallE (.const natName []) (.const natName [])) + (.sort ((Lean4Lean.VLevel.succ .zero).imax + (Lean4Lean.VLevel.succ .zero))) := + Lean4Lean.VEnv.HasType.forallE (multiNatType Γ) + (multiNatType ((.const natName []) :: Γ)) + +theorem multiBetaBodyTr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none + [(none, .vlam (.const natName [])), + (none, .vlam (.forallE (.const natName []) (.const natName [])))] + multiBetaBody (.bvar 1) := by + rw [multiBetaBody, KExpr.mkVar_shape] + exact .var rfl -theorem fullWhnfPrefixCold (prims : Primitives .anon) : - (RecM.whnfWithNatSuccModePrefix betaSource).run betaHarnessMethods - (fullNoDeltaWarmState prims) = - .ok () (fullNoDeltaWarmState prims) := by - exact RecM.whnfWithNatSuccModePrefix_disabled rfl rfl +theorem multiBetaBodyType : + worldGood.venv.HasType 0 + [(.const natName []), + (.forallE (.const natName []) (.const natName []))] + (.bvar 1) (.forallE (.const natName []) (.const natName [])) := by + exact Lean4Lean.VEnv.HasType.bvar + (Lean4Lean.Lookup.succ (Lean4Lean.Lookup.zero)) -theorem fullWhnfMissCharge (prims : Primitives .anon) : - (RecM.whnfWithNatSuccModeMissCharge : RecM .anon Unit).run - betaHarnessMethods (fullNoDeltaWarmState prims) = - .ok () (fullWhnfChargedState prims) := by - exact RecM.whnfWithNatSuccModeMissCharge_disabled rfl rfl +theorem multiBetaInnerTr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none + [(none, .vlam (.forallE (.const natName []) (.const natName [])))] + multiBetaInner + (.lam (.const natName []) (.bvar 1)) := by + unfold multiBetaInner + rw [KExpr.mkLam_shape] + exact .lam ⟨_, multiNatType + [(.forallE (.const natName []) (.const natName []))]⟩ + (multiNatTr + [(none, .vlam (.forallE (.const natName []) (.const natName [])))]) + multiBetaBodyTr + +theorem multiBetaInnerType : + worldGood.venv.HasType 0 + [(.forallE (.const natName []) (.const natName []))] + (.lam (.const natName []) (.bvar 1)) + (.forallE (.const natName []) + (.forallE (.const natName []) (.const natName []))) := by + exact Lean4Lean.VEnv.HasType.lam + (multiNatType + [(.forallE (.const natName []) (.const natName []))]) + multiBetaBodyType + +theorem multiBetaLamTr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + multiBetaLam + (.lam (.forallE (.const natName []) (.const natName [])) + (.lam (.const natName []) (.bvar 1))) := by + unfold multiBetaLam + rw [KExpr.mkLam_shape] + exact .lam ⟨_, multiBetaFunType []⟩ multiBetaFunTyTr multiBetaInnerTr + +theorem multiBetaLamType : + worldGood.venv.HasType 0 [] + (.lam (.forallE (.const natName []) (.const natName [])) + (.lam (.const natName []) (.bvar 1))) + (.forallE (.forallE (.const natName []) (.const natName [])) + (.forallE (.const natName []) + (.forallE (.const natName []) (.const natName [])))) := by + exact Lean4Lean.VEnv.HasType.lam (multiBetaFunType []) multiBetaInnerType + +def multiBetaApp1V : Lean4Lean.VExpr := + .app + (.lam (.forallE (.const natName []) (.const natName [])) + (.lam (.const natName []) (.bvar 1))) + (.const succName []) + +def multiBetaApp2V : Lean4Lean.VExpr := + .app multiBetaApp1V (.const zeroName []) + +def multiBetaSourceV : Lean4Lean.VExpr := + .app multiBetaApp2V (.const zeroName []) + +theorem multiBetaApp1Type : + worldGood.venv.HasType 0 [] multiBetaApp1V + (.forallE (.const natName []) + (.forallE (.const natName []) (.const natName []))) := by + unfold multiBetaApp1V + simpa using Lean4Lean.VEnv.HasType.app multiBetaLamType appStuckHead_type + +theorem multiBetaApp2Type : + worldGood.venv.HasType 0 [] multiBetaApp2V + (.forallE (.const natName []) (.const natName [])) := by + unfold multiBetaApp2V + simpa using Lean4Lean.VEnv.HasType.app multiBetaApp1Type betaArg_type + +theorem multiBetaSourceTr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + multiBetaSource multiBetaSourceV := by + unfold multiBetaSource + rw [KExpr.mkApp_shape, KExpr.mkApp_shape, KExpr.mkApp_shape] + unfold multiBetaSourceV multiBetaApp2V multiBetaApp1V + exact .app multiBetaApp2Type betaArg_type + (.app multiBetaApp1Type betaArg_type + (.app multiBetaLamType appStuckHead_type + multiBetaLamTr appStuckHead_tr) + betaArg_tr) + betaArg_tr + +theorem multiBetaSourceType : + worldGood.venv.HasType 0 [] multiBetaSourceV + (.const natName []) := by + unfold multiBetaSourceV + simpa using Lean4Lean.VEnv.HasType.app multiBetaApp2Type betaArg_type -/-- Fuel bookkeeping does not disturb the already populated no-delta cache. -/ -theorem fullWhnfCharged_noDeltaHit (prims : Primitives .anon) : - (RecM.whnfNoDeltaImpl betaSource .FULL .collapse).run - betaHarnessMethods (fullWhnfChargedState prims) = - .ok betaArg (fullWhnfChargedState prims) := by - rw [(RecM.WhnfDriverEntry.direct - (methods := betaHarnessMethods) (source := betaSource) - (s := fullWhnfChargedState prims) - RecM.WhnfDriverNonLeaf.app).noDelta_eval .FULL .collapse] - apply RecM.whnfNoDeltaImplNonLeaf_fullHit rfl - (coreCacheKey_eval (fullWhnfChargedState prims)) - (betaTransientFalse (fullWhnfChargedState prims)) - simp [fullWhnfChargedState, fullNoDeltaWarmState, coreCacheKey] +/-- The one dynamically generated trailing application is a real execution +request, not an unindexed support assumption. -/ +def multiBetaRequests : List WalkerRequest := + [.internExpr appStuckSource] -theorem betaFullChargedNatNone (prims : Primitives .anon) : - (RecM.tryReduceNatWithSuccMode betaArg .collapse).run betaHarnessMethods - (fullWhnfChargedState prims) = - .ok none (fullWhnfChargedState prims) := by - unfold RecM.tryReduceNatWithSuccMode betaArg - rw [KExpr.mkConst_shape] - simp [KExpr.collectSpine, KExpr.collectSpine.go, RecM.prims] - rfl +def multiBetaRunSupport : RunSupport := + RunSupport.singleton appStuckSource -theorem betaFullChargedStringNone (prims : Primitives .anon) : - (RecM.tryReduceString betaArg).run betaHarnessMethods - (fullWhnfChargedState prims) = - .ok none (fullWhnfChargedState prims) := by - unfold RecM.tryReduceString betaArg - rw [KExpr.mkConst_shape] - rfl +def multiBetaProgram : TcM .anon (KExpr .anon) := + TcM.intern appStuckSource -/-- `betaArg` is a bare constant: the offset-stuck probe either rejects its -head outright or the collected spine has no arguments — `none` either way, -for any primitive address assignment. -/ -theorem betaFullChargedNatOffsetStuckNone (prims : Primitives .anon) : - (RecM.tryNatOffsetStuck betaArg).run betaHarnessMethods - (fullWhnfChargedState prims) = - .ok none (fullWhnfChargedState prims) := by - unfold RecM.tryNatOffsetStuck - rw [ReaderT.run_bind] - change EStateM.bind ((RecM.prims).run betaHarnessMethods) _ - (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [show (RecM.prims (m := .anon)).run betaHarnessMethods - (fullWhnfChargedState prims) = - .ok prims (fullWhnfChargedState prims) from rfl] - simp only - cases hprobe : RecM.natOffsetStuckHead prims betaArg with - | false => rfl - | true => - simp only [Bool.not_true, Bool.false_eq_true, if_false] - unfold betaArg - rw [KExpr.mkConst_shape] - simp [KExpr.collectSpine, KExpr.collectSpine.go] +theorem multiBetaExecution (prims : Primitives .anon) : + ExecutionRequests multiBetaProgram (noAccelState prims) + multiBetaRequests := by + unfold multiBetaProgram multiBetaRequests + exact .internExpr (noAccelState prims) appStuckSource + +theorem multiBetaCheckSupport (prims : Primitives .anon) : + CheckConstSupport (noAccelState prims).env.intern + multiBetaRequests multiBetaRunSupport := by + constructor + · constructor + · intro x hx + obtain ⟨a, ha⟩ := hx + simp [noAccelState, state, loadedEnv, KEnv.insert] at ha + · intro u hu + obtain ⟨a, ha⟩ := hu + simp [noAccelState, state, loadedEnv, KEnv.insert] at ha + · intro request hmem + simp [multiBetaRequests] at hmem + subst request + constructor + · intro x hx + change x = appStuckSource + exact hx + · intro u hu + exact False.elim hu + +theorem multiBetaBounds : ResourceBounds multiBetaRequests := by + constructor + intro request hmem + simp [multiBetaRequests] at hmem + subst request + unfold appStuckSource appStuckHead + exact .app .const betaArg_constructed + +theorem multiBetaRunAssumptions (prims : Primitives .anon) : + RunAssumptions (noAccelState prims) multiBetaProgram + multiBetaRequests multiBetaRunSupport := + ⟨multiBetaExecution prims, + RunSupport.singleton_collisionFree appStuckSource, + multiBetaCheckSupport prims, multiBetaBounds⟩ + +theorem multiBetaStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + multiBetaRunSupport 0 [] (noAccelState prims) := by + have hbase := noAccelStateInv prims + refine ⟨?_, hbase.2.1, hbase.2.2⟩ + apply KernelStateWF.of_no_cache_entries + · exact hbase.1.core + · constructor + · intro x hx + obtain ⟨a, ha⟩ := hx + simp [noAccelState, state, loadedEnv, KEnv.insert] at ha + · intro u hu + obtain ⟨a, ha⟩ := hu + simp [noAccelState, state, loadedEnv, KEnv.insert] at ha + · rfl + · intro entry + simpa [noAccelState, state] using loadedEnv_noCacheEntries entry + +/-- The non-transient branch on the same application performs one real +intern-table update while preserving the complete WHNF invariant and the +same reflexive Theory meaning. -/ +theorem appStuckIotaInterned (prims : Primitives .anon) + (methods : Methods .anon) : + ∃ s', + (RecM.applyIotaArg appStuckHead betaArg false).run methods + (noAccelState prims) = .ok appStuckSource s' ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none + worldGood multiBetaRunSupport 0 [] s' ∧ + InternUpdateFrame (noAccelState prims) s' ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] + appStuckSource appStuckSource := by + have hcollision : multiBetaRunSupport.CollisionFree := by + unfold multiBetaRunSupport + exact RunSupport.singleton_collisionFree appStuckSource + have hsupport : multiBetaRunSupport (KExpr.mkApp appStuckHead betaArg) := by + unfold multiBetaRunSupport RunSupport.singleton appStuckSource rfl + have h := RecM.applyIotaArg_false_semantic + (sourceInfo := (KExpr.mkApp appStuckHead betaArg).info) + hcollision hsupport (multiBetaStateInv prims) methods + appStuckHead_type betaArg_type appStuckHead_tr betaArg_tr + simpa [appStuckSource] using h + +/-! ### ArgumentExecution iota-argument list execution -/ + +/-- Finite support for the three-segment executor fixture. It retains the +loaded state's original support root and adds both the unreduced function and +its one-argument result. -/ +def iotaArgsSupport : RunSupport where + expr e := support e ∨ e = appStuckHead ∨ e = appStuckSource + exprFinite := ⟨[supportExpr, appStuckHead, appStuckSource], by + intro e he + rcases he with he | he | he + · change e = supportExpr at he + subst e + simp + · subst e + simp + · subst e + simp⟩ + univ := support.univ + univFinite := support.univFinite + +theorem support_le_iotaArgsSupport : support ≤ iotaArgsSupport := by + exact ⟨fun _ h => .inl h, fun _ h => h⟩ + +theorem iotaArgsStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + iotaArgsSupport 0 [] (noAccelState prims) := by + have hbase := noAccelStateInv prims + refine ⟨?_, hbase.2.1, hbase.2.2⟩ + apply KernelStateWF.of_no_cache_entries + · exact hbase.1.core + · exact hbase.1.internSupport.mono support_le_iotaArgsSupport + · rfl + · intro entry + simpa [noAccelState, state] using loadedEnv_noCacheEntries entry + +theorem iotaArgsSupport_head : iotaArgsSupport appStuckHead := + .inr (.inl rfl) + +theorem iotaArgsSupport_source : iotaArgsSupport appStuckSource := + .inr (.inr rfl) + +/-- The actual three-call executor is inhabited with the argument placed in +the constructor-field segment. Empty prefix/trailing segments preserve the +same state; the middle transient non-lambda step rebuilds `Nat.succ Nat.zero` +without interning, and quotient transport recovers reflexive Theory meaning +for the complete application. -/ +theorem appStuckIotaTransientThreeSegments (prims : Primitives .anon) + (methods : Methods .anon) : + (do + let result ← RecM.applyIotaArgs appStuckHead #[] true + let result ← RecM.applyIotaArgs result #[betaArg] true + RecM.applyIotaArgs result #[] true).run methods + (noAccelState prims) = + .ok appStuckSource (noAccelState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + iotaArgsSupport 0 [] (noAccelState prims) ∧ + InternUpdateFrame (noAccelState prims) (noAccelState prims) ∧ + iotaArgsSupport appStuckSource ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] appStuckSource + appStuckSource := by + let hfirst : RecM.ApplyIotaArgsTrace .structuralNoAccel whnfSemantics + RawProjRel.none worldGood iotaArgsSupport 0 [] methods true + appStuckHead (.const succName []) (noAccelState prims) [] + appStuckHead (.const succName []) (noAccelState prims) := .nil _ _ _ + have hsecond := + RecM.ApplyIotaArgsTrace.transientNonLambdaSingleton + (support := iotaArgsSupport) (methods := methods) + appStuckHead_iotaNonLambda (iotaArgsStateInv prims) + iotaArgsSupport_source appStuckHead_type betaArg_type + appStuckHead_tr betaArg_tr + let hthird : RecM.ApplyIotaArgsTrace .structuralNoAccel whnfSemantics + RawProjRel.none worldGood iotaArgsSupport 0 [] methods true + appStuckSource + (.app (.const succName []) (.const zeroName [])) + (noAccelState prims) [] appStuckSource + (.app (.const succName []) (.const zeroName [])) + (noAccelState prims) := .nil _ _ _ + have h := RecM.ApplyIotaArgsTrace.threeArrayAcceptance + (first := #[]) (second := #[betaArg]) (third := #[]) + hfirst hsecond hthird structuralWhnfTheory (by trivial) + (iotaArgsStateInv prims) iotaArgsSupport_head appStuckHead_tr + simpa [appStuckSource] using h + +/-- Concrete lambda produced after the first transient application of the +three-argument multi-beta fixture. -/ +def multiIotaIntermediate : KExpr .anon := + KExpr.mkLam () () supportExpr appStuckHead + +theorem multiIotaFirstResult : + substNoIntern multiBetaInner appStuckHead 0 = multiIotaIntermediate := by + unfold multiBetaInner multiBetaBody multiIotaIntermediate appStuckHead + have hty : + substNoIntern supportExpr (KExpr.mkConst succId #[] ()) 0 = + supportExpr := by + exact KExpr.substNoIntern_of_lbr_le (by simp [supportExpr_lbr]) + have hbody : + substNoIntern (KExpr.mkVar 1 ()) (KExpr.mkConst succId #[] ()) 1 = + KExpr.mkConst succId #[] () := by + rw [KExpr.mkVar_shape, substNoIntern] + change (if (2 : UInt64) ≤ 1 then _ else _) = _ + rw [if_neg (by decide)] + simp only [beq_self_eq_true, if_true] + exact KExpr.liftNoIntern_of_lbr_le (by simp) + rw [KExpr.mkLam_shape] + rw [substNoIntern] + change (if (1 : UInt64) ≤ 0 then _ else _) = _ + rw [if_neg (by decide)] + rw [show (0 : UInt64) + 1 = 1 from rfl] + rw [hty, hbody] + +theorem multiIotaSecondResult : + substNoIntern appStuckHead betaArg 0 = appStuckHead := by + exact KExpr.substNoIntern_of_lbr_le (by simp [appStuckHead]) + +theorem appStuckHead_constructed : KExpr.Constructed appStuckHead := by + unfold appStuckHead + exact .const -theorem betaFullChargedGetZero (prims : Primitives .anon) : - TcM.tryGetConst zeroId (fullWhnfChargedState prims) = - .ok (some zeroConcrete) (fullWhnfChargedState prims) := by - unfold TcM.tryGetConst - change EStateM.bind (get : TcM .anon (TcState .anon)) _ - (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [show (get : TcM .anon (TcState .anon)) - (fullWhnfChargedState prims) = - .ok (fullWhnfChargedState prims) (fullWhnfChargedState prims) from rfl] - simp only - have henv : (fullWhnfChargedState prims).env.get? zeroId = - some zeroConcrete := by - simpa [fullWhnfChargedState, fullNoDeltaWarmState, fullCoreWarmState, - noAccelState, state] using loadedEnv_zero_k1e - rw [henv] - rfl +theorem multiBetaInner_constructed : KExpr.Constructed multiBetaInner := by + unfold multiBetaInner multiBetaBody + exact .lam supportExpr_constructed (.var (by decide)) + +theorem multiIotaIntermediate_constructed : + KExpr.Constructed multiIotaIntermediate := by + unfold multiIotaIntermediate + exact .lam supportExpr_constructed appStuckHead_constructed + +theorem appStuckHead_tr_ctx (Delta : KVLCtx) : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none Delta + appStuckHead (.const succName []) := by + rw [appStuckHead, KExpr.mkConst_shape] + exact .const (ci := succConstant) nameOf_succ + (by simpa [worldGood, goodEnv, goodName, succName] using natEnv_succ) + (by intro l hl; simp at hl) rfl -theorem betaFullChargedTryDeltaNone (prims : Primitives .anon) : - (RecM.tryDeltaUnfold betaArg).run betaHarnessMethods - (fullWhnfChargedState prims) = - .ok none (fullWhnfChargedState prims) := by - unfold RecM.tryDeltaUnfold betaArg - rw [KExpr.mkConst_shape] - simp only [KExpr.collectSpine, KExpr.collectSpine.go] - rw [ReaderT.run_bind] - change EStateM.bind (TcM.tryGetConst zeroId) _ - (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [betaFullChargedGetZero prims] - rfl +theorem appStuckHead_type_ctx (Gamma : List Lean4Lean.VExpr) : + worldGood.venv.HasType 0 Gamma (.const succName []) + (.forallE (.const natName []) (.const natName [])) := by + exact Lean4Lean.VEnv.HasType.const (env := worldGood.venv) + (U := 0) (Γ := Gamma) (ci := succConstant) (ls := []) + (by simpa [worldGood, goodEnv, goodName, succName] using natEnv_succ) + (by intro l hl; simp at hl) rfl -theorem betaFullChargedDeltaNone (prims : Primitives .anon) : - (RecM.deltaUnfoldOne betaArg).run betaHarnessMethods - (fullWhnfChargedState prims) = - .ok none (fullWhnfChargedState prims) := by - unfold RecM.deltaUnfoldOne - rw [ReaderT.run_bind] - change EStateM.bind - ((RecM.tryDeltaUnfold betaArg).run betaHarnessMethods) _ - (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [betaFullChargedTryDeltaNone prims] - unfold betaArg - rw [KExpr.mkConst_shape] - change EStateM.bind (TcM.tryGetConst zeroId) _ - (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [betaFullChargedGetZero prims] +theorem multiIotaIntermediate_tr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + multiIotaIntermediate + (.lam (.const natName []) (.const succName [])) := by + rw [multiIotaIntermediate, KExpr.mkLam_shape] + exact .lam ⟨_, multiNatType []⟩ (multiNatTr []) + (appStuckHead_tr_ctx + [(none, .vlam (.const natName []))]) + +/-- Support for the mixed transient executor includes every concrete +intermediate, not merely the final rebuilt application. -/ +def multiIotaSupport : RunSupport where + expr e := support e ∨ e = multiBetaLam ∨ e = multiIotaIntermediate ∨ + e = appStuckHead ∨ e = appStuckSource + exprFinite := + ⟨[supportExpr, multiBetaLam, multiIotaIntermediate, appStuckHead, + appStuckSource], by + intro e he + rcases he with he | he | he | he | he + · change e = supportExpr at he + subst e + simp + · subst e + simp + · subst e + simp + · subst e + simp + · subst e + simp⟩ + univ := support.univ + univFinite := support.univFinite + +theorem support_le_multiIotaSupport : support ≤ multiIotaSupport := by + exact ⟨fun _ h => .inl h, fun _ h => h⟩ + +theorem multiIotaStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + multiIotaSupport 0 [] (noAccelState prims) := by + have hbase := noAccelStateInv prims + refine ⟨?_, hbase.2.1, hbase.2.2⟩ + apply KernelStateWF.of_no_cache_entries + · exact hbase.1.core + · exact hbase.1.internSupport.mono support_le_multiIotaSupport + · rfl + · intro entry + simpa [noAccelState, state] using loadedEnv_noCacheEntries entry + +theorem multiIotaSupport_start : multiIotaSupport multiBetaLam := + .inr (.inl rfl) + +theorem multiIotaSupport_intermediate : + multiIotaSupport multiIotaIntermediate := + .inr (.inr (.inl rfl)) + +theorem multiIotaSupport_head : multiIotaSupport appStuckHead := + .inr (.inr (.inr (.inl rfl))) + +theorem multiIotaSupport_result : multiIotaSupport appStuckSource := + .inr (.inr (.inr (.inr rfl))) + +theorem multiIotaFirstTrace (prims : Primitives .anon) + (methods : Methods .anon) : + RecM.ApplyIotaArgsTrace .structuralNoAccel whnfSemantics + RawProjRel.none worldGood multiIotaSupport 0 [] methods true + multiBetaLam + (.lam (.forallE (.const natName []) (.const natName [])) + (.lam (.const natName []) (.bvar 1))) + (noAccelState prims) [appStuckHead] multiIotaIntermediate + multiBetaApp1V (noAccelState prims) := by + have hfirst := + RecM.ApplyIotaArgsTrace.transientLambdaSingletonQuot + (support := multiIotaSupport) (methods := methods) + (name := ()) (bi := ()) (ty := multiBetaFunTy) + (body := multiBetaInner) (arg := appStuckHead) + (info := (KExpr.mkLam () () multiBetaFunTy multiBetaInner).info) + multiBetaLamType appStuckHead_type + (RawProjRel.none_ok worldGood.venv 0) + multiBetaFunTyTr multiBetaInnerTr appStuckHead_tr + (multiBetaFunType []) multiBetaInnerType appStuckHead_type + multiBetaInner_constructed appStuckHead_constructed (by decide) + (multiIotaStateInv prims) + (by + rw [multiIotaFirstResult] + exact multiIotaSupport_intermediate) + simpa [multiBetaApp1V, multiIotaFirstResult] using hfirst + +theorem multiIotaSecondTrace (prims : Primitives .anon) + (methods : Methods .anon) : + RecM.ApplyIotaArgsTrace .structuralNoAccel whnfSemantics + RawProjRel.none worldGood multiIotaSupport 0 [] methods true + multiIotaIntermediate multiBetaApp1V (noAccelState prims) [betaArg] + appStuckHead multiBetaApp2V (noAccelState prims) := by + have hsecond := + RecM.ApplyIotaArgsTrace.transientLambdaSingletonQuot + (support := multiIotaSupport) (methods := methods) + (expectedV := multiBetaApp1V) + (name := ()) (bi := ()) (ty := supportExpr) (body := appStuckHead) + (arg := betaArg) + (info := (KExpr.mkLam () () supportExpr appStuckHead).info) + (A := .const natName []) (bodyV := .const succName []) + (argV := .const zeroName []) + (B := .forallE (.const natName []) (.const natName [])) + multiBetaApp1Type betaArg_type + (RawProjRel.none_ok worldGood.venv 0) + (multiNatTr []) + (appStuckHead_tr_ctx [(none, .vlam (.const natName []))]) + betaArg_tr betaA_type + (appStuckHead_type_ctx [(.const natName [])]) betaArg_type + appStuckHead_constructed betaArg_constructed (by decide) + (multiIotaStateInv prims) + (by + rw [multiIotaSecondResult] + exact multiIotaSupport_head) + rw [multiIotaIntermediate, KExpr.mkLam_shape] + simpa [multiBetaApp2V, multiIotaSecondResult] using hsecond + +theorem multiIotaThirdTrace (prims : Primitives .anon) + (methods : Methods .anon) : + RecM.ApplyIotaArgsTrace .structuralNoAccel whnfSemantics + RawProjRel.none worldGood multiIotaSupport 0 [] methods true + appStuckHead multiBetaApp2V (noAccelState prims) [betaArg] + appStuckSource multiBetaSourceV (noAccelState prims) := by + simpa [multiBetaSourceV] using + (RecM.ApplyIotaArgsTrace.transientNonLambdaSingletonQuot + (support := multiIotaSupport) (methods := methods) + (expectedV := multiBetaApp2V) + appStuckHead_iotaNonLambda (multiIotaStateInv prims) + multiIotaSupport_result multiBetaApp2Type betaArg_type + appStuckHead_type betaArg_type appStuckHead_tr betaArg_tr) + +/-- A non-vacuous ArgumentExecution trace across all three production segments. The +first argument beta-reduces the outer lambda to another lambda, the second +beta-reduces that quotient-mismatched intermediate to `Nat.succ`, and the +third rebuilds `Nat.succ Nat.zero`. Thus the final meaning proof genuinely +uses quotient transport rather than structural equality of intermediates. -/ +theorem multiIotaTransientThreeSegments (prims : Primitives .anon) + (methods : Methods .anon) : + (do + let result ← RecM.applyIotaArgs multiBetaLam #[appStuckHead] true + let result ← RecM.applyIotaArgs result #[betaArg] true + RecM.applyIotaArgs result #[betaArg] true).run methods + (noAccelState prims) = + .ok appStuckSource (noAccelState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + multiIotaSupport 0 [] (noAccelState prims) ∧ + InternUpdateFrame (noAccelState prims) (noAccelState prims) ∧ + multiIotaSupport appStuckSource ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] multiBetaSource + appStuckSource := by + have h := RecM.ApplyIotaArgsTrace.threeArrayAcceptance + (first := #[appStuckHead]) (second := #[betaArg]) + (third := #[betaArg]) (multiIotaFirstTrace prims methods) + (multiIotaSecondTrace prims methods) (multiIotaThirdTrace prims methods) + structuralWhnfTheory (by trivial) (multiIotaStateInv prims) + multiIotaSupport_start multiBetaLamTr + simpa [multiBetaSource] using h + +/-! ### SelectedRule selected-rule execution witness -/ + +def multiIotaRule : RecRule .anon := + { ctor := (), fields := 1, rhs := multiBetaLam } + +def multiIotaInfo : IotaInfo .anon := + { k := false, params := 1, motives := 0, minors := 0, indices := 0, + majorIdx := 1, rules := #[multiIotaRule], lvls := 0 } + +def multiIotaSpine : Array (KExpr .anon) := + #[appStuckHead, betaArg, betaArg] + +def multiIotaCtorArgs : Array (KExpr .anon) := #[betaArg] + +theorem multiIotaPrefixSlice : + RecM.iotaPrefixArgs multiIotaInfo multiIotaSpine = #[appStuckHead] := by rfl -/-- One full-WHNF iteration first consumes the certified no-delta hit, proves -the fresh cycle set cannot stop it, and then checks native, bitvector, Nat, -Decidable, String, offset-stuck, and delta reducers in their production -order. -/ -theorem betaFullWhnfStep (prims : Primitives .anon) : - (RecM.whnfWithNatSuccModeStep .collapse (betaSource, {})).run - betaHarnessMethods (fullWhnfChargedState prims) = - .ok (.done betaArg) (fullWhnfChargedState prims) := by - unfold RecM.whnfWithNatSuccModeStep - rw [ReaderT.run_bind] - change EStateM.bind - ((RecM.whnfNoDeltaImpl betaSource .FULL .collapse).run - betaHarnessMethods) _ (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [fullWhnfCharged_noDeltaHit prims] - simp only - have hcycle : ({} : Std.HashSet Address).contains betaArg.addr = false := by - change ({} : Std.HashMap Address Unit).contains betaArg.addr = false - exact Std.HashMap.contains_empty - simp only [hcycle, Bool.false_eq_true, if_false, pure_bind] - rw [ReaderT.run_bind] - change EStateM.bind - ((RecM.tryReduceNative betaArg).run betaHarnessMethods) _ - (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [RecM.tryReduceNative_noAccel rfl] - simp only - rw [ReaderT.run_bind] - change EStateM.bind - ((RecM.tryReduceBitvec betaArg).run betaHarnessMethods) _ - (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [RecM.tryReduceBitvec_noAccel rfl] - simp only - rw [ReaderT.run_bind] - change EStateM.bind - ((RecM.tryReduceNatWithSuccMode betaArg .collapse).run - betaHarnessMethods) _ (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [betaFullChargedNatNone prims] - simp only - rw [ReaderT.run_bind] - change EStateM.bind - ((RecM.tryReduceDecidable betaArg).run betaHarnessMethods) _ - (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [RecM.tryReduceDecidable_noAccel rfl] - simp only - rw [ReaderT.run_bind] - change EStateM.bind - ((RecM.tryReduceString betaArg).run betaHarnessMethods) _ - (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [betaFullChargedStringNone prims] - simp only - rw [ReaderT.run_bind] - change EStateM.bind - ((RecM.tryNatOffsetStuck betaArg).run betaHarnessMethods) _ - (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [betaFullChargedNatOffsetStuckNone prims] - simp only - rw [ReaderT.run_bind] - change EStateM.bind - ((RecM.deltaUnfoldOne betaArg).run betaHarnessMethods) _ - (fullWhnfChargedState prims) = _ - unfold EStateM.bind - rw [betaFullChargedDeltaNone prims] +theorem multiIotaFieldSlice : + RecM.iotaFieldArgs multiIotaCtorArgs 1 = #[betaArg] := by rfl -theorem fullWhnfTrace (prims : Primitives .anon) : - RecM.WhnfFullTrace .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] betaHarnessMethods .collapse - maxWhnfFuel.toNat (betaSource, {}) (fullWhnfChargedState prims) - betaArg (fullWhnfChargedState prims) := by - rw [show maxWhnfFuel.toNat = 10000 by rfl] - exact .done (fullWhnfChargedStateInv prims) (betaFullWhnfStep prims) - (fullWhnfChargedStateInv prims) betaResultMeaning +theorem multiIotaTrailingSlice : + RecM.iotaTrailingArgs multiIotaInfo multiIotaSpine = #[betaArg] := by + rfl -/-- The exact state after the full driver commits its semantic cache entry. -/ -def fullWhnfWarmState (prims : Primitives .anon) : TcState .anon := - let s := fullWhnfChargedState prims - {s with env := {s.env with - whnfCache := s.env.whnfCache.insert coreCacheKey betaArg}} +/-- A selected-rule trace whose three indices are the actual production +slices above. Universe instantiation takes its parameter-free fast path; +the three nonempty argument segments still execute beta, beta, then rebuild. -/ +def multiIotaRuleTrace (prims : Primitives .anon) (methods : Methods .anon) : + RecM.ApplyIotaRuleTrace .structuralNoAccel whnfSemantics + RawProjRel.none worldGood multiIotaSupport 0 [] methods multiIotaRule + #[] multiIotaInfo multiIotaSpine multiIotaCtorArgs 1 true + (.lam (.forallE (.const natName []) (.const natName [])) + (.lam (.const natName []) (.bvar 1))) + (noAccelState prims) appStuckSource multiBetaSourceV + (noAccelState prims) where + rhs := multiBetaLam + after := noAccelState prims + middle1 := multiIotaIntermediate + middle2 := appStuckHead + middleV1 := multiBetaApp1V + middleV2 := multiBetaApp2V + s1 := noAccelState prims + s2 := noAccelState prims + instantiate := rfl + prefixTrace := by + simpa [multiIotaPrefixSlice] using multiIotaFirstTrace prims methods + fieldTrace := by + simpa [multiIotaFieldSlice] using + multiIotaSecondTrace prims methods + trailingTrace := by + simpa [multiIotaTrailingSlice] using + multiIotaThirdTrace prims methods + +/-- ConstructorDispatch wraps the same non-vacuous selected-rule execution in production's +constructor-index dispatch and both of its guards. -/ +def multiIotaCtorTrace (prims : Primitives .anon) (methods : Methods .anon) : + RecM.ApplyIotaCtorTrace .structuralNoAccel whnfSemantics + RawProjRel.none worldGood multiIotaSupport 0 [] methods multiIotaInfo + #[] multiIotaSpine multiIotaCtorArgs 0 1 true multiIotaRule + (.lam (.forallE (.const natName []) (.const natName [])) + (.lam (.const natName []) (.bvar 1))) + (noAccelState prims) appStuckSource multiBetaSourceV + (noAccelState prims) where + selected := rfl + levelArity := rfl + fieldBound := by decide + ruleTrace := multiIotaRuleTrace prims methods + +/-- The complete extracted production helper is inhabited on nonempty values +in all three slices, not only the abstract list executor. -/ +theorem multiIotaRuleEval (prims : Primitives .anon) + (methods : Methods .anon) : + (RecM.applyIotaRule multiIotaRule #[] multiIotaInfo multiIotaSpine + multiIotaCtorArgs 1 true).run methods (noAccelState prims) = + .ok appStuckSource (noAccelState prims) := + (multiIotaRuleTrace prims methods).eval + +theorem multiIotaCtorEval (prims : Primitives .anon) + (methods : Methods .anon) : + (RecM.tryApplyIotaCtor multiIotaInfo #[] multiIotaSpine + multiIotaCtorArgs 0 1 true).run methods (noAccelState prims) = + .ok (some appStuckSource) (noAccelState prims) := + (multiIotaCtorTrace prims methods).eval + +theorem multiIotaRuleAcceptance (prims : Primitives .anon) + (methods : Methods .anon) : + (RecM.applyIotaRule multiIotaRule #[] multiIotaInfo multiIotaSpine + multiIotaCtorArgs 1 true).run methods (noAccelState prims) = + .ok appStuckSource (noAccelState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + multiIotaSupport 0 [] (noAccelState prims) ∧ + InternUpdateFrame (noAccelState prims) (noAccelState prims) ∧ + multiIotaSupport appStuckSource ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] multiBetaSource + appStuckSource := by + have h := (multiIotaRuleTrace prims methods).acceptance_empty rfl + structuralWhnfTheory (by trivial) (multiIotaStateInv prims) + (by simpa [multiIotaRule] using multiIotaSupport_start) + (by + simpa [multiIotaRule] using + (multiBetaLamTr.trKExpr worldGood.venvWF.ordered + structuralWhnfTheory.literalWF + structuralWhnfTheory.projections.wf (by trivial))) + obtain ⟨hrun, hfinalI, hframe, hfinalSupport, hfinalTr, hmeaning⟩ := h + exact ⟨hrun, hfinalI, hframe, hfinalSupport, by + simpa [multiIotaPrefixSlice, multiIotaFieldSlice, + multiIotaTrailingSlice, multiIotaRule, multiBetaSource] using hmeaning⟩ + +theorem multiIotaCtorAcceptance (prims : Primitives .anon) + (methods : Methods .anon) : + (RecM.tryApplyIotaCtor multiIotaInfo #[] multiIotaSpine + multiIotaCtorArgs 0 1 true).run methods (noAccelState prims) = + .ok (some appStuckSource) (noAccelState prims) ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + multiIotaSupport 0 [] (noAccelState prims) ∧ + InternUpdateFrame (noAccelState prims) (noAccelState prims) ∧ + multiIotaSupport appStuckSource ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] multiBetaSource + appStuckSource := by + have h := (multiIotaCtorTrace prims methods).acceptance_empty rfl + structuralWhnfTheory (by trivial) (multiIotaStateInv prims) + (by simpa [multiIotaRule] using multiIotaSupport_start) + (by + simpa [multiIotaRule] using + (multiBetaLamTr.trKExpr worldGood.venvWF.ordered + structuralWhnfTheory.literalWF + structuralWhnfTheory.projections.wf (by trivial))) + obtain ⟨hrun, hfinalI, hframe, hfinalSupport, hfinalTr, hmeaning⟩ := h + exact ⟨hrun, hfinalI, hframe, hfinalSupport, by + simpa [multiIotaPrefixSlice, multiIotaFieldSlice, + multiIotaTrailingSlice, multiIotaRule, multiBetaSource] using hmeaning⟩ + +theorem multiBetaFinishRequests : + RecM.FinishAppRequests multiBetaRequests + (#[appStuckHead, betaArg, betaArg].extract 2 3).toList + appStuckHead appStuckSource := by + change RecM.FinishAppRequests multiBetaRequests [betaArg] + appStuckHead appStuckSource + apply RecM.FinishAppRequests.cons + · simp [multiBetaRequests, appStuckSource] + · simpa [appStuckSource] using + (RecM.FinishAppRequests.nil (requests := multiBetaRequests) + appStuckSource) + +theorem multiBetaWalkerEval (prims : Primitives .anon) : + TcM.runIntern (simulSubst multiBetaBody #[betaArg, appStuckHead] 0) + (noAccelState prims) = .ok appStuckHead (noAccelState prims) := by + unfold TcM.runIntern + rw [multiBetaWalker] + +/-- Inhabited application rebuilding multi-beta acceptance: the source is translated and typed, +the walker selects the outer function argument, exactly one trailing argument +is rebuilt, and the complete post-state invariant plus intern-only frame are +retained. -/ +theorem multiBetaStep (prims : Primitives .anon) (flags : WhnfFlags) : + ∃ s', + (RecM.whnfCoreWithFlagsStep multiBetaSource flags).run + betaHarnessMethods (noAccelState prims) = + .ok (.next appStuckSource) s' ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + multiBetaRunSupport 0 [] s' ∧ + InternUpdateFrame (noAccelState prims) s' ∧ + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + multiBetaSource multiBetaSourceV ∧ + worldGood.venv.HasType 0 [] multiBetaSourceV + (.const natName []) := by + obtain ⟨s', hfinish, hI', hframe⟩ := + multiBetaFinishRequests.eval + (multiBetaRunAssumptions prims) (multiBetaStateInv prims) + refine ⟨s', ?_, hI', hframe, multiBetaSourceTr, multiBetaSourceType⟩ + exact RecM.whnfCoreWithFlagsStep_betaMany multiBetaSpine rfl + multiBetaConsume rfl (by simpa using multiBetaWalkerEval prims) hfinish + +/-- Two physically distinct raw heads that nevertheless translate to the +same trusted `Nat.succ` constant. The forged info addresses are deliberate: +this fixture attacks control-flow equality, while the generic finite-request +theorems above cover constructed production values. -/ +def changedHeadOriginal : KExpr .anon := + .const succId #[] (info iotaAddress) + +def changedHeadNew : KExpr .anon := + .const succId #[] (info goodAddress) + +def changedHeadSource : KExpr .anon := + KExpr.mkApp changedHeadOriginal betaArg + +def changedHeadRebuilt : KExpr .anon := + KExpr.mkApp changedHeadNew betaArg + +theorem changedHeadPhysical : + (changedHeadNew != changedHeadOriginal) = true := by + change Bool.not (goodAddress == iotaAddress) = true + simp [goodAddress, iotaAddress, address] + +theorem changedHeadSpine : + changedHeadSource.collectSpine = (changedHeadOriginal, #[betaArg]) := by + unfold changedHeadSource changedHeadOriginal + rw [KExpr.mkApp_shape] + rfl -theorem fullWhnfWarmStateInv (prims : Primitives .anon) : - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (fullWhnfWarmState prims) := by - exact RecM.WhnfDriverCacheUpdate.full_whnfStateInv - (fullWhnfChargedStateInv prims) fullWhnfProvenance +theorem changedHeadOriginalTr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + changedHeadOriginal (.const succName []) := by + exact .const (ci := succConstant) nameOf_succ + (by simpa [worldGood, goodEnv, goodName, succName] using natEnv_succ) + (by intro l hl; simp at hl) rfl -theorem fullWhnfCold_miss (prims : Primitives .anon) : - (fullNoDeltaWarmState prims).env.whnfCache[coreCacheKey]? = none := by - simp [fullNoDeltaWarmState, fullCoreWarmState, noAccelState, state, - loadedEnv, KEnv.insert, coreCacheKey] +theorem changedHeadNewTr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + changedHeadNew (.const succName []) := by + exact .const (ci := succConstant) nameOf_succ + (by simpa [worldGood, goodEnv, goodName, succName] using natEnv_succ) + (by intro l hl; simp at hl) rfl -theorem fullWhnfWarm_hit (prims : Primitives .anon) : - (fullWhnfWarmState prims).env.whnfCache[coreCacheKey]? = - some betaArg := by - simp [fullWhnfWarmState, coreCacheKey] +theorem changedHeadSourceTr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + changedHeadSource + (.app (.const succName []) (.const zeroName [])) := by + unfold changedHeadSource + rw [KExpr.mkApp_shape] + exact .app appStuckHead_type betaArg_type changedHeadOriginalTr betaArg_tr -theorem fullWhnfPrefixWarm (prims : Primitives .anon) : - (RecM.whnfWithNatSuccModePrefix betaSource).run betaHarnessMethods - (fullWhnfWarmState prims) = .ok () (fullWhnfWarmState prims) := by - exact RecM.whnfWithNatSuccModePrefix_disabled rfl rfl +theorem changedHeadRebuiltTr : + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + changedHeadRebuilt + (.app (.const succName []) (.const zeroName [])) := by + unfold changedHeadRebuilt + rw [KExpr.mkApp_shape] + exact .app appStuckHead_type betaArg_type changedHeadNewTr betaArg_tr + +theorem changedHeadMeaning : + WhnfMeaning RawProjRel.none worldGood 0 [] changedHeadSource + changedHeadRebuilt := by + exact ⟨_, _, changedHeadSourceTr, changedHeadRebuiltTr, + Lean4Lean.VEnv.IsDefEqU.refl + ⟨_, Lean4Lean.VEnv.HasType.app appStuckHead_type betaArg_type⟩⟩ + +def changedHeadSupport : RunSupport := + RunSupport.singleton changedHeadRebuilt + +theorem changedHeadStateInv (prims : Primitives .anon) : + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + changedHeadSupport 0 [] (noAccelState prims) := by + have hbase := noAccelStateInv prims + refine ⟨?_, hbase.2.1, hbase.2.2⟩ + apply KernelStateWF.of_no_cache_entries + · exact hbase.1.core + · constructor + · intro x hx + obtain ⟨a, ha⟩ := hx + simp [noAccelState, state, loadedEnv, KEnv.insert] at ha + · intro u hu + obtain ⟨a, ha⟩ := hu + simp [noAccelState, state, loadedEnv, KEnv.insert] at ha + · rfl + · intro entry + simpa [noAccelState, state] using loadedEnv_noCacheEntries entry + +/-- Low-level exact interning spec for the intentionally raw rebuilt term. +It uses the singleton collision domain directly; unlike normal production +requests it does not claim `KExpr.Constructed` for the forged metadata. -/ +theorem changedHeadInternSpec (it : InternTable .anon) (hwf : it.WF) + (hsup : changedHeadSupport.CoversIntern it) : + (internExprM changedHeadRebuilt it).1 = changedHeadRebuilt ∧ + (internExprM changedHeadRebuilt it).2.WF ∧ + changedHeadSupport.CoversIntern + (internExprM changedHeadRebuilt it).2 := by + unfold internExprM + have hkcf : KExpr.KeyCollisionFree + (fun v => it.ExprSupport v ∨ v = changedHeadRebuilt) := + KExpr.keyCollisionFree_anon.mpr <| + (RunSupport.singleton_collisionFree changedHeadRebuilt).expr.mono + fun x hx => hx.elim (hsup.expr x) (fun h => h) + have hcanon : + (it.internExpr changedHeadRebuilt).1 = changedHeadRebuilt := by + have heq := InternTable.internExpr_eraseMeta hwf hkcf + rwa [KExpr.eraseMeta_anon, KExpr.eraseMeta_anon] at heq + refine ⟨hcanon, hwf.internExpr changedHeadRebuilt, ?_⟩ + constructor + · intro x hx + rcases InternTable.ExprSupport.of_internExpr hx with hx | rfl + · exact hsup.expr x hx + · rfl + · intro u hu + exact hsup.univ u (by + simpa only [InternTable.UnivSupport, + InternTable.internExpr_univs] using hu) + +theorem changedHeadInternEval (prims : Primitives .anon) : + ∃ s', TcM.intern changedHeadRebuilt (noAccelState prims) = + .ok changedHeadRebuilt s' ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + changedHeadSupport 0 [] s' ∧ + InternUpdateFrame (noAccelState prims) s' := by + exact TcM.runIntern_whnf_eval changedHeadInternSpec + (changedHeadStateInv prims) + +/-- Harness that forces the recursive callback across the changed-head +branch. As with the earlier beta harness, the generic theorem—not this +fixture table—carries the eventual `Methods.WF` obligation. -/ +def changedHeadMethods : Methods .anon where + whnf := fun e => pure e + whnfCore := fun e => pure e + whnfMode := fun e _ => pure e + whnfCoreFlags := fun _ _ => pure changedHeadNew + infer := fun e => pure e + isDefEq := fun _ _ => pure false -/-- A cold public full-WHNF call pays one miss charge, executes its bounded -semantic trace, inserts the result, and preserves the complete invariant. -/ -theorem fullWhnfColdAcceptance (prims : Primitives .anon) : - (RecM.whnf betaSource).run betaHarnessMethods - (fullNoDeltaWarmState prims) = - .ok betaArg (fullWhnfWarmState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (fullWhnfChargedState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (fullWhnfWarmState prims) ∧ - WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by - simpa [RecM.whnf, whnfSemantics, fullWhnfWarmState] using - (RecM.whnfWithNatSuccMode_miss_acceptance - (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) - structuralWhnfTheory (.direct RecM.WhnfDriverNonLeaf.app) - (fullWhnfPrefixCold prims) - (coreCacheKey_eval (fullNoDeltaWarmState prims)) - (betaTransientFalse (fullNoDeltaWarmState prims)) - (fullWhnfCold_miss prims) (fullWhnfMissCharge prims) - (fullWhnfTrace prims) rfl fullWhnfProvenance) +theorem changedHeadIotaMiss (prims : Primitives .anon) + {s' : TcState .anon} (hframe : InternUpdateFrame (noAccelState prims) s') + (flags : WhnfFlags) : + (RecM.tryIotaWithFlags changedHeadRebuilt flags).run + changedHeadMethods s' = .ok none s' := by + unfold RecM.tryIotaWithFlags changedHeadRebuilt changedHeadNew + rw [KExpr.mkApp_shape] + simp only [KExpr.collectSpine, KExpr.collectSpine.go] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst succId) _ s' = _ + unfold EStateM.bind + have hget : s'.env.get? succId = some succConcrete := by + rw [hframe] + simpa [noAccelState, state] using loadedEnv_succ_k1e + have hlookup : TcM.tryGetConst succId s' = + .ok (some succConcrete) s' := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s' = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s' = .ok s' s' from rfl] + simp only + rw [hget] + rfl + rw [hlookup] + rfl -/-- The next public call consumes the inserted entry as a semantic hit and -does not pay another fuel charge or mutate any checker state. -/ -theorem fullWhnfWarmAcceptance (prims : Primitives .anon) : - (RecM.whnf betaSource).run betaHarnessMethods - (fullWhnfWarmState prims) = - .ok betaArg (fullWhnfWarmState prims) ∧ - WhnfStateInv .noAccel whnfSemantics RawProjRel.none worldGood - coreCacheSupport 0 [] (fullWhnfWarmState prims) ∧ - WhnfMeaning RawProjRel.none worldGood 0 [] betaSource betaArg := by - simpa [RecM.whnf, whnfSemantics] using - (RecM.whnfWithNatSuccMode_hit_acceptance - (keys := whnfContextKeys) (fallback := CacheSemantics.blockErrorsOnly) - (.direct RecM.WhnfDriverNonLeaf.app) (fullWhnfPrefixWarm prims) - (coreCacheKey_eval (fullWhnfWarmState prims)) - (betaTransientFalse (fullWhnfWarmState prims)) - (fullWhnfWarm_hit prims) (fullWhnfWarmStateInv prims) (.inl rfl) - (coreCacheKey_matches (fullWhnfWarmState prims) - (fullWhnfWarmStateInv prims).2.1)) +/-- Inhabited changed-head/iota-miss acceptance. The returned `.done` term +is the rebuilt application; the original and rebuilt sources are physically +different but have the same trusted Theory translation. -/ +theorem changedHeadStep (prims : Primitives .anon) (flags : WhnfFlags) : + ∃ s', + (RecM.whnfCoreWithFlagsStep changedHeadSource flags).run + changedHeadMethods (noAccelState prims) = + .ok (.done changedHeadRebuilt) s' ∧ + WhnfStateInv .structuralNoAccel whnfSemantics RawProjRel.none worldGood + changedHeadSupport 0 [] s' ∧ + InternUpdateFrame (noAccelState prims) s' ∧ + WhnfMeaning RawProjRel.none worldGood 0 [] changedHeadSource + changedHeadRebuilt := by + obtain ⟨s', hintern, hI', hframe⟩ := changedHeadInternEval prims + have hfinish : + (RecM.finishAppResult changedHeadNew #[betaArg] 0).run + changedHeadMethods (noAccelState prims) = + .ok changedHeadRebuilt s' := by + apply RecM.finishAppResult_one + simpa [changedHeadRebuilt] using hintern + refine ⟨s', ?_, hI', hframe, changedHeadMeaning⟩ + exact RecM.whnfCoreWithFlagsStep_appChangedDone changedHeadSpine + .const rfl changedHeadPhysical hfinish + (changedHeadIotaMiss prims hframe flags) + +/-! ### NatRecognizer descriptor success witness -/ + +/-- A deliberately untrusted recursor with the two minors required by the +linear descriptor. This fixture exercises operational trace completeness; +it is not used as semantic recursor evidence. -/ +def linearRecConcrete : KConst .anon := + .recr () () false false 0 0 0 0 2 natId 0 natRef + #[iotaRule, iotaRule] () + +def linearRecPrims (prims : Primitives .anon) : Primitives .anon := + { prims with natRec := iotaId } + +def linearRecState (prims : Primitives .anon) : TcState .anon := + let base := noAccelState (linearRecPrims prims) + { base with env := base.env.insert iotaId linearRecConcrete } + +def linearRecHead : KExpr .anon := KExpr.mkConst iotaId #[] () + +def linearRecMajor : KExpr .anon := .nat 3 iotaAddress (info iotaAddress) + +def linearRecSource : KExpr .anon := + KExpr.mkApp + (KExpr.mkApp (KExpr.mkApp linearRecHead iotaResult) iotaResult) + linearRecMajor + +def linearRecParts : NatRecLiteralParts .anon := + { spine := #[iotaResult, iotaResult, linearRecMajor] + major := 3 + baseIdx := 0 + stepIdx := 1 + majorIdx := 2 } + +theorem linearRecSpine : + linearRecSource.collectSpine = + (linearRecHead, #[iotaResult, iotaResult, linearRecMajor]) := by + unfold linearRecSource + rw [KExpr.mkApp_shape] + unfold KExpr.collectSpine + rw [KExpr.collectSpine.go, KExpr.mkApp_shape, + KExpr.collectSpine.go, KExpr.mkApp_shape, + KExpr.collectSpine.go] + unfold linearRecHead + rw [KExpr.mkConst_shape] + change + (KExpr.const iotaId #[] (KExpr.mkConst iotaId #[] ()).info, + (#[linearRecMajor, iotaResult, iotaResult] : + Array (KExpr .anon)).reverse) = _ + simp + +theorem linearRecMajorAt : + (#[iotaResult, iotaResult, linearRecMajor] : Array (KExpr .anon))[2]? = + some (.nat 3 iotaAddress (info iotaAddress)) := by + rfl -/-- The cold outer miss consumes exactly one unit; cache insertion and the -subsequent warm hit consume none. -/ -theorem fullWhnfFuelDiscipline (prims : Primitives .anon) : - (fullNoDeltaWarmState prims).recFuel = maxRecFuel ∧ - (fullWhnfChargedState prims).recFuel = maxRecFuel - 1 ∧ - (fullWhnfWarmState prims).recFuel = maxRecFuel - 1 := by - simp [fullWhnfWarmState, fullWhnfChargedState, fullNoDeltaWarmState, - fullCoreWarmState, noAccelState, state] +theorem linearRecGet (prims : Primitives .anon) : + TcM.tryGetConst iotaId (linearRecState prims) = + .ok (some linearRecConcrete) (linearRecState prims) := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ + (linearRecState prims) = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) (linearRecState prims) = + .ok (linearRecState prims) (linearRecState prims) from rfl] + simp only + have henv : (linearRecState prims).env.get? iotaId = + some linearRecConcrete := by + simp [linearRecState, KEnv.get?, KEnv.insert] + rw [henv] + rfl -/-- The final state retains all three independently certified cache layers: -structural core, no-delta, and full WHNF. -/ -theorem fullWhnfCacheLayering (prims : Primitives .anon) : - (fullWhnfWarmState prims).env.whnfCache[coreCacheKey]? = some betaArg ∧ - (fullWhnfWarmState prims).env.whnfNoDeltaCache[coreCacheKey]? = - some betaArg ∧ - (fullWhnfWarmState prims).env.whnfCoreCache[coreCacheKey]? = - some betaArg := by - constructor - · exact fullWhnfWarm_hit prims - constructor <;> simp [fullWhnfWarmState, fullWhnfChargedState, - fullNoDeltaWarmState, fullCoreWarmState, coreCacheKey] +/-- A real successful descriptor execution, certified through NatRecognizer's trace +and then inverted again by trace completeness. -/ +theorem linearRecPartsRun (prims : Primitives .anon) : + (RecM.natRecLiteralParts linearRecSource).run betaHarnessMethods + (linearRecState prims) = + .ok (some linearRecParts) (linearRecState prims) := by + apply RecM.NatRecLiteralPartsSuccessTrace.eval + refine .intro linearRecSpine ?_ (linearRecGet prims) (by decide) + linearRecMajorAt + · simp [linearRecState, linearRecPrims, noAccelState, state] + +theorem linearRecPartsTrace (prims : Primitives .anon) : + RecM.NatRecLiteralPartsSuccessTrace betaHarnessMethods linearRecSource + (linearRecState prims) linearRecParts (linearRecState prims) := + RecM.NatRecLiteralPartsSuccessTrace.complete (linearRecPartsRun prims) + +/-! ### NatPatternMatching constructive iota-match witnesses -/ + +/-- A concrete two-argument recursor prefix mirroring the descriptor fixture's +major position. The argument values are immaterial to pattern matching; the +count and constant head are not. -/ +def linearRecTheoryPrefix : Lean4Lean.VExpr := + .app + (.app (.const ``Nat.rec []) (.const ``Nat [])) + (.const ``Nat []) + +theorem linearRecTheoryPrefix_shape : + HeadConstN ``Nat.rec 2 linearRecTheoryPrefix := by + unfold linearRecTheoryPrefix + simpa using HeadConstN.app + (HeadConstN.app (HeadConstN.const (name := ``Nat.rec) [])) + +/-- The zero branch constructs Lean4Lean's real dependent capture map. -/ +theorem linearRecZeroPatternMatch : + ∃ (levels : List Lean4Lean.VLevel) + (captures : (RecursorIotaPattern ``Nat.rec 2 ``Nat.zero 0).Path → + Lean4Lean.VExpr), + Lean4Lean.Pattern.Matches + (RecursorIotaPattern ``Nat.rec 2 ``Nat.zero 0) + (.app linearRecTheoryPrefix (Lean4Lean.VExpr.natLit 0)) + levels captures := + RecursorIotaPattern.matches_natZero linearRecTheoryPrefix_shape + +/-- The successor branch constructs a capture map whose constructor argument +is the canonical predecessor numeral. -/ +theorem linearRecSuccPatternMatch : + ∃ (levels : List Lean4Lean.VLevel) + (captures : (RecursorIotaPattern ``Nat.rec 2 ``Nat.succ 1).Path → + Lean4Lean.VExpr), + Lean4Lean.Pattern.Matches + (RecursorIotaPattern ``Nat.rec 2 ``Nat.succ 1) + (.app linearRecTheoryPrefix (Lean4Lean.VExpr.natLit 3)) + levels captures := by + simpa using (RecursorIotaPattern.matches_natSucc + (predecessor := 2) linearRecTheoryPrefix_shape) + +/-! ### NatRuleLayout adversarial layout and suffix witnesses -/ + +/-- Reporting two minors does not force either corresponding rule slot to +exist. This declaration passes the descriptor's count check while carrying +an empty rule array. -/ +def missingRuleRecursor : KConst .anon := + .recr () () false false 0 0 0 0 2 natId 0 natRef #[] () + +theorem missingRuleDescriptor : + RecM.NatRecLiteralPartsDescriptor iotaId missingRuleRecursor + linearRecSource linearRecParts := by + refine ⟨#[], (KExpr.mkConst iotaId #[] ()).info, + #[iotaResult, iotaResult, linearRecMajor], (), (), false, false, + 0, 0, 0, 0, 2, natId, 0, natRef, #[], (), 3, iotaAddress, + info iotaAddress, ?_, rfl, by decide, linearRecMajorAt, rfl⟩ + change linearRecSource.collectSpine = + (linearRecHead, #[iotaResult, iotaResult, linearRecMajor]) + exact linearRecSpine + +theorem missingRuleDescriptor_noZeroRule : + ¬∃ rule, missingRuleRecursor.RecursorRuleAt 0 rule := by + simp [missingRuleRecursor, KConst.RecursorRuleAt] + +/-- Splitting the translated three-argument beta fixture at its middle +argument retains the final argument in a nonempty typed suffix. -/ +theorem multiBetaMiddleSplit : + ∃ (priorArgs laterArgs : List (KExpr .anon)) + (priorV majorV : Lean4Lean.VExpr), + [appStuckHead, betaArg, betaArg] = + priorArgs ++ betaArg :: laterArgs ∧ + 1 = priorArgs.length ∧ + RecM.TrAppSpine worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + multiBetaLam priorArgs priorV ∧ + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + betaArg majorV ∧ + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + (KExpr.mkApp (priorArgs.foldl KExpr.mkApp multiBetaLam) betaArg) + (.app priorV majorV) ∧ + RecM.TrAppSuffix worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + (.app priorV majorV) laterArgs multiBetaSourceV ∧ + laterArgs ≠ [] := by + have hspine : RecM.TrAppSpine worldGood.venv 0 worldGood.nameOf + RawProjRel.none [] multiBetaLam + [appStuckHead, betaArg, betaArg] multiBetaSourceV := by + simpa using RecM.trAppSpine_of_collectSpine + multiBetaSourceTr multiBetaSpine + obtain ⟨priorArgs, laterArgs, priorV, majorV, hargs, hindex, hpriorTr, + hmajorTr, hthroughTr, hlaterTr⟩ := + hspine.splitAt (major := betaArg) (majorIdx := 1) (by rfl) + have hlater : laterArgs ≠ [] := by + intro hempty + have hlength := congrArg List.length hargs + simp only [List.length_cons, List.length_append] at hlength + rw [hempty] at hlength + simp only [List.length_nil] at hlength + omega + exact ⟨priorArgs, laterArgs, priorV, majorV, hargs, hindex, hpriorTr, + hmajorTr, hthroughTr, hlaterTr, hlater⟩ + +/-- NatReduction's suffix transport is inhabited on a genuinely nonempty suffix. +Replacing the through-middle prefix by its own translation reconstructs the +final application rather than silently returning the prefix. -/ +theorem multiBetaMiddleRebase : + ∃ (priorArgs laterArgs : List (KExpr .anon)) + (resultV : Lean4Lean.VExpr), + laterArgs ≠ [] ∧ + TrKExprS worldGood.venv 0 worldGood.nameOf RawProjRel.none [] + (laterArgs.foldl KExpr.mkApp + (KExpr.mkApp (priorArgs.foldl KExpr.mkApp multiBetaLam) betaArg)) + resultV ∧ + worldGood.venv.IsDefEqU 0 [] multiBetaSourceV resultV := by + obtain ⟨priorArgs, laterArgs, priorV, majorV, hargs, hindex, hpriorTr, + hmajorTr, hthroughTr, hlaterTr, hlater⟩ := multiBetaMiddleSplit + obtain ⟨throughType, hthroughType⟩ := + hlaterTr.startHasType multiBetaSourceType + have hthroughEq : worldGood.venv.IsDefEqU 0 [] + (.app priorV majorV) (.app priorV majorV) := + ⟨throughType, hthroughType⟩ + obtain ⟨resultV, hresultTr, hresultEq⟩ := + hlaterTr.rebase worldGood.venvWF (by trivial) hthroughTr hthroughEq + exact ⟨priorArgs, laterArgs, resultV, hlater, hresultTr, hresultEq⟩ /-- G2a acceptance witness: one concrete state simultaneously contains a trusted, well-formed ambient Nat family; a successfully promoted standalone diff --git a/Ix/Tc/Verify/RecursiveMethods/Closure.lean b/Ix/Tc/Verify/RecursiveMethods/Closure.lean new file mode 100644 index 000000000..784cab9b3 --- /dev/null +++ b/Ix/Tc/Verify/RecursiveMethods/Closure.lean @@ -0,0 +1,78 @@ +import Ix.Tc.Verify.InferDefEq.Closure +import Ix.Tc.Verify.Whnf.Closure + +/-! +# Complete recursive method-table closure + +The production table has four WHNF fields plus inference and definitional +equality. Their proofs are developed independently, but they must share one +cache stack and one predecessor table before `methodsN` can be justified. +This module performs that final fixed-universe assembly. +-/ + +namespace Ix.Tc + +/-- The semantic cache layers beneath K1's outer WHNF and delta layers. -/ +def kernelCacheFallback (keys : WhnfContextKeys) (trProj : RawProjRel) : + CacheSemantics := + inferCacheSemantics keys trProj <| + defEqCacheSemantics keys trProj <| + isPropCacheSemantics keys trProj <| + isRecCacheSemantics CacheSemantics.blockErrorsOnly + +/-- Expose the intentional decomposition used to combine the independently +proved WHNF and inference/DefEq closure records. -/ +theorem kernelCacheSemantics_eq_k1 + (keys : WhnfContextKeys) (trProj : RawProjRel) : + kernelCacheSemantics keys trProj = + k1CacheSemantics keys trProj (kernelCacheFallback keys trProj) := rfl + +/-- Concrete resources for all six fields of one unfolded production method +table at the universe count fixed by the joint suffix model. -/ +structure RecursiveMethodClosureContext + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) + {trProj : RawProjRel} {world : VerifyWorld} (support : RunSupport) + (proposition : PropositionClassifierContext trProj world support) + (eligible : KId .anon → Prop) where + whnf : RecM.K1ClosureContext initial program requests proposition.model.keys + (kernelCacheFallback proposition.model.keys trProj) trProj world support + inferDefEq : InferDefEqClosureContext initial program requests support + proposition eligible + +namespace RecursiveMethodClosureContext + +/-- Close one fixed-universe layer of the complete six-field method table. -/ +theorem closedAt + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {proposition : PropositionClassifierContext trProj world support} + {eligible : KId .anon → Prop} + (context : RecursiveMethodClosureContext initial program requests support + proposition eligible) : + Methods.ClosedAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars := by + rw [kernelCacheSemantics_eq_k1] + exact Methods.ClosedAt.of_parts context.whnf.closedAt + context.inferDefEq.closedAt + +/-- Every finite production approximation selected by `runRec` satisfies all +six method contracts. -/ +theorem methodsN + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {proposition : PropositionClassifierContext trProj world support} + {eligible : KId .anon → Prop} + (context : RecursiveMethodClosureContext initial program requests support + proposition eligible) (n : Nat) : + Methods.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars (methodsN (m := .anon) n) := + Methods.methodsN_wfAt context.closedAt n + +end RecursiveMethodClosureContext + +end Ix.Tc diff --git a/Ix/Tc/Verify/Run.lean b/Ix/Tc/Verify/Run.lean index e3acff6b9..08f5bc69c 100644 --- a/Ix/Tc/Verify/Run.lean +++ b/Ix/Tc/Verify/Run.lean @@ -182,36 +182,41 @@ theorem instRev_spec {α : Type} {initial : TcState .anon} hsup.of_expr_univs post.2.2 (instantiateRev_preservesUnivs body fvars it)⟩ -/-- API-level abstraction adapter, including its two no-op fast paths. -/ -theorem abstractFVars_spec {α : Type} {initial : TcState .anon} - {program : TcM .anon α} {requests : List WalkerRequest} +/-- Request-independent API-level abstraction adapter, including its two +no-op fast paths. Callback-generated fvar ids cannot be selected uniformly +from one concrete execution list, so recursive inference supplies the same +finite reach and arithmetic resources directly. -/ +theorem abstractFVars_support_spec {support : RunSupport} - (h : RunAssumptions initial program requests support) + (hcollision : support.CollisionFree) {body : KExpr .anon} {fvars : Array FVarId} - (hmem : WalkerRequest.abstractFVars body fvars ∈ requests) + (hbounds : WalkerRequest.Bounds (.abstractFVars body fvars)) + (hreach : ∀ x, KExpr.AbstractReach (abstractFVarPositions fvars) + fvars.size.toUInt64 body 0 x → support x) {it : InternTable .anon} (hwf : it.WF) (hsup : support.CoversIntern it) : (abstractFVars body fvars it).1 = KExpr.abstractFVarsResult body fvars ∧ (abstractFVars body fvars it).2.WF ∧ support.CoversIntern (abstractFVars body fvars it).2 := by - obtain ⟨hbody, _, hwalk, _⟩ := h.requestBounds hmem + obtain ⟨hbody, _, hwalk, _⟩ := hbounds have post : (abstractFVars body fvars it).1 = KExpr.abstractFVarsResult body fvars ∧ (abstractFVars body fvars it).2.WF ∧ (∀ x, (abstractFVars body fvars it).2.ExprSupport x → support x) := by - by_cases hfast : (fvars.isEmpty || !body.hasFVars) = true + by_cases hfast : + (fvars.isEmpty || (!body.hasFVars && body.lbr == 0)) = true · have hrun : abstractFVars body fvars it = (body, it) := by rw [abstractFVars_eq, if_pos hfast] rfl rw [hrun] exact ⟨by simp [KExpr.abstractFVarsResult, hfast], hwf, hsup.expr⟩ · have cached := Ix.Tc.abstractFVarsCached_spec - h.collisionFree.expr hbody + hcollision.expr hbody (depth := 0) (it := it) (sc := {}) (by simpa using hwalk) - (h.coverage.abstractFVars hmem) hwf hsup.expr + hreach hwf hsup.expr (WalkScratchInv.empty support _) have hrun : abstractFVars body fvars it = ((abstractFVarsCached body (abstractFVarPositions fvars) @@ -228,6 +233,22 @@ theorem abstractFVars_spec {α : Type} {initial : TcState .anon} hsup.of_expr_univs post.2.2 (abstractFVars_preservesUnivs body fvars it)⟩ +/-- Execution-list specialization of `abstractFVars_support_spec`. -/ +theorem abstractFVars_spec {α : Type} {initial : TcState .anon} + {program : TcM .anon α} {requests : List WalkerRequest} + {support : RunSupport} + (h : RunAssumptions initial program requests support) + {body : KExpr .anon} {fvars : Array FVarId} + (hmem : WalkerRequest.abstractFVars body fvars ∈ requests) + {it : InternTable .anon} (hwf : it.WF) + (hsup : support.CoversIntern it) : + (abstractFVars body fvars it).1 = + KExpr.abstractFVarsResult body fvars ∧ + (abstractFVars body fvars it).2.WF ∧ + support.CoversIntern (abstractFVars body fvars it).2 := + abstractFVars_support_spec h.collisionFree (h.requestBounds hmem) + (h.coverage.abstractFVars hmem) hwf hsup + /-- Adapter for the cached abstraction master. The remaining API wrapper lemma exposes the slow-path master separately for recursive proof clients. -/ theorem abstractFVarsCached_spec {α : Type} @@ -291,13 +312,13 @@ theorem runIntern_supported_wf {semantics : CacheSemantics} (fun result s' => result = expected ∧ s' = { s with env := { s.env with intern := s'.env.intern } }) := by intro hI - obtain ⟨hstate, hsupport, hcaches⟩ := hI + obtain ⟨hstate, hsupport, hcaches, hequiv⟩ := hI rcases hrun : x s.env.intern with ⟨result, intern⟩ have hpost := hspec s.env.intern hstate.intern hsupport rw [hrun] at hpost simp only [TcM.runIntern, hrun] refine ⟨⟨hstate.of_consts_eq rfl hpost.2.1, hpost.2.2, - hcaches.of_intern_update⟩, + hcaches.of_intern_update, hequiv⟩, hpost.1, trivial⟩ theorem lift_wf {α : Type} {initial : TcState .anon} @@ -397,7 +418,7 @@ theorem instUniv_wf {α : Type} {initial : TcState .anon} (fun _ s' => s' = { s with env := { s.env with intern := s'.env.intern } }) := by intro hI - obtain ⟨hstate, hsupport, hcaches⟩ := hI + obtain ⟨hstate, hsupport, hcaches, hequiv⟩ := hI have hrunWF := h.instantiateUnivParams_wf hmem (s := s) ⟨hstate.intern, hsupport.expr⟩ match hrun : TcM.instantiateUnivParams e us s with @@ -415,7 +436,9 @@ theorem instUniv_wf {α : Type} {initial : TcState .anon} (CacheAuthority.stable world) support s'.env := by rw [hframe] exact hcaches.of_intern_update - exact ⟨⟨hstate.of_consts_eq hconsts hintern, hcovered, hcaches'⟩, + exact ⟨⟨hstate.of_consts_eq hconsts hintern, hcovered, hcaches', by + rw [hframe] + exact hequiv⟩, hspec, hframe⟩ | .error err s' => rw [hrun] at hrunWF @@ -430,7 +453,9 @@ theorem instUniv_wf {α : Type} {initial : TcState .anon} (CacheAuthority.stable world) support s'.env := by rw [hframe] exact hcaches.of_intern_update - exact ⟨⟨hstate.of_consts_eq hconsts hintern, hcovered, hcaches'⟩, + exact ⟨⟨hstate.of_consts_eq hconsts hintern, hcovered, hcaches', by + rw [hframe] + exact hequiv⟩, hframe⟩ end RunAssumptions diff --git a/Ix/Tc/Verify/State.lean b/Ix/Tc/Verify/State.lean index e3b7ffbfe..b8b32129f 100644 --- a/Ix/Tc/Verify/State.lean +++ b/Ix/Tc/Verify/State.lean @@ -2,6 +2,7 @@ import Ix.Tc.Verify.Env import Ix.Tc.Verify.Monad import Ix.Tc.Verify.InstUniv import Ix.Tc.Verify.Cache +import Ix.Tc.Verify.EquivalenceManager /-! # The verification world and the run invariant @@ -118,6 +119,8 @@ structure KernelStateWF (semantics : CacheSemantics) (trProj : RawProjRel) core : TcStateWF trProj s world internSupport : support.CoversIntern s.env.intern caches : CacheInvariant semantics (CacheAuthority.stable world) support s.env + equivalences : EquivManager.WF + (semantics.Equiv (CacheAuthority.stable world) support) s.equivManager /-- Existential current-world form of the complete G4 state invariant. -/ def KernelTcInv (semantics : CacheSemantics) (trProj : RawProjRel) @@ -133,9 +136,12 @@ theorem of_no_cache_entries {semantics : CacheSemantics} {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} {s : TcState .anon} (hcore : TcStateWF trProj s world) (hintern : support.CoversIntern s.env.intern) + (hequiv : s.equivManager = EquivManager.empty) (hempty : ∀ entry, ¬s.env.HasCacheEntry entry) : KernelStateWF semantics trProj world support s := - ⟨hcore, hintern, CacheInvariant.of_no_entries hempty⟩ + ⟨hcore, hintern, CacheInvariant.of_no_entries hempty, by + rw [hequiv] + exact EquivManager.WF.empty⟩ /-- A physical hit in a stable state exposes its complete provenance. -/ theorem cacheHit {semantics : CacheSemantics} {trProj : RawProjRel} @@ -170,12 +176,13 @@ theorem restoreCheckCachesOnError {semantics : CacheSemantics} (hafterIntern : support.CoversIntern after.env.intern) : KernelStateWF semantics trProj world support (before.restoreCheckCachesOnError after) := by - refine ⟨?_, ?_, ?_⟩ + refine ⟨?_, ?_, ?_, ?_⟩ · apply hafterCore.of_consts_eq · simp [TcState.restoreCheckCachesOnError] · simpa [TcState.restoreCheckCachesOnError] using hafterCore.intern · simpa [TcState.restoreCheckCachesOnError] using hafterIntern · exact hbefore.caches.restoreCheckCachesOnError + · simpa [TcState.restoreCheckCachesOnError] using hbefore.equivalences end KernelStateWF diff --git a/Ix/Tc/Verify/Suffix.lean b/Ix/Tc/Verify/Suffix.lean new file mode 100644 index 000000000..cc2cf5bfb --- /dev/null +++ b/Ix/Tc/Verify/Suffix.lean @@ -0,0 +1,468 @@ +import Ix.Tc.Verify.Whnf + +/-! +# K2 suffix-context transport boundary + +WHNF cache keys hash only the de-Bruijn suffix reachable from an expression. +The hash itself is not semantic evidence. This module states the two facts a +concrete verification of `TcM.ctxAddrForLbr` must establish and derives the +global, collision-robust cache-write rule from them. + +`WhnfSuffixModel.represents` is operational: it applies only to a checker +state reconciled with the claimed semantic context. `transport` is semantic: +two contexts represented by one suffix key preserve WHNF meaning. Separating +these clauses prevents either arbitrary-state context identification or bare +address equality from entering the cache proof. +-/ + +namespace Ix.Tc + +/-! ## Exact production memo behavior -/ + +namespace TcM + +/-- The zero-radius/empty-context fast path is state-pure. Combining the two +guards in one theorem makes the operational case split exhaustive. -/ +theorem ctxAddrForLbr_trivial + {lbr : UInt64} {s : TcState .anon} + (htrivial : (lbr == 0 || s.ctx.isEmpty) = true) : + ctxAddrForLbr lbr s = .ok emptyCtxAddr s := by + unfold ctxAddrForLbr + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp [htrivial] + rfl + +/-- A nontrivial memo hit returns the stored address without changing state. -/ +theorem ctxAddrForLbr_cacheHit + {lbr : UInt64} {s : TcState .anon} {cached : Address} + (hactive : (lbr == 0 || s.ctx.isEmpty) = false) + (hcache : s.ctxAddrCache[(s.ctxId, lbr)]? = some cached) : + ctxAddrForLbr lbr s = .ok cached s := by + unfold ctxAddrForLbr + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp [hactive, hcache] + rfl + +/-- A nontrivial memo miss returns the exact pure suffix calculation and +inserts precisely that result under the current `(ctxId, lbr)` key. -/ +theorem ctxAddrForLbr_cacheMiss + {lbr : UInt64} {s : TcState .anon} + (hactive : (lbr == 0 || s.ctx.isEmpty) = false) + (hcache : s.ctxAddrCache[(s.ctxId, lbr)]? = none) : + ctxAddrForLbr lbr s = + .ok (ctxAddrForLbrUncached s lbr) + {s with ctxAddrCache := (s.ctxAddrCache.insert (s.ctxId, lbr) + (ctxAddrForLbrUncached s lbr))} := by + unfold ctxAddrForLbr + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp [hactive, hcache] + rfl + +/-- Every successful suffix-key computation is stable on immediate replay. +This covers fast paths, pre-existing memo hits, and the newly inserted miss +entry against the actual production implementation. -/ +theorem ctxAddrForLbr_replay + {lbr : UInt64} {before after : TcState .anon} {ctxAddr : Address} + (hrun : ctxAddrForLbr lbr before = .ok ctxAddr after) : + ctxAddrForLbr lbr after = .ok ctxAddr after := by + cases hactive : (lbr == 0 || before.ctx.isEmpty) with + | true => + have heval := ctxAddrForLbr_trivial hactive + rw [heval] at hrun + injection hrun with haddr hstate + subst ctxAddr + subst after + exact heval + | false => + cases hcache : before.ctxAddrCache[(before.ctxId, lbr)]? with + | some cached => + have heval := ctxAddrForLbr_cacheHit hactive hcache + rw [heval] at hrun + injection hrun with haddr hstate + subst ctxAddr + subst after + exact ctxAddrForLbr_cacheHit hactive hcache + | none => + have heval := ctxAddrForLbr_cacheMiss hactive hcache + rw [heval] at hrun + injection hrun with haddr hstate + subst ctxAddr + subst after + apply ctxAddrForLbr_cacheHit + · simpa using hactive + · simp + +/-- Coherence of every memo entry that is observable in the current context. +Entries belonging to older `ctxId`s remain intentionally unconstrained: the +production lookup cannot consult them. Zero-radius and empty-context entries +are likewise irrelevant because those fast paths bypass the memo. -/ +def ContextAddrMemoValid (s : TcState .anon) : Prop := + ∀ {lbr : UInt64} {cached : Address}, + (lbr == 0 || s.ctx.isEmpty) = false → + s.ctxAddrCache[(s.ctxId, lbr)]? = some cached → + cached = ctxAddrForLbrUncached s lbr + +@[simp] theorem ctxSuffixNeedStep_setCache + (s : TcState .anon) (cache : Std.HashMap (Address × UInt64) Address) + (need : Nat) : + ctxSuffixNeedStep {s with ctxAddrCache := cache} need = + ctxSuffixNeedStep s need := by + unfold ctxSuffixNeedStep + rfl + +@[simp] theorem ctxSuffixNeed_setCache + (s : TcState .anon) (cache : Std.HashMap (Address × UInt64) Address) : + ∀ fuel need, + ctxSuffixNeed {s with ctxAddrCache := cache} fuel need = + ctxSuffixNeed s fuel need + | 0, _ => rfl + | fuel + 1, need => by + simp only [ctxSuffixNeed] + rw [ctxSuffixNeedStep_setCache] + split + · rfl + · exact ctxSuffixNeed_setCache s cache fuel _ + +/-- The pure suffix calculation is insensitive to the memo table. -/ +@[simp] theorem ctxAddrForLbrUncached_setCache + (s : TcState .anon) (cache : Std.HashMap (Address × UInt64) Address) + (lbr : UInt64) : + ctxAddrForLbrUncached {s with ctxAddrCache := cache} lbr = + ctxAddrForLbrUncached s lbr := by + unfold ctxAddrForLbrUncached + simp only + rw [ctxSuffixNeed_setCache] + +/-- The real memoized suffix computation preserves current-context memo +coherence. The proof audits both the overwritten key and every framed entry; +it does not infer coherence merely from replay determinism. -/ +theorem ctxAddrForLbr_memoValid + {lbr : UInt64} {before after : TcState .anon} {ctxAddr : Address} + (hvalid : ContextAddrMemoValid before) + (hrun : ctxAddrForLbr lbr before = .ok ctxAddr after) : + ContextAddrMemoValid after := by + cases hactive : (lbr == 0 || before.ctx.isEmpty) with + | true => + have heval := ctxAddrForLbr_trivial hactive + rw [heval] at hrun + injection hrun with _ hstate + subst after + change ContextAddrMemoValid before + exact hvalid + | false => + cases hcache : before.ctxAddrCache[(before.ctxId, lbr)]? with + | some cached => + have heval := ctxAddrForLbr_cacheHit hactive hcache + rw [heval] at hrun + injection hrun with _ hstate + subst after + change ContextAddrMemoValid before + exact hvalid + | none => + have heval := ctxAddrForLbr_cacheMiss hactive hcache + rw [heval] at hrun + injection hrun with haddr hstate + subst ctxAddr + subst after + intro other cached hother hlookup + rw [Std.HashMap.getElem?_insert] at hlookup + split at hlookup + · next hbeq => + have hpair := eq_of_beq hbeq + have hlbr : lbr = other := congrArg Prod.snd hpair + subst other + cases hlookup + simp + · have hold := hvalid (by simpa using hother) hlookup + simpa using hold + +end TcM + +/-- Canonical ghost interpretation generated by real suffix-key executions. +Unlike an arbitrary `WhnfContextKeys`, membership cannot be asserted from a +bare address: it stores a reconciled pre-state and the exact production run +that emitted the context component. -/ +def operationalWhnfContextKeys (trProj : RawProjRel) (world : VerifyWorld) + (uvars : Nat) : WhnfContextKeys where + uvars := uvars + Represents lbr ctxAddr Delta := + exists before after, + CtxRecon world.venv uvars world.nameOf trProj before Delta ∧ + TcM.ctxAddrForLbr lbr before = .ok ctxAddr after + +namespace operationalWhnfContextKeys + +/-- Every reconciled execution is represented by the canonical operational +interpretation. -/ +theorem represents {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {before after : TcState .anon} + {source : KExpr .anon} {key : Address × Address} {Delta : KVLCtx} + (hctx : CtxRecon world.venv uvars world.nameOf trProj before Delta) + (hrun : TcM.whnfKey source before = .ok key after) : + (operationalWhnfContextKeys trProj world uvars).Represents + source.lbr key.2 Delta := + ⟨before, after, hctx, TcM.whnfKey_ctx hrun⟩ + +/-- Direct suffix-address executions, including DefEq's shared-context key, +are represented without manufacturing an expression wrapper. -/ +theorem representsCtx {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {before after : TcState .anon} {lbr : UInt64} + {ctxAddr : Address} {Delta : KVLCtx} + (hctx : CtxRecon world.venv uvars world.nameOf trProj before Delta) + (hrun : TcM.ctxAddrForLbr lbr before = .ok ctxAddr after) : + (operationalWhnfContextKeys trProj world uvars).Represents + lbr ctxAddr Delta := + ⟨before, after, hctx, hrun⟩ + +end operationalWhnfContextKeys + +/-! ## Finite composite-digest boundary -/ + +/-- Declarative specification of the exact composite input hashed by +`ctxAddrForLbr`. + +`Input` is intentionally abstract: an implementation may normalize closed +contexts, whole-context `ctxId` inputs, and proper suffix encodings +differently. `execution` is the load-bearing implementation theorem. In +particular, it must justify memo hits as well as freshly computed hashes; an +arbitrary `ctxAddrCache` entry cannot satisfy this field merely because it was +returned by production. -/ +structure ContextDigestSpec (trProj : RawProjRel) (world : VerifyWorld) + (uvars : Nat) where + Input : Type + inputOf : UInt64 → KVLCtx → Input + digest : Input → Address + /-- States whose context-id chain and suffix memo are coherent with + `inputOf`/`digest`. This cannot be omitted: arbitrary checker states may + contain arbitrary `ctxAddrCache` entries. -/ + StateValid : TcState .anon → Prop + /-- The abstract valid-state predicate must expose the concrete memo + coherence that production actually consults. -/ + memoValid : ∀ {s}, StateValid s → TcM.ContextAddrMemoValid s + /-- State validity is stable under the real memo operation. This is needed + to chain a finite run: validity of the first key computation alone says + nothing about the next memoized call. -/ + preserves : ∀ {before after : TcState .anon} {lbr : UInt64} + {ctxAddr : Address}, + StateValid before → + TcM.ctxAddrForLbr lbr before = .ok ctxAddr after → + StateValid after + execution : ∀ {before after : TcState .anon} {lbr : UInt64} + {ctxAddr : Address} {Delta : KVLCtx}, + StateValid before → + CtxRecon world.venv uvars world.nameOf trProj before Delta → + TcM.ctxAddrForLbr lbr before = .ok ctxAddr after → + digest (inputOf lbr Delta) = ctxAddr + +/-- A genuinely finite collection of composite context-digest inputs for one +verified run. The list representation keeps finiteness constructive and +does not require classical finite-set membership. -/ +structure ContextDigestScope {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} (spec : ContextDigestSpec trProj world uvars) where + entries : List spec.Input + +namespace ContextDigestScope + +variable {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {spec : ContextDigestSpec trProj world uvars} + +/-- Membership in the run's finite composite-digest input list. -/ +def Contains (scope : ContextDigestScope spec) (input : spec.Input) : Prop := + input ∈ scope.entries + +/-- Explicit collision freedom for the *composite* digest on this finite +scope. It is deliberately separate from `RunSupport.CollisionFree`, which +only controls expression and universe addresses. -/ +def CollisionFree (scope : ContextDigestScope spec) : Prop := + ∀ {a b : spec.Input}, scope.Contains a → scope.Contains b → + spec.digest a = spec.digest b → a = b + +/-- Every reconciled production key execution from one concrete state must +land in the finite scope. Keeping `before` explicit is load-bearing: a run +scope covers reachable states, not every state that could satisfy the +unscoped context relation. -/ +def Captures (scope : ContextDigestScope spec) + (before : TcState .anon) : Prop := + ∀ {after : TcState .anon} {lbr : UInt64} + {ctxAddr : Address} {Delta : KVLCtx}, + CtxRecon world.venv uvars world.nameOf trProj before Delta → + TcM.ctxAddrForLbr lbr before = .ok ctxAddr after → + scope.Contains (spec.inputOf lbr Delta) + +end ContextDigestScope + +/-- The operational representation restricted to a finite run scope. Both +conjuncts are required: list membership without an actual production run is +not a key witness, while an arbitrary-state run outside the verified scope +cannot consume the run-scoped collision hypothesis. -/ +def scopedOperationalWhnfContextKeys {trProj : RawProjRel} + {world : VerifyWorld} {uvars : Nat} + (spec : ContextDigestSpec trProj world uvars) + (scope : ContextDigestScope spec) : WhnfContextKeys where + uvars := uvars + Represents lbr ctxAddr Delta := + ∃ before after, + spec.StateValid before ∧ + CtxRecon world.venv uvars world.nameOf trProj before Delta ∧ + TcM.ctxAddrForLbr lbr before = .ok ctxAddr after ∧ + scope.Contains (spec.inputOf lbr Delta) + +namespace scopedOperationalWhnfContextKeys + +variable {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {spec : ContextDigestSpec trProj world uvars} + {scope : ContextDigestScope spec} + +/-- A captured WHNF/inference key execution constructs scoped +representation; no address-only membership premise is accepted. -/ +theorem represents {before after : TcState .anon} {source : KExpr .anon} + {key : Address × Address} {Delta : KVLCtx} + (hvalid : spec.StateValid before) + (hcapture : scope.Captures before) + (hctx : CtxRecon world.venv uvars world.nameOf trProj before Delta) + (hrun : TcM.whnfKey source before = .ok key after) : + (scopedOperationalWhnfContextKeys spec scope).Represents + source.lbr key.2 Delta := by + exact ⟨before, after, hvalid, hctx, TcM.whnfKey_ctx hrun, + hcapture hctx (TcM.whnfKey_ctx hrun)⟩ + +/-- Direct captured context-key execution, used by DefEq. -/ +theorem representsCtx {before after : TcState .anon} {lbr : UInt64} + {ctxAddr : Address} {Delta : KVLCtx} + (hvalid : spec.StateValid before) + (hcapture : scope.Captures before) + (hctx : CtxRecon world.venv uvars world.nameOf trProj before Delta) + (hrun : TcM.ctxAddrForLbr lbr before = .ok ctxAddr after) : + (scopedOperationalWhnfContextKeys spec scope).Represents + lbr ctxAddr Delta := + ⟨before, after, hvalid, hctx, hrun, hcapture hctx hrun⟩ + +/-- Scoped representation exposes the exact digest equation supplied by the +implementation specification. -/ +theorem digest_eq {lbr : UInt64} {ctxAddr : Address} {Delta : KVLCtx} + (hrep : (scopedOperationalWhnfContextKeys spec scope).Represents + lbr ctxAddr Delta) : + spec.digest (spec.inputOf lbr Delta) = ctxAddr := by + obtain ⟨before, after, hvalid, hctx, hrun, _⟩ := hrep + exact spec.execution hvalid hctx hrun + +/-- Scoped representation also exposes finite-list membership independently +of its operational witness. -/ +theorem mem {lbr : UInt64} {ctxAddr : Address} {Delta : KVLCtx} + (hrep : (scopedOperationalWhnfContextKeys spec scope).Represents + lbr ctxAddr Delta) : + scope.Contains (spec.inputOf lbr Delta) := by + obtain ⟨_, _, _, _, _, hmem⟩ := hrep + exact hmem + +end scopedOperationalWhnfContextKeys + +/-- Sound interpretation of the production suffix-context address. -/ +structure WhnfSuffixModel (trProj : RawProjRel) (world : VerifyWorld) where + keys : WhnfContextKeys + represents : ∀ {before after : TcState .anon} {key : Address × Address} + {Delta : KVLCtx} {source : KExpr .anon}, + CtxRecon world.venv keys.uvars world.nameOf trProj before Delta → + TcM.whnfKey source before = .ok key after → + keys.Represents source.lbr key.2 Delta + transport : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {source result : KExpr .anon}, + keys.Represents source.lbr ctxAddr Delta → + keys.Represents source.lbr ctxAddr Delta' → + WhnfMeaning trProj world keys.uvars Delta source result → + WhnfMeaning trProj world keys.uvars Delta' source result + +namespace WhnfSuffixModel + +/-- Construct the operational model once the actual semantic sufficiency +theorem for equal emitted suffix addresses is available. This removes the +former representation oracle entirely: only semantic transport remains K2 +proof debt. -/ +def operational {trProj : RawProjRel} {world : VerifyWorld} (uvars : Nat) + (htransport : ∀ {ctxAddr : Address} {Delta Delta' : KVLCtx} + {source result : KExpr .anon}, + (operationalWhnfContextKeys trProj world uvars).Represents + source.lbr ctxAddr Delta → + (operationalWhnfContextKeys trProj world uvars).Represents + source.lbr ctxAddr Delta' → + WhnfMeaning trProj world uvars Delta source result → + WhnfMeaning trProj world uvars Delta' source result) : + WhnfSuffixModel trProj world where + keys := operationalWhnfContextKeys trProj world uvars + represents hctx hrun := + operationalWhnfContextKeys.represents hctx hrun + transport hDelta hDelta' hmeaning := + htransport hDelta hDelta' hmeaning + +/-- The operational model directly supplies the repaired per-call key +representation premise used by the WHNF shells. -/ +theorem keyRepresents {trProj : RawProjRel} {world : VerifyWorld} + (model : WhnfSuffixModel trProj world) {source : KExpr .anon} + {Delta : KVLCtx} : + RecM.WhnfKey.Represents model.keys trProj world source Delta := by + intro before key after hctx hrun + exact model.represents hctx hrun + +/-- Suffix transport plus finite expression-address collision freedom turns +one executed reduction into validity for every supported cache lookup sharing +the key. Direct-reference authorization stays separate because it is a +property of the generated expression graph, not of context hashing. -/ +theorem cacheWriteOracle {trProj : RawProjRel} {fallback : CacheSemantics} + {world : VerifyWorld} {support : RunSupport} + (model : WhnfSuffixModel trProj world) + (hcollision : support.CollisionFree) + (hreferences : ∀ {kind key source result}, + (kind = .whnfNoDelta ∨ kind = .whnfNoDeltaCheap ∨ kind = .whnf) → + support source → support result → source.addr = key.1 → + (CacheEntry.expr kind key result).ReferencesAuthorized + (CacheAuthority.stable world) support) : + RecM.WhnfCacheWriteOracle model.keys trProj fallback world support := by + have build : ∀ {kind : ExprCacheKind} {Delta source key result s}, + (kind = .whnfNoDelta ∨ kind = .whnfNoDeltaCheap ∨ kind = .whnf) → + support source → + support result → + model.keys.Matches trProj world s Delta source key → + WhnfMeaning trProj world model.keys.uvars Delta source result → + CacheProvenance + (whnfCacheSemantics model.keys trProj fallback) + (CacheAuthority.stable world) support (.expr kind key result) := by + intro kind Delta source key result s hkind hsource hresult hmatch hmeaning + refine ⟨⟨⟨source, hsource, hmatch.sourceAddr⟩, hresult⟩, + hreferences hkind hsource hresult hmatch.sourceAddr, ?_⟩ + have his : kind.IsWhnf := by + rcases hkind with hkind | hkind + · subst kind + exact .whnfNoDelta + · rcases hkind with hkind | hkind + · subst kind + exact .whnfNoDeltaCheap + · subst kind + exact .whnf + have hvalid : ∀ other, support other → other.addr = key.1 → + ∀ Delta', model.keys.Represents other.lbr key.2 Delta' → + WhnfMeaning trProj world model.keys.uvars Delta' other result := by + intro other hother haddr Delta' hrepresented + have heq : source = other := by + have herase := hcollision.expr hsource hother + (hmatch.sourceAddr.trans haddr.symm) + simpa only [KExpr.eraseMeta_anon] using herase + subst other + exact model.transport hmatch.2.1 hrepresented hmeaning + cases his <;> exact hvalid + refine ⟨?_, ?_, ?_⟩ + · intro Delta source key result s hsource hresult hmatch hmeaning + exact build (.inl rfl) hsource hresult hmatch hmeaning + · intro Delta source key result s hsource hresult hmatch hmeaning + exact build (.inr (.inl rfl)) hsource hresult hmatch hmeaning + · intro Delta source key result s hsource hresult hmatch hmeaning + exact build (.inr (.inr rfl)) hsource hresult hmatch hmeaning + +end WhnfSuffixModel + +end Ix.Tc diff --git a/Ix/Tc/Verify/Support.lean b/Ix/Tc/Verify/Support.lean index 333f1a720..8676da2d2 100644 --- a/Ix/Tc/Verify/Support.lean +++ b/Ix/Tc/Verify/Support.lean @@ -305,7 +305,7 @@ production API. This equation is the bridge from an `abstractFVars` request to the already-proved cached walker. -/ theorem abstractFVars_eq (body : KExpr .anon) (fvars : Array FVarId) : abstractFVars body fvars = - if fvars.isEmpty || !body.hasFVars then pure body + if fvars.isEmpty || (!body.hasFVars && body.lbr == 0) then pure body else runWalk (abstractFVarsCached body (abstractFVarPositions fvars) fvars.size.toUInt64 0) := by rw [abstractFVars] @@ -313,16 +313,66 @@ theorem abstractFVars_eq (body : KExpr .anon) (fvars : Array FVarId) : namespace KExpr -/-- Pure result of the production `abstractFVars` API, including both of its -no-op fast paths. The cached walker spec is used only on the slow path. -/ +/-- Pure result of the production `abstractFVars` API. A term without fvars +is a no-op only when it also has no loose bvars: otherwise wrapping new +binders must shift those bvars even though none of the target fvars occurs. -/ def abstractFVarsResult (body : KExpr .anon) (fvars : Array FVarId) : KExpr .anon := - if fvars.isEmpty || !body.hasFVars then body + if fvars.isEmpty || (!body.hasFVars && body.lbr == 0) then body else abstractFVarsSpec body (abstractFVarPositions fvars) fvars.size.toUInt64 0 end KExpr +/-! ## Cheap-beta finite footprint -/ + +/-- Every base/candidate in the left-associated application chain selected +by one cheap-beta plan. -/ +def cheapBetaChainList (base : KExpr .anon) : + List (KExpr .anon) → List (KExpr .anon) + | [] => [base] + | arg :: trailing => + base :: cheapBetaChainList (KExpr.mkApp base arg) trailing + +/-- Exact finite expression footprint of `cheapBetaReduce`: the unchanged +source plus the selected base and every intermediate application candidate. -/ +def KExpr.CheapBetaReach (source x : KExpr .anon) : Prop := + x ∈ source :: match cheapBetaPlan? source with + | none => [] + | some plan => cheapBetaChainList plan.base plan.trailing + +namespace KExpr.CheapBetaReach + +theorem finite (source : KExpr .anon) : + FiniteSupport (KExpr.CheapBetaReach source) := + ⟨source :: match cheapBetaPlan? source with + | none => [] + | some plan => cheapBetaChainList plan.base plan.trailing, + fun {_} h => h⟩ + +end KExpr.CheapBetaReach + +/-- Arithmetic/constructedness contract shared by the simultaneous- +substitution request and cheap beta's consumed prefix. -/ +def SimulSubstBounds (body : KExpr .anon) + (substs : Array (KExpr .anon)) (depth : UInt64) : Prop := + KExpr.Constructed body ∧ + (∀ k, k < substs.size → KExpr.Constructed substs[k]!) ∧ + (∀ k, k < substs.size → substs[k]!.size < UInt64.size) ∧ + depth.toNat + body.size + substs.size < UInt64.size ∧ + (∀ k, k < substs.size → + substs[k]!.lbr.toNat + substs[k]!.size + depth.toNat + body.size < + UInt64.size) + +/-- Resource bounds for the exact lambda prefix selected by cheap beta. -/ +def KExpr.CheapBetaBounds (source : KExpr .anon) : Prop := + (∀ x, KExpr.CheapBetaReach source x → KExpr.Constructed x) ∧ + ∀ {head : KExpr .anon} {args : Array (KExpr .anon)} + {body : KExpr .anon} {consumed : Nat}, + source.collectSpine = (head, args) → + peelLamsN args.size head = (body, consumed) → + SimulSubstBounds body (args.extract 0 consumed).reverse 0 + /-- One interning operation whose address reads, memo keys, and candidates must be covered by the run support. -/ inductive WalkerRequest where @@ -335,6 +385,7 @@ inductive WalkerRequest where | instRev (body : KExpr .anon) (fvars : Array (KExpr .anon)) | abstractFVars (body : KExpr .anon) (fvars : Array FVarId) | instUniv (e : KExpr .anon) (us : Array (KUniv .anon)) + | cheapBeta (e : KExpr .anon) namespace WalkerRequest @@ -350,6 +401,7 @@ def Reach : WalkerRequest → KExpr .anon → Prop KExpr.AbstractReach (abstractFVarPositions fvars) fvars.size.toUInt64 body 0 | .instUniv e us => KExpr.InstUnivReach us e + | .cheapBeta e => KExpr.CheapBetaReach e /-- Universe candidates are tracked separately from expressions: the two address domains have different erasures and therefore different collision @@ -372,13 +424,14 @@ theorem reach_finite (request : WalkerRequest) : exact KExpr.AbstractReach.finite (abstractFVarPositions fvars) fvars.size.toUInt64 body 0 | instUniv e us => exact KExpr.InstUnivReach.finite us e + | cheapBeta e => exact KExpr.CheapBetaReach.finite e theorem univReach_finite (request : WalkerRequest) : FiniteSupport request.UnivReach := by cases request with | internUniv u => exact FiniteSupport.singleton u | internExpr | lift | subst | simulSubst | instRev | abstractFVars | - instUniv => + instUniv | cheapBeta => exact FiniteSupport.empty /-- Covering one request means covering every expression it can address, @@ -407,13 +460,7 @@ def Bounds : WalkerRequest → Prop arg.size < UInt64.size ∧ arg.lbr.toNat + arg.size + depth.toNat + body.size < UInt64.size | .simulSubst body substs depth => - KExpr.Constructed body ∧ - (∀ k, k < substs.size → KExpr.Constructed substs[k]!) ∧ - (∀ k, k < substs.size → substs[k]!.size < UInt64.size) ∧ - depth.toNat + body.size + substs.size < UInt64.size ∧ - (∀ k, k < substs.size → - substs[k]!.lbr.toNat + substs[k]!.size + depth.toNat + body.size < - UInt64.size) + SimulSubstBounds body substs depth | .instRev body fvars => KExpr.Constructed body ∧ (∀ k, k < fvars.size → KExpr.Constructed fvars[k]!) ∧ @@ -426,6 +473,7 @@ def Bounds : WalkerRequest → Prop body.size < UInt64.size ∧ body.lbr.toNat + body.size + fvars.size.toUInt64.toNat < UInt64.size | .instUniv _ _ => True + | .cheapBeta e => KExpr.CheapBetaBounds e namespace Bounds diff --git a/Ix/Tc/Verify/Trans.lean b/Ix/Tc/Verify/Trans.lean index c9617b9f1..fcb8f3ebc 100644 --- a/Ix/Tc/Verify/Trans.lean +++ b/Ix/Tc/Verify/Trans.lean @@ -127,6 +127,37 @@ inductive TrKExprS {m : Mode} : KVLCtx → KExpr m → VExpr → Prop env.ContainsLits (.strVal s) → TrKExprS Δ (.str s blob md) (.trLiteral (.strVal s)) +/-! ### Environment-extension monotonicity + +This theorem lives with the translation rather than the concrete environment +log so admission relations can retain typed translations without creating an +`Env`/`Inductive` import cycle. The projection relation is environment-free; +only Theory typing and lookup premises need transport. -/ + +/-- Structural translation is stable when the trusted Theory environment +grows. -/ +theorem TrKExprS.mono {env env' : VEnv} (henv : env ≤ env') + {uvars : Nat} {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + {m : Mode} {Δ : KVLCtx} {e : KExpr m} {e' : VExpr} + (H : TrKExprS env uvars nameOf trProj Δ e e') : + TrKExprS env' uvars nameOf trProj Δ e e' := by + induction H with + | var h1 => exact .var h1 + | fvar h1 => exact .fvar h1 + | sort h1 => exact .sort h1 + | const h1 h2 h3 h4 => exact .const h1 (henv.constants h2) h3 h4 + | app h1 h2 _ _ ih1 ih2 => + exact .app (h1.mono henv) (h2.mono henv) ih1 ih2 + | lam h1 _ _ ih1 ih2 => exact .lam (h1.mono henv) ih1 ih2 + | all h1 h2 _ _ ih1 ih2 => + exact .all (h1.mono henv) (h2.mono henv) ih1 ih2 + | letE h1 _ _ _ ih1 ih2 ih3 => + exact .letE (h1.mono henv) ih1 ih2 ih3 + | prj h1 _ h3 ih => exact .prj h1 ih h3 + | nat h1 => exact .nat (h1.mono henv) + | str h1 => exact .str (h1.mono henv) + /-- The translation is metadata-blind: erasing to the anon twin translates to the SAME `VExpr`. (With `KExpr.eraseMeta_anon` this also means anon statements subsume meta ones — the v1 checker's @@ -517,6 +548,203 @@ theorem TrKExprS.weakBV {env : Lean4Lean.VEnv} {uvars : Nat} liftN_trLiteral (.strVal s) n k] exact .str h +private theorem tr_toNat_max (a b : UInt64) : + (max a b).toNat = max a.toNat b.toNat := by + show (if a ≤ b then b else a).toNat = max a.toNat b.toNat + rw [Nat.max_def] + split <;> split <;> + first + | rfl + | (rename_i h1 h2 + exact absurd (UInt64.le_iff_toNat_le.mp h1) h2) + | (rename_i h1 h2 + exact absurd h2 fun hh => h1 (UInt64.le_iff_toNat_le.mpr hh)) + +private theorem tr_toNat_le_sat1_add_one (x : UInt64) : + x.toNat ≤ x.sat1.toNat + 1 := by + unfold UInt64.sat1 + split + · next h => rw [eq_of_beq h]; exact Nat.le_succ _ + · next h => + have hx0 : x ≠ 0 := fun he => h (beq_iff_eq.mpr he) + have hn0 : x.toNat ≠ 0 := fun h0 => + hx0 (UInt64.toNat_inj.mp (by simpa using h0)) + have hsub : (x - 1).toNat = x.toNat - 1 := by + rw [UInt64.toNat_sub_of_le x 1 (UInt64.le_iff_toNat_le.mpr (by + rw [show (1 : UInt64).toNat = 1 from rfl]; omega))] + rfl + omega + +/-- Walker-tight weakening. Unlike `weakBV`, the arithmetic hypotheses + mention only the source expression: `hcut` bounds binder descent and + `hlift` bounds shifted loose indices. These are exactly the two + no-wrap obligations carried by `WalkerRequest.Bounds (.lift ...)`. -/ +theorem TrKExprS.weakBV_lbr {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + (henv : env.Ordered) + (htp : ∀ {Γ Γ' : List VExpr} {n k : Nat} {s : Lean.Name} {i : Nat} + {e e' : VExpr}, Lean4Lean.Ctx.LiftN n k Γ Γ' → trProj Γ s i e e' → + trProj Γ' s i (e.liftN n k) (e'.liftN n k)) + {Δ : KVLCtx} {e : KExpr .anon} {e' : VExpr} + (hcon : KExpr.Constructed e) + (H : TrKExprS env uvars nameOf trProj Δ e e') : + ∀ {Δ' : KVLCtx} {dn dk n k : Nat} {shift cutoff : UInt64}, + KVLCtx.KBVLift Δ Δ' dn dk n k → + shift.toNat = dn → cutoff.toNat = dk → + cutoff.toNat + e.size < UInt64.size → + e.lbr.toNat + e.size + shift.toNat < UInt64.size → + TrKExprS env uvars nameOf trProj Δ' + (KExpr.liftSpec e shift cutoff) (e'.liftN n k) := by + induction H with + | @var Δ idx name info e A h => + cases hcon with + | @var _ _ md hidx => + intro Δ' dn dk n k shift cutoff W hshift hcutoff hcut hlift + change cutoff.toNat + 1 < UInt64.size at hcut + change (idx + 1).toNat + 1 + shift.toNat < UInt64.size at hlift + have hlbr : (idx + 1).toNat = idx.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt hidx + rw [hlbr] at hlift + have hW := W.find? h + rw [KExpr.liftSpec] + by_cases hge : idx ≥ cutoff + · have hnl : ¬ (idx.toNat < dk) := by + have := UInt64.le_iff_toNat_le.mp hge + omega + rw [if_pos hge, KExpr.mkVar_shape] + refine .var (A := A.liftN n k) ?_ + have htn : (idx + shift).toNat = idx.toNat + dn := by + rw [UInt64.toNat_add, hshift] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hlift) + rw [htn] + simpa [KVLCtx.liftVar, hnl] using hW + · have hl : idx.toNat < dk := by + have : ¬ (cutoff.toNat ≤ idx.toNat) := fun hh => + hge (UInt64.le_iff_toNat_le.mpr hh) + omega + rw [if_neg hge] + refine .var (A := A.liftN n k) ?_ + simpa [KVLCtx.liftVar, hl] using hW + | @fvar Δ id name info e A h => + cases hcon + intro Δ' dn dk n k shift cutoff W hshift hcutoff hcut hlift + have hW := W.find? h + exact .fvar (A := A.liftN n k) (by + simpa [KExpr.liftSpec, KVLCtx.liftVar] using hW) + | @sort Δ u info h => + cases hcon + intro Δ' dn dk n k shift cutoff W hshift hcutoff hcut hlift + exact .sort h + | @const Δ id us info c ci h1 h2 h3 h4 => + cases hcon + intro Δ' dn dk n k shift cutoff W hshift hcutoff hcut hlift + exact .const h1 h2 h3 h4 + | @app Δ f a info f' a' A B h1 h2 htf hta ihf iha => + cases hcon with + | @app _ _ md hf ha => + intro Δ' dn dk n k shift cutoff W hshift hcutoff hcut hlift + change cutoff.toNat + (f.size + a.size + 1) < UInt64.size at hcut + change (max f.lbr a.lbr).toNat + (f.size + a.size + 1) + + shift.toNat < UInt64.size at hlift + rw [tr_toNat_max] at hlift + have hszf := KExpr.size_pos f + have hsza := KExpr.size_pos a + rw [KExpr.liftSpec, KExpr.mkApp_shape] + exact .app (h1.weakN henv W.toCtx) (h2.weakN henv W.toCtx) + (ihf hf W hshift hcutoff (by omega) (by omega)) + (iha ha W hshift hcutoff (by omega) (by omega)) + | @lam Δ name bi ty body info ty' body' h1 htty htbody ihty ihbody => + cases hcon with + | @lam _ _ _ _ md hty hbody => + intro Δ' dn dk n k shift cutoff W hshift hcutoff hcut hlift + change cutoff.toNat + (ty.size + body.size + 1) < UInt64.size at hcut + change (max ty.lbr body.lbr.sat1).toNat + + (ty.size + body.size + 1) + shift.toNat < UInt64.size at hlift + rw [tr_toNat_max] at hlift + have hsat := tr_toNat_le_sat1_add_one body.lbr + have hszty := KExpr.size_pos ty + have hszbody := KExpr.size_pos body + have hc1 : (cutoff + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + hcutoff] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hcut) + rw [KExpr.liftSpec, KExpr.mkLam_shape] + exact .lam (h1.weakN henv W.toCtx) + (ihty hty W hshift hcutoff (by omega) (by omega)) + (ihbody hbody (W.cons (.vlam ty')) hshift hc1 + (by rw [hc1]; omega) (by omega)) + | @all Δ name bi ty body info ty' body' h1 h2 htty htbody ihty ihbody => + cases hcon with + | @all _ _ _ _ md hty hbody => + intro Δ' dn dk n k shift cutoff W hshift hcutoff hcut hlift + change cutoff.toNat + (ty.size + body.size + 1) < UInt64.size at hcut + change (max ty.lbr body.lbr.sat1).toNat + + (ty.size + body.size + 1) + shift.toNat < UInt64.size at hlift + rw [tr_toNat_max] at hlift + have hsat := tr_toNat_le_sat1_add_one body.lbr + have hszty := KExpr.size_pos ty + have hszbody := KExpr.size_pos body + have hc1 : (cutoff + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + hcutoff] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hcut) + rw [KExpr.liftSpec, KExpr.mkAll_shape] + exact .all (h1.weakN henv W.toCtx) (h2.weakN henv W.toCtx.succ) + (ihty hty W hshift hcutoff (by omega) (by omega)) + (ihbody hbody (W.cons (.vlam ty')) hshift hc1 + (by rw [hc1]; omega) (by omega)) + | @letE Δ name ty val body nd info ty' val' body' h1 htty htval htbody + ihty ihval ihbody => + cases hcon with + | @letE _ _ _ _ _ md hty hval hbody => + intro Δ' dn dk n k shift cutoff W hshift hcutoff hcut hlift + change cutoff.toNat + (ty.size + val.size + body.size + 1) < + UInt64.size at hcut + change (max (max ty.lbr val.lbr) body.lbr.sat1).toNat + + (ty.size + val.size + body.size + 1) + shift.toNat < + UInt64.size at hlift + rw [tr_toNat_max, tr_toNat_max] at hlift + have hsat := tr_toNat_le_sat1_add_one body.lbr + have hszty := KExpr.size_pos ty + have hszval := KExpr.size_pos val + have hszbody := KExpr.size_pos body + have hc1 : (cutoff + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + hcutoff] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hcut) + rw [KExpr.liftSpec, KExpr.mkLet_shape] + exact .letE (h1.weakN henv W.toCtx) + (ihty hty W hshift hcutoff (by omega) (by omega)) + (ihval hval W hshift hcutoff (by omega) (by omega)) + (ihbody hbody (W.cons (.vlet ty' val')) hshift hc1 + (by rw [hc1]; omega) (by omega)) + | @prj Δ id field val info sName e' e'' h1 htval htrp ihval => + cases hcon with + | @prj _ _ _ md hval => + intro Δ' dn dk n k shift cutoff W hshift hcutoff hcut hlift + change cutoff.toNat + (val.size + 1) < UInt64.size at hcut + change val.lbr.toNat + (val.size + 1) + shift.toNat < + UInt64.size at hlift + have hszval := KExpr.size_pos val + rw [KExpr.liftSpec, KExpr.mkPrj_shape] + exact .prj h1 (ihval hval W hshift hcutoff (by omega) (by omega)) + (htp W.toCtx htrp) + | @nat Δ v blob info h => + cases hcon + intro Δ' dn dk n k shift cutoff W hshift hcutoff hcut hlift + rw [show (Lean4Lean.VExpr.natLit v).liftN n k + = Lean4Lean.VExpr.natLit v from liftN_natLit v n k] + exact .nat h + | @str Δ v blob info h => + cases hcon + intro Δ' dn dk n k shift cutoff W hshift hcutoff hcut hlift + rw [show (Lean4Lean.VExpr.trLiteral (.strVal v)).liftN n k + = Lean4Lean.VExpr.trLiteral (.strVal v) from + liftN_trLiteral (.strVal v) n k] + exact .str h + /-! ### Instantiation: `substSpec` corresponds to `VExpr.inst` Mirror of upstream `VLCtx.InstN`/`TrExprS.instN`, with one structural @@ -687,6 +915,139 @@ theorem KInstN.find?_fvar {Δ₀ : KVLCtx} {e₀ A₀ : VExpr} {dk k : Nat} end KVLCtx +/-! ### Let instantiation: `substSpec` removes a depth-zero `vlet` + +Unlike `KInstN`, this relation removes a `vlet`, whose Theory depth is zero. +The source and target bare Theory contexts are therefore definitionally the +same, and declarations above the removed let are not instantiated. Kernel +de Bruijn indices still count the removed entry, so the `dk`/`k` split remains +essential: `dk` counts mixed-context entries while `k` sums Theory depths. -/ + +namespace KVLCtx + +variable (Δ₀ : KVLCtx) (e₀ A₀ : VExpr) in +/-- `Δ₁` carries the `vlet A₀ e₀` at entry-position `dk`; `Δ` removes it. + Since a `vlet` contributes no Theory binder, both contexts have the same + `toCtx`; `k` only records the depth of declarations above the let. -/ +inductive KInstLet : Nat → Nat → KVLCtx → KVLCtx → Prop + | zero : KInstLet 0 0 ((none, .vlet A₀ e₀) :: Δ₀) Δ₀ + | succ {dk k : Nat} {Γ Γ' : KVLCtx} {d : VLocalDecl} : + KInstLet dk k Γ Γ' → + KInstLet (dk + 1) (k + d.depth) ((none, d) :: Γ) + ((none, d) :: Γ') + +/-- Removing a `vlet` does not alter the bare Theory context. -/ +protected theorem KInstLet.toCtx {Δ₀ : KVLCtx} {e₀ A₀ : VExpr} + {dk k : Nat} {Δ₁ Δ : KVLCtx} (W : KInstLet Δ₀ e₀ A₀ dk k Δ₁ Δ) : + Δ₁.toCtx = Δ.toCtx := by + induction W with + | zero => rfl + | @succ dk k Γ Γ' d _ ih => + cases d <;> simp only [KVLCtx.toCtx, ih] + +/-- The context retained above the removed let is a pure insertion over its + base. This is the weakening bridge for a hit on the let-bound variable. -/ +theorem KInstLet.toKBVLift {Δ₀ : KVLCtx} {e₀ A₀ : VExpr} + {dk k : Nat} {Δ₁ Δ : KVLCtx} (W : KInstLet Δ₀ e₀ A₀ dk k Δ₁ Δ) : + KBVLift Δ₀ Δ dk 0 k 0 := by + induction W with + | zero => exact .refl + | @succ dk k Γ Γ' d _ ih => exact .skip d ih + +theorem KInstLet.dk_le_bvars {Δ₀ : KVLCtx} {e₀ A₀ : VExpr} + {dk k : Nat} {Δ₁ Δ : KVLCtx} (W : KInstLet Δ₀ e₀ A₀ dk k Δ₁ Δ) : + dk ≤ Δ.bvars := by + induction W with + | zero => exact Nat.zero_le _ + | succ _ ih => + simp [KVLCtx.bvars] + omega + +/-- A reference to the removed let resolves to its stored value, lifted by + exactly the Theory depth of declarations above it. -/ +theorem KInstLet.find?_hit {Δ₀ : KVLCtx} {e₀ A₀ : VExpr} + {dk k : Nat} {Δ₁ Δ : KVLCtx} (W : KInstLet Δ₀ e₀ A₀ dk k Δ₁ Δ) : + ∀ {e' A : VExpr}, find? Δ₁ (.inl dk) = some (e', A) → + e' = e₀.liftN k := by + induction W with + | zero => + intro e' A H + simp [find?, next] at H + obtain ⟨rfl, rfl⟩ := H + simp [Lean4Lean.VLocalDecl.value] + | @succ dk k Γ Γ' d _ ih => + intro e' A H + simp [find?, next] at H + obtain ⟨e, A', H, rfl, rfl⟩ := H + rw [ih H, Lean4Lean.VExpr.liftN_liftN] + +/-- References below the removed let retain both their index and resolved + Theory pair. -/ +theorem KInstLet.find?_lt {Δ₀ : KVLCtx} {e₀ A₀ : VExpr} + {dk k : Nat} {Δ₁ Δ : KVLCtx} (W : KInstLet Δ₀ e₀ A₀ dk k Δ₁ Δ) : + ∀ {j : Nat} {e' A : VExpr}, j < dk → + find? Δ₁ (.inl j) = some (e', A) → + find? Δ (.inl j) = some (e', A) := by + induction W with + | zero => omega + | @succ dk k Γ Γ' d _ ih => + intro j e' A hj H + match j with + | 0 => + simp [find?, next] at H ⊢ + exact H + | j + 1 => + simp [find?, next] at H ⊢ + obtain ⟨e, A', H, rfl, rfl⟩ := H + exact ⟨_, _, ih (by omega) H, rfl, rfl⟩ + +/-- References above the removed let shift down by one mixed-context entry, + while their resolved Theory pair is unchanged. -/ +theorem KInstLet.find?_gt {Δ₀ : KVLCtx} {e₀ A₀ : VExpr} + {dk k : Nat} {Δ₁ Δ : KVLCtx} (W : KInstLet Δ₀ e₀ A₀ dk k Δ₁ Δ) : + ∀ {j : Nat} {e' A : VExpr}, dk < j → + find? Δ₁ (.inl j) = some (e', A) → + find? Δ (.inl (j - 1)) = some (e', A) := by + induction W with + | zero => + intro j e' A hj H + match j, hj with + | j + 1, _ => + simp [find?, next] at H + obtain ⟨e, A', H, rfl, rfl⟩ := H + simpa [Lean4Lean.VLocalDecl.depth] using H + | @succ dk k Γ Γ' d _ ih => + intro j e' A hj H + match j, hj with + | j' + 1, _ => + simp [find?, next] at H + obtain ⟨e, A', H, rfl, rfl⟩ := H + have hj' : dk < j' := by omega + obtain ⟨j'', rfl⟩ : ∃ j'', j' = j'' + 1 := ⟨j' - 1, by omega⟩ + simp only [Nat.add_sub_cancel] + simp [find?, next] + exact ⟨_, _, ih hj' H, rfl, rfl⟩ + +/-- Fvar lookup is independent of the removed untagged let entry. -/ +theorem KInstLet.find?_fvar {Δ₀ : KVLCtx} {e₀ A₀ : VExpr} + {dk k : Nat} {Δ₁ Δ : KVLCtx} (W : KInstLet Δ₀ e₀ A₀ dk k Δ₁ Δ) : + ∀ {fv : FVarId} {e' A : VExpr}, + find? Δ₁ (.inr fv) = some (e', A) → + find? Δ (.inr fv) = some (e', A) := by + induction W with + | zero => + intro fv e' A H + simp [find?, next] at H + obtain ⟨e, A', H, rfl, rfl⟩ := H + simpa [Lean4Lean.VLocalDecl.depth] using H + | @succ dk k Γ Γ' d _ ih => + intro fv e' A H + simp [find?, next] at H ⊢ + obtain ⟨e, A', H, rfl, rfl⟩ := H + exact ⟨_, _, ih H, rfl, rfl⟩ + +end KVLCtx + /-- Closed literal encodings are `inst`-invariant. -/ private theorem inst_natLit (v : Nat) (e₀ : VExpr) (k : Nat) : (Lean4Lean.VExpr.natLit v).inst e₀ k = Lean4Lean.VExpr.natLit v := by @@ -862,6 +1223,254 @@ theorem TrKExprS.instN {env : Lean4Lean.VEnv} {uvars : Nat} inst_trLiteral (.strVal s) e₀' k] exact .str h +/-- **Let instantiation** — substituting the concrete value for a mixed + context `vlet` leaves the translated Theory expression unchanged. + This mirrors upstream `TrExprS.instN_let`, while retaining the explicit + UInt64 resource bound required by `KExpr.substSpec`. -/ +theorem TrKExprS.instN_let {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + (henv : env.Ordered) + (htp : ∀ {Γ Γ' : List VExpr} {n k : Nat} {s : Lean.Name} {i : Nat} + {e e' : VExpr}, Lean4Lean.Ctx.LiftN n k Γ Γ' → trProj Γ s i e e' → + trProj Γ' s i (e.liftN n k) (e'.liftN n k)) + {Δ₀ : KVLCtx} {arg : KExpr .anon} {e₀' A₀ : VExpr} + (h₀ : TrKExprS env uvars nameOf trProj Δ₀ arg e₀') + {Δ₁ : KVLCtx} {body : KExpr .anon} {body' : VExpr} + (H : TrKExprS env uvars nameOf trProj Δ₁ body body') : + ∀ {Δ : KVLCtx} {dk k : Nat} {depth : UInt64}, + KVLCtx.KInstLet Δ₀ e₀' A₀ dk k Δ₁ Δ → + depth.toNat = dk → + Δ.bvars + body.size + arg.size < UInt64.size → + TrKExprS env uvars nameOf trProj Δ + (KExpr.substSpec body arg depth) body' := by + induction H with + | @var Δ₁' i nm md e A h => + intro Δ dk k depth W hdepth hbig + rw [KExpr.substSpec] + by_cases heq : (i == depth) = true + · have hik : i.toNat = dk := by rw [eq_of_beq heq]; exact hdepth + rw [if_pos heq] + have hhit : e = e₀'.liftN k := + W.find?_hit (e' := e) (A := A) (by rw [← hik]; exact h) + rw [hhit] + exact TrKExprS.weakBV henv htp h₀ W.toKBVLift hdepth rfl + (Nat.lt_of_le_of_lt (by omega) hbig) + · by_cases hgt : i > depth + · have hik : dk < i.toNat := by + have := UInt64.lt_iff_toNat_lt.mp hgt + omega + rw [if_neg heq, if_pos hgt, KExpr.mkVar_shape] + refine .var (A := A) ?_ + have h1i : (1 : UInt64) ≤ i := + UInt64.le_iff_toNat_le.mpr (by + rw [show (1 : UInt64).toNat = 1 from rfl]; omega) + rw [UInt64.toNat_sub_of_le i 1 h1i, + show (1 : UInt64).toNat = 1 from rfl] + exact W.find?_gt hik h + · have hik : i.toNat < dk := by + have hne : i.toNat ≠ depth.toNat := fun hh => + heq (beq_iff_eq.mpr (UInt64.toNat_inj.mp hh)) + have hnlt : ¬ (depth.toNat < i.toNat) := fun hh => + hgt (UInt64.lt_iff_toNat_lt.mpr hh) + omega + rw [if_neg heq, if_neg hgt] + exact .var (A := A) (W.find?_lt hik h) + | @fvar Δ₁' fv nm md e A h => + intro Δ dk k depth W hdepth hbig + exact .fvar (A := A) (W.find?_fvar h) + | @sort Δ₁' u md h => + intro Δ dk k depth W hdepth hbig + exact .sort h + | @const Δ₁' id us md c ci h1 h2 h3 h4 => + intro Δ dk k depth W hdepth hbig + exact .const h1 h2 h3 h4 + | @app Δ₁' f a md f' a' A B h1 h2 htf hta ihf iha => + intro Δ dk k depth W hdepth hbig + have hbig' : Δ.bvars + (f.size + a.size + 1) + arg.size + < UInt64.size := hbig + rw [KExpr.substSpec, KExpr.mkApp_shape] + exact .app (W.toCtx ▸ h1) (W.toCtx ▸ h2) + (ihf W hdepth (Nat.lt_of_le_of_lt (by omega) hbig')) + (iha W hdepth (Nat.lt_of_le_of_lt (by omega) hbig')) + | @lam Δ₁' nm bi ty body md ty' body' h1 htty htbody ihty ihbody => + intro Δ dk k depth W hdepth hbig + have hbig' : Δ.bvars + (ty.size + body.size + 1) + arg.size + < UInt64.size := hbig + have hdk : dk ≤ Δ.bvars := W.dk_le_bvars + have hc1 : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.substSpec, KExpr.mkLam_shape] + exact .lam (W.toCtx ▸ h1) + (ihty W hdepth (Nat.lt_of_le_of_lt (by omega) hbig')) + (ihbody (W.succ (d := .vlam ty')) hc1 + (by show Δ.bvars + 1 + body.size + arg.size < UInt64.size + exact Nat.lt_of_le_of_lt (by omega) hbig')) + | @all Δ₁' nm bi ty body md ty' body' h1 h2 htty htbody ihty ihbody => + intro Δ dk k depth W hdepth hbig + have hbig' : Δ.bvars + (ty.size + body.size + 1) + arg.size + < UInt64.size := hbig + have hdk : dk ≤ Δ.bvars := W.dk_le_bvars + have hc1 : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.substSpec, KExpr.mkAll_shape] + exact .all (W.toCtx ▸ h1) (W.toCtx ▸ h2) + (ihty W hdepth (Nat.lt_of_le_of_lt (by omega) hbig')) + (ihbody (W.succ (d := .vlam ty')) hc1 + (by show Δ.bvars + 1 + body.size + arg.size < UInt64.size + exact Nat.lt_of_le_of_lt (by omega) hbig')) + | @letE Δ₁' nm ty val body nd md ty' val' body' h1 htty htval htbody + ihty ihval ihbody => + intro Δ dk k depth W hdepth hbig + have hbig' : + Δ.bvars + (ty.size + val.size + body.size + 1) + arg.size + < UInt64.size := hbig + have hdk : dk ≤ Δ.bvars := W.dk_le_bvars + have hc1 : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.substSpec, KExpr.mkLet_shape] + exact .letE (W.toCtx ▸ h1) + (ihty W hdepth (Nat.lt_of_le_of_lt (by omega) hbig')) + (ihval W hdepth (Nat.lt_of_le_of_lt (by omega) hbig')) + (ihbody (W.succ (d := .vlet ty' val')) hc1 + (by show Δ.bvars + 1 + body.size + arg.size < UInt64.size + exact Nat.lt_of_le_of_lt (by omega) hbig')) + | @prj Δ₁' sid field val md sName e' e'' h1 htval htrp ihval => + intro Δ dk k depth W hdepth hbig + have hbig' : Δ.bvars + (val.size + 1) + arg.size < UInt64.size := + hbig + rw [KExpr.substSpec, KExpr.mkPrj_shape] + exact .prj h1 + (ihval W hdepth (Nat.lt_of_le_of_lt (by omega) hbig')) + (W.toCtx ▸ htrp) + | @nat Δ₁' v blob md h => + intro Δ dk k depth W hdepth hbig + exact .nat h + | @str Δ₁' s blob md h => + intro Δ dk k depth W hdepth hbig + exact .str h + +/-- Walker-tight let instantiation. The bound is the final conjunct of + `WalkerRequest.Bounds (.subst body arg depth)`, and `harg` is its + constructed-argument conjunct. No ambient-context size is needed. -/ +theorem TrKExprS.instN_let_lbr {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + (henv : env.Ordered) + (htp : ∀ {Γ Γ' : List VExpr} {n k : Nat} {s : Lean.Name} {i : Nat} + {e e' : VExpr}, Lean4Lean.Ctx.LiftN n k Γ Γ' → trProj Γ s i e e' → + trProj Γ' s i (e.liftN n k) (e'.liftN n k)) + {Δ₀ : KVLCtx} {arg : KExpr .anon} {e₀' A₀ : VExpr} + (harg : KExpr.Constructed arg) + (h₀ : TrKExprS env uvars nameOf trProj Δ₀ arg e₀') + {Δ₁ : KVLCtx} {body : KExpr .anon} {body' : VExpr} + (H : TrKExprS env uvars nameOf trProj Δ₁ body body') : + ∀ {Δ : KVLCtx} {dk k : Nat} {depth : UInt64}, + KVLCtx.KInstLet Δ₀ e₀' A₀ dk k Δ₁ Δ → + depth.toNat = dk → + arg.lbr.toNat + arg.size + depth.toNat + body.size < UInt64.size → + TrKExprS env uvars nameOf trProj Δ + (KExpr.substSpec body arg depth) body' := by + induction H with + | @var Δ₁' i nm md e A h => + intro Δ dk k depth W hdepth hbig + rw [KExpr.substSpec] + by_cases heq : (i == depth) = true + · have hik : i.toNat = dk := by rw [eq_of_beq heq]; exact hdepth + rw [if_pos heq] + have hhit : e = e₀'.liftN k := + W.find?_hit (e' := e) (A := A) (by rw [← hik]; exact h) + rw [hhit] + exact TrKExprS.weakBV_lbr henv htp harg h₀ W.toKBVLift hdepth rfl + (by rw [show (0 : UInt64).toNat = 0 from rfl]; omega) (by omega) + · by_cases hgt : i > depth + · have hik : dk < i.toNat := by + have := UInt64.lt_iff_toNat_lt.mp hgt + omega + rw [if_neg heq, if_pos hgt, KExpr.mkVar_shape] + refine .var (A := A) ?_ + have h1i : (1 : UInt64) ≤ i := + UInt64.le_iff_toNat_le.mpr (by + rw [show (1 : UInt64).toNat = 1 from rfl]; omega) + rw [UInt64.toNat_sub_of_le i 1 h1i, + show (1 : UInt64).toNat = 1 from rfl] + exact W.find?_gt hik h + · have hik : i.toNat < dk := by + have hne : i.toNat ≠ depth.toNat := fun hh => + heq (beq_iff_eq.mpr (UInt64.toNat_inj.mp hh)) + have hnlt : ¬ (depth.toNat < i.toNat) := fun hh => + hgt (UInt64.lt_iff_toNat_lt.mpr hh) + omega + rw [if_neg heq, if_neg hgt] + exact .var (A := A) (W.find?_lt hik h) + | @fvar Δ₁' fv nm md e A h => + intro Δ dk k depth W hdepth hbig + exact .fvar (A := A) (W.find?_fvar h) + | @sort Δ₁' u md h => + intro Δ dk k depth W hdepth hbig + exact .sort h + | @const Δ₁' id us md c ci h1 h2 h3 h4 => + intro Δ dk k depth W hdepth hbig + exact .const h1 h2 h3 h4 + | @app Δ₁' f a md f' a' A B h1 h2 htf hta ihf iha => + intro Δ dk k depth W hdepth hbig + have hbig' : arg.lbr.toNat + arg.size + depth.toNat + + (f.size + a.size + 1) < UInt64.size := hbig + rw [KExpr.substSpec, KExpr.mkApp_shape] + exact .app (W.toCtx ▸ h1) (W.toCtx ▸ h2) + (ihf W hdepth (by omega)) + (iha W hdepth (by omega)) + | @lam Δ₁' nm bi ty body md ty' body' h1 htty htbody ihty ihbody => + intro Δ dk k depth W hdepth hbig + have hbig' : arg.lbr.toNat + arg.size + depth.toNat + + (ty.size + body.size + 1) < UInt64.size := hbig + have hc1 : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.substSpec, KExpr.mkLam_shape] + exact .lam (W.toCtx ▸ h1) + (ihty W hdepth (by omega)) + (ihbody (W.succ (d := .vlam ty')) hc1 (by rw [hc1]; omega)) + | @all Δ₁' nm bi ty body md ty' body' h1 h2 htty htbody ihty ihbody => + intro Δ dk k depth W hdepth hbig + have hbig' : arg.lbr.toNat + arg.size + depth.toNat + + (ty.size + body.size + 1) < UInt64.size := hbig + have hc1 : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.substSpec, KExpr.mkAll_shape] + exact .all (W.toCtx ▸ h1) (W.toCtx ▸ h2) + (ihty W hdepth (by omega)) + (ihbody (W.succ (d := .vlam ty')) hc1 (by rw [hc1]; omega)) + | @letE Δ₁' nm ty val body nd md ty' val' body' h1 htty htval htbody + ihty ihval ihbody => + intro Δ dk k depth W hdepth hbig + have hbig' : arg.lbr.toNat + arg.size + depth.toNat + + (ty.size + val.size + body.size + 1) < UInt64.size := hbig + have hc1 : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.substSpec, KExpr.mkLet_shape] + exact .letE (W.toCtx ▸ h1) + (ihty W hdepth (by omega)) + (ihval W hdepth (by omega)) + (ihbody (W.succ (d := .vlet ty' val')) hc1 (by rw [hc1]; omega)) + | @prj Δ₁' sid field val md sName e' e'' h1 htval htrp ihval => + intro Δ dk k depth W hdepth hbig + have hbig' : arg.lbr.toNat + arg.size + depth.toNat + + (val.size + 1) < UInt64.size := hbig + rw [KExpr.substSpec, KExpr.mkPrj_shape] + exact .prj h1 (ihval W hdepth (by omega)) (W.toCtx ▸ htrp) + | @nat Δ₁' v blob md h => + intro Δ dk k depth W hdepth hbig + exact .nat h + | @str Δ₁' s blob md h => + intro Δ dk k depth W hdepth hbig + exact .str h + /-- **Beta step at the API level**: substituting under one `vlam`. Upstream `TrExprS.inst`. -/ theorem TrKExprS.inst {env : Lean4Lean.VEnv} {uvars : Nat} @@ -884,6 +1493,46 @@ theorem TrKExprS.inst {env : Lean4Lean.VEnv} {uvars : Nat} (KExpr.substSpec body arg 0) (body'.inst e₀') := TrKExprS.instN henv htp htpI h₀ t₀ H .zero rfl hbig +/-- **Explicit-let step at the API level**: substituting under one `vlet` + preserves the already-inlined Theory translation. Upstream + `TrExprS.inst_let`. -/ +theorem TrKExprS.inst_let {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + (henv : env.Ordered) + (htp : ∀ {Γ Γ' : List VExpr} {n k : Nat} {s : Lean.Name} {i : Nat} + {e e' : VExpr}, Lean4Lean.Ctx.LiftN n k Γ Γ' → trProj Γ s i e e' → + trProj Γ' s i (e.liftN n k) (e'.liftN n k)) + {Δ : KVLCtx} {arg body : KExpr .anon} {e₀' A₀ body' : VExpr} + (H : TrKExprS env uvars nameOf trProj + ((none, .vlet A₀ e₀') :: Δ) body body') + (h₀ : TrKExprS env uvars nameOf trProj Δ arg e₀') + (hbig : Δ.bvars + body.size + arg.size < UInt64.size) : + TrKExprS env uvars nameOf trProj Δ + (KExpr.substSpec body arg 0) body' := + TrKExprS.instN_let henv htp h₀ H .zero rfl hbig + +/-- Explicit-let instantiation with the exact depth-zero substitution + resource bound, independent of the ambient context size. -/ +theorem TrKExprS.inst_let_lbr {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + (henv : env.Ordered) + (htp : ∀ {Γ Γ' : List VExpr} {n k : Nat} {s : Lean.Name} {i : Nat} + {e e' : VExpr}, Lean4Lean.Ctx.LiftN n k Γ Γ' → trProj Γ s i e e' → + trProj Γ' s i (e.liftN n k) (e'.liftN n k)) + {Δ : KVLCtx} {arg body : KExpr .anon} {e₀' A₀ body' : VExpr} + (harg : KExpr.Constructed arg) + (H : TrKExprS env uvars nameOf trProj + ((none, .vlet A₀ e₀') :: Δ) body body') + (h₀ : TrKExprS env uvars nameOf trProj Δ arg e₀') + (hbig : arg.lbr.toNat + arg.size + body.size < UInt64.size) : + TrKExprS env uvars nameOf trProj Δ + (KExpr.substSpec body arg 0) body' := + TrKExprS.instN_let_lbr henv htp harg h₀ H .zero rfl (by + rw [show (0 : UInt64).toNat = 0 from rfl] + omega) + /-! ### Context typing kit (upstream `VLCtx.WF` lemma transfers) -/ /-- `VLocalDecl.WF.hasType` re-keyed: the resolved (value, type) pair of diff --git a/Ix/Tc/Verify/Whnf.lean b/Ix/Tc/Verify/Whnf.lean index 7ab0a3dc9..db206771c 100644 --- a/Ix/Tc/Verify/Whnf.lean +++ b/Ix/Tc/Verify/Whnf.lean @@ -172,18 +172,22 @@ validity is deliberately quantified over every represented context. K2 constructs this model from `ctxAddrForLbr` plus suffix sufficiency. -/ structure WhnfContextKeys where uvars : Nat - Represents : Address → KVLCtx → Prop + /-- `Represents lbr key Δ` interprets `key` as the suffix requested at + loose-bvar radius `lbr`. The radius is part of the cache key's semantic + domain even though it is compressed into the emitted digest. -/ + Represents : UInt64 → Address → KVLCtx → Prop namespace WhnfContextKeys /-- Closed expressions use the distinguished empty-context key. -/ def closed (uvars : Nat) : WhnfContextKeys where uvars := uvars - Represents key Δ := key = emptyCtxAddr ∧ Δ = [] + Represents lbr key Δ := lbr = 0 ∧ key = emptyCtxAddr ∧ Δ = [] -@[simp] theorem closed_represents {uvars : Nat} {key : Address} +@[simp] theorem closed_represents {uvars : Nat} {lbr : UInt64} {key : Address} {Δ : KVLCtx} : - (closed uvars).Represents key Δ ↔ key = emptyCtxAddr ∧ Δ = [] := + (closed uvars).Represents lbr key Δ ↔ + lbr = 0 ∧ key = emptyCtxAddr ∧ Δ = [] := Iff.rfl /-- A represented semantic context tied to the actual production cache-key @@ -193,7 +197,7 @@ def Matches (keys : WhnfContextKeys) (trProj : RawProjRel) (world : VerifyWorld) (s : TcState .anon) (Δ : KVLCtx) (source : KExpr .anon) (key : Address × Address) : Prop := CtxRecon world.venv keys.uvars world.nameOf trProj s Δ ∧ - keys.Represents key.2 Δ ∧ + keys.Represents source.lbr key.2 Δ ∧ ∃ s', TcM.whnfKey source s = .ok key s' end WhnfContextKeys @@ -222,6 +226,19 @@ namespace TcM TcM.ctxAddrForLbr 0 s = .ok emptyCtxAddr s := by rfl +/-- With no legacy de-Bruijn frames, every suffix request denotes the empty +context and does not populate the memo table. Fvar frames are intentionally +irrelevant: `ctxAddrForLbr` keys only the legacy stack. -/ +theorem ctxAddrForLbr_empty {s : TcState .anon} + (hempty : s.ctx.isEmpty = true) (lbr : UInt64) : + TcM.ctxAddrForLbr lbr s = .ok emptyCtxAddr s := by + unfold TcM.ctxAddrForLbr + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp [hempty] + rfl + /-- Closed expressions compute the distinguished empty-context key without mutating even the context-address memo. -/ theorem whnfKey_closed {source : KExpr .anon} {s : TcState .anon} @@ -251,6 +268,22 @@ theorem whnfKey_fst {s s' : TcState .anon} {source : KExpr .anon} rfl · contradiction +/-- The second component and post-state of a successful WHNF-key run come +from the underlying suffix-address computation exactly. -/ +theorem whnfKey_ctx {s s' : TcState .anon} {source : KExpr .anon} + {key : Address × Address} + (h : TcM.whnfKey source s = .ok key s') : + TcM.ctxAddrForLbr source.lbr s = .ok key.2 s' := by + unfold TcM.whnfKey at h + change EStateM.bind (TcM.ctxAddrForLbr source.lbr) + (fun addr => pure (source.addr, addr)) s = .ok key s' at h + unfold EStateM.bind at h + split at h + · next addr after hctx => + cases h + exact hctx + · contradiction + end TcM namespace WhnfContextKeys.Matches @@ -279,12 +312,72 @@ def blockErrorsOnly : CacheSemantics where mono := by intro before after support entry hle h exact h + Equiv _ _ := Eq + equivEquivalence := by + intro authority support + exact ⟨fun _ => rfl, Eq.symm, Eq.trans⟩ + equivMono := by + intro before after support left right hle h + exact h blockError := by intro authority support block err trivial end CacheSemantics +/-- Validity owned by the operational recursion-classifier cache. + +An `.isRec` entry is permitted exactly when its address names a trusted +anonymous declaration. The cached Boolean intentionally has no stronger +meaning: `true` is also used as a conservative re-entrancy marker and may +survive a declaration-discovery error, while any struct-eta success reached +through `false` is justified independently by the checked iota semantic +boundary. The fallback owns every other cache family. -/ +def IsRecCacheValid (fallback : CacheSemantics) + (authority : CacheAuthority) (support : RunSupport) : CacheEntry → Prop + | .isRec ind _ => + ∃ id : KId .anon, authority.world.trusted id ∧ id.addr = ind + | entry => fallback.Valid authority support entry + +namespace IsRecCacheValid + +/-- Trusted classifier addresses remain trusted when the semantic world +grows; all other entries inherit the fallback's monotonicity. -/ +theorem mono {fallback : CacheSemantics} + {before after : CacheAuthority} {support : RunSupport} + {entry : CacheEntry} (hle : before ≤ after) + (h : IsRecCacheValid fallback before support entry) : + IsRecCacheValid fallback after support entry := by + cases entry with + | isRec ind value => + obtain ⟨id, htrusted, haddr⟩ := h + exact ⟨id, hle.world.trusted htrusted, haddr⟩ + | expr | defEq | defEqFailure | unfold | natSuccStuck | isProp | + recursor | recMajors | blockPeer | blockResult => + exact fallback.mono hle h + +/-- Any Boolean for a trusted anonymous inductive address is accepted by the +classifier cache contract. -/ +theorem trusted {fallback : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {ind : KId .anon} {value : Bool} + (htrusted : authority.world.trusted ind) : + IsRecCacheValid fallback authority support (.isRec ind.addr value) := + ⟨ind, htrusted, rfl⟩ + +end IsRecCacheValid + +/-- Overlay the operational recursion-classifier family on an arbitrary +fallback cache semantics. -/ +def isRecCacheSemantics (fallback : CacheSemantics) : CacheSemantics where + Valid := IsRecCacheValid fallback + mono := IsRecCacheValid.mono + Equiv := fallback.Equiv + equivEquivalence := fallback.equivEquivalence + equivMono := fallback.equivMono + blockError := by + intro authority support block err + exact fallback.blockError authority support block err + /-- Exact K1 validity for one tagged entry. The fallback owns every non-K1 cache family. A WHNF entry must be sound for every finite-support source whose address is its first key component and every context represented by @@ -294,24 +387,25 @@ def WhnfCacheValid (keys : WhnfContextKeys) (trProj : RawProjRel) (support : RunSupport) : CacheEntry → Prop | .expr .whnf key value => ∀ source, support source → source.addr = key.1 → - ∀ Δ, keys.Represents key.2 Δ → + ∀ Δ, keys.Represents source.lbr key.2 Δ → WhnfMeaning trProj authority.world keys.uvars Δ source value | .expr .whnfNoDelta key value => ∀ source, support source → source.addr = key.1 → - ∀ Δ, keys.Represents key.2 Δ → + ∀ Δ, keys.Represents source.lbr key.2 Δ → WhnfMeaning trProj authority.world keys.uvars Δ source value | .expr .whnfNoDeltaCheap key value => ∀ source, support source → source.addr = key.1 → - ∀ Δ, keys.Represents key.2 Δ → + ∀ Δ, keys.Represents source.lbr key.2 Δ → WhnfMeaning trProj authority.world keys.uvars Δ source value | .expr .whnfCore key value => ∀ source, support source → source.addr = key.1 → - ∀ Δ, keys.Represents key.2 Δ → + ∀ Δ, keys.Represents source.lbr key.2 Δ → WhnfMeaning trProj authority.world keys.uvars Δ source value | .expr .whnfCoreCheap key value => ∀ source, support source → source.addr = key.1 → - ∀ Δ, keys.Represents key.2 Δ → + ∀ Δ, keys.Represents source.lbr key.2 Δ → WhnfMeaning trProj authority.world keys.uvars Δ source value + | .natSuccStuck _ => True | entry => fallback.Valid authority support entry namespace WhnfCacheValid @@ -329,7 +423,8 @@ theorem mono {keys : WhnfContextKeys} {trProj : RawProjRel} exact (h source hsource haddr Δ hctx).mono hle.world | infer | inferOnly => exact fallback.mono hle h - | defEq | defEqFailure | unfold | natSuccStuck | isProp | isRec | + | natSuccStuck => trivial + | defEq | defEqFailure | unfold | isProp | isRec | recursor | recMajors | blockPeer | blockResult => exact fallback.mono hle h @@ -343,10 +438,20 @@ theorem expr {keys : WhnfContextKeys} {trProj : RawProjRel} (h : WhnfCacheValid keys trProj fallback authority support (.expr kind key value)) (hsource : support source) (haddr : source.addr = key.1) - {Δ : KVLCtx} (hctx : keys.Represents key.2 Δ) : + {Δ : KVLCtx} (hctx : keys.Represents source.lbr key.2 Δ) : WhnfMeaning trProj authority.world keys.uvars Δ source value := by cases hkind <;> exact h source hsource haddr Δ hctx +/-- A stuck-successor marker carries no positive reduction claim. Its +semantic component is therefore unconditional; finite support and trusted +reference authorization remain mandatory in `CacheProvenance`. -/ +theorem natSuccStuck {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {key : Address × Address} : + WhnfCacheValid keys trProj fallback authority support + (.natSuccStuck key) := by + trivial + end WhnfCacheValid /-- Overlay the exact K1 meanings on an existing semantic family. -/ @@ -354,12 +459,35 @@ def whnfCacheSemantics (keys : WhnfContextKeys) (trProj : RawProjRel) (fallback : CacheSemantics) : CacheSemantics where Valid := WhnfCacheValid keys trProj fallback mono := WhnfCacheValid.mono + Equiv := fallback.Equiv + equivEquivalence := fallback.equivEquivalence + equivMono := fallback.equivMono blockError := by intro authority support block err exact fallback.blockError authority support block err namespace CacheProvenance +/-- Construct K1 provenance for a negative successor marker. Unlike a +cached expression result, the marker needs no Theory reduction witness; it +still records a supported source address and proves that every supported +source sharing that address refers only to trusted declarations. -/ +theorem whnfNatSuccStuck + {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {world : VerifyWorld} + {support : RunSupport} {key : Address × Address} + (hsupported : support.HasExprAddr key.1) + (hreferences : ∀ {id}, + CacheEntry.SourceReferences support key.1 id → world.trusted id) : + CacheProvenance (whnfCacheSemantics keys trProj fallback) + (CacheAuthority.stable world) support (.natSuccStuck key) := by + refine ⟨hsupported, ?_, WhnfCacheValid.natSuccStuck + (keys := keys) (trProj := trProj) (fallback := fallback) + (authority := CacheAuthority.stable world) (support := support) + (key := key)⟩ + intro id href + exact .inl (hreferences href) + /-- A provenance-certified K1 hit exposes concrete Theory reduction meaning; support and dependency facts remain available in `h`. -/ theorem whnfMeaning {keys : WhnfContextKeys} {trProj : RawProjRel} @@ -370,7 +498,7 @@ theorem whnfMeaning {keys : WhnfContextKeys} {trProj : RawProjRel} authority support (.expr kind key value)) (hkind : kind.IsWhnf) (hsource : support source) (haddr : source.addr = key.1) {Δ : KVLCtx} - (hctx : keys.Represents key.2 Δ) : + (hctx : keys.Represents source.lbr key.2 Δ) : WhnfMeaning trProj authority.world keys.uvars Δ source value := by exact WhnfCacheValid.expr hkind h.valid hsource haddr hctx @@ -403,7 +531,7 @@ theorem whnfHit {keys : WhnfContextKeys} {trProj : RawProjRel} (hhit : env.HasCacheEntry (.expr kind key value)) (hkind : kind.IsWhnf) (hsource : support source) (haddr : source.addr = key.1) {Δ : KVLCtx} - (hctx : keys.Represents key.2 Δ) : + (hctx : keys.Represents source.lbr key.2 Δ) : WhnfMeaning trProj authority.world keys.uvars Δ source value := (h.hit hhit).whnfMeaning hkind hsource haddr hctx @@ -425,17 +553,138 @@ end CacheInvariant /-! ## Conditional recursive-method interface -/ -/-- The two theorem layers required by K1. The no-acceleration layer pins -the production flag; the accelerated layer permits native helpers and hence -requires `NativeOracle` at their successful branches. -/ +/-- The theorem layers used by K1. `structuralNoAccel` is deliberately +restricted to syntax-directed fixtures: it pins the acceleration gate but +does not claim that the state's primitive table is the production anon +table. The two production layers both bind every observable table address to +`PrimAddrs.canonical`; `noAccel` additionally pins the gate, while +`accelerated` permits native helpers and hence requires `NativeOracle` at +their successful branches. -/ inductive WhnfLayer where + | structuralNoAccel | noAccel | accelerated deriving Repr, DecidableEq +namespace Primitives + +/-- Erase an anon primitive table to exactly the addresses observed by the +kernel. `Primitives` omits the two PProd entries that live only in +`PrimAddrs`; those components are fixed directly to the canonical table. -/ +def addressTable (p : Primitives .anon) : PrimAddrs where + nat := p.nat.addr + natZero := p.natZero.addr + natSucc := p.natSucc.addr + natAdd := p.natAdd.addr + natPred := p.natPred.addr + natSub := p.natSub.addr + natMul := p.natMul.addr + natPow := p.natPow.addr + natGcd := p.natGcd.addr + natMod := p.natMod.addr + natDiv := p.natDiv.addr + natBitwise := p.natBitwise.addr + natBeq := p.natBeq.addr + natBle := p.natBle.addr + natLand := p.natLand.addr + natLor := p.natLor.addr + natXor := p.natXor.addr + natShiftLeft := p.natShiftLeft.addr + natShiftRight := p.natShiftRight.addr + boolType := p.boolType.addr + boolTrue := p.boolTrue.addr + boolFalse := p.boolFalse.addr + string := p.string.addr + stringMk := p.stringMk.addr + charType := p.charType.addr + charMk := p.charMk.addr + charOfNat := p.charOfNat.addr + stringOfList := p.stringOfList.addr + stringToByteArray := p.stringToByteArray.addr + byteArrayEmpty := p.byteArrayEmpty.addr + list := p.list.addr + listNil := p.listNil.addr + listCons := p.listCons.addr + eq := p.eq.addr + eqRefl := p.eqRefl.addr + quotType := p.quotType.addr + quotCtor := p.quotCtor.addr + quotLift := p.quotLift.addr + quotInd := p.quotInd.addr + reduceBool := p.reduceBool.addr + reduceNat := p.reduceNat.addr + eagerReduce := p.eagerReduce.addr + systemPlatformNumBits := p.systemPlatformNumBits.addr + systemPlatformGetNumBits := p.systemPlatformGetNumBits.addr + subtypeVal := p.subtypeVal.addr + natDecLe := p.natDecLe.addr + natDecEq := p.natDecEq.addr + natDecLt := p.natDecLt.addr + decidableRec := p.decidableRec.addr + decidableIsTrue := p.decidableIsTrue.addr + decidableIsFalse := p.decidableIsFalse.addr + natLeOfBleEqTrue := p.natLeOfBleEqTrue.addr + natNotLeOfNotBleEqTrue := p.natNotLeOfNotBleEqTrue.addr + natEqOfBeqEqTrue := p.natEqOfBeqEqTrue.addr + natNeOfBeqEqFalse := p.natNeOfBeqEqFalse.addr + fin := p.fin.addr + boolNoConfusion := p.boolNoConfusion.addr + int := p.int.addr + intOfNat := p.intOfNat.addr + intNegSucc := p.intNegSucc.addr + intAdd := p.intAdd.addr + intSub := p.intSub.addr + intMul := p.intMul.addr + intNeg := p.intNeg.addr + intEmod := p.intEmod.addr + intEdiv := p.intEdiv.addr + intBmod := p.intBmod.addr + intBdiv := p.intBdiv.addr + intNatAbs := p.intNatAbs.addr + intPow := p.intPow.addr + intDecEq := p.intDecEq.addr + intDecLe := p.intDecLe.addr + intDecLt := p.intDecLt.addr + punit := p.punit.addr + pprod := PrimAddrs.canonical.pprod + pprodMk := PrimAddrs.canonical.pprodMk + natRec := p.natRec.addr + natCasesOn := p.natCasesOn.addr + bitVec := p.bitVec.addr + bitVecToNat := p.bitVecToNat.addr + bitVecOfNat := p.bitVecOfNat.addr + bitVecUlt := p.bitVecUlt.addr + decidableDecide := p.decidableDecide.addr + ltLt := p.ltLt.addr + ofNatOfNat := p.ofNatOfNat.addr + unit := p.unit.addr + punitSizeOf1 := p.punitSizeOf1.addr + sizeOfSizeOf := p.sizeOfSizeOf.addr + stringBack := p.stringBack.addr + stringLegacyBack := p.stringLegacyBack.addr + stringUtf8ByteSize := p.stringUtf8ByteSize.addr + stringAppend := p.stringAppend.addr + stringDecEq := p.stringDecEq.addr + +/-- The production anon primitive condition. It constrains every address the +kernel can observe, while deliberately ignoring diagnostic name payloads. -/ +def CanonicalAnon (p : Primitives .anon) : Prop := + p.addressTable = PrimAddrs.canonical + +/-- The table installed by `TcState.ofEnvAnon` and the lazy anon driver is +canonical by construction. -/ +theorem ofAnonAddrs_canonical : + CanonicalAnon Primitives.ofAnonAddrs := by + simp only [CanonicalAnon, addressTable, Primitives.ofAnonAddrs, + Primitives.ofResolve] + +end Primitives + def WhnfLayer.StateOK : WhnfLayer → TcState .anon → Prop - | .noAccel, s => s.noAccel = true - | .accelerated, _ => True + | .structuralNoAccel, s => s.noAccel = true + | .noAccel, s => + s.noAccel = true ∧ s.prims.CanonicalAnon + | .accelerated, s => s.prims.CanonicalAnon /-- Fixed-world state invariant for one method call. Ordinary reduction does not promote declarations. Cache/intern coherence, concrete/ghost @@ -463,18 +712,81 @@ theorem of_semantic_fields_eq (hlet : after.letVals = before.letVals) (hnum : after.numLetBindings = before.numLetBindings) (hlctx : after.lctx = before.lctx) - (hnoAccel : after.noAccel = before.noAccel) : + (hprims : after.prims = before.prims) + (hnoAccel : after.noAccel = before.noAccel) + (hequiv : after.equivManager = before.equivManager) : WhnfStateInv layer semantics trProj world support uvars Δ after := by rcases h with ⟨hkernel, hrecon, hlayer⟩ refine ⟨?_, ?_, ?_⟩ · exact { core := hkernel.core.of_env_eq henv internSupport := by simpa only [henv] using hkernel.internSupport - caches := by simpa only [henv] using hkernel.caches } + caches := by simpa only [henv] using hkernel.caches + equivalences := by simpa only [hequiv] using hkernel.equivalences } · exact hrecon.of_fields_eq hctx hlet hnum hlctx (by simp [henv]) · cases layer with - | noAccel => simpa only [WhnfLayer.StateOK, hnoAccel] using hlayer - | accelerated => trivial + | structuralNoAccel => + simpa only [WhnfLayer.StateOK, hnoAccel] using hlayer + | noAccel => + simpa only [WhnfLayer.StateOK, hprims, hnoAccel] using hlayer + | accelerated => + simpa only [WhnfLayer.StateOK, hprims] using hlayer + +/-- Replace only the equivalence manager after separately proving its +semantic representation invariant. This is the sole state bridge used by +DefEq manager queries, path compression, and justified union operations. -/ +theorem setEquivManager + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + (h : WhnfStateInv layer semantics trProj world support uvars Delta s) + (manager : EquivManager) + (hmanager : EquivManager.WF + (semantics.Equiv (CacheAuthority.stable world) support) manager) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with equivManager := manager} := by + rcases h with ⟨hkernel, hctx, hlayer⟩ + exact ⟨{ + core := hkernel.core.of_env_eq rfl + internSupport := hkernel.internSupport + caches := hkernel.caches + equivalences := hmanager }, + hctx.of_fields_eq rfl rfl rfl rfl (by simp), by + cases layer <;> simpa [WhnfLayer.StateOK] using hlayer⟩ + +/-- The production no-acceleration invariant fixes the complete anon +primitive table, not merely the `noAccel` Boolean gate. -/ +theorem noAccel_primitives + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + (h : WhnfStateInv .noAccel semantics trProj world support uvars Δ s) : + s.prims.CanonicalAnon := + h.2.2.2 + +/-- Accelerated production runs use the same canonical anon primitive table. +Only the native execution gate differs. -/ +theorem accelerated_primitives + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + (h : WhnfStateInv .accelerated semantics trProj world support uvars Δ s) : + s.prims.CanonicalAnon := + h.2.2 + +/-- Rebudgeting recursive fuel is operational bookkeeping only. Naming this +frame is useful for Nat's open-argument reducer, which lowers the budget before +a recursive WHNF callback and restores the caller-visible remainder on every +callback outcome. -/ +theorem set_recFuel + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + (h : WhnfStateInv layer semantics trProj world support uvars Δ s) + (fuel : UInt64) : + WhnfStateInv layer semantics trProj world support uvars Δ + {s with recFuel := fuel} := + h.of_semantic_fields_eq rfl rfl rfl rfl rfl rfl rfl rfl end WhnfStateInv @@ -502,20 +814,40 @@ theorem whnfStateInv {layer : WhnfLayer} {semantics : CacheSemantics} simpa [ContextKeyFrame] using congrArg TcState.lctx hframe have hnoAccel : after.noAccel = before.noAccel := by simpa [ContextKeyFrame] using congrArg TcState.noAccel hframe + have hprims : after.prims = before.prims := by + simpa [ContextKeyFrame] using congrArg TcState.prims hframe + have hequiv : after.equivManager = before.equivManager := by + simpa [ContextKeyFrame] using congrArg TcState.equivManager hframe refine ⟨?_, ?_, ?_⟩ · exact { core := hkernel.core.of_env_eq henv internSupport := by simpa [henv] using hkernel.internSupport - caches := by simpa [henv] using hkernel.caches } + caches := by simpa [henv] using hkernel.caches + equivalences := by simpa [hequiv] using hkernel.equivalences } · exact hctx.of_fields_eq hctxEq hlet hnum hlctx (by simp [henv]) · cases layer with - | noAccel => simpa [WhnfLayer.StateOK, hnoAccel] using hlayer - | accelerated => trivial + | structuralNoAccel => + simpa [WhnfLayer.StateOK, hnoAccel] using hlayer + | noAccel => + simpa [WhnfLayer.StateOK, hprims, hnoAccel] using hlayer + | accelerated => + simpa [WhnfLayer.StateOK, hprims] using hlayer end ContextKeyFrame namespace InternUpdateFrame +/-- Doing no interning is the identity intern-only frame. -/ +@[refl] theorem refl (s : TcState .anon) : InternUpdateFrame s s := by + rfl + +/-- Sequential intern-only computations compose to one intern-only frame. -/ +theorem trans {s₀ s₁ s₂ : TcState .anon} + (h₁ : InternUpdateFrame s₀ s₁) + (h₂ : InternUpdateFrame s₁ s₂) : InternUpdateFrame s₀ s₂ := by + unfold InternUpdateFrame at * + rw [h₂, h₁] + /-- Intern-table growth preserves the context and acceleration components of the K1 invariant once the post-state kernel invariant has been re-established. Keeping the kernel premise explicit lets the finite-support walker proofs @@ -541,11 +873,17 @@ theorem whnfStateInv {layer : WhnfLayer} {semantics : CacheSemantics} congrArg (fun s : TcState .anon => s.env.nextFVarId) hframe have hnoAccel : after.noAccel = before.noAccel := by simpa [InternUpdateFrame] using congrArg TcState.noAccel hframe + have hprims : after.prims = before.prims := by + simpa [InternUpdateFrame] using congrArg TcState.prims hframe refine ⟨hkernel, ?_, ?_⟩ · exact hctx.of_fields_eq hctxEq hlet hnum hlctx (by simp [hnext]) · cases layer with - | noAccel => simpa [WhnfLayer.StateOK, hnoAccel] using hlayer - | accelerated => trivial + | structuralNoAccel => + simpa [WhnfLayer.StateOK, hnoAccel] using hlayer + | noAccel => + simpa [WhnfLayer.StateOK, hprims, hnoAccel] using hlayer + | accelerated => + simpa [WhnfLayer.StateOK, hprims] using hlayer end InternUpdateFrame @@ -577,7 +915,8 @@ theorem runIntern_whnf_wf {layer : WhnfLayer} have hkernel' : KernelStateWF semantics trProj world support { s with env := { s.env with intern } } := ⟨hkernel.core.of_consts_eq rfl hpost.2.1, - hpost.2.2, hkernel.caches.of_intern_update⟩ + hpost.2.2, hkernel.caches.of_intern_update, + hkernel.equivalences⟩ exact ⟨hframe.whnfStateInv hkernel' hI, hpost.1, hframe⟩ /-- Executable form of `runIntern_whnf_wf`. `InternM` cannot throw, so an @@ -603,6 +942,68 @@ theorem runIntern_whnf_eval {layer : WhnfLayer} simp only [TcM.runIntern, hrun] rw [hwf.2.1] +/-- Direct expression interning needs only finite support for the requested +node and collision freedom on that same run domain. This is the request-list +independent form used by primitive reducers whose generated syntax is already +enumerated by their verification context. -/ +theorem internExpr_support_spec + {support : RunSupport} (hcollision : support.CollisionFree) + {e : KExpr .anon} (hsupport : support e) + (it : InternTable .anon) (hwf : it.WF) + (hcover : support.CoversIntern it) : + (it.internExpr e).1 = e ∧ + (it.internExpr e).2.WF ∧ + support.CoversIntern (it.internExpr e).2 := by + have hkcf : KExpr.KeyCollisionFree + (fun value => it.ExprSupport value ∨ value = e) := + KExpr.keyCollisionFree_anon.mpr <| + hcollision.expr.mono fun value hvalue => + hvalue.elim (hcover.expr value) fun h => h ▸ hsupport + have hcanon : (it.internExpr e).1 = e := by + have heq := InternTable.internExpr_eraseMeta hwf hkcf + rwa [KExpr.eraseMeta_anon, KExpr.eraseMeta_anon] at heq + refine ⟨hcanon, hwf.internExpr e, ?_⟩ + constructor + · intro value hvalue + rcases InternTable.ExprSupport.of_internExpr hvalue with hvalue | rfl + · exact hcover.expr value hvalue + · exact hsupport + · intro u hu + exact hcover.univ u (by + simpa only [InternTable.UnivSupport, + InternTable.internExpr_univs] using hu) + +/-- Hoare form of direct primitive-result interning over a finite collision- +free support. The returned expression is the requested anon node exactly, +and only the intern table may change. -/ +theorem intern_whnf_wf {layer : WhnfLayer} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Δ : KVLCtx} {e : KExpr .anon} {s : TcState .anon} + (hcollision : support.CollisionFree) (hsupport : support e) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s + (TcM.intern e) + (fun result s' => result = e ∧ InternUpdateFrame s s') := by + exact TcM.runIntern_whnf_wf + (x := internExprM e) (expected := e) + (fun it hwf hcover => + internExpr_support_spec hcollision hsupport it hwf hcover) + +/-- Executable form of `intern_whnf_wf`; direct interning cannot throw. -/ +theorem intern_whnf_eval {layer : WhnfLayer} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Δ : KVLCtx} {e : KExpr .anon} {s : TcState .anon} + (hcollision : support.CollisionFree) (hsupport : support e) + (hI : WhnfStateInv layer semantics trProj world support uvars Δ s) : + ∃ s', TcM.intern e s = .ok e s' ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s' ∧ + InternUpdateFrame s s' := by + exact TcM.runIntern_whnf_eval + (x := internExprM e) (expected := e) + (fun it hwf hcover => + internExpr_support_spec hcollision hsupport it hwf hcover) hI + private theorem get_bind_run {α : Type} (s : TcState .anon) (f : TcState .anon → TcM .anon α) : ((get >>= f : TcM .anon α) s) = f s s := rfl @@ -628,6 +1029,30 @@ theorem lookupLetVal_eval {idx : UInt64} rw [hlift] rfl +/-- A successful `lookupLetVal` miss is state-pure. The only stateful arm + runs `lift` and always wraps its successful result in `some`; therefore it + cannot witness an `.ok none` outcome, even if the lift changes state. -/ +theorem lookupLetVal_none_state {idx : UInt64} + {s s' : TcState .anon} + (h : TcM.lookupLetVal idx s = .ok none s') : s' = s := by + unfold TcM.lookupLetVal at h + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ at h + unfold EStateM.bind at h + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] at h + simp only at h + split at h + · cases h + rfl + · split at h + · cases h + rfl + · rename_i val hval + change EStateM.bind (TcM.runIntern (lift val (idx + 1) 0)) + (fun r => pure (some r)) s = _ at h + unfold EStateM.bind at h + cases hrun : TcM.runIntern (lift val (idx + 1) 0) s <;> + rw [hrun] at h <;> cases h + /-- Implementation-level frame theorem for `ctxAddrForLbr`. It is polymorphic in the invariant: clients only need to prove closure under the single permitted memo-table write. -/ @@ -687,8 +1112,10 @@ theorem whnfKey_matches_wf {layer : WhnfLayer} {semantics : CacheSemantics} {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} {keys : WhnfContextKeys} {Δ : KVLCtx} {source : KExpr .anon} {s : TcState .anon} - (hrep : ∀ key s', TcM.whnfKey source s = .ok key s' → - keys.Represents key.2 Δ) : + (hrep : ∀ key s', + CtxRecon world.venv keys.uvars world.nameOf trProj s Δ → + TcM.whnfKey source s = .ok key s' → + keys.Represents source.lbr key.2 Δ) : TcM.WF (WhnfStateInv layer semantics trProj world support keys.uvars Δ) s (TcM.whnfKey source) @@ -702,11 +1129,72 @@ theorem whnfKey_matches_wf {layer : WhnfLayer} | .ok key s' => rw [hrun] at hwf exact ⟨hwf.1, - ⟨⟨hI.2.1, hrep key s' hrun, ⟨s', hrun⟩⟩, hwf.2.2⟩⟩ + ⟨⟨hI.2.1, hrep key s' hI.2.1 hrun, ⟨s', hrun⟩⟩, hwf.2.2⟩⟩ | .error err s' => rw [hrun] at hwf exact hwf +/-- `isLetVar` is a read-only prefix test. Recording its exact state frame + lets the public WHNF dispatch theorem handle legacy variables without an + extra operational oracle. -/ +theorem isLetVar_wf {I : TcState .anon -> Prop} (idx : UInt64) + (s : TcState .anon) : + TcM.WF I s (TcM.isLetVar idx) + (fun _ s' => s' = s) := by + unfold TcM.isLetVar + apply TcM.WF.bind + (Q₁ := fun read s' => read = s ∧ s' = s) + (TcM.WF.get fun _ => ⟨rfl, rfl⟩) + rintro read s' ⟨rfl, rfl⟩ + simp only + split <;> exact TcM.WF.pure (fun _ => rfl) + +/-- Step journaling has no semantic state effect, whether enabled or not. -/ +theorem stepTrace_whnf_wf {layer : WhnfLayer} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} (tag : String) (payload : Unit -> String) + (s : TcState .anon) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.stepTrace tag payload) (fun _ _ => True) := by + unfold TcM.stepTrace + apply TcM.WF.bind + (Q₁ := fun read s' => read = s ∧ s' = s) + (TcM.WF.get fun _ => ⟨rfl, rfl⟩) + rintro read s' ⟨rfl, rfl⟩ + simp only + split <;> exact TcM.WF.pure (fun _ => trivial) + +/-- A statistics update preserves WHNF state whenever its semantic fields + frame. The production call/miss counter updates instantiate every + premise by reflexivity. -/ +theorem bumpStats_whnf_wf {layer : WhnfLayer} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} (f : TcState .anon -> TcState .anon) + (henv : forall s, (f s).env = s.env) + (hctx : forall s, (f s).ctx = s.ctx) + (hlet : forall s, (f s).letVals = s.letVals) + (hnum : forall s, (f s).numLetBindings = s.numLetBindings) + (hlctx : forall s, (f s).lctx = s.lctx) + (hprims : forall s, (f s).prims = s.prims) + (hnoAccel : forall s, (f s).noAccel = s.noAccel) + (hequiv : forall s, (f s).equivManager = s.equivManager) + (s : TcState .anon) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.bumpStats f) (fun _ _ => True) := by + unfold TcM.bumpStats + apply TcM.WF.bind + (Q₁ := fun read s' => read = s ∧ s' = s) + (TcM.WF.get fun _ => ⟨rfl, rfl⟩) + rintro read s' ⟨rfl, rfl⟩ + split + · exact TcM.WF.modifyGet + (fun hI => hI.of_semantic_fields_eq (henv s') (hctx s') (hlet s') + (hnum s') (hlctx s') (hprims s') (hnoAccel s') (hequiv s')) + (fun _ => trivial) + · exact TcM.WF.pure (fun _ => trivial) + /-! ### Exact instrumentation and fuel equations -/ /-- A disabled step journal is an exact state-preserving no-op. -/ @@ -746,6 +1234,65 @@ end TcM namespace RunAssumptions +/-- One certified expression-intern request returns the requested raw +expression exactly, preserves the complete K1 invariant, and changes only the +intern table. Collision freedom and finite support are supplied by the +execution-indexed request rather than assumed for an arbitrary expression. -/ +theorem internExpr_whnf_eval {α : Type} {initial : TcState .anon} + {program : TcM .anon α} {requests : List WalkerRequest} + {support : RunSupport} + (h : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Δ : KVLCtx} {e : KExpr .anon} + (hmem : WalkerRequest.internExpr e ∈ requests) + {s : TcState .anon} + (hI : WhnfStateInv layer semantics trProj world support uvars Δ s) : + ∃ s', TcM.intern e s = .ok e s' ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s' ∧ + InternUpdateFrame s s' := by + exact TcM.runIntern_whnf_eval + (fun _ hwf hsup => h.internExpr_spec hmem hwf hsup) hI + +/-- The verified single-substitution walker preserves the complete K1 +invariant. This is the explicit-let sibling of `simulSubst_whnf_wf`: +production substitutes the let value into its body while only the intern +table may grow. -/ +theorem subst_whnf_wf {α : Type} {initial : TcState .anon} + {program : TcM .anon α} {requests : List WalkerRequest} + {support : RunSupport} + (h : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Δ : KVLCtx} {body arg : KExpr .anon} {depth : UInt64} + (hmem : WalkerRequest.subst body arg depth ∈ requests) + {s : TcState .anon} : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s + (TcM.runIntern (subst body arg depth)) + (fun result s' => result = KExpr.substSpec body arg depth ∧ + InternUpdateFrame s s') := + TcM.runIntern_whnf_wf fun _ hwf hsup => + h.subst_spec hmem hwf hsup + +/-- Concrete-success projection of `subst_whnf_wf`, used by the production +explicit-let step. -/ +theorem subst_whnf_eval {α : Type} {initial : TcState .anon} + {program : TcM .anon α} {requests : List WalkerRequest} + {support : RunSupport} + (h : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Δ : KVLCtx} {body arg : KExpr .anon} {depth : UInt64} + (hmem : WalkerRequest.subst body arg depth ∈ requests) + {s : TcState .anon} + (hI : WhnfStateInv layer semantics trProj world support uvars Δ s) : + ∃ s', TcM.runIntern (subst body arg depth) s = + .ok (KExpr.substSpec body arg depth) s' ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s' ∧ + InternUpdateFrame s s' := + TcM.runIntern_whnf_eval + (fun _ hwf hsup => h.subst_spec hmem hwf hsup) hI + /-- The verified lifting walker preserves the complete K1 invariant. This is the legacy-zeta sibling of `simulSubst_whnf_wf`: the stored let value is rebased to the current de Bruijn depth while only the intern table may grow. -/ @@ -928,6 +1475,31 @@ theorem zetaFVar {trProj : RawProjRel} {world : VerifyWorld} ⟨A, hctx.wf.find?_wf world.venvWF.ordered hresolve⟩ exact ⟨e, e, hsource, hresult, hwf⟩ +/-- One explicit-let zeta step. `TrKExprS` already inlines the source let +into `bodyV`; `TrKExprS.inst_let_lbr` proves that production's concrete +`substSpec` result translates to that same Theory expression. Thus the +semantic equality is reflexive, but only after the mixed-context +instantiation theorem has connected the two concrete terms. -/ +theorem letE {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + {s : TcState .anon} {Δ : KVLCtx} + (hctx : CtxRecon world.venv uvars world.nameOf trProj s Δ) + {name : Mode.anon.F Name} {ty val body : KExpr .anon} + {nondep : Bool} {info : ExprInfo .anon} {bodyV : VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ + (.letE name ty val body nondep info) bodyV) + (hvalCon : KExpr.Constructed val) + (hbig : val.lbr.toNat + val.size + body.size < UInt64.size) : + WhnfMeaning trProj world uvars Δ + (.letE name ty val body nondep info) (KExpr.substSpec body val 0) := by + let .letE hvalTy hty hval hbody := hsource + have hresult : TrKExprS world.venv uvars world.nameOf trProj Δ + (KExpr.substSpec body val 0) bodyV := + TrKExprS.inst_let_lbr world.venvWF.ordered theory.projections.weakN + hvalCon hbody hval hbig + exact ⟨bodyV, bodyV, hsource, hresult, + Lean4Lean.VEnv.IsDefEqU.refl (theory.exprWF hctx hresult)⟩ + /-- One concrete beta step. The result is the same `substSpec` computed by the verified substitution walker; the proof uses `TrKExprS.instN` and the Theory's beta rule, so no syntactic address equality stands in for reduction @@ -1029,6 +1601,37 @@ theorem refl {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} WhnfPost trProj world uvars Δ sourceV e := ⟨sourceV, htr, hwf⟩ +/-- Extend a postcondition through one locally sound reduction step. The + concrete middle expression may have two structural translations; their + uniqueness is the only bridge used before Theory transitivity. -/ +theorem transMeaning {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Delta : KVLCtx} {sourceV : VExpr} + {middle result : KExpr .anon} (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hpost : WhnfPost trProj world uvars Delta sourceV middle) + (hstep : WhnfMeaning trProj world uvars Delta middle result) : + WhnfPost trProj world uvars Delta sourceV result := by + obtain ⟨middleV1, hmiddle1, hdefeq1⟩ := hpost + obtain ⟨middleV2, resultV, hmiddle2, hresult, hdefeq2⟩ := hstep + have hctx := KVLCtx.IsDefEq.refl world.venvWF hDelta + have hmiddle := hmiddle1.uniq world.venvWF theory.literalWF + theory.projections hctx hmiddle2 + refine ⟨resultV, hresult, ?_⟩ + exact hdefeq1.trans world.venvWF hDelta <| + hmiddle.trans world.venvWF hDelta hdefeq2 + +/-- Recover the concrete source/result reduction meaning when the caller + retains the source translation used to state `WhnfPost`. -/ +theorem meaning {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Delta : KVLCtx} {source : KExpr .anon} + {sourceV : VExpr} {result : KExpr .anon} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hpost : WhnfPost trProj world uvars Delta sourceV result) : + WhnfMeaning trProj world uvars Delta source result := by + obtain ⟨resultV, hresult, hdefeq⟩ := hpost + exact ⟨sourceV, resultV, hsource, hresult, hdefeq⟩ + end WhnfPost /-- Successful inference callback postcondition used inside WHNF's K/struct @@ -1042,6 +1645,62 @@ def InferPost (trProj : RawProjRel) (world : VerifyWorld) namespace Methods +/-- Semantic closure of all six recursive back-edges at one declaration +universe count. + +Every recursive method call made while checking a declaration stays at that +declaration's `uvars`; only the local context changes. Indexing this record +by `uvars` therefore matches production execution and permits the cache +semantics to interpret universe-sensitive WHNF keys honestly. The older +unindexed `Methods.WF` below is retained as the strictly stronger +all-universe package used by compatibility statements. -/ +structure WFAt (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (methods : Methods .anon) : Prop where + whnf : ∀ {Δ s e sourceV}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Δ e sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s + (methods.whnf e) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Δ sourceV result) + whnfCore : ∀ {Δ s e sourceV}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Δ e sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s + (methods.whnfCore e) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Δ sourceV result) + whnfMode : ∀ {Δ s e sourceV} {mode : NatSuccMode}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Δ e sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s + (methods.whnfMode e mode) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Δ sourceV result) + whnfCoreFlags : ∀ {Δ s e sourceV} {flags : WhnfFlags}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Δ e sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s + (methods.whnfCoreFlags e flags) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Δ sourceV result) + infer : ∀ {Δ s e sourceV}, + support e → + TrKExprS world.venv uvars world.nameOf trProj Δ e sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s + (methods.infer e) + (fun ty _ => support ty ∧ InferPost trProj world uvars Δ sourceV ty) + isDefEq : ∀ {Δ s a b va vb}, + support a → + support b → + TrKExprS world.venv uvars world.nameOf trProj Δ a va → + TrKExprS world.venv uvars world.nameOf trProj Δ b vb → + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s + (methods.isDefEq a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Δ.toCtx va vb) + /-- Conditional semantic closure of all six K0 method-table back-edges. K1 consumes this record while proving WHNF; K2 proves the inference/defeq fields and closes `methodsN` by induction. -/ @@ -1049,31 +1708,42 @@ structure WF (layer : WhnfLayer) (semantics : CacheSemantics) (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) (methods : Methods .anon) : Prop where whnf : ∀ {uvars Δ s e sourceV}, + support e → TrKExprS world.venv uvars world.nameOf trProj Δ e sourceV → TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s (methods.whnf e) - (fun result _ => WhnfPost trProj world uvars Δ sourceV result) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Δ sourceV result) whnfCore : ∀ {uvars Δ s e sourceV}, + support e → TrKExprS world.venv uvars world.nameOf trProj Δ e sourceV → TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s (methods.whnfCore e) - (fun result _ => WhnfPost trProj world uvars Δ sourceV result) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Δ sourceV result) whnfMode : ∀ {uvars Δ s e sourceV} {mode : NatSuccMode}, + support e → TrKExprS world.venv uvars world.nameOf trProj Δ e sourceV → TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s (methods.whnfMode e mode) - (fun result _ => WhnfPost trProj world uvars Δ sourceV result) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Δ sourceV result) whnfCoreFlags : ∀ {uvars Δ s e sourceV} {flags : WhnfFlags}, + support e → TrKExprS world.venv uvars world.nameOf trProj Δ e sourceV → TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s (methods.whnfCoreFlags e flags) - (fun result _ => WhnfPost trProj world uvars Δ sourceV result) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Δ sourceV result) infer : ∀ {uvars Δ s e sourceV}, + support e → TrKExprS world.venv uvars world.nameOf trProj Δ e sourceV → TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s (methods.infer e) - (fun ty _ => InferPost trProj world uvars Δ sourceV ty) + (fun ty _ => support ty ∧ InferPost trProj world uvars Δ sourceV ty) isDefEq : ∀ {uvars Δ s a b va vb}, + support a → + support b → TrKExprS world.venv uvars world.nameOf trProj Δ a va → TrKExprS world.venv uvars world.nameOf trProj Δ b vb → TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s @@ -1081,11 +1751,30 @@ structure WF (layer : WhnfLayer) (semantics : CacheSemantics) (fun answer _ => answer = true → world.venv.IsDefEqU uvars Δ.toCtx va vb) +namespace WF + +/-- Forget the all-universe strength of the legacy method contract and use it +at the universe count of the active checker run. -/ +theorem atUvars {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {methods : Methods .anon} + (h : Methods.WF layer semantics trProj world support methods) + (uvars : Nat) : + Methods.WFAt layer semantics trProj world support uvars methods where + whnf := h.whnf + whnfCore := h.whnfCore + whnfMode := h.whnfMode + whnfCoreFlags := h.whnfCoreFlags + infer := h.infer + isDefEq := h.isDefEq + +end WF + end Methods /-! ## Projection/iota semantic boundary -/ -/-- Conditional K1e boundary for the two inductive structural reducers. +/-- Conditional semantic boundary for the two inductive structural reducers. The production helpers are intentionally syntax-directed: a loaded constructor-shaped constant is enough for them to select a projection field @@ -1105,7 +1794,7 @@ structure InductiveReductionOracle (layer : WhnfLayer) (world : VerifyWorld) (support : RunSupport) : Prop where projection : ∀ {uvars Δ methods s s₁ s₂ id field value wvalue result info flags sourceV}, - Methods.WF layer semantics trProj world support methods → + Methods.WFAt layer semantics trProj world support uvars methods → TrKExprS world.venv uvars world.nameOf trProj Δ (.prj id field value info) sourceV → WhnfStateInv layer semantics trProj world support uvars Δ s → @@ -1119,7 +1808,7 @@ structure InductiveReductionOracle (layer : WhnfLayer) (.prj id field value info) result iota : ∀ {uvars Δ methods s s₁ s₂ recId us headInfo appInfo f arg args result flags sourceV}, - Methods.WF layer semantics trProj world support methods → + Methods.WFAt layer semantics trProj world support uvars methods → TrKExprS world.venv uvars world.nameOf trProj Δ (.app f arg appInfo) sourceV → WhnfStateInv layer semantics trProj world support uvars Δ s → @@ -1144,7 +1833,7 @@ def WF (layer : WhnfLayer) (semantics : CacheSemantics) (uvars : Nat) (Δ : KVLCtx) (s : TcState .anon) (x : RecM .anon α) (Q : α → TcState .anon → Prop) (E : TcError .anon → TcState .anon → Prop := fun _ _ => True) : Prop := - ∀ methods, methods.WF layer semantics trProj world support → + ∀ methods, methods.WFAt layer semantics trProj world support uvars → TcM.WF (WhnfStateInv layer semantics trProj world support uvars Δ) s (x.run methods) Q E @@ -1186,6 +1875,33 @@ theorem mono {layer : WhnfLayer} {semantics : CacheSemantics} intro methods hmethods exact TcM.WF.mono (hx methods hmethods) hq he +/-- Expose the invariant already guaranteed by a Hoare triple inside its +success postcondition. This strengthening is useful when a later generated +term is indexed by the concrete callback post-state; the error predicate is +left unchanged so the result composes through ordinary `bind`. -/ +theorem withInv {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + {x : RecM .anon α} {Q : α → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (hx : RecM.WF layer semantics trProj world support uvars Δ s x Q E) : + RecM.WF layer semantics trProj world support uvars Δ s x + (fun result after => + WhnfStateInv layer semantics trProj world support uvars Δ after ∧ + Q result after) + E := by + intro methods hmethods hI + have hpost := hx methods hmethods hI + match hrun : x.run methods s with + | .ok result after => + rw [hrun] at hpost + simp only at hpost ⊢ + exact ⟨hpost.1, hpost.1, hpost.2⟩ + | .error err after => + rw [hrun] at hpost + simp only at hpost ⊢ + exact hpost + theorem bind {layer : WhnfLayer} {semantics : CacheSemantics} {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} @@ -1202,8 +1918,366 @@ theorem bind {layer : WhnfLayer} {semantics : CacheSemantics} exact TcM.WF.bind (hx methods hmethods) fun a s' ha => hf a s' ha methods hmethods +/-- Reader-level non-backtracking catch. The handler receives the exact +partial post-state certified by the body, matching `EStateM` rather than a +rollback-style exception transformer. -/ +theorem tryCatch {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + {x : RecM .anon α} {handler : TcError .anon → RecM .anon α} + {Q : α → TcState .anon → Prop} + {E₁ E₂ : TcError .anon → TcState .anon → Prop} + (hx : RecM.WF layer semantics trProj world support uvars Δ s x Q E₁) + (hh : ∀ err s', E₁ err s' → + RecM.WF layer semantics trProj world support uvars Δ s' + (handler err) Q E₂) : + RecM.WF layer semantics trProj world support uvars Δ s + (tryCatch x handler) Q E₂ := by + intro methods hmethods + change TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Δ) s + (EStateM.tryCatch (x.run methods) + (fun err => (handler err).run methods)) Q E₂ + exact TcM.WF.tryCatch (hx methods hmethods) fun err s' herr => + hh err s' herr methods hmethods + +/-- Lift a verified base `TcM` action through the method-table reader. -/ +theorem liftTcM {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {x : TcM .anon alpha} {Q : alpha -> TcState .anon -> Prop} + {E : TcError .anon -> TcState .anon -> Prop} + (hx : TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s x Q E) : + RecM.WF layer semantics trProj world support uvars Delta s + (liftM x) Q E := by + intro methods hmethods + exact hx + +/-- Reader-level state observation preserves the K1 invariant exactly. -/ +theorem get {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {Q : TcState .anon -> TcState .anon -> Prop} + {E : TcError .anon -> TcState .anon -> Prop} + (h : WhnfStateInv layer semantics trProj world support uvars Delta s -> + Q s s) : + RecM.WF layer semantics trProj world support uvars Delta s + (get : RecM .anon (TcState .anon)) Q E := by + intro methods hmethods + exact TcM.WF.get h + +/-- Reader-level state update rule used by the three WHNF cache shells. -/ +theorem modifyGet {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {f : TcState .anon -> alpha × TcState .anon} + {Q : alpha -> TcState .anon -> Prop} + {E : TcError .anon -> TcState .anon -> Prop} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s -> + WhnfStateInv layer semantics trProj world support uvars Delta (f s).2) + (hQ : WhnfStateInv layer semantics trProj world support uvars Delta s -> + Q (f s).1 (f s).2) : + RecM.WF layer semantics trProj world support uvars Delta s + (modifyGet f : RecM .anon alpha) Q E := by + intro methods hmethods + exact TcM.WF.modifyGet hI hQ + +theorem modify {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {f : TcState .anon -> TcState .anon} + {Q : Unit -> TcState .anon -> Prop} + {E : TcError .anon -> TcState .anon -> Prop} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s -> + WhnfStateInv layer semantics trProj world support uvars Delta (f s)) + (hQ : WhnfStateInv layer semantics trProj world support uvars Delta s -> + Q () (f s)) : + RecM.WF layer semantics trProj world support uvars Delta s + (modify f : RecM .anon Unit) Q E := by + intro methods hmethods + exact TcM.WF.modifyGet hI hQ + end WF +/-- The direct recursive full-WHNF callback inherits the smaller method +table's semantic contract. Keeping this adapter at `RecM.WF` level lets +helper proofs compose without reopening the reader implementation. -/ +theorem whnfRec_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr} + (hsource : support source) + (htr : TrKExprS world.venv uvars world.nameOf trProj Δ source sourceV) : + RecM.WF layer semantics trProj world support uvars Δ s + (whnfRec source) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Δ sourceV result) := by + intro methods hmethods + simpa only [whnfRec] using hmethods.whnf hsource htr + +/-- The policy-sensitive recursive WHNF callback inherits the corresponding +method-table contract. This is the callback used by the successor-collapse +loop, where `.stuck` deliberately prevents recursive successor collapsing. -/ +theorem whnfModeRec_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr} {mode : NatSuccMode} + (hsource : support source) + (htr : TrKExprS world.venv uvars world.nameOf trProj Δ source sourceV) : + RecM.WF layer semantics trProj world support uvars Δ s + (whnfModeRec source mode) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Δ sourceV result) := by + intro methods hmethods + simpa only [whnfModeRec] using hmethods.whnfMode hsource htr + +/-- Reading the production primitive table is state-transparent. Naming the +exact reader frame avoids repeatedly unfolding `get` in primitive helpers. -/ +theorem prims_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} : + RecM.WF layer semantics trProj world support uvars Δ s prims + (fun result after => result = s.prims ∧ after = s) := by + unfold prims + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s ∧ after = s) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + rintro observed after ⟨rfl, rfl⟩ + exact RecM.WF.pure fun _ => ⟨rfl, rfl⟩ + +/-- The arithmetic classifier only reads the primitive table. -/ +theorem isNatBinArithAddr_inv_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} (addr : Address) : + RecM.WF layer semantics trProj world support uvars Δ s + (isNatBinArithAddr addr) (fun _ after => after = s) := by + unfold isNatBinArithAddr + apply RecM.WF.bind (prims_wf (s := s)) + intro prims after hread + rcases hread with ⟨rfl, rfl⟩ + exact RecM.WF.pure fun _ => rfl + +/-- The predicate classifier is likewise an exact state-transparent read. -/ +theorem isNatBinPredAddr_inv_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} (addr : Address) : + RecM.WF layer semantics trProj world support uvars Δ s + (isNatBinPredAddr addr) (fun _ after => after = s) := by + unfold isNatBinPredAddr + apply RecM.WF.bind (prims_wf (s := s)) + intro prims after hread + rcases hread with ⟨rfl, rfl⟩ + exact RecM.WF.pure fun _ => rfl + +/-- The arithmetic classifier has a concrete, state-transparent execution. +This equation is useful when inverting the production dispatcher: no +classifier outcome or intermediate state has to be postulated. -/ +theorem isNatBinArithAddr_eval + (methods : Methods .anon) (s : TcState .anon) (addr : Address) : + (isNatBinArithAddr addr).run methods s = .ok + (addr == s.prims.natAdd.addr || addr == s.prims.natSub.addr + || addr == s.prims.natMul.addr || addr == s.prims.natDiv.addr + || addr == s.prims.natMod.addr || addr == s.prims.natPow.addr + || addr == s.prims.natGcd.addr || addr == s.prims.natLand.addr + || addr == s.prims.natLor.addr || addr == s.prims.natXor.addr + || addr == s.prims.natShiftLeft.addr + || addr == s.prims.natShiftRight.addr) s := by + rfl + +/-- The predicate classifier has a concrete, state-transparent execution. -/ +theorem isNatBinPredAddr_eval + (methods : Methods .anon) (s : TcState .anon) (addr : Address) : + (isNatBinPredAddr addr).run methods s = .ok + (addr == s.prims.natBeq.addr || addr == s.prims.natBle.addr) s := by + rfl + +/-- A positive predicate-classifier result identifies one of the two +production predicate addresses. -/ +theorem isNatBinPredAddr_true + {methods : Methods .anon} {s : TcState .anon} {addr : Address} + (hrun : (isNatBinPredAddr addr).run methods s = .ok true s) : + addr = s.prims.natBeq.addr ∨ addr = s.prims.natBle.addr := by + rw [isNatBinPredAddr_eval] at hrun + have hdecision : + (addr == s.prims.natBeq.addr || addr == s.prims.natBle.addr) = true := by + exact EStateM.Result.ok.inj hrun |>.1 + simpa only [Bool.or_eq_true, beq_iff_eq] using hdecision + +/-- Nat's shared argument normalizer preserves the complete WHNF invariant +through both execution policies. Closed/eager arguments use the recursive +WHNF callback directly. Open arguments temporarily lower `recFuel`, retain +all callback state on error, restore the caller-visible remaining budget, and +turn only depth/fuel exhaustion into `none`. A successful result carries the +same semantic WHNF meaning as the callback. -/ +theorem whnfNatReducerArg_post_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + {arg : KExpr .anon} {argV : VExpr} + (harg : support arg) + (htr : TrKExprS world.venv uvars world.nameOf trProj Δ arg argV) : + RecM.WF layer semantics trProj world support uvars Δ s + (whnfNatReducerArg arg) + (fun result _ => match result with + | none => True + | some reduced => + support reduced ∧ + WhnfPost trProj world uvars Δ argV reduced) := by + unfold whnfNatReducerArg + apply RecM.WF.bind + (Q₁ := fun observed after => observed = after) + (RecM.WF.get fun _ => rfl) + intro observed s₀ hobserved + subst observed + split + · apply RecM.WF.bind (whnfRec_wf harg htr) + intro reduced s₁ hred + exact RecM.WF.pure fun _ => hred + · apply RecM.WF.bind + (Q₁ := fun observed after => observed = after) + (RecM.WF.get fun _ => rfl) + intro saved s₁ hsaved + subst saved + apply RecM.WF.bind + (Q₁ := fun observed after => observed = after) + (RecM.WF.get fun _ => rfl) + intro savedState afterSaved hsavedState + subst afterSaved + apply RecM.WF.bind + (Q₁ := fun _ after => after = + {savedState with recFuel := + (min savedState.recFuel natReducerOpenArgRecFuel)}) + · exact RecM.WF.modify + (Q := fun _ after => after = + {savedState with recFuel := + (min savedState.recFuel natReducerOpenArgRecFuel)}) + (f := fun state => + {state with + recFuel := min savedState.recFuel natReducerOpenArgRecFuel}) + (fun hI => hI.set_recFuel _) + (fun _ => rfl) + · intro _ limited hlimited + subst limited + apply RecM.WF.bind + (Q₁ := fun result : Except (TcError .anon) (KExpr .anon) => + fun _ => match result with + | .ok reduced => + support reduced ∧ + WhnfPost trProj world uvars Δ argV reduced + | .error _ => True) + · apply RecM.WF.tryCatch (E₁ := fun _ _ => True) + · apply RecM.WF.bind (whnfRec_wf harg htr) + intro reduced after hred + exact RecM.WF.pure fun _ => hred + · intro err after _ + exact RecM.WF.pure fun _ => trivial + · intro result afterCallback hresult + apply RecM.WF.bind + (Q₁ := fun observed after => observed = after) + (RecM.WF.get fun _ => rfl) + intro observed afterRead hobserved + subst observed + apply RecM.WF.bind + (Q₁ := fun _ restored => restored = + {afterRead with recFuel := savedState.recFuel - + (min savedState.recFuel + (min savedState.recFuel natReducerOpenArgRecFuel - + afterRead.recFuel))}) + · exact RecM.WF.modify + (Q := fun _ restored => restored = + {afterRead with recFuel := savedState.recFuel - + (min savedState.recFuel + (min savedState.recFuel natReducerOpenArgRecFuel - + afterRead.recFuel))}) + (f := fun state => + {state with recFuel := savedState.recFuel - + (min savedState.recFuel + (min savedState.recFuel natReducerOpenArgRecFuel - + afterRead.recFuel))}) + (fun hI => hI.set_recFuel _) + (fun _ => rfl) + · intro _ restored hrestored + subst restored + cases result with + | ok reduced => + exact RecM.WF.pure fun _ => hresult + | error err => + cases err <;> + first + | exact RecM.WF.pure fun _ => trivial + | exact RecM.WF.throw fun _ => trivial + +/-- Evaluate the shared Nat callback contract at any successful outcome. In +particular, both production `none` and `some` preserve the complete WHNF +invariant after the open-argument fuel budget has been restored. -/ +theorem whnfNatReducerArg_ok_inv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {methods : Methods .anon} + {s s' : TcState .anon} {arg : KExpr .anon} {argV : VExpr} + {result : Option (KExpr .anon)} + (harg : support arg) + (htr : TrKExprS world.venv uvars world.nameOf trProj Δ arg argV) + (hmethods : Methods.WFAt layer semantics trProj world support uvars methods) + (hI : WhnfStateInv layer semantics trProj world support uvars Δ s) + (hrun : (whnfNatReducerArg arg).run methods s = .ok result s') : + WhnfStateInv layer semantics trProj world support uvars Δ s' := by + have hpost := whnfNatReducerArg_post_wf harg htr methods hmethods hI + rw [hrun] at hpost + exact hpost.1 + +/-- Evaluate the shared Nat callback contract at an error. The error's +partial state—not the entry state—satisfies the complete invariant after the +open-argument fuel budget has been restored. -/ +theorem whnfNatReducerArg_error_inv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {methods : Methods .anon} + {s s' : TcState .anon} {arg : KExpr .anon} {argV : VExpr} + {err : TcError .anon} + (harg : support arg) + (htr : TrKExprS world.venv uvars world.nameOf trProj Δ arg argV) + (hmethods : Methods.WFAt layer semantics trProj world support uvars methods) + (hI : WhnfStateInv layer semantics trProj world support uvars Δ s) + (hrun : (whnfNatReducerArg arg).run methods s = .error err s') : + WhnfStateInv layer semantics trProj world support uvars Δ s' := by + have hpost := whnfNatReducerArg_post_wf harg htr methods hmethods hI + rw [hrun] at hpost + exact hpost.1 + +/-- Existential reduction meaning is the translation-independent projection +of `whnfNatReducerArg_post_wf`. Most outer reducer proofs should use the +stronger theorem so the application arguments retain the translations +obtained from the source spine. -/ +theorem whnfNatReducerArg_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + {arg : KExpr .anon} {argV : VExpr} + (harg : support arg) + (htr : TrKExprS world.venv uvars world.nameOf trProj Δ arg argV) : + RecM.WF layer semantics trProj world support uvars Δ s + (whnfNatReducerArg arg) + (fun result _ => match result with + | none => True + | some reduced => + support reduced ∧ + WhnfMeaning trProj world uvars Δ arg reduced) := by + apply RecM.WF.mono (whnfNatReducerArg_post_wf harg htr) + · intro result after hresult + cases result with + | none => trivial + | some reduced => + exact ⟨hresult.1, WhnfPost.meaning htr hresult.2⟩ + · intro _ _ _ + trivial + /-- Generic invariant rule for K0's total bounded-loop driver. Exhaustion is explicit in `hexhaust`; every successful `.next` re-establishes `P`, and every `.done` establishes the final postcondition. -/ @@ -1237,6 +2311,58 @@ theorem runBounded_wf {layer : WhnfLayer} {semantics : CacheSemantics} | done result => exact RecM.WF.pure fun _ => haction +/-! ### Semantic bounded-step closure -/ + +/-- Errors from a bounded semantic loop are classified without conflating + driver exhaustion with an error raised by the production step. -/ +def WhnfLoopError (stepError : TcError .anon -> TcState .anon -> Prop) + (err : TcError .anon) (s : TcState .anon) : Prop := + err = .maxRecDepth ∨ stepError err s + +namespace WhnfStep + +/-- Semantic admissibility of the expression observed by one loop state. + This premise is load-bearing: `WhnfStateInv` constrains the checker state, + but does not make every arbitrary `KExpr` translatable. -/ +def Source {sigma : Type} (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) (Delta : KVLCtx) + (view : sigma -> KExpr .anon) (state : sigma) : Prop := + support (view state) ∧ + exists sourceV, + TrKExprS world.venv uvars world.nameOf trProj Delta (view state) sourceV + +/-- Local semantic payload required from one successful bounded step. -/ +def Meaning {sigma : Type} (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) (Delta : KVLCtx) + (view : sigma -> KExpr .anon) + (state : sigma) (action : BoundedStep sigma (KExpr .anon)) : Prop := + match action with + | .next next => + support (view next) ∧ + WhnfMeaning trProj world uvars Delta (view state) (view next) + | .done result => + support result ∧ + WhnfMeaning trProj world uvars Delta (view state) result + +/-- Branch-local contract consumed by the bounded-loop closure theorem. + It is intentionally one iteration wide and requires an actual structural + translation of the current expression. Successful `.next` meaning then + supplies the translation required by the following iteration; this keeps + unsupported raw syntax out of the semantic loop induction. -/ +def WF {sigma : Type} (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (view : sigma -> KExpr .anon) + (step : sigma -> RecM .anon (BoundedStep sigma (KExpr .anon))) + (stepError : TcError .anon -> TcState .anon -> Prop) : Prop := + forall state s, + Source trProj world support uvars Delta view state -> + RecM.WF layer semantics trProj world support uvars Delta s (step state) + (fun action _ => + Meaning trProj world support uvars Delta view state action) + stepError + +end WhnfStep + /-- Execution-indexed semantic certificate for the production structural WHNF loop. Its fuel index is the actual fuel presented to `runBounded`. Every iteration records the exact production equation, the fixed @@ -1284,6 +2410,109 @@ theorem no_zero {layer : WhnfLayer} {semantics : CacheSemantics} intro h cases h +/-- A local semantic contract is sufficient to reconstruct the exact + execution-indexed trace for every successful bounded run. On failure, + the same induction preserves the K1 invariant and says whether the loop + exhausted its own bound or the production step raised the error. -/ +theorem complete {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {flags : WhnfFlags} + {stepError : TcError .anon -> TcState .anon -> Prop} + (hstep : WhnfStep.WF layer semantics trProj world support uvars Delta id + (fun cur => whnfCoreWithFlagsStep cur flags) stepError) + {methods : Methods .anon} + (hmethods : Methods.WFAt layer semantics trProj world support uvars methods) + {fuel : Nat} {source : KExpr .anon} {s : TcState .anon} + (hsource : WhnfStep.Source trProj world support uvars Delta id source) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) : + match (runBounded (fun cur => whnfCoreWithFlagsStep cur flags) + fuel source).run methods s with + | .ok result s' => + support result ∧ + WhnfCoreTrace layer semantics trProj world support uvars Delta + methods flags fuel source s result s' + | .error err s' => + WhnfStateInv layer semantics trProj world support uvars Delta s' ∧ + WhnfLoopError stepError err s' := by + induction fuel generalizing source s with + | zero => + rw [runBounded] + exact ⟨hI, Or.inl rfl⟩ + | succ fuel ih => + have hlocal := hstep source s hsource methods hmethods hI + match hrun : (whnfCoreWithFlagsStep source flags).run methods s with + | .error err s' => + rw [hrun] at hlocal + rw [runBounded, ReaderT.run_bind] + change match EStateM.bind + ((whnfCoreWithFlagsStep source flags).run methods) _ s with + | .ok result s'' => + support result ∧ + WhnfCoreTrace layer semantics trProj world support uvars + Delta methods flags (fuel + 1) source s result s'' + | .error err s'' => + WhnfStateInv layer semantics trProj world support uvars Delta + s'' ∧ + WhnfLoopError stepError err s'' + unfold EStateM.bind + rw [hrun] + exact ⟨hlocal.1, Or.inr hlocal.2⟩ + | .ok action s' => + rw [hrun] at hlocal + cases action with + | done result => + have hmeaning : WhnfMeaning trProj world uvars Delta source + result := by + simpa [WhnfStep.Meaning] using hlocal.2.2 + rw [runBounded, ReaderT.run_bind] + change match EStateM.bind + ((whnfCoreWithFlagsStep source flags).run methods) _ s with + | .ok result s'' => + support result ∧ + WhnfCoreTrace layer semantics trProj world support uvars + Delta methods flags (fuel + 1) source s result s'' + | .error err s'' => + WhnfStateInv layer semantics trProj world support uvars + Delta s'' ∧ + WhnfLoopError stepError err s'' + unfold EStateM.bind + rw [hrun] + exact ⟨hlocal.2.1, + .done hI hrun hlocal.1 hlocal.2.2⟩ + | next next => + have hmeaning : WhnfMeaning trProj world uvars Delta source + next := by + simpa [WhnfStep.Meaning] using hlocal.2.2 + have hnextSource : WhnfStep.Source trProj world support uvars + Delta id next := by + obtain ⟨_, nextV, _, hnext, _⟩ := hmeaning + exact ⟨hlocal.2.1, nextV, hnext⟩ + have htail := ih (source := next) (s := s') hnextSource hlocal.1 + rw [runBounded, ReaderT.run_bind] + change match EStateM.bind + ((whnfCoreWithFlagsStep source flags).run methods) _ s with + | .ok result s'' => + support result ∧ + WhnfCoreTrace layer semantics trProj world support uvars + Delta methods flags (fuel + 1) source s result s'' + | .error err s'' => + WhnfStateInv layer semantics trProj world support uvars + Delta s'' ∧ + WhnfLoopError stepError err s'' + unfold EStateM.bind + rw [hrun] + simp only + match htailRun : + (runBounded (fun cur => whnfCoreWithFlagsStep cur flags) + fuel next).run methods s' with + | .ok result s'' => + rw [htailRun] at htail + exact ⟨htail.1, + .next hI hrun hlocal.1 hmeaning htail.2⟩ + | .error err s'' => + rw [htailRun] at htail + exact htail + /-- Erase the semantic payload to the exact successful production execution. This direction is deliberately one-way: raw success alone is not a semantic certificate. -/ @@ -1383,6 +2612,46 @@ theorem uncached_acceptance {layer : WhnfLayer} WhnfMeaning trProj world uvars Δ source result := ⟨h.uncached_eval, h.initialInv, h.finalInv, h.meaning theory⟩ +/-- Conditional Hoare closure for the complete structural loop. Success is + obtained by constructing and folding `WhnfCoreTrace`; failure preserves + the invariant and retains the exhaustion/step-error distinction. -/ +theorem uncached_wf {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {flags : WhnfFlags} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world uvars) + (hstep : WhnfStep.WF layer semantics trProj world support uvars Delta id + (fun cur => whnfCoreWithFlagsStep cur flags) stepError) + {source : KExpr .anon} {sourceV : VExpr} {s : TcState .anon} + (hsupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreWithFlagsUncached source flags) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + (WhnfLoopError stepError) := by + intro methods hmethods hI + have hcomplete := WhnfCoreTrace.complete hstep hmethods + (fuel := maxWhnfFuel.toNat) (source := source) (s := s) + ⟨hsupport, sourceV, hsource⟩ hI + unfold whnfCoreWithFlagsUncached + match hrun : + (runBounded (fun cur => whnfCoreWithFlagsStep cur flags) + maxWhnfFuel.toNat source).run methods s with + | .ok result s' => + rw [hrun] at hcomplete + simp only at hcomplete ⊢ + refine ⟨hcomplete.2.finalInv, hcomplete.1, ?_⟩ + have hstart := WhnfPost.refl hsource + (theory.exprWF hI.2.1 hsource) + exact hstart.transMeaning theory hI.2.1.wf + (hcomplete.2.meaning theory) + | .error err s' => + rw [hrun] at hcomplete + simp only at hcomplete ⊢ + exact hcomplete + end WhnfCoreTrace /-! ## Outer structural-WHNF cache composition -/ @@ -1636,15 +2905,14 @@ theorem full_whnfStateInv whnfCoreCache := s.env.whnfCoreCache.insert key result}} := by rcases hI with ⟨hkernel, hctx, hlayer⟩ refine ⟨?_, ?_, ?_⟩ - · refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ · exact hkernel.core.of_consts_eq rfl (by simpa using hkernel.core.intern) · simpa using hkernel.internSupport · exact hkernel.caches.insertWhnfCore hnew + · exact hkernel.equivalences · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) - · cases layer with - | noAccel => simpa [WhnfLayer.StateOK] using hlayer - | accelerated => trivial + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer /-- Inserting one provenance-certified cheap-core result preserves the full invariant without changing the full-policy partition. -/ @@ -1661,18 +2929,47 @@ theorem cheap_whnfStateInv whnfCoreCheapCache := s.env.whnfCoreCheapCache.insert key result}} := by rcases hI with ⟨hkernel, hctx, hlayer⟩ refine ⟨?_, ?_, ?_⟩ - · refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ · exact hkernel.core.of_consts_eq rfl (by simpa using hkernel.core.intern) · simpa using hkernel.internSupport · exact hkernel.caches.insertWhnfCoreCheap hnew + · exact hkernel.equivalences · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) - · cases layer with - | noAccel => simpa [WhnfLayer.StateOK] using hlayer - | accelerated => trivial + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer end WhnfCoreCacheUpdate +namespace NatSuccStuckCacheUpdate + +/-- The exact state frame for either successor-loop stuck exit. All visited +markers must already carry cache provenance; under that condition the fold +changes only `natSuccStuck` and preserves the complete fixed-world invariant. -/ +theorem fold_whnfStateInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + (visited : Array (Address × Address)) + (hI : WhnfStateInv layer semantics trProj world support uvars Δ s) + (hnew : ∀ key ∈ visited, + CacheProvenance semantics (CacheAuthority.stable world) support + (.natSuccStuck key)) : + WhnfStateInv layer semantics trProj world support uvars Δ + {s with env := {s.env with natSuccStuck := + (visited.foldl (·.insert ·) s.env.natSuccStuck) } } := by + rcases hI with ⟨hkernel, hctx, hlayer⟩ + refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ + · exact hkernel.core.of_consts_eq rfl (by + simpa using hkernel.core.intern) + · simpa using hkernel.internSupport + · exact hkernel.caches.insertNatSuccStuckArray visited hnew + · exact hkernel.equivalences + · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer + +end NatSuccStuckCacheUpdate + /-- A physical full-core hit is accepted only with both a semantic cache invariant and an executed/context-reconciled key match. -/ theorem whnfCoreWithFlags_fullHit_acceptance @@ -1870,6 +3167,115 @@ theorem no_zero {layer : WhnfLayer} {semantics : CacheSemantics} intro h cases h +/-- Construct the production no-delta trace from a one-step semantic + contract, retaining invariant-preserving step failures separately from + bounded-loop exhaustion. -/ +theorem complete {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + {stepError : TcError .anon -> TcState .anon -> Prop} + (hstep : WhnfStep.WF layer semantics trProj world support uvars Delta id + (whnfNoDeltaImplStep flags natSuccMode) stepError) + {methods : Methods .anon} + (hmethods : Methods.WFAt layer semantics trProj world support uvars methods) + {fuel : Nat} {source : KExpr .anon} {s : TcState .anon} + (hsource : WhnfStep.Source trProj world support uvars Delta id source) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) : + match (runBounded (whnfNoDeltaImplStep flags natSuccMode) + fuel source).run methods s with + | .ok result s' => + support result ∧ + WhnfNoDeltaTrace layer semantics trProj world support uvars Delta + methods flags natSuccMode fuel source s result s' + | .error err s' => + WhnfStateInv layer semantics trProj world support uvars Delta s' ∧ + WhnfLoopError stepError err s' := by + induction fuel generalizing source s with + | zero => + rw [runBounded] + exact ⟨hI, Or.inl rfl⟩ + | succ fuel ih => + have hlocal := hstep source s hsource methods hmethods hI + match hrun : + (whnfNoDeltaImplStep flags natSuccMode source).run methods s with + | .error err s' => + rw [hrun] at hlocal + rw [runBounded, ReaderT.run_bind] + change match EStateM.bind + ((whnfNoDeltaImplStep flags natSuccMode source).run methods) _ s + with + | .ok result s'' => + support result ∧ + WhnfNoDeltaTrace layer semantics trProj world support uvars + Delta methods flags natSuccMode (fuel + 1) source s result + s'' + | .error err s'' => + WhnfStateInv layer semantics trProj world support uvars Delta + s'' ∧ + WhnfLoopError stepError err s'' + unfold EStateM.bind + rw [hrun] + exact ⟨hlocal.1, Or.inr hlocal.2⟩ + | .ok action s' => + rw [hrun] at hlocal + cases action with + | done result => + have hmeaning : WhnfMeaning trProj world uvars Delta source + result := by + simpa [WhnfStep.Meaning] using hlocal.2.2 + rw [runBounded, ReaderT.run_bind] + change match EStateM.bind + ((whnfNoDeltaImplStep flags natSuccMode source).run methods) _ + s with + | .ok result s'' => + support result ∧ + WhnfNoDeltaTrace layer semantics trProj world support + uvars Delta methods flags natSuccMode (fuel + 1) + source s result s'' + | .error err s'' => + WhnfStateInv layer semantics trProj world support uvars + Delta s'' ∧ + WhnfLoopError stepError err s'' + unfold EStateM.bind + rw [hrun] + exact ⟨hlocal.2.1, .done hI hrun hlocal.1 hmeaning⟩ + | next next => + have hmeaning : WhnfMeaning trProj world uvars Delta source + next := by + simpa [WhnfStep.Meaning] using hlocal.2.2 + have hnextSource : WhnfStep.Source trProj world support uvars + Delta id next := by + obtain ⟨_, nextV, _, hnext, _⟩ := hmeaning + exact ⟨hlocal.2.1, nextV, hnext⟩ + have htail := ih (source := next) (s := s') hnextSource hlocal.1 + rw [runBounded, ReaderT.run_bind] + change match EStateM.bind + ((whnfNoDeltaImplStep flags natSuccMode source).run methods) _ + s with + | .ok result s'' => + support result ∧ + WhnfNoDeltaTrace layer semantics trProj world support + uvars Delta methods flags natSuccMode (fuel + 1) + source s result s'' + | .error err s'' => + WhnfStateInv layer semantics trProj world support uvars + Delta s'' ∧ + WhnfLoopError stepError err s'' + unfold EStateM.bind + rw [hrun] + simp only + match htailRun : + (runBounded (whnfNoDeltaImplStep flags natSuccMode) + fuel next).run methods s' with + | .ok result s'' => + rw [htailRun] at htail + exact ⟨htail.1, + .next hI hrun hlocal.1 hmeaning htail.2⟩ + | .error err s'' => + rw [htailRun] at htail + exact htail + theorem eval {layer : WhnfLayer} {semantics : CacheSemantics} {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} {uvars : Nat} {Δ : KVLCtx} {methods : Methods .anon} @@ -1958,6 +3364,45 @@ theorem uncached_acceptance {layer : WhnfLayer} WhnfMeaning trProj world uvars Δ source result := ⟨h.uncached_eval, h.initialInv, h.finalInv, h.meaning theory⟩ +/-- Conditional Hoare closure for the no-delta bounded loop. -/ +theorem uncached_wf {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world uvars) + (hstep : WhnfStep.WF layer semantics trProj world support uvars Delta id + (whnfNoDeltaImplStep flags natSuccMode) stepError) + {source : KExpr .anon} {sourceV : VExpr} {s : TcState .anon} + (hsupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (whnfNoDeltaImplUncached source flags natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + (WhnfLoopError stepError) := by + intro methods hmethods hI + have hcomplete := WhnfNoDeltaTrace.complete hstep hmethods + (fuel := maxWhnfFuel.toNat) (source := source) (s := s) + ⟨hsupport, sourceV, hsource⟩ hI + unfold whnfNoDeltaImplUncached + match hrun : + (runBounded (whnfNoDeltaImplStep flags natSuccMode) + maxWhnfFuel.toNat source).run methods s with + | .ok result s' => + rw [hrun] at hcomplete + simp only at hcomplete ⊢ + refine ⟨hcomplete.2.finalInv, hcomplete.1, ?_⟩ + have hstart := WhnfPost.refl hsource + (theory.exprWF hI.2.1 hsource) + exact hstart.transMeaning theory hI.2.1.wf + (hcomplete.2.meaning theory) + | .error err s' => + rw [hrun] at hcomplete + simp only at hcomplete ⊢ + exact hcomplete + end WhnfNoDeltaTrace /-- Execution-indexed semantic certificate for the production full-WHNF @@ -2002,6 +3447,115 @@ theorem no_zero {layer : WhnfLayer} {semantics : CacheSemantics} intro h cases h +/-- Construct the full-WHNF trace from a one-step semantic contract. The + cycle-detection set remains operational state; only each pair's + expression component participates in `WhnfMeaning`. -/ +theorem complete {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {natSuccMode : NatSuccMode} + {stepError : TcError .anon -> TcState .anon -> Prop} + (hstep : WhnfStep.WF layer semantics trProj world support uvars Delta + (fun state : KExpr .anon × HashSet Address => state.1) + (whnfWithNatSuccModeStep natSuccMode) stepError) + {methods : Methods .anon} + (hmethods : Methods.WFAt layer semantics trProj world support uvars methods) + {fuel : Nat} {source : KExpr .anon × HashSet Address} + {s : TcState .anon} + (hsource : WhnfStep.Source trProj world support uvars Delta + (fun state : KExpr .anon × HashSet Address => state.1) source) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) : + match (runBounded (whnfWithNatSuccModeStep natSuccMode) + fuel source).run methods s with + | .ok result s' => + support result ∧ + WhnfFullTrace layer semantics trProj world support uvars Delta + methods natSuccMode fuel source s result s' + | .error err s' => + WhnfStateInv layer semantics trProj world support uvars Delta s' ∧ + WhnfLoopError stepError err s' := by + induction fuel generalizing source s with + | zero => + rw [runBounded] + exact ⟨hI, Or.inl rfl⟩ + | succ fuel ih => + have hlocal := hstep source s hsource methods hmethods hI + match hrun : + (whnfWithNatSuccModeStep natSuccMode source).run methods s with + | .error err s' => + rw [hrun] at hlocal + rw [runBounded, ReaderT.run_bind] + change match EStateM.bind + ((whnfWithNatSuccModeStep natSuccMode source).run methods) _ s + with + | .ok result s'' => + support result ∧ + WhnfFullTrace layer semantics trProj world support uvars + Delta methods natSuccMode (fuel + 1) source s result s'' + | .error err s'' => + WhnfStateInv layer semantics trProj world support uvars Delta + s'' ∧ + WhnfLoopError stepError err s'' + unfold EStateM.bind + rw [hrun] + exact ⟨hlocal.1, Or.inr hlocal.2⟩ + | .ok action s' => + rw [hrun] at hlocal + cases action with + | done result => + have hmeaning : WhnfMeaning trProj world uvars Delta source.1 + result := by + simpa [WhnfStep.Meaning] using hlocal.2.2 + rw [runBounded, ReaderT.run_bind] + change match EStateM.bind + ((whnfWithNatSuccModeStep natSuccMode source).run methods) _ s + with + | .ok result s'' => + support result ∧ + WhnfFullTrace layer semantics trProj world support uvars + Delta methods natSuccMode (fuel + 1) source s result s'' + | .error err s'' => + WhnfStateInv layer semantics trProj world support uvars + Delta s'' ∧ + WhnfLoopError stepError err s'' + unfold EStateM.bind + rw [hrun] + exact ⟨hlocal.2.1, .done hI hrun hlocal.1 hmeaning⟩ + | next next => + have hmeaning : WhnfMeaning trProj world uvars Delta source.1 + next.1 := by + simpa [WhnfStep.Meaning] using hlocal.2.2 + have hnextSource : WhnfStep.Source trProj world support uvars Delta + (fun state : KExpr .anon × HashSet Address => state.1) + next := by + obtain ⟨_, nextV, _, hnext, _⟩ := hmeaning + exact ⟨hlocal.2.1, nextV, hnext⟩ + have htail := ih (source := next) (s := s') hnextSource hlocal.1 + rw [runBounded, ReaderT.run_bind] + change match EStateM.bind + ((whnfWithNatSuccModeStep natSuccMode source).run methods) _ s + with + | .ok result s'' => + support result ∧ + WhnfFullTrace layer semantics trProj world support uvars + Delta methods natSuccMode (fuel + 1) source s result s'' + | .error err s'' => + WhnfStateInv layer semantics trProj world support uvars + Delta s'' ∧ + WhnfLoopError stepError err s'' + unfold EStateM.bind + rw [hrun] + simp only + match htailRun : + (runBounded (whnfWithNatSuccModeStep natSuccMode) + fuel next).run methods s' with + | .ok result s'' => + rw [htailRun] at htail + exact ⟨htail.1, + .next hI hrun hlocal.1 hmeaning htail.2⟩ + | .error err s'' => + rw [htailRun] at htail + exact htail + theorem eval {layer : WhnfLayer} {semantics : CacheSemantics} {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} {uvars : Nat} {Δ : KVLCtx} {methods : Methods .anon} @@ -2093,8 +3647,186 @@ theorem uncached_acceptance {layer : WhnfLayer} WhnfMeaning trProj world uvars Δ source result := ⟨h.uncached_eval, h.initialInv, h.finalInv, h.meaning theory⟩ +/-- Conditional Hoare closure for the full-WHNF bounded loop. -/ +theorem uncached_wf {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {natSuccMode : NatSuccMode} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world uvars) + (hstep : WhnfStep.WF layer semantics trProj world support uvars Delta + (fun state : KExpr .anon × HashSet Address => state.1) + (whnfWithNatSuccModeStep natSuccMode) stepError) + {source : KExpr .anon} {sourceV : VExpr} {s : TcState .anon} + (hsupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (whnfWithNatSuccModeUncached source natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world uvars Delta sourceV result) + (WhnfLoopError stepError) := by + intro methods hmethods hI + have hcomplete := WhnfFullTrace.complete hstep hmethods + (fuel := maxWhnfFuel.toNat) (source := (source, {})) (s := s) + ⟨hsupport, sourceV, hsource⟩ hI + unfold whnfWithNatSuccModeUncached + match hrun : + (runBounded (whnfWithNatSuccModeStep natSuccMode) + maxWhnfFuel.toNat (source, {})).run methods s with + | .ok result s' => + rw [hrun] at hcomplete + simp only at hcomplete ⊢ + refine ⟨hcomplete.2.finalInv, hcomplete.1, ?_⟩ + have hstart := WhnfPost.refl hsource + (theory.exprWF hI.2.1 hsource) + exact hstart.transMeaning theory hI.2.1.wf + (hcomplete.2.meaning theory) + | .error err s' => + rw [hrun] at hcomplete + simp only at hcomplete ⊢ + exact hcomplete + end WhnfFullTrace +/-! ### Public-driver shell obligations -/ + +namespace WhnfKey + +/-- The context-suffix fact still owed by the concrete key algorithm. It is + quantified over the actual pre/post execution so public-driver proofs do + not turn address equality into a context theorem. -/ +def Represents (keys : WhnfContextKeys) (trProj : RawProjRel) + (world : VerifyWorld) (source : KExpr .anon) (Delta : KVLCtx) : Prop := + forall before key after, + CtxRecon world.venv keys.uvars world.nameOf trProj before Delta -> + TcM.whnfKey source before = .ok key after -> + keys.Represents source.lbr key.2 Delta + +/-- K2's suffix transport is unnecessary for a syntactically closed source: + production returns the distinguished empty-context key exactly. -/ +theorem closed_represents {uvars : Nat} {source : KExpr .anon} + {trProj : RawProjRel} {world : VerifyWorld} + (hclosed : source.lbr = 0) : + Represents (WhnfContextKeys.closed uvars) trProj world source [] := by + intro before key after hctx hrun + have hexact := TcM.whnfKey_closed (s := before) hclosed + rw [hexact] at hrun + cases hrun + exact ⟨hclosed, rfl, rfl⟩ + +end WhnfKey + +namespace TransientNatWork + +/-- State-preservation contract for the production transient-work probe. + Its trusted constant reads and lazy-ingress behavior are independent of + reduction meaning and therefore remain a named shell obligation. -/ +def WF (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (source : KExpr .anon) : Prop := + forall s, + RecM.WF layer semantics trProj world support uvars Delta s + (isTransientNatLiteralWork source) (fun _ _ => True) + +end TransientNatWork + +/-- Collision-robust provenance needed at the three outer cache insertion + sites. A meaning proof for the executed source alone is insufficient: + cache validity quantifies over every supported source sharing the key's + address and every represented context. Keeping this interface explicit + prevents a hash-collision assumption from entering K1 unnoticed. -/ +structure WhnfCacheWriteOracle (keys : WhnfContextKeys) + (trProj : RawProjRel) (fallback : CacheSemantics) + (world : VerifyWorld) (support : RunSupport) : Prop where + noDelta : forall {Delta source key result s}, + support source -> + support result -> + keys.Matches trProj world s Delta source key -> + WhnfMeaning trProj world keys.uvars Delta source result -> + CacheProvenance (whnfCacheSemantics keys trProj fallback) + (CacheAuthority.stable world) support + (.expr .whnfNoDelta key result) + noDeltaCheap : forall {Delta source key result s}, + support source -> + support result -> + keys.Matches trProj world s Delta source key -> + WhnfMeaning trProj world keys.uvars Delta source result -> + CacheProvenance (whnfCacheSemantics keys trProj fallback) + (CacheAuthority.stable world) support + (.expr .whnfNoDeltaCheap key result) + full : forall {Delta source key result s}, + support source -> + support result -> + keys.Matches trProj world s Delta source key -> + WhnfMeaning trProj world keys.uvars Delta source result -> + CacheProvenance (whnfCacheSemantics keys trProj fallback) + (CacheAuthority.stable world) support (.expr .whnf key result) + +namespace WhnfCacheWriteOracle + +/-- Construct all three outer write rules for closed expressions. Expression + collision freedom identifies every supported source at the address key; + the remaining premise is exactly direct-reference authorization for the + concrete cache entry. Open-context transport is deliberately absent and + remains K2 work. -/ +theorem closed + {uvars : Nat} {trProj : RawProjRel} {fallback : CacheSemantics} + {world : VerifyWorld} {support : RunSupport} + (hcollision : support.CollisionFree) + (hreferences : forall {kind key source result}, + (kind = .whnfNoDelta ∨ kind = .whnfNoDeltaCheap ∨ kind = .whnf) -> + support source -> support result -> source.addr = key.1 -> + (CacheEntry.expr kind key result).ReferencesAuthorized + (CacheAuthority.stable world) support) : + WhnfCacheWriteOracle (WhnfContextKeys.closed uvars) trProj fallback + world support := by + have build : forall {kind : ExprCacheKind} {Delta source key result s}, + (kind = .whnfNoDelta ∨ kind = .whnfNoDeltaCheap ∨ kind = .whnf) -> + support source -> + support result -> + (WhnfContextKeys.closed uvars).Matches trProj world s Delta source key -> + WhnfMeaning trProj world uvars Delta source result -> + CacheProvenance + (whnfCacheSemantics (WhnfContextKeys.closed uvars) trProj fallback) + (CacheAuthority.stable world) support (.expr kind key result) := by + intro kind Delta source key result s hkind hsource hresult hmatch hmeaning + have hDelta : Delta = [] := hmatch.2.1.2.2 + subst Delta + refine ⟨⟨⟨source, hsource, hmatch.sourceAddr⟩, hresult⟩, + hreferences hkind hsource hresult hmatch.sourceAddr, ?_⟩ + have his : kind.IsWhnf := by + rcases hkind with hkind | hkind + · subst kind + exact .whnfNoDelta + · rcases hkind with hkind | hkind + · subst kind + exact .whnfNoDeltaCheap + · subst kind + exact .whnf + have htransport : forall other, support other -> other.addr = key.1 -> + forall Delta, + (WhnfContextKeys.closed uvars).Represents other.lbr key.2 Delta -> + WhnfMeaning trProj world uvars Delta other result := by + intro other hother haddr Delta hrepresented + have heq : source = other := by + have herase := hcollision.expr hsource hother + (hmatch.sourceAddr.trans haddr.symm) + simpa only [KExpr.eraseMeta_anon] using herase + subst other + have hDelta : Delta = [] := hrepresented.2.2 + subst Delta + exact hmeaning + cases his <;> exact htransport + refine ⟨?_, ?_, ?_⟩ + · intro Delta source key result s hsource hresult hmatch hmeaning + exact build (.inl rfl) hsource hresult hmatch hmeaning + · intro Delta source key result s hsource hresult hmatch hmeaning + exact build (.inr (.inl rfl)) hsource hresult hmatch hmeaning + · intro Delta source key result s hsource hresult hmatch hmeaning + exact build (.inr (.inr rfl)) hsource hresult hmatch hmeaning + +end WhnfCacheWriteOracle + /-- Non-leaf forms shared by the no-delta and full-WHNF public prefixes. -/ inductive WhnfDriverNonLeaf : KExpr .anon → Prop | const {id us info} : WhnfDriverNonLeaf (.const id us info) @@ -2489,15 +4221,14 @@ theorem noDelta_whnfStateInv whnfNoDeltaCache := s.env.whnfNoDeltaCache.insert key result}} := by rcases hI with ⟨hkernel, hctx, hlayer⟩ refine ⟨?_, ?_, ?_⟩ - · refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ · exact hkernel.core.of_consts_eq rfl (by simpa using hkernel.core.intern) · simpa using hkernel.internSupport · exact hkernel.caches.insertWhnfNoDelta hnew + · exact hkernel.equivalences · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) - · cases layer with - | noAccel => simpa [WhnfLayer.StateOK] using hlayer - | accelerated => trivial + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer theorem noDeltaCheap_whnfStateInv {layer : WhnfLayer} {semantics : CacheSemantics} @@ -2513,15 +4244,14 @@ theorem noDeltaCheap_whnfStateInv s.env.whnfNoDeltaCheapCache.insert key result}} := by rcases hI with ⟨hkernel, hctx, hlayer⟩ refine ⟨?_, ?_, ?_⟩ - · refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ · exact hkernel.core.of_consts_eq rfl (by simpa using hkernel.core.intern) · simpa using hkernel.internSupport · exact hkernel.caches.insertWhnfNoDeltaCheap hnew + · exact hkernel.equivalences · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) - · cases layer with - | noAccel => simpa [WhnfLayer.StateOK] using hlayer - | accelerated => trivial + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer theorem full_whnfStateInv {layer : WhnfLayer} {semantics : CacheSemantics} @@ -2536,18 +4266,747 @@ theorem full_whnfStateInv whnfCache := s.env.whnfCache.insert key result}} := by rcases hI with ⟨hkernel, hctx, hlayer⟩ refine ⟨?_, ?_, ?_⟩ - · refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ · exact hkernel.core.of_consts_eq rfl (by simpa using hkernel.core.intern) · simpa using hkernel.internSupport · exact hkernel.caches.insertWhnf hnew + · exact hkernel.equivalences · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) - · cases layer with - | noAccel => simpa [WhnfLayer.StateOK] using hlayer - | accelerated => trivial + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer end WhnfDriverCacheUpdate +/-- Conditional Hoare closure for the keyed no-delta shell. The bounded + semantic loop is proved above; this theorem discharges the cache-control + flow and leaves only context-key reconciliation, transient lookup state + preservation, and collision-robust insertion provenance as named + premises. -/ +theorem whnfNoDeltaImplNonLeaf_wf + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {Delta : KVLCtx} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {source : KExpr .anon} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world keys.uvars) + (hkeyRep : WhnfKey.Represents keys trProj world source Delta) + (htransient : TransientNatWork.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta source) + (hstep : WhnfStep.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta id (whnfNoDeltaImplStep flags natSuccMode) stepError) + (hwrites : WhnfCacheWriteOracle keys trProj fallback world support) + (hsupport : support source) + {sourceV : VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s + (whnfNoDeltaImplNonLeaf source flags natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + have hinner : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 + (whnfNoDeltaImplUncached source flags natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + fun s0 => RecM.WF.mono + (WhnfNoDeltaTrace.uncached_wf theory hstep (s := s0) hsupport hsource) + (fun _ _ h => h) (fun _ _ _ => trivial) + have hinnerRead : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 + (do + let result ← whnfNoDeltaImplUncached source flags natSuccMode + let _ ← (get : RecM .anon (TcState .anon)) + pure result) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + intro s0 + apply RecM.WF.bind (hinner s0) + intro result s3 hpost + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s3 ∧ after = s3) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + exact RecM.WF.pure fun _ => hpost + unfold whnfNoDeltaImplNonLeaf + apply RecM.WF.bind + (Q₁ := fun key _ => keys.Matches trProj world s Delta source key) + · apply RecM.WF.liftTcM + exact TcM.WF.mono + (TcM.whnfKey_matches_wf + (fun key after hctx hrun => hkeyRep s key after hctx hrun)) + (fun key _ h => h.1) (fun _ _ h => h) + · intro key s1 hmatch + apply RecM.WF.bind (htransient s1) + intro transient s2 _ + cases natSuccMode with + | stuck => + simpa [natSuccMode_stuck_beq] using hinnerRead s2 + | collapse => + cases transient with + | true => + simpa [natSuccMode_collapse_beq] using hinnerRead s2 + | false => + cases hfull : flags.isFull with + | true => + simp only [natSuccMode_collapse_beq, Bool.not_false, + Bool.true_and, if_true] + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s2 ∧ after = s2) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + let found := s2.env.whnfNoDeltaCache[key]? + cases hfound : found with + | some cached => + have hcache : s2.env.whnfNoDeltaCache[key]? = + some cached := by + simpa [found] using hfound + simp only [hcache] + exact RecM.WF.pure fun hI2 => by + have hcached := + (hI2.1.caches.hit (.whnfNoDelta hcache)).supported.2 + have hmeaning := hI2.1.caches.whnfHitOfMatches + (.whnfNoDelta hcache) .whnfNoDelta hsupport hmatch + have hstart := WhnfPost.refl hsource + (theory.exprWF hI2.2.1 hsource) + exact ⟨hcached, + hstart.transMeaning theory hI2.2.1.wf hmeaning⟩ + | none => + have hcache : s2.env.whnfNoDeltaCache[key]? = none := by + simpa [found] using hfound + simp only [hcache] + apply RecM.WF.bind (hinner s2) + intro result s3 hpost + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s3 ∧ after = s3) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + cases hnative : s3.inNativeReduce with + | true => + simp only [Bool.not_true, Bool.false_and, + Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => hpost + | false => + simp only [Bool.not_false, Bool.true_and, + if_true] + let next := {s3 with env := {s3.env with + whnfNoDeltaCache := + s3.env.whnfNoDeltaCache.insert key result}} + apply RecM.WF.bind + (Q₁ := fun _ after => after = next) + · refine RecM.WF.modify (f := fun st => + {st with env := {st.env with + whnfNoDeltaCache := + st.env.whnfNoDeltaCache.insert key result}}) ?_ + (fun _ => rfl) + intro hI3 + exact WhnfDriverCacheUpdate.noDelta_whnfStateInv + hI3 (hwrites.noDelta hsupport hpost.1 hmatch + (hpost.2.meaning hsource)) + · intro _ s4 hs4 + subst s4 + exact RecM.WF.pure fun _ => hpost + | false => + simp only [natSuccMode_collapse_beq, Bool.not_false, + Bool.true_and, if_true] + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s2 ∧ after = s2) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + let found := s2.env.whnfNoDeltaCheapCache[key]? + cases hfound : found with + | some cached => + have hcache : s2.env.whnfNoDeltaCheapCache[key]? = + some cached := by + simpa [found] using hfound + simp only [hcache] + exact RecM.WF.pure fun hI2 => by + have hcached := + (hI2.1.caches.hit + (.whnfNoDeltaCheap hcache)).supported.2 + have hmeaning := hI2.1.caches.whnfHitOfMatches + (.whnfNoDeltaCheap hcache) .whnfNoDeltaCheap + hsupport hmatch + have hstart := WhnfPost.refl hsource + (theory.exprWF hI2.2.1 hsource) + exact ⟨hcached, + hstart.transMeaning theory hI2.2.1.wf hmeaning⟩ + | none => + have hcache : s2.env.whnfNoDeltaCheapCache[key]? = + none := by + simpa [found] using hfound + simp only [hcache] + apply RecM.WF.bind (hinner s2) + intro result s3 hpost + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s3 ∧ after = s3) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + cases hnative : s3.inNativeReduce with + | true => + simp only [Bool.not_true, Bool.false_and, + Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => hpost + | false => + simp only [Bool.not_false, Bool.true_and, + if_true] + let next := {s3 with env := {s3.env with + whnfNoDeltaCheapCache := + s3.env.whnfNoDeltaCheapCache.insert key result}} + apply RecM.WF.bind + (Q₁ := fun _ after => after = next) + · refine RecM.WF.modify (f := fun st => + {st with env := {st.env with + whnfNoDeltaCheapCache := + st.env.whnfNoDeltaCheapCache.insert key result}}) + ?_ (fun _ => rfl) + intro hI3 + exact + WhnfDriverCacheUpdate.noDeltaCheap_whnfStateInv + hI3 (hwrites.noDeltaCheap hsupport hpost.1 hmatch + (hpost.2.meaning hsource)) + · intro _ s4 hs4 + subst s4 + exact RecM.WF.pure fun _ => hpost + +/-- Public no-delta entry for every form that bypasses the legacy-variable + prefix. The equation bridge is exact; all semantic assumptions are the + shell obligations exposed by `whnfNoDeltaImplNonLeaf_wf`. -/ +theorem whnfNoDeltaImpl_nonLeaf_wf + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {Delta : KVLCtx} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {source : KExpr .anon} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world keys.uvars) + (hnonleaf : WhnfDriverNonLeaf source) + (hkeyRep : WhnfKey.Represents keys trProj world source Delta) + (htransient : TransientNatWork.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta source) + (hstep : WhnfStep.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta id (whnfNoDeltaImplStep flags natSuccMode) stepError) + (hwrites : WhnfCacheWriteOracle keys trProj fallback world support) + (hsupport : support source) + {sourceV : VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s (whnfNoDeltaImpl source flags natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + rw [hnonleaf.noDelta_enter] + exact whnfNoDeltaImplNonLeaf_wf theory hkeyRep htransient hstep hwrites + hsupport hsource + +/-- Conditional Hoare closure for the keyed full-WHNF shell. Prefix + instrumentation and the post-miss fuel charge are kept as separate + operational contracts; the semantic loop, hit validity, and insertion + invariant are proved compositionally. -/ +theorem whnfWithNatSuccModeNonLeaf_wf + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {Delta : KVLCtx} {natSuccMode : NatSuccMode} + {source : KExpr .anon} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world keys.uvars) + (hprefix : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 (whnfWithNatSuccModePrefix source) + (fun _ _ => True)) + (hkeyRep : WhnfKey.Represents keys trProj world source Delta) + (htransient : TransientNatWork.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta source) + (hcharge : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 + (whnfWithNatSuccModeMissCharge : RecM .anon Unit) + (fun _ _ => True)) + (hstep : WhnfStep.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta + (fun state : KExpr .anon × HashSet Address => state.1) + (whnfWithNatSuccModeStep natSuccMode) stepError) + (hwrites : WhnfCacheWriteOracle keys trProj fallback world support) + (hsupport : support source) + {sourceV : VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s + (whnfWithNatSuccModeNonLeaf source natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + have hinner : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 + (whnfWithNatSuccModeUncached source natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + fun s0 => RecM.WF.mono + (WhnfFullTrace.uncached_wf theory hstep (s := s0) hsupport hsource) + (fun _ _ h => h) (fun _ _ _ => trivial) + have hwork : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 + (do + whnfWithNatSuccModeMissCharge + let result ← whnfWithNatSuccModeUncached source natSuccMode + let _ ← (get : RecM .anon (TcState .anon)) + pure result) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + intro s0 + apply RecM.WF.bind (hcharge s0) + intro _ s1 _ + apply RecM.WF.bind (hinner s1) + intro result s2 hpost + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s2 ∧ after = s2) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + exact RecM.WF.pure fun _ => hpost + unfold whnfWithNatSuccModeNonLeaf + apply RecM.WF.bind (hprefix s) + intro _ s0 _ + simp only + apply RecM.WF.bind + (Q₁ := fun key _ => keys.Matches trProj world s0 Delta source key) + · apply RecM.WF.liftTcM + exact TcM.WF.mono + (TcM.whnfKey_matches_wf + (fun key after hctx hrun => hkeyRep s0 key after hctx hrun)) + (fun key _ h => h.1) (fun _ _ h => h) + · intro key s1 hmatch + apply RecM.WF.bind (htransient s1) + intro transient s2 _ + cases natSuccMode with + | stuck => + simpa [natSuccMode_stuck_beq] using hwork s2 + | collapse => + cases transient with + | true => + simpa [natSuccMode_collapse_beq] using hwork s2 + | false => + simp only [natSuccMode_collapse_beq, Bool.not_false, + Bool.true_and, if_true] + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s2 ∧ after = s2) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + let found := s2.env.whnfCache[key]? + cases hfound : found with + | some cached => + have hcache : s2.env.whnfCache[key]? = some cached := by + simpa [found] using hfound + simp only [hcache] + exact RecM.WF.pure fun hI2 => by + have hcached := + (hI2.1.caches.hit (.whnf hcache)).supported.2 + have hmeaning := hI2.1.caches.whnfHitOfMatches + (.whnf hcache) .whnf hsupport hmatch + have hstart := WhnfPost.refl hsource + (theory.exprWF hI2.2.1 hsource) + exact ⟨hcached, + hstart.transMeaning theory hI2.2.1.wf hmeaning⟩ + | none => + have hcache : s2.env.whnfCache[key]? = none := by + simpa [found] using hfound + simp only [hcache] + apply RecM.WF.bind (hcharge s2) + intro _ s3 _ + apply RecM.WF.bind (hinner s3) + intro result s4 hpost + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s4 ∧ after = s4) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + cases hnative : s4.inNativeReduce with + | true => + simp only [Bool.not_true, Bool.false_and, + Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => hpost + | false => + simp only [Bool.not_false, Bool.true_and, if_true] + let next := {s4 with env := {s4.env with + whnfCache := s4.env.whnfCache.insert key result}} + apply RecM.WF.bind + (Q₁ := fun _ after => after = next) + · refine RecM.WF.modify (f := fun st => + {st with env := {st.env with + whnfCache := st.env.whnfCache.insert key result}}) + ?_ (fun _ => rfl) + intro hI4 + exact WhnfDriverCacheUpdate.full_whnfStateInv hI4 + (hwrites.full hsupport hpost.1 hmatch + (hpost.2.meaning hsource)) + · intro _ s5 hs5 + subst s5 + exact RecM.WF.pure fun _ => hpost + +/-- Public full-WHNF entry for every direct non-leaf form. -/ +theorem whnfWithNatSuccMode_nonLeaf_wf + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {Delta : KVLCtx} {natSuccMode : NatSuccMode} + {source : KExpr .anon} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world keys.uvars) + (hnonleaf : WhnfDriverNonLeaf source) + (hprefix : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 (whnfWithNatSuccModePrefix source) + (fun _ _ => True)) + (hkeyRep : WhnfKey.Represents keys trProj world source Delta) + (htransient : TransientNatWork.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta source) + (hcharge : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 + (whnfWithNatSuccModeMissCharge : RecM .anon Unit) + (fun _ _ => True)) + (hstep : WhnfStep.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta + (fun state : KExpr .anon × HashSet Address => state.1) + (whnfWithNatSuccModeStep natSuccMode) stepError) + (hwrites : WhnfCacheWriteOracle keys trProj fallback world support) + (hsupport : support source) + {sourceV : VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s (whnfWithNatSuccMode source natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + rw [hnonleaf.full_enter] + exact whnfWithNatSuccModeNonLeaf_wf theory hprefix hkeyRep htransient + hcharge hstep hwrites hsupport hsource + +/-- The full-WHNF trace/statistics prefix preserves every semantic component + of the K1 state invariant, independently of instrumentation settings. -/ +theorem whnfWithNatSuccModePrefix_wf + {semantics : CacheSemantics} {layer : WhnfLayer} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} (source : KExpr .anon) + (s : TcState .anon) : + RecM.WF layer semantics trProj world support uvars Delta s + (whnfWithNatSuccModePrefix source) (fun _ _ => True) := by + unfold whnfWithNatSuccModePrefix + apply RecM.WF.bind + · apply RecM.WF.liftTcM + exact TcM.stepTrace_whnf_wf "whnf+" (fun _ => TcM.addr8 source.addr) s + · intro _ s1 _ + apply RecM.WF.liftTcM + exact TcM.bumpStats_whnf_wf + (fun st => {st with whnfCalls := st.whnfCalls + 1}) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) s1 + +/-- The full-WHNF miss charge preserves the K1 invariant on both outcomes. + Its only possible error is the underlying `.maxRecFuel`; the bounded-loop + `.maxRecDepth` classification remains separate in `WhnfLoopError`. -/ +theorem whnfWithNatSuccModeMissCharge_wf + {semantics : CacheSemantics} {layer : WhnfLayer} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} (s : TcState .anon) : + RecM.WF layer semantics trProj world support uvars Delta s + (whnfWithNatSuccModeMissCharge : RecM .anon Unit) + (fun _ _ => True) := by + unfold whnfWithNatSuccModeMissCharge + apply RecM.WF.bind + · apply RecM.WF.liftTcM + exact TcM.bumpStats_whnf_wf + (fun st => {st with whnfMisses := st.whnfMisses + 1}) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) s + · intro _ s1 _ + apply RecM.WF.liftTcM + exact TcM.WF.mono + (TcM.tick.wf (fun _ hI => hI.of_semantic_fields_eq + rfl rfl rfl rfl rfl rfl rfl rfl)) + (fun _ _ _ => trivial) (fun _ _ _ => trivial) + +/-- Full-WHNF public non-leaf closure with the mechanical prefix and charge + obligations discharged. -/ +theorem whnfWithNatSuccMode_nonLeaf_semantic_wf + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {Delta : KVLCtx} {natSuccMode : NatSuccMode} + {source : KExpr .anon} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world keys.uvars) + (hnonleaf : WhnfDriverNonLeaf source) + (hkeyRep : WhnfKey.Represents keys trProj world source Delta) + (htransient : TransientNatWork.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta source) + (hstep : WhnfStep.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta + (fun state : KExpr .anon × HashSet Address => state.1) + (whnfWithNatSuccModeStep natSuccMode) stepError) + (hwrites : WhnfCacheWriteOracle keys trProj fallback world support) + (hsupport : support source) + {sourceV : VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s (whnfWithNatSuccMode source natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + whnfWithNatSuccMode_nonLeaf_wf theory hnonleaf + (whnfWithNatSuccModePrefix_wf source) hkeyRep htransient + whnfWithNatSuccModeMissCharge_wf hstep hwrites hsupport hsource + +/-- Conditional closure of the actual public no-delta dispatcher for every + expression form. Immediate leaves return reflexively; a legacy variable + performs the proved read-only let test and enters the same keyed shell + only when necessary. -/ +theorem whnfNoDeltaImpl_wf + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {Delta : KVLCtx} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {source : KExpr .anon} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world keys.uvars) + (hkeyRep : WhnfKey.Represents keys trProj world source Delta) + (htransient : TransientNatWork.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta source) + (hstep : WhnfStep.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta id (whnfNoDeltaImplStep flags natSuccMode) stepError) + (hwrites : WhnfCacheWriteOracle keys trProj fallback world support) + (hsupport : support source) + {sourceV : VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s (whnfNoDeltaImpl source flags natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + have hreflexive : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 (pure source) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + fun s0 => RecM.WF.pure fun hI => + ⟨hsupport, WhnfPost.refl hsource (theory.exprWF hI.2.1 hsource)⟩ + cases source with + | sort u info => + simpa [whnfNoDeltaImpl] using hreflexive s + | all name bi ty body info => + simpa [whnfNoDeltaImpl] using hreflexive s + | lam name bi ty body info => + simpa [whnfNoDeltaImpl] using hreflexive s + | nat value blob info => + simpa [whnfNoDeltaImpl] using hreflexive s + | str value blob info => + simpa [whnfNoDeltaImpl] using hreflexive s + | const id us info => + simpa [whnfNoDeltaImpl] using + (whnfNoDeltaImplNonLeaf_wf theory hkeyRep htransient hstep hwrites + hsupport (s := s) hsource) + | fvar id name info => + simpa [whnfNoDeltaImpl] using + (whnfNoDeltaImplNonLeaf_wf theory hkeyRep htransient hstep hwrites + hsupport (s := s) hsource) + | app f arg info => + simpa [whnfNoDeltaImpl] using + (whnfNoDeltaImplNonLeaf_wf theory hkeyRep htransient hstep hwrites + hsupport (s := s) hsource) + | letE name ty value body nondep info => + simpa [whnfNoDeltaImpl] using + (whnfNoDeltaImplNonLeaf_wf theory hkeyRep htransient hstep hwrites + hsupport (s := s) hsource) + | prj id field value info => + simpa [whnfNoDeltaImpl] using + (whnfNoDeltaImplNonLeaf_wf theory hkeyRep htransient hstep hwrites + hsupport (s := s) hsource) + | var idx name info => + unfold whnfNoDeltaImpl + apply RecM.WF.bind + · apply RecM.WF.liftTcM + exact TcM.isLetVar_wf idx s + · intro isLet s1 hs1 + subst s1 + cases isLet with + | false => + simpa using hreflexive s + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false, + pure_bind] + exact whnfNoDeltaImplNonLeaf_wf theory hkeyRep htransient hstep + hwrites hsupport (s := s) hsource + +/-- Conditional closure of the actual full-WHNF dispatcher for every input + form and both successor policies. -/ +theorem whnfWithNatSuccMode_wf + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {Delta : KVLCtx} {natSuccMode : NatSuccMode} + {source : KExpr .anon} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world keys.uvars) + (hkeyRep : WhnfKey.Represents keys trProj world source Delta) + (htransient : TransientNatWork.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta source) + (hstep : WhnfStep.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta + (fun state : KExpr .anon × HashSet Address => state.1) + (whnfWithNatSuccModeStep natSuccMode) stepError) + (hwrites : WhnfCacheWriteOracle keys trProj fallback world support) + (hsupport : support source) + {sourceV : VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s (whnfWithNatSuccMode source natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + have hreflexive : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 (pure source) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + fun s0 => RecM.WF.pure fun hI => + ⟨hsupport, WhnfPost.refl hsource (theory.exprWF hI.2.1 hsource)⟩ + have hshell : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 + (whnfWithNatSuccModeNonLeaf source natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + fun s0 => whnfWithNatSuccModeNonLeaf_wf theory + (whnfWithNatSuccModePrefix_wf source) hkeyRep htransient + whnfWithNatSuccModeMissCharge_wf hstep hwrites hsupport (s := s0) + hsource + cases source with + | sort u info => + simpa [whnfWithNatSuccMode] using hreflexive s + | all name bi ty body info => + simpa [whnfWithNatSuccMode] using hreflexive s + | lam name bi ty body info => + simpa [whnfWithNatSuccMode] using hreflexive s + | nat value blob info => + simpa [whnfWithNatSuccMode] using hreflexive s + | str value blob info => + simpa [whnfWithNatSuccMode] using hreflexive s + | const id us info => + simpa [whnfWithNatSuccMode] using hshell s + | fvar id name info => + simpa [whnfWithNatSuccMode] using hshell s + | app f arg info => + simpa [whnfWithNatSuccMode] using hshell s + | letE name ty value body nondep info => + simpa [whnfWithNatSuccMode] using hshell s + | prj id field value info => + simpa [whnfWithNatSuccMode] using hshell s + | var idx name info => + unfold whnfWithNatSuccMode + apply RecM.WF.bind + · apply RecM.WF.liftTcM + exact TcM.isLetVar_wf idx s + · intro isLet s1 hs1 + subst s1 + cases isLet with + | false => + simpa using hreflexive s + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false, + pure_bind] + exact hshell s + +/-- Public `RecM.whnfNoDelta` specialization of the conditional dispatcher + theorem. -/ +theorem whnfNoDelta_wf + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {Delta : KVLCtx} {source : KExpr .anon} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world keys.uvars) + (hkeyRep : WhnfKey.Represents keys trProj world source Delta) + (htransient : TransientNatWork.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta source) + (hstep : WhnfStep.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta id + (whnfNoDeltaImplStep .FULL .collapse) stepError) + (hwrites : WhnfCacheWriteOracle keys trProj fallback world support) + (hsupport : support source) + {sourceV : VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s (whnfNoDelta source) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + whnfNoDeltaImpl_wf theory hkeyRep htransient hstep hwrites hsupport hsource + +/-- Public `RecM.whnf` specialization. K2 can use this theorem directly + when proving the corresponding `Methods.WF.whnf` field for `methodsN`. -/ +theorem whnf_wf + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {Delta : KVLCtx} {source : KExpr .anon} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world keys.uvars) + (hkeyRep : WhnfKey.Represents keys trProj world source Delta) + (htransient : TransientNatWork.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta source) + (hstep : WhnfStep.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta + (fun state : KExpr .anon × HashSet Address => state.1) + (whnfWithNatSuccModeStep .collapse) stepError) + (hwrites : WhnfCacheWriteOracle keys trProj fallback world support) + (hsupport : support source) + {sourceV : VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s (whnf source) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + whnfWithNatSuccMode_wf theory hkeyRep htransient hstep hwrites hsupport + hsource + theorem whnfNoDeltaImpl_fullHit_acceptance {keys : WhnfContextKeys} {fallback : CacheSemantics} {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} @@ -3141,6 +5600,330 @@ theorem eval {e : KExpr .anon} (h : WhnfCoreLeaf e) end WhnfCoreLeaf +/-- A recursive head-callback result that cannot enter the beta branch. +Although `collectSpine` never returns an application as its *input* head, a +semantically closed callback may return an application definitionally equal +to that head. Production treats such a result in the ordinary changed or +unchanged non-lambda path, so the verification classifier must include it. -/ +inductive WhnfCoreNonLambda : KExpr .anon → Prop + | var {idx name info} : WhnfCoreNonLambda (.var idx name info) + | fvar {id name info} : WhnfCoreNonLambda (.fvar id name info) + | sort {u info} : WhnfCoreNonLambda (.sort u info) + | app {f arg info} : WhnfCoreNonLambda (.app f arg info) + | all {name bi ty body info} : WhnfCoreNonLambda (.all name bi ty body info) + | letE {name ty val body nondep info} : + WhnfCoreNonLambda (.letE name ty val body nondep info) + | prj {id field val info} : WhnfCoreNonLambda (.prj id field val info) + | nat {value blob info} : WhnfCoreNonLambda (.nat value blob info) + | str {value blob info} : WhnfCoreNonLambda (.str value blob info) + | const {id us info} : WhnfCoreNonLambda (.const id us info) + +/-! ### Application-spine rebuilding -/ + +/-- A structurally recursive list view of an application spine. The proof +below connects it to production's accumulator/reverse implementation, while +this view makes translation induction direct. -/ +def appSpineView (e : KExpr m) : KExpr m × List (KExpr m) := + match e with + | .app f a _ => + let (head, args) := appSpineView f + (head, args ++ [a]) + | e => (e, []) +termination_by structural e + +/-- Production's accumulator contains the reversed pending suffix; the +structural view contributes the already ordered prefix. -/ +theorem appSpineView_go (e : KExpr m) (acc : Array (KExpr m)) : + let (head, args) := appSpineView e + (KExpr.collectSpine.go e acc).1 = head ∧ + (KExpr.collectSpine.go e acc).2.toList = + args ++ acc.toList.reverse := by + induction e generalizing acc <;> + simp_all [appSpineView, KExpr.collectSpine.go, + List.reverse_append, List.append_assoc] + +/-- The structural view is extensionally the actual production spine. -/ +theorem appSpineView_collectSpine (e : KExpr m) : + let (head, args) := appSpineView e + e.collectSpine.1 = head ∧ e.collectSpine.2.toList = args := by + simpa [KExpr.collectSpine] using appSpineView_go e #[] + +/-- Translation-indexed spine view. Each extension retains the exact +function and argument typing derivations needed for semantic application +congruence. -/ +inductive TrAppSpine (env : Lean4Lean.VEnv) (uvars : Nat) + (nameOf : Address → Option Lean.Name) (trProj : RawProjRel) + (Δ : KVLCtx) (head : KExpr .anon) : + List (KExpr .anon) → VExpr → Prop + | head {headV} : + TrKExprS env uvars nameOf trProj Δ head headV → + TrAppSpine env uvars nameOf trProj Δ head [] headV + | app {args fV arg argV A B} : + TrAppSpine env uvars nameOf trProj Δ head args fV → + env.HasType uvars Δ.toCtx fV (.forallE A B) → + env.HasType uvars Δ.toCtx argV A → + TrKExprS env uvars nameOf trProj Δ arg argV → + TrAppSpine env uvars nameOf trProj Δ head (args ++ [arg]) + (.app fV argV) + +/-- Every structural translation induces the corresponding typed spine +translation; expression metadata is deliberately absent from the view. -/ +theorem trAppSpine_of_tr + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Δ : KVLCtx} {e : KExpr .anon} {eV : VExpr} + (h : TrKExprS env uvars nameOf trProj Δ e eV) : + let (head, args) := appSpineView e + TrAppSpine env uvars nameOf trProj Δ head args eV := by + induction h with + | var h => exact .head (.var h) + | fvar h => exact .head (.fvar h) + | sort h => exact .head (.sort h) + | const h₁ h₂ h₃ h₄ => exact .head (.const h₁ h₂ h₃ h₄) + | @app Δ f arg md fV argV A B h₁ h₂ htf hta ihf iha => + simp only [appSpineView] + generalize hview : appSpineView f = view at ihf + cases view with + | mk head args => + exact .app ihf h₁ h₂ hta + | lam h₁ h₂ h₃ ih₂ ih₃ => exact .head (.lam h₁ h₂ h₃) + | all h₁ h₂ h₃ h₄ ih₃ ih₄ => exact .head (.all h₁ h₂ h₃ h₄) + | letE h₁ h₂ h₃ h₄ ih₂ ih₃ ih₄ => exact .head (.letE h₁ h₂ h₃ h₄) + | prj h₁ h₂ h₃ ih₁ => exact .head (.prj h₁ h₂ h₃) + | nat h => exact .head (.nat h) + | str h => exact .head (.str h) + +namespace TrAppSpine + +/-- Every concrete argument named by a typed spine retains its own +translation and typing derivation. This is the membership form needed by +descriptor-driven reducers whose argument positions are discovered only at +runtime. -/ +theorem argument + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {head arg : KExpr .anon} + {args : List (KExpr .anon)} {resultV : VExpr} + (h : TrAppSpine env uvars nameOf trProj Delta head args resultV) + (hmem : arg ∈ args) : + ∃ argV A, + env.HasType uvars Delta.toCtx argV A ∧ + TrKExprS env uvars nameOf trProj Delta arg argV := by + induction h with + | head hhead => simp at hmem + | app hprefix hfun hlast hlastTr ih => + simp only [List.mem_append, List.mem_singleton] at hmem + rcases hmem with hprefixMem | rfl + · exact ih hprefixMem + · exact ⟨_, _, hlast, hlastTr⟩ + +/-- Rebuild the canonical metadata-free raw spine without changing its +Theory translation. -/ +theorem tr + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Δ : KVLCtx} {head : KExpr .anon} {args : List (KExpr .anon)} + {eV : VExpr} + (h : TrAppSpine env uvars nameOf trProj Δ head args eV) : + TrKExprS env uvars nameOf trProj Δ + (args.foldl KExpr.mkApp head) eV := by + cases h with + | head h => exact h + | app hprefix hfun harg htr => + rw [List.foldl_append] + simp only [List.foldl_cons, List.foldl_nil] + rw [KExpr.mkApp_shape] + exact .app hfun harg hprefix.tr htr + +end TrAppSpine + +/-- Re-index a source translation by the head and array returned by the +actual production `collectSpine`. -/ +theorem trAppSpine_of_collectSpine + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Δ : KVLCtx} {source head : KExpr .anon} + {args : Array (KExpr .anon)} {sourceV : VExpr} + (hsource : TrKExprS env uvars nameOf trProj Δ source sourceV) + (hspine : source.collectSpine = (head, args)) : + TrAppSpine env uvars nameOf trProj Δ head args.toList sourceV := by + generalize hview : appSpineView source = view + cases view with + | mk viewHead viewArgs => + have htr := trAppSpine_of_tr hsource + rw [hview] at htr + have hv := appSpineView_collectSpine source + rw [hview] at hv + have hsHead := congrArg Prod.fst hspine + have hsArgs := congrArg (fun p => p.2.toList) hspine + have hhead : head = viewHead := hsHead.symm.trans hv.1 + have hargs : args.toList = viewArgs := hsArgs.symm.trans hv.2 + simpa only [hhead, hargs] using htr + +/-- Pure left-to-right result of production's application-spine helper. +Only the suffix beginning at `consumed` is rebuilt. -/ +def finishAppResultSpec (result : KExpr .anon) + (args : Array (KExpr .anon)) (consumed : Nat) : KExpr .anon := + KExpr.mkAppN result (args.extract consumed args.size) + +/-- The imperative `for` loop in `finishAppResult` is exactly a monadic +left fold over the requested suffix. This equation fixes both argument order +and the consumed-prefix boundary without changing the production helper. -/ +theorem finishAppResult_eq_foldlM (result : KExpr m) + (args : Array (KExpr m)) (consumed : Nat) : + finishAppResult result args consumed = + (args.extract consumed args.size).foldlM (m := RecM m) + (fun result arg => liftM (TcM.intern (KExpr.mkApp result arg))) + result := by + unfold finishAppResult + simp [Array.forIn_yield_eq_foldlM] + +/-- Production's application-suffix rebuild is operationally total. This +fact is deliberately weaker than semantic correctness: without a finite +request certificate, an intern collision may change the returned syntax and +the post-state need not satisfy the checker invariant. The finite-request +closure uses totality only to rule out a late miss/error after a primitive +result was selected. -/ +theorem finishAppResult_total + {methods : Methods .anon} {s : TcState .anon} + (result : KExpr .anon) (args : Array (KExpr .anon)) (consumed : Nat) : + ∃ final s', + (finishAppResult result args consumed).run methods s = .ok final s' := by + rw [finishAppResult_eq_foldlM] + rw [← Array.foldlM_toList] + generalize hrest : (args.extract consumed args.size).toList = rest + clear hrest + induction rest generalizing result s with + | nil => + exact ⟨result, s, rfl⟩ + | cons arg rest ih => + rw [List.foldlM_cons, ReaderT.run_bind, ReaderT.run_monadLift] + let pair := internExprM (KExpr.mkApp result arg) s.env.intern + let next := {s with env := {s.env with intern := pair.2}} + obtain ⟨final, s', htail⟩ := ih (result := pair.1) (s := next) + refine ⟨final, s', ?_⟩ + change EStateM.bind (TcM.intern (KExpr.mkApp result arg)) _ s = _ + unfold EStateM.bind TcM.intern TcM.runIntern + exact htail + +/-- Exact one-argument specialization used by adversarial fixtures and by +single-node suffix certificates. -/ +theorem finishAppResult_one + {methods : Methods .anon} {s s' : TcState .anon} + {result arg final : KExpr .anon} + (hintern : TcM.intern (KExpr.mkApp result arg) s = .ok final s') : + (finishAppResult result #[arg] 0).run methods s = .ok final s' := by + rw [finishAppResult_eq_foldlM] + change EStateM.bind (TcM.intern _) _ s = _ + simpa [EStateM.bind] using hintern + +/-- Finite execution certificate for rebuilding an application suffix. +Each node records the exact dynamically generated application passed to +`TcM.intern`; the indices force a left-to-right spine and expose every support +and collision-freedom obligation through `WalkerRequest.internExpr`. -/ +inductive FinishAppRequests (requests : List WalkerRequest) : + List (KExpr .anon) → KExpr .anon → KExpr .anon → Prop + | nil (result) : FinishAppRequests requests [] result result + | cons {arg result rest final} + (head : WalkerRequest.internExpr (KExpr.mkApp result arg) ∈ requests) + (tail : FinishAppRequests requests rest + (KExpr.mkApp result arg) final) : + FinishAppRequests requests (arg :: rest) result final + +namespace FinishAppRequests + +/-- The certificate's final expression is the pure left fold described by +its indices; an argument permutation cannot inhabit this equality. -/ +theorem result_eq_foldl {requests : List WalkerRequest} + {rest : List (KExpr .anon)} {result final : KExpr .anon} + (h : FinishAppRequests requests rest result final) : + final = rest.foldl KExpr.mkApp result := by + induction h with + | nil => rfl + | cons head tail ih => + simpa only [List.foldl_cons] using ih + +/-- Every intermediate application requested by a certificate—and hence its +final result—is covered by the finite run support. -/ +theorem support {α : Type} {initial : TcState .anon} + {program : TcM .anon α} {requests : List WalkerRequest} + {runSupport : RunSupport} + (hrun : RunAssumptions initial program requests runSupport) + {rest : List (KExpr .anon)} {result final : KExpr .anon} + (h : FinishAppRequests requests rest result final) + (hresult : runSupport result) : runSupport final := by + induction h with + | nil => exact hresult + | cons head tail ih => + exact ih (hrun.coverage.internExpr head) + +/-- Execute the certified list fold. Each direct intern request preserves +the full invariant; their intern-only frames compose transitively. -/ +theorem foldlM_eval {α : Type} {initial : TcState .anon} + {program : TcM .anon α} {requests : List WalkerRequest} + {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Δ : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {rest : List (KExpr .anon)} {result final : KExpr .anon} + (h : FinishAppRequests requests rest result final) + (hI : WhnfStateInv layer semantics trProj world support uvars Δ s) : + ∃ s', + (rest.foldlM (m := RecM .anon) + (fun result arg => liftM (TcM.intern (KExpr.mkApp result arg))) + result).run methods s = .ok final s' ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s' ∧ + InternUpdateFrame s s' := by + induction h generalizing s with + | nil => + exact ⟨s, rfl, hI, InternUpdateFrame.refl s⟩ + | cons head tail ih => + obtain ⟨s₁, hstep, hI₁, hframe₁⟩ := + hrun.internExpr_whnf_eval head hI + obtain ⟨s₂, htail, hI₂, hframe₂⟩ := ih hI₁ + refine ⟨s₂, ?_, hI₂, hframe₁.trans hframe₂⟩ + rw [List.foldlM_cons, ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern _) _ s = _ + unfold EStateM.bind + rw [hstep] + exact htail + +/-- Execute the actual production helper from a certificate for precisely +the extracted suffix. -/ +theorem eval {α : Type} {initial : TcState .anon} + {program : TcM .anon α} {requests : List WalkerRequest} + {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Δ : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {args : Array (KExpr .anon)} {consumed : Nat} + {result final : KExpr .anon} + (h : FinishAppRequests requests + (args.extract consumed args.size).toList result final) + (hI : WhnfStateInv layer semantics trProj world support uvars Δ s) : + ∃ s', + (finishAppResult result args consumed).run methods s = .ok final s' ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s' ∧ + InternUpdateFrame s s' := by + obtain ⟨s', hrun', hI', hframe⟩ := h.foldlM_eval hrun hI + refine ⟨s', ?_, hI', hframe⟩ + rw [finishAppResult_eq_foldlM] + simpa only [← Array.foldlM_toList] using hrun' + +/-- The certificate result agrees with the named pure helper specification. -/ +theorem final_eq_spec {requests : List WalkerRequest} + {args : Array (KExpr .anon)} {consumed : Nat} + {result final : KExpr .anon} + (h : FinishAppRequests requests + (args.extract consumed args.size).toList result final) : + final = finishAppResultSpec result args consumed := by + rw [finishAppResultSpec, KExpr.mkAppN] + simpa only [Array.foldl_toList] using h.result_eq_foldl + +end FinishAppRequests + /-- Exact production step for successful legacy de-Bruijn zeta reduction. The lookup may grow only the intern table because it lifts the stored value to the current depth. -/ @@ -3176,6 +5959,68 @@ theorem whnfCoreWithFlagsStep_fvarZeta rw [hfind] rfl +/-- Exact production fallback for a legacy variable that is not let-bound. + Any successful `none` lookup is state-pure by + `TcM.lookupLetVal_none_state`. -/ +theorem whnfCoreWithFlagsStep_varDone + {methods : Methods .anon} {s s' : TcState .anon} + {idx : UInt64} {name : Mode.anon.F Name} {md : ExprInfo .anon} + {flags : WhnfFlags} + (hlookup : TcM.lookupLetVal idx s = .ok none s') : + (whnfCoreWithFlagsStep (.var idx name md) flags).run methods s = + .ok (.done (.var idx name md)) s' := by + unfold whnfCoreWithFlagsStep + change EStateM.bind (TcM.lookupLetVal idx) _ s = _ + unfold EStateM.bind + rw [hlookup] + rfl + +/-- Exact production fallback for an fvar whose declaration is absent or a + regular binder. The quantified exclusion covers both lookup outcomes + without assuming that a translated fvar must be present in arbitrary raw + state. -/ +theorem whnfCoreWithFlagsStep_fvarDone + {methods : Methods .anon} {s : TcState .anon} + {id : FVarId} {name : Mode.anon.F Name} {md : ExprInfo .anon} + {flags : WhnfFlags} + (hnot : ∀ declName ty val, + s.lctx.find? id ≠ some (.ldecl declName ty val)) : + (whnfCoreWithFlagsStep (.fvar id name md) flags).run methods s = + .ok (.done (.fvar id name md)) s := by + unfold whnfCoreWithFlagsStep + rw [ReaderT.run_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only + cases hfind : s.lctx.find? id with + | none => rfl + | some decl => + cases decl with + | cdecl => rfl + | ldecl declName ty val => exact False.elim (hnot declName ty val hfind) + +/-- Exact production step for an explicit let expression. The named +single-substitution walker is the only stateful action on this branch. -/ +theorem whnfCoreWithFlagsStep_letE + {methods : Methods .anon} {s s' : TcState .anon} + {name : Mode.anon.F Name} {ty val body result : KExpr .anon} + {nondep : Bool} {info : ExprInfo .anon} {flags : WhnfFlags} + (hwalk : TcM.runIntern (subst body val 0) s = .ok result s') : + (whnfCoreWithFlagsStep (.letE name ty val body nondep info) flags).run + methods s = .ok (.next result) s' := by + unfold whnfCoreWithFlagsStep + change ReaderT.run + (BoundedStep.next <$> liftM (TcM.runIntern (subst body val 0)) : + RecM .anon (BoundedStep (KExpr .anon) (KExpr .anon))) methods s = _ + rw [ReaderT.run_map, ReaderT.run_monadLift] + rw [← bind_pure_comp] + change EStateM.bind (TcM.runIntern (subst body val 0)) + (fun r => pure (BoundedStep.next r)) s = _ + unfold EStateM.bind + rw [hwalk] + rfl + /-- Exact production step for a direct one-argument beta redex. The head callback equation is intentionally stronger than `Methods.WF`: semantic closure alone cannot force a callback to return this syntactic lambda. -/ @@ -3210,6 +6055,59 @@ theorem whnfCoreWithFlagsStep_betaOne rw [hwalk] rfl +/-- Exact production step for general multi-argument beta. Unlike the +single-argument convenience theorem, this exposes the lambda-peeling result, +the simultaneous-substitution execution, and rebuilding of only the +unconsumed argument suffix. -/ +theorem whnfCoreWithFlagsStep_betaMany + {methods : Methods .anon} {s s₁ s₂ s₃ : TcState .anon} + {f arg head : KExpr .anon} {appInfo : ExprInfo .anon} + {args : Array (KExpr .anon)} + {nm : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body body₀ : KExpr .anon} {lamInfo : ExprInfo .anon} + {consumed : Array (KExpr .anon)} {substituted result : KExpr .anon} + {flags : WhnfFlags} + (hspine : (.app f arg appInfo : KExpr .anon).collectSpine = (head, args)) + (hhead : methods.whnfCoreFlags head flags s = + .ok (.lam nm bi ty body lamInfo) s₁) + (hconsume : consumeBetaLams (.lam nm bi ty body lamInfo) args = + (body₀, consumed)) + (hnonempty : (!consumed.isEmpty) = true) + (hsubst : TcM.runIntern (simulSubst body₀ consumed.reverse 0) s₁ = + .ok substituted s₂) + (hfinish : (finishAppResult substituted args consumed.size).run methods s₂ = + .ok result s₃) : + (whnfCoreWithFlagsStep (.app f arg appInfo) flags).run methods s = + .ok (.next result) s₃ := by + unfold whnfCoreWithFlagsStep + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + rw [hspine] + change EStateM.bind (methods.whnfCoreFlags head flags) _ s = _ + unfold EStateM.bind + rw [hhead] + simp only + rw [hconsume] + simp only + rw [hnonempty] + simp only [↓reduceIte] + change ReaderT.run + ((liftM (TcM.runIntern (simulSubst body₀ consumed.reverse 0)) >>= fun r => do + pure PUnit.unit + let r ← finishAppResult r args consumed.size + pure (BoundedStep.next r)) : + RecM .anon (BoundedStep (KExpr .anon) (KExpr .anon))) methods s₁ = _ + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind + (TcM.runIntern (simulSubst body₀ consumed.reverse 0)) _ s₁ = _ + unfold EStateM.bind + rw [hsubst] + change EStateM.bind + (ReaderT.run (finishAppResult substituted args consumed.size) methods) _ + s₂ = _ + unfold EStateM.bind + rw [hfinish] + rfl + /-- Exact production step for a successful projection reduction. Both the cheap and full value-WHNF policies are represented by the same explicit callback equation, followed by the actual `tryProjReduce` execution. -/ @@ -3242,6 +6140,90 @@ theorem whnfCoreWithFlagsStep_projection rw [hreduce] rfl +/-- Exact production fallback for a projection whose value callback succeeds +but whose syntax-directed reduction helper returns `none`. The returned +expression is the original projection, not the normalized `wvalue`. -/ +theorem whnfCoreWithFlagsStep_projectionDone + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {id : KId .anon} {field : UInt64} {value wvalue : KExpr .anon} + {info : ExprInfo .anon} {flags : WhnfFlags} + (hwhnf : + (if flags.cheapProj then + (whnfCoreFlagsRec value flags).run methods s + else (whnfRec value).run methods s) = .ok wvalue s₁) + (hreduce : (tryProjReduce id field wvalue).run methods s₁ = + .ok none s₂) : + (whnfCoreWithFlagsStep (.prj id field value info) flags).run methods s = + .ok (.done (.prj id field value info)) s₂ := by + unfold whnfCoreWithFlagsStep + simp only + cases hcheap : flags.cheapProj <;> + simp only [hcheap, Bool.false_eq_true, ↓reduceIte] at hwhnf ⊢ + all_goals + rw [ReaderT.run_bind] + change EStateM.bind _ _ s = _ + unfold EStateM.bind + rw [hwhnf] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjReduce id field wvalue) methods) _ s₁ = _ + unfold EStateM.bind + rw [hreduce] + rfl + +/-- Errors from the projection value callback are propagated with their +post-state before the reduction helper is entered. -/ +theorem whnfCoreWithFlagsStep_projectionWhnfError + {methods : Methods .anon} {s s₁ : TcState .anon} + {id : KId .anon} {field : UInt64} {value : KExpr .anon} + {info : ExprInfo .anon} {flags : WhnfFlags} {err : TcError .anon} + (hwhnf : + (if flags.cheapProj then + (whnfCoreFlagsRec value flags).run methods s + else (whnfRec value).run methods s) = .error err s₁) : + (whnfCoreWithFlagsStep (.prj id field value info) flags).run methods s = + .error err s₁ := by + unfold whnfCoreWithFlagsStep + simp only + cases hcheap : flags.cheapProj <;> + simp only [hcheap, Bool.false_eq_true, ↓reduceIte] at hwhnf ⊢ + all_goals + rw [ReaderT.run_bind] + change EStateM.bind _ _ s = _ + unfold EStateM.bind + rw [hwhnf] + +/-- Errors from `tryProjReduce` retain both the exact error and the helper's +partial post-state. -/ +theorem whnfCoreWithFlagsStep_projectionReduceError + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {id : KId .anon} {field : UInt64} {value wvalue : KExpr .anon} + {info : ExprInfo .anon} {flags : WhnfFlags} {err : TcError .anon} + (hwhnf : + (if flags.cheapProj then + (whnfCoreFlagsRec value flags).run methods s + else (whnfRec value).run methods s) = .ok wvalue s₁) + (hreduce : (tryProjReduce id field wvalue).run methods s₁ = + .error err s₂) : + (whnfCoreWithFlagsStep (.prj id field value info) flags).run methods s = + .error err s₂ := by + unfold whnfCoreWithFlagsStep + simp only + cases hcheap : flags.cheapProj <;> + simp only [hcheap, Bool.false_eq_true, ↓reduceIte] at hwhnf ⊢ + all_goals + rw [ReaderT.run_bind] + change EStateM.bind _ _ s = _ + unfold EStateM.bind + rw [hwhnf] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjReduce id field wvalue) methods) _ s₁ = _ + unfold EStateM.bind + rw [hreduce] + /-- Exact production step for a successful ordinary iota reduction after the recursive head callback returns the same recursor constant. State changes made by that callback remain explicit as `s₁`; semantic closure does @@ -3278,23 +6260,652 @@ theorem whnfCoreWithFlagsStep_iota rw [hiota] rfl -/-- Every structural leaf terminates one named production loop iteration. -/ -theorem whnfCoreWithFlagsStep_leaf {methods : Methods .anon} - {s : TcState .anon} {e : KExpr .anon} (hleaf : WhnfCoreLeaf e) - (flags : WhnfFlags) : - (whnfCoreWithFlagsStep e flags).run methods s = .ok (.done e) s := by - cases hleaf <;> rfl +/-- Exact stuck-application fallback after the recursive head callback +returns the original non-lambda head and the iota helper returns `none`. -/ +theorem whnfCoreWithFlagsStep_appUnchangedDone + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {f arg head : KExpr .anon} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} {flags : WhnfFlags} + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hnonlam : WhnfCoreNonLambda head) + (hhead : methods.whnfCoreFlags head flags s = .ok head s₁) + (hself : (head != head) = false) + (hiota : (tryIotaWithFlags (.app f arg info) flags).run methods s₁ = + .ok none s₂) : + (whnfCoreWithFlagsStep (.app f arg info) flags).run methods s = + .ok (.done (.app f arg info)) s₂ := by + unfold whnfCoreWithFlagsStep + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + rw [hspine] + change EStateM.bind (methods.whnfCoreFlags head flags) _ s = _ + unfold EStateM.bind + rw [hhead] + simp only + cases hnonlam <;> simp only + all_goals + rw [hself] + change EStateM.bind + (ReaderT.run (tryIotaWithFlags (.app f arg info) flags) methods) _ s₁ = _ + unfold EStateM.bind + rw [hiota] + rfl -/-- Generic two-iteration equation for the production bounded driver: one -successful `.next` step followed by a structural leaf. Keeping this seam -branch-agnostic lets beta, both zeta paths, and later projection/iota proofs -share the exact 10,000-fuel argument. -/ -theorem whnfCoreWithFlagsUncached_nextLeaf - {methods : Methods .anon} {s s' : TcState .anon} - {source result : KExpr .anon} {flags : WhnfFlags} - (hstep : (whnfCoreWithFlagsStep source flags).run methods s = - .ok (.next result) s') - (hleaf : WhnfCoreLeaf result) : +/-- A failing recursive head callback is propagated before beta, rebuilding, +or iota dispatch. -/ +theorem whnfCoreWithFlagsStep_appHeadError + {methods : Methods .anon} {s s₁ : TcState .anon} + {f arg head : KExpr .anon} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} {flags : WhnfFlags} + {err : TcError .anon} + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hhead : methods.whnfCoreFlags head flags s = .error err s₁) : + (whnfCoreWithFlagsStep (.app f arg info) flags).run methods s = + .error err s₁ := by + unfold whnfCoreWithFlagsStep + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + rw [hspine] + change EStateM.bind (methods.whnfCoreFlags head flags) _ s = _ + unfold EStateM.bind + rw [hhead] + +/-- On an unchanged non-lambda head, an iota-helper error is propagated with +the helper's partial post-state. -/ +theorem whnfCoreWithFlagsStep_appUnchangedIotaError + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {f arg head : KExpr .anon} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} {flags : WhnfFlags} + {err : TcError .anon} + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hnonlam : WhnfCoreNonLambda head) + (hhead : methods.whnfCoreFlags head flags s = .ok head s₁) + (hself : (head != head) = false) + (hiota : (tryIotaWithFlags (.app f arg info) flags).run methods s₁ = + .error err s₂) : + (whnfCoreWithFlagsStep (.app f arg info) flags).run methods s = + .error err s₂ := by + unfold whnfCoreWithFlagsStep + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + rw [hspine] + change EStateM.bind (methods.whnfCoreFlags head flags) _ s = _ + unfold EStateM.bind + rw [hhead] + simp only + cases hnonlam <;> simp only + all_goals + rw [hself] + change EStateM.bind + (ReaderT.run (tryIotaWithFlags (.app f arg info) flags) methods) _ s₁ = _ + unfold EStateM.bind + rw [hiota] + +/-- A changed non-lambda head is rebuilt with the complete original argument +spine before one successful iota reduction is attempted. -/ +theorem whnfCoreWithFlagsStep_appChangedIota + {methods : Methods .anon} {s s₁ s₂ s₃ : TcState .anon} + {f arg head changed rebuilt result : KExpr .anon} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hnonlam : WhnfCoreNonLambda changed) + (hhead : methods.whnfCoreFlags head flags s = .ok changed s₁) + (hchanged : (changed != head) = true) + (hfinish : (finishAppResult changed args 0).run methods s₁ = + .ok rebuilt s₂) + (hiota : (tryIotaWithFlags rebuilt flags).run methods s₂ = + .ok (some result) s₃) : + (whnfCoreWithFlagsStep (.app f arg info) flags).run methods s = + .ok (.next result) s₃ := by + unfold whnfCoreWithFlagsStep + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + rw [hspine] + change EStateM.bind (methods.whnfCoreFlags head flags) _ s = _ + unfold EStateM.bind + rw [hhead] + simp only + cases hnonlam <;> simp only + all_goals + rw [hchanged] + change EStateM.bind + (ReaderT.run (finishAppResult _ args 0) methods) _ s₁ = _ + unfold EStateM.bind + rw [hfinish] + change EStateM.bind + (ReaderT.run (tryIotaWithFlags rebuilt flags) methods) _ s₂ = _ + unfold EStateM.bind + rw [hiota] + rfl + +/-- If iota misses after changed-head rebuilding, the rebuilt application—not +the original source—is the exact `.done` result. -/ +theorem whnfCoreWithFlagsStep_appChangedDone + {methods : Methods .anon} {s s₁ s₂ s₃ : TcState .anon} + {f arg head changed rebuilt : KExpr .anon} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hnonlam : WhnfCoreNonLambda changed) + (hhead : methods.whnfCoreFlags head flags s = .ok changed s₁) + (hchanged : (changed != head) = true) + (hfinish : (finishAppResult changed args 0).run methods s₁ = + .ok rebuilt s₂) + (hiota : (tryIotaWithFlags rebuilt flags).run methods s₂ = + .ok none s₃) : + (whnfCoreWithFlagsStep (.app f arg info) flags).run methods s = + .ok (.done rebuilt) s₃ := by + unfold whnfCoreWithFlagsStep + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + rw [hspine] + change EStateM.bind (methods.whnfCoreFlags head flags) _ s = _ + unfold EStateM.bind + rw [hhead] + simp only + cases hnonlam <;> simp only + all_goals + rw [hchanged] + change EStateM.bind + (ReaderT.run (finishAppResult _ args 0) methods) _ s₁ = _ + unfold EStateM.bind + rw [hfinish] + change EStateM.bind + (ReaderT.run (tryIotaWithFlags rebuilt flags) methods) _ s₂ = _ + unfold EStateM.bind + rw [hiota] + rfl + +/-- Iota errors after changed-head rebuilding retain the helper's exact +partial post-state. The preceding intern-only rebuild has already completed. -/ +theorem whnfCoreWithFlagsStep_appChangedIotaError + {methods : Methods .anon} {s s₁ s₂ s₃ : TcState .anon} + {f arg head changed rebuilt : KExpr .anon} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} {err : TcError .anon} + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hnonlam : WhnfCoreNonLambda changed) + (hhead : methods.whnfCoreFlags head flags s = .ok changed s₁) + (hchanged : (changed != head) = true) + (hfinish : (finishAppResult changed args 0).run methods s₁ = + .ok rebuilt s₂) + (hiota : (tryIotaWithFlags rebuilt flags).run methods s₂ = + .error err s₃) : + (whnfCoreWithFlagsStep (.app f arg info) flags).run methods s = + .error err s₃ := by + unfold whnfCoreWithFlagsStep + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + rw [hspine] + change EStateM.bind (methods.whnfCoreFlags head flags) _ s = _ + unfold EStateM.bind + rw [hhead] + simp only + cases hnonlam <;> simp only + all_goals + rw [hchanged] + change EStateM.bind + (ReaderT.run (finishAppResult _ args 0) methods) _ s₁ = _ + unfold EStateM.bind + rw [hfinish] + change EStateM.bind + (ReaderT.run (tryIotaWithFlags rebuilt flags) methods) _ s₂ = _ + unfold EStateM.bind + rw [hiota] + +/-- Every structural leaf terminates one named production loop iteration. -/ +theorem whnfCoreWithFlagsStep_leaf {methods : Methods .anon} + {s : TcState .anon} {e : KExpr .anon} (hleaf : WhnfCoreLeaf e) + (flags : WhnfFlags) : + (whnfCoreWithFlagsStep e flags).run methods s = .ok (.done e) s := by + cases hleaf <;> rfl + +/-- Structural-leaf base branch: every immediately WHNF form satisfies the +repaired one-step contract. The proof consumes both finite-support membership +and an actual source translation; neither follows from the state invariant. -/ +theorem whnfCoreWithFlagsStep_leaf_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {e : KExpr .anon} + {flags : WhnfFlags} {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world uvars) (hleaf : WhnfCoreLeaf e) : + forall s, + WhnfStep.Source trProj world support uvars Delta id e -> + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreWithFlagsStep e flags) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta id + e action) stepError := by + intro s hsource methods hmethods + intro hI + rw [whnfCoreWithFlagsStep_leaf hleaf] + obtain ⟨hsupport, sourceV, htr⟩ := hsource + exact ⟨hI, hsupport, + WhnfMeaning.refl htr (theory.exprWF hI.2.1 htr)⟩ + +/-- A non-let legacy variable supplies a complete `.done` payload. The + lookup equation cannot hide an intern-table mutation: an `.ok none` + outcome is proved to return the original state. -/ +theorem whnfCoreWithFlagsStep_varDone_acceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s s' : TcState .anon} {idx : UInt64} + {name : Mode.anon.F Name} {md : ExprInfo .anon} {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hsource : WhnfStep.Source trProj world support uvars Delta id + (.var idx name md)) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hlookup : TcM.lookupLetVal idx s = .ok none s') : + (whnfCoreWithFlagsStep (.var idx name md) flags).run methods s = + .ok (.done (.var idx name md)) s' ∧ + WhnfStateInv layer semantics trProj world support uvars Delta s' ∧ + WhnfStep.Meaning trProj world support uvars Delta id + (.var idx name md) (.done (.var idx name md)) := by + have hsame := TcM.lookupLetVal_none_state hlookup + subst s' + obtain ⟨hsupport, sourceV, htr⟩ := hsource + exact ⟨whnfCoreWithFlagsStep_varDone hlookup, hI, hsupport, + WhnfMeaning.refl htr (theory.exprWF hI.2.1 htr)⟩ + +/-- An absent or regular-binder fvar supplies the analogous state-pure + `.done` payload. Excluding only `.ldecl` is deliberate: `.cdecl` is the + ordinary open-binder case and must remain stuck. -/ +theorem whnfCoreWithFlagsStep_fvarDone_acceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s : TcState .anon} {fv : FVarId} + {name : Mode.anon.F Name} {md : ExprInfo .anon} {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hsource : WhnfStep.Source trProj world support uvars Delta id + (.fvar fv name md)) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hnot : ∀ declName ty val, + s.lctx.find? fv ≠ some (.ldecl declName ty val)) : + (whnfCoreWithFlagsStep (.fvar fv name md) flags).run methods s = + .ok (.done (.fvar fv name md)) s ∧ + WhnfStateInv layer semantics trProj world support uvars Delta s ∧ + WhnfStep.Meaning trProj world support uvars Delta id + (.fvar fv name md) (.done (.fvar fv name md)) := by + obtain ⟨hsupport, sourceV, htr⟩ := hsource + exact ⟨whnfCoreWithFlagsStep_fvarDone hnot, hI, hsupport, + WhnfMeaning.refl htr (theory.exprWF hI.2.1 htr)⟩ + +/-- Successful explicit-let substitution supplies the complete local payload +consumed by `WhnfStep.WF`. Exact execution, post-state invariant, and finite +result support come from one indexed substitution request; source +translatability plus that request's constructedness and exact UInt64 bounds +construct the Theory meaning through `WhnfMeaning.letE`. -/ +theorem whnfCoreWithFlagsStep_letE_acceptance + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Δ : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {name : Mode.anon.F Name} {ty val body : KExpr .anon} + {nondep : Bool} {info : ExprInfo .anon} {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hmem : WalkerRequest.subst body val 0 ∈ requests) + (hsource : WhnfStep.Source trProj world support uvars Δ id + (.letE name ty val body nondep info)) + (hI : WhnfStateInv layer semantics trProj world support uvars Δ s) : + ∃ s', + (whnfCoreWithFlagsStep (.letE name ty val body nondep info) flags).run + methods s = .ok (.next (KExpr.substSpec body val 0)) s' ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s' ∧ + WhnfStep.Meaning trProj world support uvars Δ id + (.letE name ty val body nondep info) + (.next (KExpr.substSpec body val 0)) := by + obtain ⟨s', hwalk, hI', _⟩ := hrun.subst_whnf_eval hmem hI + obtain ⟨_, hvalCon, _, _, hbound⟩ := hrun.requestBounds hmem + obtain ⟨_, bodyV, htr⟩ := hsource + have hsupport : support (KExpr.substSpec body val 0) := + hrun.coverage.subst hmem _ (KExpr.SubstReach.spec val body 0) + have hmeaning := WhnfMeaning.letE theory hI.2.1 htr hvalCon (by + simpa using hbound) + exact ⟨s', whnfCoreWithFlagsStep_letE hwalk, hI', hsupport, hmeaning⟩ + +/-- Successful direct beta supplies the exact one-step payload consumed by +`WhnfStep.WF`: production execution and invariant preservation come from the +verified simultaneous-substitution walker, while Theory beta meaning remains +an explicit semantic premise. The result-support fact is recovered from the +same finite request that justifies the walker. -/ +theorem whnfCoreWithFlagsStep_betaOne_acceptance + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {nm : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body arg : KExpr .anon} {lamMd appMd : ExprInfo .anon} + {flags : WhnfFlags} + (hmem : WalkerRequest.simulSubst body #[arg] 0 ∈ requests) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hhead : methods.whnfCoreFlags (.lam nm bi ty body lamMd) flags s = + .ok (.lam nm bi ty body lamMd) s) + (hmeaning : WhnfMeaning trProj world uvars Delta + (.app (.lam nm bi ty body lamMd) arg appMd) + (KExpr.simulSubstSpec body #[arg] 0)) : + ∃ s', + (whnfCoreWithFlagsStep + (.app (.lam nm bi ty body lamMd) arg appMd) flags).run methods s = + .ok (.next (KExpr.simulSubstSpec body #[arg] 0)) s' ∧ + WhnfStateInv layer semantics trProj world support uvars Delta s' ∧ + WhnfStep.Meaning trProj world support uvars Delta id + (.app (.lam nm bi ty body lamMd) arg appMd) + (.next (KExpr.simulSubstSpec body #[arg] 0)) := by + obtain ⟨s', hwalk, hI', _⟩ := + hrun.simulSubst_whnf_eval hmem hI + have hsupport : support (KExpr.simulSubstSpec body #[arg] 0) := + hrun.coverage.simulSubst hmem _ + (KExpr.SimulSubstReach.spec #[arg] body 0) + exact ⟨s', whnfCoreWithFlagsStep_betaOne hhead hwalk, hI', + hsupport, hmeaning⟩ + +/-- General multi-beta acceptance. The recursive head callback's exact +syntax and post-invariant remain visible, while the substitution request and +application certificate discharge all subsequent execution, support, +collision-freedom, argument-order, and intern-frame obligations. Semantic +meaning is explicit until the Theory-side multi-beta congruence lemma is +connected to `consumeBetaLams`. -/ +theorem whnfCoreWithFlagsStep_betaMany_acceptance + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Δ : KVLCtx} {methods : Methods .anon} {s s₁ : TcState .anon} + {f arg head : KExpr .anon} {appInfo : ExprInfo .anon} + {args : Array (KExpr .anon)} + {nm : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body body₀ : KExpr .anon} {lamInfo : ExprInfo .anon} + {consumed : Array (KExpr .anon)} {result : KExpr .anon} + {flags : WhnfFlags} + (hmem : WalkerRequest.simulSubst body₀ consumed.reverse 0 ∈ requests) + (hfinish : FinishAppRequests requests + (args.extract consumed.size args.size).toList + (KExpr.simulSubstSpec body₀ consumed.reverse 0) result) + (hI₁ : WhnfStateInv layer semantics trProj world support uvars Δ s₁) + (hspine : (.app f arg appInfo : KExpr .anon).collectSpine = (head, args)) + (hhead : methods.whnfCoreFlags head flags s = + .ok (.lam nm bi ty body lamInfo) s₁) + (hconsume : consumeBetaLams (.lam nm bi ty body lamInfo) args = + (body₀, consumed)) + (hnonempty : (!consumed.isEmpty) = true) + (hmeaning : WhnfMeaning trProj world uvars Δ (.app f arg appInfo) result) : + ∃ s₃, + (whnfCoreWithFlagsStep (.app f arg appInfo) flags).run methods s = + .ok (.next result) s₃ ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s₃ ∧ + WhnfStep.Meaning trProj world support uvars Δ id + (.app f arg appInfo) (.next result) := by + obtain ⟨s₂, hsubst, hI₂, _⟩ := + hrun.simulSubst_whnf_eval hmem hI₁ + obtain ⟨s₃, hfinishRun, hI₃, _⟩ := hfinish.eval hrun hI₂ + have hsubSupport : + support (KExpr.simulSubstSpec body₀ consumed.reverse 0) := + hrun.coverage.simulSubst hmem _ + (KExpr.SimulSubstReach.spec consumed.reverse body₀ 0) + have hresultSupport : support result := + hfinish.support hrun hsubSupport + exact ⟨s₃, + whnfCoreWithFlagsStep_betaMany hspine hhead hconsume hnonempty + hsubst hfinishRun, + hI₃, hresultSupport, hmeaning⟩ + +/-- Successful projection supplies one complete local step payload. Source +translation is taken from `WhnfStep.Source`; the inductive-reduction oracle +justifies the syntax-directed helper result, and finite result support stays +an explicit construction obligation. -/ +theorem whnfCoreWithFlagsStep_projection_acceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (oracle : InductiveReductionOracle layer semantics trProj world support) + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s s1 s2 : TcState .anon} {id : KId .anon} {field : UInt64} + {value wvalue result : KExpr .anon} {info : ExprInfo .anon} + {flags : WhnfFlags} + (hmethods : Methods.WFAt layer semantics trProj world support uvars methods) + (hsource : WhnfStep.Source trProj world support uvars Delta (fun e => e) + (.prj id field value info)) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hwhnf : + (if flags.cheapProj then + (whnfCoreFlagsRec value flags).run methods s + else (whnfRec value).run methods s) = .ok wvalue s1) + (hreduce : (tryProjReduce id field wvalue).run methods s1 = + .ok (some result) s2) + (hresult : support result) : + (whnfCoreWithFlagsStep (.prj id field value info) flags).run methods s = + .ok (.next result) s2 ∧ + WhnfStateInv layer semantics trProj world support uvars Delta s2 ∧ + WhnfStep.Meaning trProj world support uvars Delta (fun e => e) + (.prj id field value info) (.next result) := by + obtain ⟨_, sourceV, htr⟩ := hsource + have hsemantic := oracle.projection hmethods htr hI hwhnf hreduce + exact ⟨whnfCoreWithFlagsStep_projection hwhnf hreduce, + hsemantic.1, hresult, hsemantic.2⟩ + +/-- Successful ordinary iota supplies the analogous local step payload. As +with projection, helper success alone is insufficient: the translated source +and registered-rule oracle remain load-bearing premises. -/ +theorem whnfCoreWithFlagsStep_iota_acceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (oracle : InductiveReductionOracle layer semantics trProj world support) + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s s1 s2 : TcState .anon} {recId : KId .anon} + {us : Array (KUniv .anon)} {headInfo appInfo : ExprInfo .anon} + {f arg result : KExpr .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} + (hmethods : Methods.WFAt layer semantics trProj world support uvars methods) + (hsource : WhnfStep.Source trProj world support uvars Delta id + (.app f arg appInfo)) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hspine : (.app f arg appInfo : KExpr .anon).collectSpine = + (.const recId us headInfo, args)) + (hhead : methods.whnfCoreFlags (.const recId us headInfo) flags s = + .ok (.const recId us headInfo) s1) + (hself : ((.const recId us headInfo : KExpr .anon) != + .const recId us headInfo) = false) + (hiota : (tryIotaWithFlags (.app f arg appInfo) flags).run methods s1 = + .ok (some result) s2) + (hresult : support result) : + (whnfCoreWithFlagsStep (.app f arg appInfo) flags).run methods s = + .ok (.next result) s2 ∧ + WhnfStateInv layer semantics trProj world support uvars Delta s2 ∧ + WhnfStep.Meaning trProj world support uvars Delta id + (.app f arg appInfo) (.next result) := by + obtain ⟨_, sourceV, htr⟩ := hsource + have hsemantic := + oracle.iota hmethods htr hI hspine hhead hself hiota + exact ⟨whnfCoreWithFlagsStep_iota hspine hhead hself hiota, + hsemantic.1, hresult, hsemantic.2⟩ + +/-- A projection miss returns the original source. The explicit post-state +invariant is the still-open helper-frame obligation; semantic meaning itself +is reflexive and needs no inductive reduction oracle. -/ +theorem whnfCoreWithFlagsStep_projectionDone_acceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s s₁ s₂ : TcState .anon} {id : KId .anon} {field : UInt64} + {value wvalue : KExpr .anon} {info : ExprInfo .anon} + {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hsource : WhnfStep.Source trProj world support uvars Delta (fun e => e) + (.prj id field value info)) + (hpost : WhnfStateInv layer semantics trProj world support uvars Delta s₂) + (hwhnf : + (if flags.cheapProj then + (whnfCoreFlagsRec value flags).run methods s + else (whnfRec value).run methods s) = .ok wvalue s₁) + (hreduce : (tryProjReduce id field wvalue).run methods s₁ = + .ok none s₂) : + (whnfCoreWithFlagsStep (.prj id field value info) flags).run methods s = + .ok (.done (.prj id field value info)) s₂ ∧ + WhnfStateInv layer semantics trProj world support uvars Delta s₂ ∧ + WhnfStep.Meaning trProj world support uvars Delta (fun e => e) + (.prj id field value info) (.done (.prj id field value info)) := by + obtain ⟨hsupport, sourceV, htr⟩ := hsource + exact ⟨whnfCoreWithFlagsStep_projectionDone hwhnf hreduce, hpost, + hsupport, WhnfMeaning.refl htr (theory.exprWF hpost.2.1 htr)⟩ + +/-- The unchanged-head/iota-miss branch has the same reflexive semantic +shape. Its post-state invariant remains explicit until the iota helper frame +is proved for every success and error path. -/ +theorem whnfCoreWithFlagsStep_appUnchangedDone_acceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s s₁ s₂ : TcState .anon} {f arg head : KExpr .anon} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hsource : WhnfStep.Source trProj world support uvars Delta id + (.app f arg info)) + (hpost : WhnfStateInv layer semantics trProj world support uvars Delta s₂) + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hnonlam : WhnfCoreNonLambda head) + (hhead : methods.whnfCoreFlags head flags s = .ok head s₁) + (hself : (head != head) = false) + (hiota : (tryIotaWithFlags (.app f arg info) flags).run methods s₁ = + .ok none s₂) : + (whnfCoreWithFlagsStep (.app f arg info) flags).run methods s = + .ok (.done (.app f arg info)) s₂ ∧ + WhnfStateInv layer semantics trProj world support uvars Delta s₂ ∧ + WhnfStep.Meaning trProj world support uvars Delta id + (.app f arg info) (.done (.app f arg info)) := by + obtain ⟨hsupport, sourceV, htr⟩ := hsource + exact ⟨whnfCoreWithFlagsStep_appUnchangedDone hspine hnonlam hhead hself hiota, + hpost, hsupport, WhnfMeaning.refl htr (theory.exprWF hpost.2.1 htr)⟩ + +/-- Changed-head/iota-miss acceptance. The finite rebuild certificate is +checked against the exact helper state, proving its intern-only execution and +result support. Head-reduction meaning and the iota helper's final frame are +still explicit semantic/post-state premises at this local boundary. -/ +theorem whnfCoreWithFlagsStep_appChangedDone_acceptance + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Δ : KVLCtx} {methods : Methods .anon} + {s s₁ s₂ s₃ : TcState .anon} + {f arg head changed rebuilt : KExpr .anon} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} + (hfinish : FinishAppRequests requests + (args.extract 0 args.size).toList changed rebuilt) + (hchangedSupport : support changed) + (hI₁ : WhnfStateInv layer semantics trProj world support uvars Δ s₁) + (hpost : WhnfStateInv layer semantics trProj world support uvars Δ s₃) + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hnonlam : WhnfCoreNonLambda changed) + (hhead : methods.whnfCoreFlags head flags s = .ok changed s₁) + (hchanged : (changed != head) = true) + (hfinishRun : (finishAppResult changed args 0).run methods s₁ = + .ok rebuilt s₂) + (hiota : (tryIotaWithFlags rebuilt flags).run methods s₂ = .ok none s₃) + (hmeaning : WhnfMeaning trProj world uvars Δ + (.app f arg info) rebuilt) : + (whnfCoreWithFlagsStep (.app f arg info) flags).run methods s = + .ok (.done rebuilt) s₃ ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s₃ ∧ + WhnfStep.Meaning trProj world support uvars Δ id + (.app f arg info) (.done rebuilt) := by + obtain ⟨s₂', hfinishRun', _, _⟩ := hfinish.eval hrun hI₁ + rw [hfinishRun] at hfinishRun' + cases hfinishRun' + have hrebuiltSupport : support rebuilt := + hfinish.support hrun hchangedSupport + exact ⟨whnfCoreWithFlagsStep_appChangedDone hspine hnonlam hhead hchanged + hfinishRun hiota, + hpost, hrebuiltSupport, hmeaning⟩ + +/-- Changed-head/iota-hit acceptance. Rebuilding is fully certified; support +and semantic meaning of the syntax-directed iota result stay explicit until +the inductive-reduction oracle is generalized from unchanged to rebuilt +sources. -/ +theorem whnfCoreWithFlagsStep_appChangedIota_acceptance + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Δ : KVLCtx} {methods : Methods .anon} + {s s₁ s₂ s₃ : TcState .anon} + {f arg head changed rebuilt result : KExpr .anon} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} + (hfinish : FinishAppRequests requests + (args.extract 0 args.size).toList changed rebuilt) + (hI₁ : WhnfStateInv layer semantics trProj world support uvars Δ s₁) + (hpost : WhnfStateInv layer semantics trProj world support uvars Δ s₃) + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hnonlam : WhnfCoreNonLambda changed) + (hhead : methods.whnfCoreFlags head flags s = .ok changed s₁) + (hchanged : (changed != head) = true) + (hfinishRun : (finishAppResult changed args 0).run methods s₁ = + .ok rebuilt s₂) + (hiota : (tryIotaWithFlags rebuilt flags).run methods s₂ = + .ok (some result) s₃) + (hresultSupport : support result) + (hmeaning : WhnfMeaning trProj world uvars Δ + (.app f arg info) result) : + (whnfCoreWithFlagsStep (.app f arg info) flags).run methods s = + .ok (.next result) s₃ ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s₃ ∧ + WhnfStep.Meaning trProj world support uvars Δ id + (.app f arg info) (.next result) := by + obtain ⟨s₂', hfinishRun', _, _⟩ := hfinish.eval hrun hI₁ + rw [hfinishRun] at hfinishRun' + cases hfinishRun' + exact ⟨whnfCoreWithFlagsStep_appChangedIota hspine hnonlam hhead hchanged + hfinishRun hiota, + hpost, hresultSupport, hmeaning⟩ + +/-- The changed-head error path retains the exact iota partial state and its +invariant; certified rebuilding has completed successfully beforehand. -/ +theorem whnfCoreWithFlagsStep_appChangedIotaError_acceptance + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Δ : KVLCtx} {methods : Methods .anon} + {s s₁ s₂ s₃ : TcState .anon} + {f arg head changed rebuilt : KExpr .anon} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} {err : TcError .anon} + (hfinish : FinishAppRequests requests + (args.extract 0 args.size).toList changed rebuilt) + (hI₁ : WhnfStateInv layer semantics trProj world support uvars Δ s₁) + (hpost : WhnfStateInv layer semantics trProj world support uvars Δ s₃) + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hnonlam : WhnfCoreNonLambda changed) + (hhead : methods.whnfCoreFlags head flags s = .ok changed s₁) + (hchanged : (changed != head) = true) + (hfinishRun : (finishAppResult changed args 0).run methods s₁ = + .ok rebuilt s₂) + (hiota : (tryIotaWithFlags rebuilt flags).run methods s₂ = + .error err s₃) : + (whnfCoreWithFlagsStep (.app f arg info) flags).run methods s = + .error err s₃ ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s₃ := by + obtain ⟨s₂', hfinishRun', _, _⟩ := hfinish.eval hrun hI₁ + rw [hfinishRun] at hfinishRun' + cases hfinishRun' + exact ⟨whnfCoreWithFlagsStep_appChangedIotaError hspine hnonlam hhead + hchanged hfinishRun hiota, hpost⟩ + +/-- Generic two-iteration equation for the production bounded driver: one +successful `.next` step followed by a structural leaf. Keeping this seam +branch-agnostic lets beta, both zeta paths, and later projection/iota proofs +share the exact 10,000-fuel argument. -/ +theorem whnfCoreWithFlagsUncached_nextLeaf + {methods : Methods .anon} {s s' : TcState .anon} + {source result : KExpr .anon} {flags : WhnfFlags} + (hstep : (whnfCoreWithFlagsStep source flags).run methods s = + .ok (.next result) s') + (hleaf : WhnfCoreLeaf result) : (whnfCoreWithFlagsUncached source flags).run methods s = .ok result s' := by unfold whnfCoreWithFlagsUncached @@ -3355,7 +6966,7 @@ theorem whnfCoreWithFlagsUncached_iota whnfCoreWithFlagsUncached_nextLeaf (whnfCoreWithFlagsStep_iota hspine hhead hself hiota) hleaf -/-- Conditional K1e projection package. The production execution is proved +/-- Conditional projection package. The production execution is proved definitionally above; semantic validity and full invariant preservation are obtained only through the explicit inductive-reduction boundary, which also requires a translation of the original projection. -/ @@ -3367,7 +6978,7 @@ theorem whnfCoreWithFlagsUncached_projection_acceptance {s s₁ s₂ : TcState .anon} {id : KId .anon} {field : UInt64} {value wvalue result : KExpr .anon} {info : ExprInfo .anon} {flags : WhnfFlags} {sourceV : VExpr} - (hmethods : Methods.WF layer semantics trProj world support methods) + (hmethods : Methods.WFAt layer semantics trProj world support uvars methods) (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ (.prj id field value info) sourceV) (hI : WhnfStateInv layer semantics trProj world support uvars Δ s) @@ -3388,7 +6999,7 @@ theorem whnfCoreWithFlagsUncached_projection_acceptance exact ⟨whnfCoreWithFlagsUncached_projection hwhnf hreduce hleaf, hsemantic.1, hsemantic.2⟩ -/-- Conditional K1e iota package. The source translation premise is +/-- Conditional iota package. The source translation premise is load-bearing: an untrusted catalog recursor can drive the production helper without denoting a Theory term, as the adversarial fixture demonstrates. -/ theorem whnfCoreWithFlagsUncached_iota_acceptance @@ -3400,7 +7011,7 @@ theorem whnfCoreWithFlagsUncached_iota_acceptance {us : Array (KUniv .anon)} {headInfo appInfo : ExprInfo .anon} {f arg result : KExpr .anon} {args : Array (KExpr .anon)} {flags : WhnfFlags} {sourceV : VExpr} - (hmethods : Methods.WF layer semantics trProj world support methods) + (hmethods : Methods.WFAt layer semantics trProj world support uvars methods) (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ (.app f arg appInfo) sourceV) (hI : WhnfStateInv layer semantics trProj world support uvars Δ s) @@ -3450,7 +7061,7 @@ theorem whnfCoreWithFlagsUncached_fvarZeta whnfCoreWithFlagsUncached_nextLeaf (whnfCoreWithFlagsStep_fvarZeta hfind) hleaf -/-- K1d legacy-zeta package. The execution-indexed lift walker supplies the +/-- Legacy-zeta package. The execution-indexed lift walker supplies the exact production result and intern-only frame; the reconciled context supplies the same inlined Theory value, so operational execution, invariant preservation, and semantic meaning are established together. -/ @@ -3491,7 +7102,7 @@ theorem whnfCoreWithFlagsUncached_varZeta_acceptance hI', hframe, WhnfMeaning.zetaVar hI.2.1 htp hidx hsz hty hov hbig⟩ -/-- K1d fvar-zeta package. Unlike the legacy branch this execution is +/-- Free-variable zeta package. Unlike the legacy branch this execution is state-pure. `hclosed` is intentionally visible: without it, a mixed context may have newer de Bruijn frames and production's unchanged stored value is not justified by `CtxRecon`. -/ @@ -3665,52 +7276,8119 @@ structure NativeOracle (semantics : CacheSemantics) (trProj : RawProjRel) .ok (some result) s' → WhnfMeaning trProj world uvars Δ (.prj id field value info) result -namespace RecM +/-! ## No-delta optional-reducer contract -/ -/-- With `noAccel` pinned, the general native helper returns `none` without -changing state and without consulting the method table. -/ -theorem tryReduceNative_noAccel {methods : Methods .anon} - {s : TcState .anon} (h : s.noAccel = true) (e : KExpr .anon) : - (tryReduceNative e).run methods s = .ok none s := by - unfold tryReduceNative - rw [ReaderT.run_bind] - change (EStateM.bind EStateM.get _) s = _ - simp [EStateM.bind, EStateM.get, h] - rfl +namespace OptionalReduction -/-- The BitVec acceleration gate is absent from the no-acceleration layer. -/ -theorem tryReduceBitvec_noAccel {methods : Methods .anon} - {s : TcState .anon} (h : s.noAccel = true) (e : KExpr .anon) : - (tryReduceBitvec e).run methods s = .ok none s := by - unfold tryReduceBitvec - rw [ReaderT.run_bind] - change (EStateM.bind EStateM.get _) s = _ - simp [EStateM.bind, EStateM.get, h] - rfl +/-- Fixed-universe Hoare boundary for one optional reducer. This is the +honest contract for reducers whose cache semantics is indexed by the active +run's universe count, notably delta unfolding. -/ +def WFAt (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) + (reduce : KExpr .anon → RecM .anon (Option (KExpr .anon))) : Prop := + ∀ {Δ source sourceV s}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Δ source sourceV → + RecM.WF layer semantics trProj world support uvars Δ s (reduce source) + (fun result _ => match result with + | none => True + | some reduced => + support reduced ∧ + WhnfMeaning trProj world uvars Δ source reduced) + +/-- Uniform Hoare boundary for one optional no-delta reducer. A miss carries +no semantic claim but still preserves the complete state invariant; a hit +must additionally preserve finite support and justify the concrete reduction +in the fixed Theory context. Errors preserve the invariant through +`RecM.WF`'s ordinary error arm. -/ +def WF (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (reduce : KExpr .anon → RecM .anon (Option (KExpr .anon))) : Prop := + ∀ {uvars Δ source sourceV s}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Δ source sourceV → + RecM.WF layer semantics trProj world support uvars Δ s (reduce source) + (fun result _ => match result with + | none => True + | some reduced => + support reduced ∧ + WhnfMeaning trProj world uvars Δ source reduced) + +/-- Specialize a universe-uniform optional-reducer proof to one active +universe count. -/ +theorem WF.atUvars + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {reduce : KExpr .anon → RecM .anon (Option (KExpr .anon))} + (h : WF layer semantics trProj world support reduce) (uvars : Nat) : + WFAt layer semantics trProj world support uvars reduce := by + intro Δ source sourceV s hsource htr + exact h hsource htr + +end OptionalReduction + +/-- The five reducers that remain active when acceleration is disabled. +Keeping this boundary separate is adversarially important: `.noAccel` proves +that native and BitVec helpers miss, but it says nothing about the trusted +primitive-address interpretation, finite support for generated terms, or the +semantic correctness of projection/Nat/String/quotient hits. -/ +structure NoDeltaBaseOracle (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (flags : WhnfFlags) (natSuccMode : NatSuccMode) : Prop where + projApp : OptionalReduction.WF .noAccel semantics trProj world support + (fun source => RecM.tryProjAppReduceFinished source flags) + nat : OptionalReduction.WF .noAccel semantics trProj world support + (fun source => RecM.tryReduceNatWithSuccMode source natSuccMode) + string : OptionalReduction.WF .noAccel semantics trProj world support + RecM.tryReduceString + projectionDef : OptionalReduction.WF .noAccel semantics trProj world support + RecM.tryReduceProjectionDefinition + quot : OptionalReduction.WF .noAccel semantics trProj world support + RecM.tryQuotReduce + +/-! ## Production primitive/world/support binding -/ + +/-- One primitive-table entry denotes an already trusted Theory constant at +the expected Lean name. The trusted bit is essential: a matching `nameOf` +entry by itself is representation data, not semantic authority. -/ +def PrimitiveIdAgrees (world : VerifyWorld) (id : KId .anon) + (name : Lean.Name) : Prop := + world.trusted id ∧ world.nameOf id.addr = some name + +namespace PrimitiveIdAgrees + +/-- A bound primitive id is present in the Theory environment once the +world's trusted-catalog log is available. -/ +theorem contains {trProj : RawProjRel} {world : VerifyWorld} + {id : KId .anon} {name : Lean.Name} + (hcatalog : TrustedCatalogRel trProj world) + (h : PrimitiveIdAgrees world id name) : + world.venv.contains name := by + obtain ⟨_, actualName, ci, _, hname, hlookup⟩ := + hcatalog.lookup h.1 + rw [h.2] at hname + cases hname + exact ⟨ci, hlookup⟩ + +/-- Two primitive identifiers assigned distinct trusted names cannot share an +address. This uses only functionality of the fixed `nameOf` map; it does not +appeal to native evaluation of the concrete Blake3 hashes. -/ +theorem addr_ne {world : VerifyWorld} + {id₁ id₂ : KId .anon} {name₁ name₂ : Lean.Name} + (h₁ : PrimitiveIdAgrees world id₁ name₁) + (h₂ : PrimitiveIdAgrees world id₂ name₂) + (hne : name₁ ≠ name₂) : + id₁.addr ≠ id₂.addr := by + intro haddr + apply hne + apply Option.some.inj + calc + some name₁ = world.nameOf id₁.addr := h₁.2.symm + _ = world.nameOf id₂.addr := congrArg world.nameOf haddr + _ = some name₂ := h₂.2 + +/-- Primitive-name agreement is stable under trusted-world extension because +`VerifyWorld.LE` fixes `nameOf` and only grows the trusted set. -/ +theorem mono {before after : VerifyWorld} {id : KId .anon} + {name : Lean.Name} (hle : before ≤ after) + (h : PrimitiveIdAgrees before id name) : + PrimitiveIdAgrees after id name := by + exact ⟨hle.trusted h.1, by simpa only [← hle.nameOf] using h.2⟩ + +end PrimitiveIdAgrees + +/-- Exact address-to-name agreement needed by the active no-delta primitive +reducers. Projection-app and projection-wrapper rewriting are absent here: +they obtain their authority from translated projection/declaration facts, +not from `Primitives`. The list mirrors every direct table read in the Nat, +String, and quotient helpers, including Nat's linear-recognizer read. -/ +structure NoDeltaPrimitiveTableAgrees (world : VerifyWorld) + (prims : Primitives .anon) : Prop where + nat : PrimitiveIdAgrees world prims.nat ``Nat + natZero : PrimitiveIdAgrees world prims.natZero ``Nat.zero + natSucc : PrimitiveIdAgrees world prims.natSucc ``Nat.succ + natAdd : PrimitiveIdAgrees world prims.natAdd ``Nat.add + natSub : PrimitiveIdAgrees world prims.natSub ``Nat.sub + natMul : PrimitiveIdAgrees world prims.natMul ``Nat.mul + natPow : PrimitiveIdAgrees world prims.natPow ``Nat.pow + natGcd : PrimitiveIdAgrees world prims.natGcd ``Nat.gcd + natMod : PrimitiveIdAgrees world prims.natMod ``Nat.mod + natDiv : PrimitiveIdAgrees world prims.natDiv ``Nat.div + natBeq : PrimitiveIdAgrees world prims.natBeq ``Nat.beq + natBle : PrimitiveIdAgrees world prims.natBle ``Nat.ble + natLand : PrimitiveIdAgrees world prims.natLand ``Nat.land + natLor : PrimitiveIdAgrees world prims.natLor ``Nat.lor + natXor : PrimitiveIdAgrees world prims.natXor ``Nat.xor + natShiftLeft : + PrimitiveIdAgrees world prims.natShiftLeft ``Nat.shiftLeft + natShiftRight : + PrimitiveIdAgrees world prims.natShiftRight ``Nat.shiftRight + natRec : PrimitiveIdAgrees world prims.natRec ``Nat.rec + boolType : PrimitiveIdAgrees world prims.boolType ``Bool + boolTrue : PrimitiveIdAgrees world prims.boolTrue ``Bool.true + boolFalse : PrimitiveIdAgrees world prims.boolFalse ``Bool.false + stringBack : PrimitiveIdAgrees world prims.stringBack ``String.back + stringLegacyBack : + PrimitiveIdAgrees world prims.stringLegacyBack ``String.Legacy.back + stringUtf8ByteSize : + PrimitiveIdAgrees world prims.stringUtf8ByteSize ``String.utf8ByteSize + stringToByteArray : + PrimitiveIdAgrees world prims.stringToByteArray ``String.toByteArray + byteArrayEmpty : + PrimitiveIdAgrees world prims.byteArrayEmpty ``ByteArray.empty + charOfNat : PrimitiveIdAgrees world prims.charOfNat ``Char.ofNat + quotCtor : PrimitiveIdAgrees world prims.quotCtor ``Quot.mk + quotLift : PrimitiveIdAgrees world prims.quotLift ``Quot.lift + quotInd : PrimitiveIdAgrees world prims.quotInd ``Quot.ind + +namespace NoDeltaPrimitiveTableAgrees + +theorem mono {before after : VerifyWorld} {prims : Primitives .anon} + (hle : before ≤ after) + (h : NoDeltaPrimitiveTableAgrees before prims) : + NoDeltaPrimitiveTableAgrees after prims where + nat := h.nat.mono hle + natZero := h.natZero.mono hle + natSucc := h.natSucc.mono hle + natAdd := h.natAdd.mono hle + natSub := h.natSub.mono hle + natMul := h.natMul.mono hle + natPow := h.natPow.mono hle + natGcd := h.natGcd.mono hle + natMod := h.natMod.mono hle + natDiv := h.natDiv.mono hle + natBeq := h.natBeq.mono hle + natBle := h.natBle.mono hle + natLand := h.natLand.mono hle + natLor := h.natLor.mono hle + natXor := h.natXor.mono hle + natShiftLeft := h.natShiftLeft.mono hle + natShiftRight := h.natShiftRight.mono hle + natRec := h.natRec.mono hle + boolType := h.boolType.mono hle + boolTrue := h.boolTrue.mono hle + boolFalse := h.boolFalse.mono hle + stringBack := h.stringBack.mono hle + stringLegacyBack := h.stringLegacyBack.mono hle + stringUtf8ByteSize := h.stringUtf8ByteSize.mono hle + stringToByteArray := h.stringToByteArray.mono hle + byteArrayEmpty := h.byteArrayEmpty.mono hle + charOfNat := h.charOfNat.mono hle + quotCtor := h.quotCtor.mono hle + quotLift := h.quotLift.mono hle + quotInd := h.quotInd.mono hle + +end NoDeltaPrimitiveTableAgrees + +/-- Finite generated-term coverage stated against actual successful helper +executions. Requiring every numeral or application globally would make a +finite run support artificially infinite; these five fields cover exactly +the results reachable from supported inputs in this run. -/ +structure NoDeltaGeneratedSupport (support : RunSupport) + (flags : WhnfFlags) (natSuccMode : NatSuccMode) : Prop where + boolConst : ∀ {prims : Primitives .anon}, prims.CanonicalAnon → + ∀ decision : Bool, + support (KExpr.mkConst + (if decision then prims.boolTrue else prims.boolFalse) #[]) + projApp : ∀ {methods s source result s'}, + support source → + (RecM.tryProjAppReduceFinished source flags).run methods s = + .ok (some result) s' → + support result + nat : ∀ {methods s source result s'}, + support source → + (RecM.tryReduceNatWithSuccMode source natSuccMode).run methods s = + .ok (some result) s' → + support result + string : ∀ {methods s source result s'}, + support source → + (RecM.tryReduceString source).run methods s = .ok (some result) s' → + support result + projectionDef : ∀ {methods s source result s'}, + support source → + (RecM.tryReduceProjectionDefinition source).run methods s = + .ok (some result) s' → + support result + quot : ∀ {methods s source result s'}, + support source → + (RecM.tryQuotReduce source).run methods s = .ok (some result) s' → + support result + +/-- Finite input closure needed by reducers that recursively normalize an +application argument. This is intentionally spine closure rather than +global constructor closure: the arguments of a supported expression form a +finite subdomain, and applying the field again to a supported callback result +reaches successor/recursor subspines without making the run support infinite. -/ +structure NoDeltaInputSupport (support : RunSupport) : Prop where + spine : ∀ {source head args}, + support source → + source.collectSpine = (head, args) → + support head ∧ ∀ (i : Nat) (hi : i < args.size), support args[i] + +/-- The concrete K1 input for active no-delta primitive proofs. It binds the +canonical anon table to trusted Theory names, carries Lean4Lean's primitive +reflection laws, records the quotient lift equation, and scopes generated +syntax to actual supported executions. This is necessary but intentionally +not sufficient for `NoDeltaBaseOracle`: helper state frames and branch-level +`WhnfMeaning` proofs remain real proof obligations. -/ +structure NoDeltaPrimitiveContext (world : VerifyWorld) (support : RunSupport) + (flags : WhnfFlags) (natSuccMode : NatSuccMode) : Prop where + table : ∀ prims, prims.CanonicalAnon → + NoDeltaPrimitiveTableAgrees world prims + theoryPrimitives : world.venv.HasPrimitives + quotientDefEq : world.venv.defeqs Lean4Lean.quotDefEq + collisionFree : support.CollisionFree + inputs : NoDeltaInputSupport support + generated : NoDeltaGeneratedSupport support flags natSuccMode + +namespace NoDeltaPrimitiveContext + +/-- Connect the fixed production state invariant to the trusted primitive +table relation consumed by an active reducer proof. -/ +theorem stateTable + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Δ s) : + NoDeltaPrimitiveTableAgrees world s.prims := by + exact context.table s.prims hI.noAccel_primitives + +/-- `computeNatBin` uses the fixed canonical address table. Under the +production table binding, every successful arithmetic result is therefore +one of Lean4Lean's reflected primitive equations, lifted from the empty +universe/local context to the current checker context. -/ +theorem computeNatBin_defeq + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + {uvars : Nat} {Δ : KVLCtx} {prims : Primitives .anon} + {addr : Address} {a b result : Nat} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + (hcatalog : TrustedCatalogRel trProj world) + (hcanonical : prims.CanonicalAnon) + (hcompute : computeNatBin addr PrimAddrs.canonical a b = some result) : + ∃ name, + world.nameOf addr = some name ∧ + world.venv.IsDefEqU uvars Δ.toCtx + (.app (.app (.const name []) (.natLit a)) (.natLit b)) + (.natLit result) := by + have htable := context.table prims hcanonical + have liftReflection {name : Lean.Name} {f : Nat → Nat → Nat} + {primitiveId : KId .anon} + (hid : PrimitiveIdAgrees world primitiveId name) + (hreflect : world.venv.ReflectsNatNatNat name f) : + world.venv.IsDefEqU uvars Δ.toCtx + (.app (.app (.const name []) (.natLit a)) (.natLit b)) + (.natLit (f a b)) := by + have h := hreflect (hid.contains hcatalog) a b + have h := h.instL (U' := uvars) (ls := []) (by simp) + simpa [VExpr.instL] using h.weak0 world.venvWF (Γ := Δ.toCtx) + have hnatAdd : prims.natAdd.addr = PrimAddrs.canonical.natAdd := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natAdd hcanonical + have hnatSub : prims.natSub.addr = PrimAddrs.canonical.natSub := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natSub hcanonical + have hnatMul : prims.natMul.addr = PrimAddrs.canonical.natMul := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natMul hcanonical + have hnatDiv : prims.natDiv.addr = PrimAddrs.canonical.natDiv := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natDiv hcanonical + have hnatMod : prims.natMod.addr = PrimAddrs.canonical.natMod := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natMod hcanonical + have hnatPow : prims.natPow.addr = PrimAddrs.canonical.natPow := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natPow hcanonical + have hnatGcd : prims.natGcd.addr = PrimAddrs.canonical.natGcd := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natGcd hcanonical + have hnatLand : prims.natLand.addr = PrimAddrs.canonical.natLand := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natLand hcanonical + have hnatLor : prims.natLor.addr = PrimAddrs.canonical.natLor := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natLor hcanonical + have hnatXor : prims.natXor.addr = PrimAddrs.canonical.natXor := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natXor hcanonical + have hnatShiftLeft : + prims.natShiftLeft.addr = PrimAddrs.canonical.natShiftLeft := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natShiftLeft hcanonical + have hnatShiftRight : + prims.natShiftRight.addr = PrimAddrs.canonical.natShiftRight := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natShiftRight hcanonical + generalize hfixed : PrimAddrs.canonical = fixed at hcompute + unfold computeNatBin at hcompute + by_cases hopAdd : addr == fixed.natAdd + · rw [if_pos hopAdd] at hcompute + have haddr := beq_iff_eq.mp hopAdd + simp only [Option.some.injEq] at hcompute + subst result + refine ⟨``Nat.add, ?_, + liftReflection htable.natAdd context.theoryPrimitives.natAdd⟩ + simpa only [haddr, ← hfixed, ← hnatAdd] using htable.natAdd.2 + · rw [if_neg hopAdd] at hcompute + by_cases hopSub : addr == fixed.natSub + · rw [if_pos hopSub] at hcompute + have haddr := beq_iff_eq.mp hopSub + simp only [Option.some.injEq] at hcompute + subst result + refine ⟨``Nat.sub, ?_, + liftReflection htable.natSub context.theoryPrimitives.natSub⟩ + simpa only [haddr, ← hfixed, ← hnatSub] using htable.natSub.2 + · rw [if_neg hopSub] at hcompute + by_cases hopMul : addr == fixed.natMul + · rw [if_pos hopMul] at hcompute + have haddr := beq_iff_eq.mp hopMul + simp only [Option.some.injEq] at hcompute + subst result + refine ⟨``Nat.mul, ?_, + liftReflection htable.natMul context.theoryPrimitives.natMul⟩ + simpa only [haddr, ← hfixed, ← hnatMul] using htable.natMul.2 + · rw [if_neg hopMul] at hcompute + by_cases hopDiv : addr == fixed.natDiv + · rw [if_pos hopDiv] at hcompute + have haddr := beq_iff_eq.mp hopDiv + simp only [Option.some.injEq] at hcompute + have hresult : result = a / b := by + calc + result = (if b == 0 then 0 else a / b) := hcompute.symm + _ = a / b := by + by_cases hb : b = 0 <;> simp [hb] + rw [hresult] + refine ⟨``Nat.div, ?_, + liftReflection htable.natDiv context.theoryPrimitives.natDiv⟩ + simpa only [haddr, ← hfixed, ← hnatDiv] using htable.natDiv.2 + · rw [if_neg hopDiv] at hcompute + by_cases hopMod : addr == fixed.natMod + · rw [if_pos hopMod] at hcompute + have haddr := beq_iff_eq.mp hopMod + simp only [Option.some.injEq] at hcompute + have hresult : result = a % b := by + calc + result = (if b == 0 then a else a % b) := hcompute.symm + _ = a % b := by + by_cases hb : b = 0 <;> simp [hb] + rw [hresult] + refine ⟨``Nat.mod, ?_, + liftReflection htable.natMod context.theoryPrimitives.natMod⟩ + simpa only [haddr, ← hfixed, ← hnatMod] using htable.natMod.2 + · rw [if_neg hopMod] at hcompute + by_cases hopPow : addr == fixed.natPow + · rw [if_pos hopPow] at hcompute + have haddr := beq_iff_eq.mp hopPow + by_cases hbound : b ≤ 16777216 + · rw [if_pos hbound] at hcompute + simp only [Option.some.injEq] at hcompute + subst result + refine ⟨``Nat.pow, ?_, + liftReflection htable.natPow + context.theoryPrimitives.natPow⟩ + simpa only [haddr, ← hfixed, ← hnatPow] using + htable.natPow.2 + · rw [if_neg hbound] at hcompute + contradiction + · rw [if_neg hopPow] at hcompute + by_cases hopGcd : addr == fixed.natGcd + · rw [if_pos hopGcd] at hcompute + have haddr := beq_iff_eq.mp hopGcd + simp only [Option.some.injEq] at hcompute + subst result + refine ⟨``Nat.gcd, ?_, + liftReflection htable.natGcd + context.theoryPrimitives.natGcd⟩ + simpa only [haddr, ← hfixed, ← hnatGcd] using + htable.natGcd.2 + · rw [if_neg hopGcd] at hcompute + by_cases hopLand : addr == fixed.natLand + · rw [if_pos hopLand] at hcompute + have haddr := beq_iff_eq.mp hopLand + simp only [Option.some.injEq] at hcompute + subst result + refine ⟨``Nat.land, ?_, + liftReflection htable.natLand + context.theoryPrimitives.natLAnd⟩ + simpa only [haddr, ← hfixed, ← hnatLand] using + htable.natLand.2 + · rw [if_neg hopLand] at hcompute + by_cases hopLor : addr == fixed.natLor + · rw [if_pos hopLor] at hcompute + have haddr := beq_iff_eq.mp hopLor + simp only [Option.some.injEq] at hcompute + subst result + refine ⟨``Nat.lor, ?_, + liftReflection htable.natLor + context.theoryPrimitives.natLOr⟩ + simpa only [haddr, ← hfixed, ← hnatLor] using + htable.natLor.2 + · rw [if_neg hopLor] at hcompute + by_cases hopXor : addr == fixed.natXor + · rw [if_pos hopXor] at hcompute + have haddr := beq_iff_eq.mp hopXor + simp only [Option.some.injEq] at hcompute + subst result + refine ⟨``Nat.xor, ?_, + liftReflection htable.natXor + context.theoryPrimitives.natXor⟩ + simpa only [haddr, ← hfixed, ← hnatXor] using + htable.natXor.2 + · rw [if_neg hopXor] at hcompute + by_cases hopShiftLeft : addr == fixed.natShiftLeft + · rw [if_pos hopShiftLeft] at hcompute + have haddr := beq_iff_eq.mp hopShiftLeft + by_cases hbound : b < 2 ^ 64 + · rw [if_pos hbound] at hcompute + simp only [Option.some.injEq] at hcompute + subst result + refine ⟨``Nat.shiftLeft, ?_, + liftReflection htable.natShiftLeft + context.theoryPrimitives.natShiftLeft⟩ + simpa only [haddr, ← hfixed, ← hnatShiftLeft] using + htable.natShiftLeft.2 + · rw [if_neg hbound] at hcompute + contradiction + · rw [if_neg hopShiftLeft] at hcompute + by_cases hopShiftRight : addr == fixed.natShiftRight + · rw [if_pos hopShiftRight] at hcompute + have haddr := beq_iff_eq.mp hopShiftRight + by_cases hbound : b < 2 ^ 64 + · rw [if_pos hbound] at hcompute + simp only [Option.some.injEq] at hcompute + subst result + refine ⟨``Nat.shiftRight, ?_, + liftReflection htable.natShiftRight + context.theoryPrimitives.natShiftRight⟩ + simpa only [haddr, ← hfixed, + ← hnatShiftRight] using + htable.natShiftRight.2 + · rw [if_neg hbound] at hcompute + contradiction + · rw [if_neg hopShiftRight] at hcompute + contradiction + +/-- A successful binary-Nat computation is classified as arithmetic and not +as a predicate by the actual production readers. Arithmetic membership +comes from the same ordered address tests as `computeNatBin`; exclusion from +the predicate table is derived constructively from the distinct trusted +Theory names, rather than from native comparison of concrete hashes. -/ +theorem computeNatBin_classifiers + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Δ : KVLCtx} {methods : Methods .anon} + {s : TcState .anon} {addr : Address} {a b result : Nat} + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Δ s) + (hcompute : computeNatBin addr PrimAddrs.canonical a b = some result) : + (RecM.isNatBinArithAddr addr).run methods s = .ok true s ∧ + (RecM.isNatBinPredAddr addr).run methods s = .ok false s := by + have htable := context.stateTable hI + have hcanonical := hI.noAccel_primitives + have hnatAdd : s.prims.natAdd.addr = PrimAddrs.canonical.natAdd := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natAdd hcanonical + have hnatSub : s.prims.natSub.addr = PrimAddrs.canonical.natSub := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natSub hcanonical + have hnatMul : s.prims.natMul.addr = PrimAddrs.canonical.natMul := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natMul hcanonical + have hnatDiv : s.prims.natDiv.addr = PrimAddrs.canonical.natDiv := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natDiv hcanonical + have hnatMod : s.prims.natMod.addr = PrimAddrs.canonical.natMod := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natMod hcanonical + have hnatPow : s.prims.natPow.addr = PrimAddrs.canonical.natPow := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natPow hcanonical + have hnatGcd : s.prims.natGcd.addr = PrimAddrs.canonical.natGcd := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natGcd hcanonical + have hnatLand : s.prims.natLand.addr = PrimAddrs.canonical.natLand := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natLand hcanonical + have hnatLor : s.prims.natLor.addr = PrimAddrs.canonical.natLor := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natLor hcanonical + have hnatXor : s.prims.natXor.addr = PrimAddrs.canonical.natXor := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natXor hcanonical + have hnatShiftLeft : + s.prims.natShiftLeft.addr = PrimAddrs.canonical.natShiftLeft := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natShiftLeft hcanonical + have hnatShiftRight : + s.prims.natShiftRight.addr = PrimAddrs.canonical.natShiftRight := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natShiftRight hcanonical + have classify {id : KId .anon} {name : Lean.Name} + (hid : PrimitiveIdAgrees world id name) + (harith : + (id.addr == s.prims.natAdd.addr || + id.addr == s.prims.natSub.addr || + id.addr == s.prims.natMul.addr || + id.addr == s.prims.natDiv.addr || + id.addr == s.prims.natMod.addr || + id.addr == s.prims.natPow.addr || + id.addr == s.prims.natGcd.addr || + id.addr == s.prims.natLand.addr || + id.addr == s.prims.natLor.addr || + id.addr == s.prims.natXor.addr || + id.addr == s.prims.natShiftLeft.addr || + id.addr == s.prims.natShiftRight.addr) = true) + (hneBeq : name ≠ ``Nat.beq) (hneBle : name ≠ ``Nat.ble) + (haddr : addr = id.addr) : + (RecM.isNatBinArithAddr addr).run methods s = .ok true s ∧ + (RecM.isNatBinPredAddr addr).run methods s = .ok false s := by + constructor + · unfold RecM.isNatBinArithAddr RecM.prims + change EStateM.Result.ok + (addr == s.prims.natAdd.addr || + addr == s.prims.natSub.addr || + addr == s.prims.natMul.addr || + addr == s.prims.natDiv.addr || + addr == s.prims.natMod.addr || + addr == s.prims.natPow.addr || + addr == s.prims.natGcd.addr || + addr == s.prims.natLand.addr || + addr == s.prims.natLor.addr || + addr == s.prims.natXor.addr || + addr == s.prims.natShiftLeft.addr || + addr == s.prims.natShiftRight.addr) s = .ok true s + rw [haddr, harith] + · have hbeq := hid.addr_ne htable.natBeq hneBeq + have hble := hid.addr_ne htable.natBle hneBle + unfold RecM.isNatBinPredAddr RecM.prims + change EStateM.Result.ok + (addr == s.prims.natBeq.addr || addr == s.prims.natBle.addr) s = + .ok false s + simp [haddr, hbeq, hble] + generalize hfixed : PrimAddrs.canonical = fixed at hcompute + unfold computeNatBin at hcompute + by_cases hopAdd : addr == fixed.natAdd + · rw [if_pos hopAdd] at hcompute + apply classify htable.natAdd (by simp) (by decide) (by decide) + simpa only [← hfixed, ← hnatAdd] using beq_iff_eq.mp hopAdd + · rw [if_neg hopAdd] at hcompute + by_cases hopSub : addr == fixed.natSub + · rw [if_pos hopSub] at hcompute + apply classify htable.natSub (by simp) (by decide) (by decide) + simpa only [← hfixed, ← hnatSub] using beq_iff_eq.mp hopSub + · rw [if_neg hopSub] at hcompute + by_cases hopMul : addr == fixed.natMul + · rw [if_pos hopMul] at hcompute + apply classify htable.natMul (by simp) (by decide) (by decide) + simpa only [← hfixed, ← hnatMul] using beq_iff_eq.mp hopMul + · rw [if_neg hopMul] at hcompute + by_cases hopDiv : addr == fixed.natDiv + · rw [if_pos hopDiv] at hcompute + apply classify htable.natDiv (by simp) (by decide) (by decide) + simpa only [← hfixed, ← hnatDiv] using beq_iff_eq.mp hopDiv + · rw [if_neg hopDiv] at hcompute + by_cases hopMod : addr == fixed.natMod + · rw [if_pos hopMod] at hcompute + apply classify htable.natMod (by simp) (by decide) (by decide) + simpa only [← hfixed, ← hnatMod] using beq_iff_eq.mp hopMod + · rw [if_neg hopMod] at hcompute + by_cases hopPow : addr == fixed.natPow + · rw [if_pos hopPow] at hcompute + apply classify htable.natPow (by simp) (by decide) (by decide) + simpa only [← hfixed, ← hnatPow] using beq_iff_eq.mp hopPow + · rw [if_neg hopPow] at hcompute + by_cases hopGcd : addr == fixed.natGcd + · rw [if_pos hopGcd] at hcompute + apply classify htable.natGcd (by simp) (by decide) (by decide) + simpa only [← hfixed, ← hnatGcd] using beq_iff_eq.mp hopGcd + · rw [if_neg hopGcd] at hcompute + by_cases hopLand : addr == fixed.natLand + · rw [if_pos hopLand] at hcompute + apply classify htable.natLand (by simp) (by decide) (by decide) + simpa only [← hfixed, ← hnatLand] using beq_iff_eq.mp hopLand + · rw [if_neg hopLand] at hcompute + by_cases hopLor : addr == fixed.natLor + · rw [if_pos hopLor] at hcompute + apply classify htable.natLor (by simp) (by decide) (by decide) + simpa only [← hfixed, ← hnatLor] using beq_iff_eq.mp hopLor + · rw [if_neg hopLor] at hcompute + by_cases hopXor : addr == fixed.natXor + · rw [if_pos hopXor] at hcompute + apply classify htable.natXor (by simp) (by decide) (by decide) + simpa only [← hfixed, ← hnatXor] using beq_iff_eq.mp hopXor + · rw [if_neg hopXor] at hcompute + by_cases hopShiftLeft : addr == fixed.natShiftLeft + · rw [if_pos hopShiftLeft] at hcompute + apply classify htable.natShiftLeft (by simp) + (by decide) (by decide) + simpa only [← hfixed, ← hnatShiftLeft] using + beq_iff_eq.mp hopShiftLeft + · rw [if_neg hopShiftLeft] at hcompute + by_cases hopShiftRight : addr == fixed.natShiftRight + · rw [if_pos hopShiftRight] at hcompute + apply classify htable.natShiftRight (by simp) + (by decide) (by decide) + simpa only [← hfixed, ← hnatShiftRight] using + beq_iff_eq.mp hopShiftRight + · rw [if_neg hopShiftRight] at hcompute + contradiction + +/-- Either trusted binary-Nat predicate address is classified by the two +production readers exactly as intended. All twelve arithmetic exclusions +come from distinct Theory names through `PrimitiveIdAgrees.addr_ne`; no +concrete content-hash comparison enters the proof. -/ +theorem natPredicate_classifiers + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Δ : KVLCtx} {methods : Methods .anon} + {s : TcState .anon} {addr : Address} + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Δ s) + (haddr : addr = s.prims.natBeq.addr ∨ + addr = s.prims.natBle.addr) : + (RecM.isNatBinArithAddr addr).run methods s = .ok false s ∧ + (RecM.isNatBinPredAddr addr).run methods s = .ok true s := by + have htable := context.stateTable hI + have classify {id : KId .anon} + (haddr : addr = id.addr) + (harith : + (id.addr == s.prims.natAdd.addr || + id.addr == s.prims.natSub.addr || + id.addr == s.prims.natMul.addr || + id.addr == s.prims.natDiv.addr || + id.addr == s.prims.natMod.addr || + id.addr == s.prims.natPow.addr || + id.addr == s.prims.natGcd.addr || + id.addr == s.prims.natLand.addr || + id.addr == s.prims.natLor.addr || + id.addr == s.prims.natXor.addr || + id.addr == s.prims.natShiftLeft.addr || + id.addr == s.prims.natShiftRight.addr) = false) + (hpred : + (id.addr == s.prims.natBeq.addr || + id.addr == s.prims.natBle.addr) = true) : + (RecM.isNatBinArithAddr addr).run methods s = .ok false s ∧ + (RecM.isNatBinPredAddr addr).run methods s = .ok true s := by + constructor + · unfold RecM.isNatBinArithAddr RecM.prims + change EStateM.Result.ok + (addr == s.prims.natAdd.addr || + addr == s.prims.natSub.addr || + addr == s.prims.natMul.addr || + addr == s.prims.natDiv.addr || + addr == s.prims.natMod.addr || + addr == s.prims.natPow.addr || + addr == s.prims.natGcd.addr || + addr == s.prims.natLand.addr || + addr == s.prims.natLor.addr || + addr == s.prims.natXor.addr || + addr == s.prims.natShiftLeft.addr || + addr == s.prims.natShiftRight.addr) s = .ok false s + rw [haddr, harith] + · unfold RecM.isNatBinPredAddr RecM.prims + change EStateM.Result.ok + (addr == s.prims.natBeq.addr || addr == s.prims.natBle.addr) s = + .ok true s + rw [haddr, hpred] + rcases haddr with hbeq | hble + · apply classify hbeq + · simp [htable.natBeq.addr_ne htable.natAdd (by decide), + htable.natBeq.addr_ne htable.natSub (by decide), + htable.natBeq.addr_ne htable.natMul (by decide), + htable.natBeq.addr_ne htable.natDiv (by decide), + htable.natBeq.addr_ne htable.natMod (by decide), + htable.natBeq.addr_ne htable.natPow (by decide), + htable.natBeq.addr_ne htable.natGcd (by decide), + htable.natBeq.addr_ne htable.natLand (by decide), + htable.natBeq.addr_ne htable.natLor (by decide), + htable.natBeq.addr_ne htable.natXor (by decide), + htable.natBeq.addr_ne htable.natShiftLeft (by decide), + htable.natBeq.addr_ne htable.natShiftRight (by decide)] + · simp + · apply classify hble + · simp [htable.natBle.addr_ne htable.natAdd (by decide), + htable.natBle.addr_ne htable.natSub (by decide), + htable.natBle.addr_ne htable.natMul (by decide), + htable.natBle.addr_ne htable.natDiv (by decide), + htable.natBle.addr_ne htable.natMod (by decide), + htable.natBle.addr_ne htable.natPow (by decide), + htable.natBle.addr_ne htable.natGcd (by decide), + htable.natBle.addr_ne htable.natLand (by decide), + htable.natBle.addr_ne htable.natLor (by decide), + htable.natBle.addr_ne htable.natXor (by decide), + htable.natBle.addr_ne htable.natShiftLeft (by decide), + htable.natBle.addr_ne htable.natShiftRight (by decide)] + · simp + +/-- Reflect the concrete predicate decision selected by production into the +corresponding Lean4Lean `Nat.beq` or `Nat.ble` equation. -/ +theorem natPredicate_defeq + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + {uvars : Nat} {Δ : KVLCtx} {prims : Primitives .anon} + {addr : Address} {a b : Nat} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + (hcatalog : TrustedCatalogRel trProj world) + (hcanonical : prims.CanonicalAnon) + (haddr : addr = prims.natBeq.addr ∨ addr = prims.natBle.addr) : + ∃ name decision, + world.nameOf addr = some name ∧ + decision = + (if addr == prims.natBeq.addr then a == b else a.ble b) ∧ + world.venv.IsDefEqU uvars Δ.toCtx + (.app (.app (.const name []) (.natLit a)) (.natLit b)) + (.boolLit decision) := by + have htable := context.table prims hcanonical + have liftReflection {name : Lean.Name} {f : Nat → Nat → Bool} + {primitiveId : KId .anon} + (hid : PrimitiveIdAgrees world primitiveId name) + (hreflect : world.venv.ReflectsNatNatBool name f) : + world.venv.IsDefEqU uvars Δ.toCtx + (.app (.app (.const name []) (.natLit a)) (.natLit b)) + (.boolLit (f a b)) := by + have h := hreflect (hid.contains hcatalog) a b + have h := h.instL (U' := uvars) (ls := []) (by simp) + simpa [VExpr.instL] using h.weak0 world.venvWF (Γ := Δ.toCtx) + rcases haddr with hbeq | hble + · subst addr + refine ⟨``Nat.beq, a == b, htable.natBeq.2, by simp, ?_⟩ + have hdecision : Nat.beq a b = (a == b) := by + apply Bool.eq_iff_iff.mpr + simp + simpa only [hdecision] using + (liftReflection htable.natBeq context.theoryPrimitives.natBEq) + · subst addr + have hne := htable.natBle.addr_ne htable.natBeq (by decide) + refine ⟨``Nat.ble, a.ble b, htable.natBle.2, by simp [hne], ?_⟩ + exact liftReflection htable.natBle context.theoryPrimitives.natBLE + +end NoDeltaPrimitiveContext + +namespace TrKExprS + +/-- A successful production Nat-literal extraction has the canonical Theory +translation. The constructor case is not justified by address equality +alone: `NoDeltaPrimitiveTableAgrees` fixes the address's trusted name, while +`HasPrimitives.natZero` fixes its declaration to zero universe parameters. +Consequently a translated `Nat.zero` accepted by `extractNatLit` cannot carry +spurious universe arguments. -/ +theorem of_extractNatLit + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Δ : KVLCtx} {prims : Primitives .anon} + {e : KExpr .anon} {eV : VExpr} {n : Nat} + (htable : NoDeltaPrimitiveTableAgrees world prims) + (hprims : world.venv.HasPrimitives) + (htr : TrKExprS world.venv uvars world.nameOf trProj Δ e eV) + (hextract : extractNatLit e prims = some n) : + eV = .natLit n := by + cases e with + | nat value blob info => + simp only [extractNatLit, Option.some.injEq] at hextract + subst n + let .nat _ := htr + rfl + | const id us info => + simp only [extractNatLit] at hextract + split at hextract + · rename_i hzero + have haddr : id.addr = prims.natZero.addr := + beq_iff_eq.mp hzero + simp only [Option.some.injEq] at hextract + subst n + let .const (c := c) (ci := ci) hname hlookup _ hsize := htr + have hc : c = ``Nat.zero := by + rw [haddr, htable.natZero.2] at hname + exact Option.some.inj hname.symm + subst c + have hci := hprims.natZero hlookup + subst ci + have hus : us = #[] := Array.eq_empty_of_size_eq_zero hsize + subst us + rfl + · contradiction + | var idx name info => simp [extractNatLit] at hextract + | fvar id name info => simp [extractNatLit] at hextract + | sort u info => simp [extractNatLit] at hextract + | app f a info => simp [extractNatLit] at hextract + | lam name bi ty body info => simp [extractNatLit] at hextract + | all name bi ty body info => simp [extractNatLit] at hextract + | letE name ty val body nondep info => simp [extractNatLit] at hextract + | prj id field val info => simp [extractNatLit] at hextract + | str value blob info => simp [extractNatLit] at hextract + +/-- The numeral materialized by the Nat reducer translates directly to the +canonical Theory numeral. -/ +theorem natExprFromValue + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Δ : KVLCtx} {prims : Primitives .anon} + (hcatalog : TrustedCatalogRel trProj world) + (htable : NoDeltaPrimitiveTableAgrees world prims) + (n : Nat) : + TrKExprS world.venv uvars world.nameOf trProj Δ + (RecM.natExprFromValue (m := .anon) n) (.natLit n) := by + rw [RecM.natExprFromValue, KExpr.mkNat_shape] + exact .nat (htable.nat.contains hcatalog) + +/-- The finite Bool constant selected by the Nat predicate reducer translates +to the matching Theory Bool literal. `HasPrimitives` fixes both declarations +to zero universe parameters, so no universe payload can be hidden behind the +trusted address. -/ +theorem boolExprFromDecision + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Δ : KVLCtx} {prims : Primitives .anon} + (hcatalog : TrustedCatalogRel trProj world) + (htable : NoDeltaPrimitiveTableAgrees world prims) + (hprims : world.venv.HasPrimitives) + (decision : Bool) : + TrKExprS world.venv uvars world.nameOf trProj Δ + (KExpr.mkConst + (if decision then prims.boolTrue else prims.boolFalse) #[]) + (.boolLit decision) := by + cases decision with + | false => + rw [KExpr.mkConst_shape] + obtain ⟨ci, hlookup⟩ := htable.boolFalse.contains hcatalog + have hci := hprims.boolFalse hlookup + subst ci + simpa [VExpr.boolLit, VExpr.boolFalse] using + (TrKExprS.const (Δ := Δ) (uvars := uvars) + htable.boolFalse.2 hlookup (by simp) (by simp)) + | true => + rw [KExpr.mkConst_shape] + obtain ⟨ci, hlookup⟩ := htable.boolTrue.contains hcatalog + have hci := hprims.boolTrue hlookup + subst ci + simpa [VExpr.boolLit, VExpr.boolTrue] using + (TrKExprS.const (Δ := Δ) (uvars := uvars) + htable.boolTrue.2 hlookup (by simp) (by simp)) + +/-- Invert a translated exact binary application after its concrete head has +been identified with a reflected primitive. The reflected equation proves +that `name` is usable with no universe arguments; uniqueness of the constant +lookup then forces the concrete source's universe array to be empty. -/ +theorem natBinExact_inv + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Δ : KVLCtx} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + {sourceV resultV : VExpr} {name : Lean.Name} {a b : Nat} + (hΔ : KVLCtx.WF world.venv uvars Δ) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) sourceV) + (hname : world.nameOf headId.addr = some name) + (hreflect : world.venv.IsDefEqU uvars Δ.toCtx + (.app (.app (.const name []) (.natLit a)) (.natLit b)) + resultV) : + ∃ argAV argBV, + sourceV = (.app (.app (.const name []) argAV) argBV) ∧ + TrKExprS world.venv uvars world.nameOf trProj Δ argA argAV ∧ + TrKExprS world.venv uvars world.nameOf trProj Δ argB argBV := by + let .app _ _ hprefix hargB := hsource + let .app _ _ hhead hargA := hprefix + let .const (c := c) (ci := ci) hheadName hlookup _ hsize := hhead + have hc : c = name := by + rw [hname] at hheadName + exact Option.some.inj hheadName.symm + subst c + obtain ⟨_, hreflectTyped⟩ := hreflect + have happType := hreflectTyped.hasType.1 + obtain ⟨_, _, hprefixType, _⟩ := + happType.app_inv world.venvWF.ordered hΔ + obtain ⟨_, _, hconstType, _⟩ := + hprefixType.app_inv world.venvWF.ordered hΔ + obtain ⟨reflectedCi, hreflectedLookup, _, hreflectedArity⟩ := + hconstType.const_inv world.venvWF.ordered hΔ + have hci : ci = reflectedCi := by + rw [hlookup] at hreflectedLookup + exact Option.some.inj hreflectedLookup + subst reflectedCi + have hzero : ci.uvars = 0 := by simpa using hreflectedArity.symm + have husSize : us.size = 0 := hsize.trans hzero + have hus : us = #[] := Array.eq_empty_of_size_eq_zero husSize + subst us + exact ⟨_, _, rfl, hargA, hargB⟩ + +/-- A translation of a left-associated application fold contains a +translation of its initial function. This is the structural inversion used +to recover each prefix while suffix congruence proceeds left-to-right. -/ +theorem foldlMkApp_initial + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Δ : KVLCtx} {rest : List (KExpr .anon)} + {initial : KExpr .anon} {finalV : VExpr} + (h : TrKExprS world.venv uvars world.nameOf trProj Δ + (rest.foldl KExpr.mkApp initial) finalV) : + ∃ initialV, + TrKExprS world.venv uvars world.nameOf trProj Δ initial initialV := by + induction rest generalizing initial finalV with + | nil => + exact ⟨finalV, h⟩ + | cons arg rest ih => + have hprefix := ih (initial := KExpr.mkApp initial arg) h + obtain ⟨prefixV, hprefix⟩ := hprefix + rw [KExpr.mkApp_shape] at hprefix + let .app _ _ hinitial _ := hprefix + exact ⟨_, hinitial⟩ + +end TrKExprS -/-- The Decidable synthesis acceleration gate is absent from the -no-acceleration layer. -/ -theorem tryReduceDecidable_noAccel {methods : Methods .anon} - {s : TcState .anon} (h : s.noAccel = true) (e : KExpr .anon) : - (tryReduceDecidable e).run methods s = .ok none s := by - unfold tryReduceDecidable - rw [ReaderT.run_bind] - change (EStateM.bind EStateM.get _) s = _ - simp [EStateM.bind, EStateM.get, h] - rfl +namespace WhnfPost -/-- The specialized `Fin.val`/`Decidable.rec` acceleration gate is absent -from the no-acceleration layer. -/ -theorem tryReduceFinValDecidableRec_noAccel {methods : Methods .anon} - {s : TcState .anon} (h : s.noAccel = true) (id : KId .anon) - (field : UInt64) (head : KExpr .anon) (args : Array (KExpr .anon)) : - (tryReduceFinValDecidableRec id field head args).run methods s = - .ok none s := by - unfold tryReduceFinValDecidableRec - rw [ReaderT.run_bind] - change (EStateM.bind EStateM.get _) s = _ - simp [EStateM.bind, EStateM.get, h] - rfl +/-- If the shared argument normalizer returns something recognized by the +production literal extractor, its retained callback postcondition specializes +to definitional equality with the corresponding Theory numeral. -/ +theorem of_extractNatLit + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Δ : KVLCtx} {prims : Primitives .anon} + {sourceV : VExpr} {result : KExpr .anon} {n : Nat} + (htable : NoDeltaPrimitiveTableAgrees world prims) + (hprims : world.venv.HasPrimitives) + (hpost : WhnfPost trProj world uvars Δ sourceV result) + (hextract : extractNatLit result prims = some n) : + world.venv.IsDefEqU uvars Δ.toCtx sourceV (.natLit n) := by + obtain ⟨resultV, hresult, hdefeq⟩ := hpost + have heq := hresult.of_extractNatLit htable hprims hextract + simpa only [heq] using hdefeq + +end WhnfPost + +namespace WhnfMeaning + +/-- Definitional equality of a function is preserved when both sides are +applied to the same translated argument. The source application supplies +the function/argument typing facts; translation uniqueness reconciles its +function translation with the one stored in the incoming meaning. -/ +theorem appSameArg + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + {Δ : KVLCtx} (hΔ : KVLCtx.WF world.venv uvars Δ) + {source result arg : KExpr .anon} {sourceInfo : ExprInfo .anon} + {sourceAppV : VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ + (.app source arg sourceInfo) sourceAppV) + (hmeaning : WhnfMeaning trProj world uvars Δ source result) : + WhnfMeaning trProj world uvars Δ (.app source arg sourceInfo) + (KExpr.mkApp result arg) := by + cases hsource with + | @app _ _ _ _ sourceV₀ argV A B hsourceType hargType + hsourceTr hargTr => + obtain ⟨sourceV, resultV, hsourceTr', hresultTr, hdefeq⟩ := hmeaning + have hctx := KVLCtx.IsDefEq.refl world.venvWF hΔ + have hsourceEq := hsourceTr.uniq world.venvWF theory.literalWF + theory.projections hctx hsourceTr' + have hfunEq := hsourceEq.trans world.venvWF hΔ hdefeq + have hfunEqTyped := hfunEq.of_l world.venvWF hΔ hsourceType + have hargEq : world.venv.IsDefEqU uvars Δ.toCtx _ _ := + Lean4Lean.VEnv.IsDefEqU.refl ⟨_, hargType⟩ + have hargEqTyped := hargEq.of_l world.venvWF hΔ hargType + have hresultTr' : TrKExprS world.venv uvars world.nameOf trProj Δ + (KExpr.mkApp result arg) (.app resultV argV) := by + rw [KExpr.mkApp_shape] + exact .app hfunEqTyped.hasType.2 hargType hresultTr hargTr + exact ⟨_, _, .app hsourceType hargType hsourceTr hargTr, hresultTr', + (hfunEqTyped.appDF hargEqTyped).toU⟩ + +/-- Fold `appSameArg` over a concrete left-associated suffix. The final +source translation alone suffices: `foldlMkApp_initial` recovers the prefix +translation required at each induction step. -/ +theorem foldlMkApp + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + {Δ : KVLCtx} (hΔ : KVLCtx.WF world.venv uvars Δ) + {rest : List (KExpr .anon)} {source result : KExpr .anon} + {sourceV : VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ + (rest.foldl KExpr.mkApp source) sourceV) + (hmeaning : WhnfMeaning trProj world uvars Δ source result) : + WhnfMeaning trProj world uvars Δ + (rest.foldl KExpr.mkApp source) + (rest.foldl KExpr.mkApp result) := by + induction rest generalizing source result sourceV with + | nil => + exact hmeaning + | cons arg rest ih => + have hprefix := TrKExprS.foldlMkApp_initial + (rest := rest) hsource + obtain ⟨prefixV, hprefix⟩ := hprefix + have hstep := appSameArg theory hΔ hprefix hmeaning + exact ih hsource hstep + +/-- Array form matching `finishAppResultSpec` and production's spine arrays. -/ +theorem mkAppN + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + {Δ : KVLCtx} (hΔ : KVLCtx.WF world.venv uvars Δ) + {args : Array (KExpr .anon)} {source result : KExpr .anon} + {sourceV : VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ + (KExpr.mkAppN source args) sourceV) + (hmeaning : WhnfMeaning trProj world uvars Δ source result) : + WhnfMeaning trProj world uvars Δ + (KExpr.mkAppN source args) (KExpr.mkAppN result args) := by + rw [KExpr.mkAppN] at hsource ⊢ + have hsource' : TrKExprS world.venv uvars world.nameOf trProj Δ + (args.toList.foldl KExpr.mkApp source) sourceV := by + simpa only [Array.foldl_toList] using hsource + have hresult := foldlMkApp theory hΔ hsource' hmeaning + simpa only [Array.foldl_toList] using hresult + +/-- Replace the concrete source of a meaning proof when both concrete +expressions translate to the same Theory expression. This is the metadata +bridge needed after `collectSpine`: production retains the original +application metadata, while `mkAppN` rebuilds a canonical metadata-free +spine. -/ +theorem ofSharedSourceTranslation + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + {Delta : KVLCtx} (hDelta : KVLCtx.WF world.venv uvars Delta) + {source canonical result : KExpr .anon} {sourceV : VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + source sourceV) + (hcanonical : TrKExprS world.venv uvars world.nameOf trProj Delta + canonical sourceV) + (hmeaning : WhnfMeaning trProj world uvars Delta canonical result) : + WhnfMeaning trProj world uvars Delta source result := by + obtain ⟨canonicalV, resultV, hcanonical', hresult, hdefeq⟩ := hmeaning + have hctx := KVLCtx.IsDefEq.refl world.venvWF hDelta + have hsourceEq := hcanonical.uniq world.venvWF theory.literalWF + theory.projections hctx hcanonical' + exact ⟨sourceV, resultV, hsource, hresult, + hsourceEq.trans world.venvWF hDelta hdefeq⟩ + +/-- Compose the exact two argument callback posts with one reflected Nat +primitive equation. The source translation is deliberately fixed to the +primitive application shape, so no translation-uniqueness or projection +oracle is needed: both callback posts are stated against the very argument +translations embedded in that source. -/ +theorem natBinExact + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Δ : KVLCtx} {prims : Primitives .anon} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB argAResult argBResult resultExpr : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + {name : Lean.Name} {argAV argBV resultV : VExpr} {a b : Nat} + (hΔ : KVLCtx.WF world.venv uvars Δ) + (htable : NoDeltaPrimitiveTableAgrees world prims) + (hprims : world.venv.HasPrimitives) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) + (.app (.app (.const name []) argAV) argBV)) + (hargA : WhnfPost trProj world uvars Δ argAV argAResult) + (hargB : WhnfPost trProj world uvars Δ argBV argBResult) + (hextractA : extractNatLit argAResult prims = some a) + (hextractB : extractNatLit argBResult prims = some b) + (hreflect : world.venv.IsDefEqU uvars Δ.toCtx + (.app (.app (.const name []) (.natLit a)) (.natLit b)) + resultV) + (hresult : TrKExprS world.venv uvars world.nameOf trProj Δ resultExpr + resultV) : + WhnfMeaning trProj world uvars Δ + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) + resultExpr := by + let .app hprefixType hargBType hprefixTr hargBTr := hsource + let .app hconstType hargAType hconstTr hargATr := hprefixTr + have hargADef := hargA.of_extractNatLit htable hprims hextractA + have hargBDef := hargB.of_extractNatLit htable hprims hextractB + have hargADefTyped := + hargADef.of_l world.venvWF hΔ hargAType + have hprefixDef := hconstType.appDF hargADefTyped + have hprefixDefTyped := + hprefixDef.toU.of_l world.venvWF hΔ hprefixType + have hargBDefTyped := + hargBDef.of_l world.venvWF hΔ hargBType + have hsourceDef := (hprefixDefTyped.appDF hargBDefTyped).toU + exact ⟨_, _, hsource, hresult, + hsourceDef.trans world.venvWF hΔ hreflect⟩ + +end WhnfMeaning + +namespace RecM + +/-- State-only Hoare closure for the exact two-argument predicate helper. +Every callback miss/error and both extraction misses preserve the invariant; +the successful Bool intern is justified by the finite generated support and +collision boundary. Semantic meaning of a hit is supplied separately by +`tryReduceNatWithSuccMode_binPredExact_acceptance`. -/ +theorem tryReduceNatPredicate_bin_inv_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + {addr : Address} {argA argB : KExpr .anon} {argAV argBV : VExpr} + (hargASupport : support argA) + (hargATr : TrKExprS world.venv uvars world.nameOf trProj Δ argA argAV) + (hargBSupport : support argB) + (hargBTr : TrKExprS world.venv uvars world.nameOf trProj Δ argB argBV) : + RecM.WF .noAccel semantics trProj world support uvars Δ s + (tryReduceNatPredicate addr #[argA, argB]) (fun _ _ => True) := by + unfold tryReduceNatPredicate + have hzero : (#[argA, argB] : Array (KExpr .anon))[0]! = argA := by + simp + have hone : (#[argA, argB] : Array (KExpr .anon))[1]! = argB := by + simp + rw [hzero, hone] + apply RecM.WF.bind <| + RecM.WF.withInv <| whnfNatReducerArg_post_wf hargASupport hargATr + intro first afterFirst hfirst + cases first with + | none => + exact RecM.WF.pure fun _ => trivial + | some firstResult => + have hI₁ := hfirst.1 + apply RecM.WF.bind (prims_wf (s := afterFirst)) + intro prims afterRead hread + rcases hread with ⟨rfl, rfl⟩ + match hextractA : extractNatLit firstResult afterRead.prims with + | none => + exact RecM.WF.pure fun _ => trivial + | some a => + apply RecM.WF.bind <| + RecM.WF.withInv <| + whnfNatReducerArg_post_wf hargBSupport hargBTr + intro second afterSecond hsecond + cases second with + | none => + exact RecM.WF.pure fun _ => trivial + | some secondResult => + match hextractB : + extractNatLit secondResult afterRead.prims with + | none => + simp only [hextractB] + exact RecM.WF.pure fun _ => trivial + | some b => + simp only [hextractB] + let decision := + if addr == afterRead.prims.natBeq.addr then + a == b + else a.ble b + let resultExpr := KExpr.mkConst + (if decision then afterRead.prims.boolTrue + else afterRead.prims.boolFalse) #[] + have hresultSupport : support resultExpr := by + exact context.generated.boolConst + hI₁.noAccel_primitives decision + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf context.collisionFree hresultSupport + intro interned afterIntern hintern + have hinterned : interned = resultExpr := hintern.1 + subst interned + simpa [decision, resultExpr, finishAppResult] using + (RecM.WF.pure + (layer := .noAccel) (semantics := semantics) + (trProj := trProj) (world := world) + (support := support) (uvars := uvars) (Δ := Δ) + (s := afterIntern) (a := some resultExpr) + (fun _ => trivial)) + +/-- State-only Hoare closure for an exact two-argument binary Nat +application through the production dispatcher. The theorem covers both +classifier orders, every arithmetic/predicate miss, all callback errors, and +both successful result forms. Hit semantics remains separated into the +arithmetic and predicate acceptance theorems below. -/ +theorem tryReduceNatWithSuccMode_bin_inv_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} {sourceV : VExpr} + (hsourceSupport : support + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) sourceV) + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) : + RecM.WF .noAccel semantics trProj world support uvars Δ s + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode) + (fun _ _ => True) := by + let .app _ _ hprefix hargBTr := hsource + let .app _ _ _ hargATr := hprefix + have hinputSupport := context.inputs.spine hsourceSupport hspine + have hargASupport : support argA := by + simpa using hinputSupport.2 0 (by simp) + have hargBSupport : support argB := by + simpa using hinputSupport.2 1 (by simp) + unfold tryReduceNatWithSuccMode + rw [hspine] + apply RecM.WF.bind (prims_wf (s := s)) + intro prims afterRead hread + rcases hread with ⟨rfl, rfl⟩ + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + apply RecM.WF.bind (isNatBinArithAddr_inv_wf headId.addr) + intro isArith afterArith hafterArith + subst afterArith + apply RecM.WF.bind (isNatBinPredAddr_inv_wf headId.addr) + intro isPred afterPred hafterPred + subst afterPred + match isArith, isPred with + | false, false => + simp + exact RecM.WF.pure fun _ => trivial + | false, true => + simpa using tryReduceNatPredicate_bin_inv_wf context + hargASupport hargATr hargBSupport hargBTr + | true, true => + simpa using tryReduceNatPredicate_bin_inv_wf context + hargASupport hargATr hargBSupport hargBTr + | true, false => + simp only [Bool.not_true, Bool.not_false, Bool.false_and, + Bool.false_eq_true, if_false] + apply RecM.WF.bind (Q₂ := fun _ _ => True) <| + whnfNatReducerArg_post_wf hargASupport hargATr + intro first afterFirst hfirst + cases first with + | none => + exact RecM.WF.pure fun _ => trivial + | some firstResult => + apply RecM.WF.bind (Q₂ := fun _ _ => True) <| + whnfNatReducerArg_post_wf hargBSupport hargBTr + intro second afterSecond hsecond + cases second with + | none => + exact RecM.WF.pure fun _ => trivial + | some secondResult => + match hextractA : extractNatLit firstResult afterRead.prims with + | none => + exact RecM.WF.pure fun _ => trivial + | some a => + match hextractB : + extractNatLit secondResult afterRead.prims with + | none => + simp only [hextractB] + exact RecM.WF.pure fun _ => trivial + | some b => + simp only [hextractB] + match hcompute : computeNatBin headId.addr + PrimAddrs.canonical a b with + | none => + exact RecM.WF.pure fun _ => trivial + | some result => + simpa [finishAppResult] using + (RecM.WF.pure + (layer := .noAccel) (semantics := semantics) + (trProj := trProj) (world := world) + (support := support) (uvars := uvars) (Δ := Δ) + (s := afterSecond) + (a := some + (natExprFromValue (m := .anon) result)) + (fun _ => trivial)) + +/-- Exact two-argument execution of the dedicated Nat predicate helper. The +only mutation is the explicitly supplied Bool-constant intern; the empty +application suffix performs no further writes. -/ +theorem tryReduceNatPredicate_exact + {methods : Methods .anon} {s s₁ s₂ s₃ : TcState .anon} + {prims : Primitives .anon} {addr : Address} + {argA argB argAResult argBResult : KExpr .anon} + {a b : Nat} {decision : Bool} {result : KExpr .anon} + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hprims : s₁.prims = prims) + (hextractA : extractNatLit argAResult prims = some a) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractB : extractNatLit argBResult prims = some b) + (hdecision : + (if addr == prims.natBeq.addr then a == b else a.ble b) = decision) + (hintern : TcM.intern + (KExpr.mkConst + (if decision then prims.boolTrue else prims.boolFalse) #[]) s₂ = + .ok result s₃) : + (tryReduceNatPredicate addr #[argA, argB]).run methods s = + .ok (some result) s₃ := by + unfold tryReduceNatPredicate + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s₁ = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s₁ = .ok prims s₁ := by + unfold RecM.prims + change EStateM.Result.ok s₁.prims s₁ = .ok prims s₁ + rw [hprims] + rw [hprimsRun] + simp only + rw [hextractA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hargB] + simp only + rw [hextractB] + simp only + rw [hdecision] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern _) _ s₂ = _ + unfold EStateM.bind + rw [hintern] + simp [finishAppResult] + rfl + +/-- General-suffix execution of the predicate helper. The first two spine +arguments are consumed by the predicate; `finishAppResult` rebuilds exactly +the supplied trailing array and may grow only the intern table. -/ +theorem tryReduceNatPredicate_suffixExact + {methods : Methods .anon} {s s₁ s₂ s₃ s₄ : TcState .anon} + {prims : Primitives .anon} {addr : Address} + {args suffix : Array (KExpr .anon)} + {argA argB argAResult argBResult requested base final : KExpr .anon} + {a b : Nat} {decision : Bool} + (hargs : args = #[argA, argB] ++ suffix) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hprims : s₁.prims = prims) + (hextractA : extractNatLit argAResult prims = some a) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractB : extractNatLit argBResult prims = some b) + (hdecision : + (if addr == prims.natBeq.addr then a == b else a.ble b) = decision) + (hrequested : requested = KExpr.mkConst + (if decision then prims.boolTrue else prims.boolFalse) #[]) + (hintern : TcM.intern requested s₂ = .ok base s₃) + (hfinish : (finishAppResult base args 2).run methods s₃ = + .ok final s₄) : + (tryReduceNatPredicate addr args).run methods s = + .ok (some final) s₄ := by + have hzero : args[0]! = argA := by + rw [hargs] + grind + have hone : args[1]! = argB := by + rw [hargs] + grind + unfold tryReduceNatPredicate + rw [hzero, hone, ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s₁ = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s₁ = .ok prims s₁ := by + unfold RecM.prims + change EStateM.Result.ok s₁.prims s₁ = .ok prims s₁ + rw [hprims] + rw [hprimsRun] + simp only + rw [hextractA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hargB] + simp only + rw [hextractB] + simp only + rw [hdecision, ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern _) _ s₂ = _ + unfold EStateM.bind + rw [← hrequested, hintern] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((finishAppResult base args 2).run methods) _ s₃ = _ + unfold EStateM.bind + rw [hfinish] + rfl + +/-- A miss from the first predicate argument callback stops immediately and +retains that callback's exact partial state. -/ +theorem tryReduceNatPredicate_argAMiss + {methods : Methods .anon} {s s₁ : TcState .anon} + {addr : Address} {argA argB : KExpr .anon} + (hargA : (whnfNatReducerArg argA).run methods s = .ok none s₁) : + (tryReduceNatPredicate addr #[argA, argB]).run methods s = + .ok none s₁ := by + unfold tryReduceNatPredicate + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + rfl + +/-- An error from the first predicate argument callback is propagated without +running the primitive-table read or the second callback. -/ +theorem tryReduceNatPredicate_argAError + {methods : Methods .anon} {s s₁ : TcState .anon} + {addr : Address} {argA argB : KExpr .anon} {err : TcError .anon} + (hargA : (whnfNatReducerArg argA).run methods s = .error err s₁) : + (tryReduceNatPredicate addr #[argA, argB]).run methods s = + .error err s₁ := by + unfold tryReduceNatPredicate + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + +/-- Failure to recognize the first normalized predicate argument as a literal +is a state-preserving miss after exactly the first callback. -/ +theorem tryReduceNatPredicate_extractAMiss + {methods : Methods .anon} {s s₁ : TcState .anon} + {prims : Primitives .anon} {addr : Address} + {argA argB argAResult : KExpr .anon} + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hprims : s₁.prims = prims) + (hextractA : extractNatLit argAResult prims = none) : + (tryReduceNatPredicate addr #[argA, argB]).run methods s = + .ok none s₁ := by + unfold tryReduceNatPredicate + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s₁ = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s₁ = .ok prims s₁ := by + unfold RecM.prims + change EStateM.Result.ok s₁.prims s₁ = .ok prims s₁ + rw [hprims] + rw [hprimsRun] + simp only + rw [hextractA] + rfl + +/-- A miss from the second predicate argument callback retains all state +changes made by the first and second callbacks. -/ +theorem tryReduceNatPredicate_argBMiss + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {prims : Primitives .anon} {addr : Address} + {argA argB argAResult : KExpr .anon} {a : Nat} + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hprims : s₁.prims = prims) + (hextractA : extractNatLit argAResult prims = some a) + (hargB : (whnfNatReducerArg argB).run methods s₁ = .ok none s₂) : + (tryReduceNatPredicate addr #[argA, argB]).run methods s = + .ok none s₂ := by + unfold tryReduceNatPredicate + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s₁ = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s₁ = .ok prims s₁ := by + unfold RecM.prims + change EStateM.Result.ok s₁.prims s₁ = .ok prims s₁ + rw [hprims] + rw [hprimsRun] + simp only + rw [hextractA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hargB] + rfl + +/-- An error from the second predicate argument callback is propagated with +the state reached after the successful first callback. -/ +theorem tryReduceNatPredicate_argBError + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {prims : Primitives .anon} {addr : Address} + {argA argB argAResult : KExpr .anon} {a : Nat} + {err : TcError .anon} + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hprims : s₁.prims = prims) + (hextractA : extractNatLit argAResult prims = some a) + (hargB : (whnfNatReducerArg argB).run methods s₁ = .error err s₂) : + (tryReduceNatPredicate addr #[argA, argB]).run methods s = + .error err s₂ := by + unfold tryReduceNatPredicate + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s₁ = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s₁ = .ok prims s₁ := by + unfold RecM.prims + change EStateM.Result.ok s₁.prims s₁ = .ok prims s₁ + rw [hprims] + rw [hprimsRun] + simp only + rw [hextractA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hargB] + +/-- Failure to recognize the second normalized predicate argument as a +literal is a miss at the exact post-second-callback state. -/ +theorem tryReduceNatPredicate_extractBMiss + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {prims : Primitives .anon} {addr : Address} + {argA argB argAResult argBResult : KExpr .anon} {a : Nat} + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hprims : s₁.prims = prims) + (hextractA : extractNatLit argAResult prims = some a) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractB : extractNatLit argBResult prims = none) : + (tryReduceNatPredicate addr #[argA, argB]).run methods s = + .ok none s₂ := by + unfold tryReduceNatPredicate + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s₁ = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s₁ = .ok prims s₁ := by + unfold RecM.prims + change EStateM.Result.ok s₁.prims s₁ = .ok prims s₁ + rw [hprims] + rw [hprimsRun] + simp only + rw [hextractA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hargB] + simp only + rw [hextractB] + rfl + +/-- Route an exact two-argument predicate application through the outer Nat +dispatcher. The theorem pins predicate precedence over the arithmetic body +and delegates the helper's callback/intern trace to +`tryReduceNatPredicate_exact`. -/ +theorem tryReduceNatWithSuccMode_binPredExact + {methods : Methods .anon} {s s' : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB result : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok false s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok true s) + (hhelper : (tryReduceNatPredicate headId.addr #[argA, argB]).run + methods s = .ok (some result) s') : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = + .ok (some result) s' := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + simp only [Bool.not_false, Bool.not_true, Bool.and_false, + Bool.false_eq_true, if_false, if_true] + simpa using hhelper + +/-- Predicate classification has precedence even if an unconstrained method +table reports that the same address is arithmetic too. Canonical production +states later rule out that overlap; the operational success trace does not +need to assume it away while it is being inverted. -/ +theorem tryReduceNatWithSuccMode_binPredAnyExact + {methods : Methods .anon} {s s' : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB result : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} {isArith : Bool} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = + .ok isArith s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok true s) + (hhelper : (tryReduceNatPredicate headId.addr #[argA, argB]).run + methods s = .ok (some result) s') : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = + .ok (some result) s' := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + cases isArith <;> + simp only [Bool.not_false, Bool.not_true, Bool.and_false, + Bool.false_eq_true, if_false, if_true] <;> + simpa using hhelper + +/-- General-spine predicate routing. Predicate precedence is independent of +the suffix length; the dedicated helper consumes two arguments and returns +the fully rebuilt result. -/ +theorem tryReduceNatWithSuccMode_binPredSuffixExact + {methods : Methods .anon} {s s' : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {source : KExpr .anon} {headId : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {args suffix : Array (KExpr .anon)} {argA argB result : KExpr .anon} + {isArith : Bool} + (hspine : source.collectSpine = (.const headId us headInfo, args)) + (hargs : args = #[argA, argB] ++ suffix) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = + .ok isArith s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok true s) + (hhelper : (tryReduceNatPredicate headId.addr args).run methods s = + .ok (some result) s') : + (tryReduceNatWithSuccMode source natSuccMode).run methods s = + .ok (some result) s' := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : (args.size == 1) = false := by + rw [hargs] + grind + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : ¬(args.size < 2) := by + rw [hargs] + grind + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + cases isArith <;> + simp only [Bool.not_false, Bool.not_true, Bool.and_false, + Bool.false_eq_true, if_false, if_true] <;> + simpa using hhelper + +/-- A predicate-helper miss is returned unchanged by the exact binary outer +dispatcher, including the helper's partial state. -/ +theorem tryReduceNatWithSuccMode_binPredMiss + {methods : Methods .anon} {s s' : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok false s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok true s) + (hhelper : (tryReduceNatPredicate headId.addr #[argA, argB]).run + methods s = .ok none s') : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = .ok none s' := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + simp only [Bool.not_false, Bool.not_true, Bool.and_false, + Bool.false_eq_true, if_false, if_true] + simpa using hhelper + +/-- A predicate-helper error is propagated unchanged by the exact binary +outer dispatcher, with no later arithmetic work. -/ +theorem tryReduceNatWithSuccMode_binPredError + {methods : Methods .anon} {s s' : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB : KExpr .anon} {err : TcError .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok false s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok true s) + (hhelper : (tryReduceNatPredicate headId.addr #[argA, argB]).run + methods s = .error err s') : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = .error err s' := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + simp only [Bool.not_false, Bool.not_true, Bool.and_false, + Bool.false_eq_true, if_false, if_true] + simpa using hhelper + +/-- Exact production execution for the two-argument arithmetic hit. Keeping +the two classifier equations explicit separates address classification from +the callback/state proof and makes the precedence over Nat predicates +auditable. Since the spine has exactly two arguments, `finishAppResult` +rebuilds an empty suffix and performs no intern-table mutation. -/ +theorem tryReduceNatWithSuccMode_binArithExact + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB argAResult argBResult : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + {a b result : Nat} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok true s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok false s) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractA : extractNatLit argAResult prims = some a) + (hextractB : extractNatLit argBResult prims = some b) + (hcompute : computeNatBin headId.addr PrimAddrs.canonical a b = + some result) : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = + .ok (some (natExprFromValue result)) s₂ := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = + EStateM.Result.ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = EStateM.Result.ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + simp only [Bool.not_true, Bool.not_false, Bool.false_and, + Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hargB] + simp only + rw [hextractA, hextractB] + simp only + rw [hcompute] + simp [finishAppResult] + rfl + +/-- General-spine arithmetic routing. The reducer consumes exactly its first +two arguments, then delegates every trailing argument and its possible intern +table growth to the explicit `finishAppResult` execution premise. -/ +theorem tryReduceNatWithSuccMode_binArithSuffixExact + {methods : Methods .anon} {s s₁ s₂ s₃ : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {source : KExpr .anon} {headId : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {args suffix : Array (KExpr .anon)} + {argA argB argAResult argBResult final : KExpr .anon} + {a b result : Nat} + (hspine : source.collectSpine = (.const headId us headInfo, args)) + (hargs : args = #[argA, argB] ++ suffix) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok true s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok false s) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractA : extractNatLit argAResult prims = some a) + (hextractB : extractNatLit argBResult prims = some b) + (hcompute : computeNatBin headId.addr PrimAddrs.canonical a b = + some result) + (hfinish : + (finishAppResult (natExprFromValue result) args 2).run methods s₂ = + .ok final s₃) : + (tryReduceNatWithSuccMode source natSuccMode).run methods s = + .ok (some final) s₃ := by + have hzero : args[0]! = argA := by + rw [hargs] + grind + have hone : args[1]! = argB := by + rw [hargs] + grind + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : (args.size == 1) = false := by + rw [hargs] + grind + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : ¬(args.size < 2) := by + rw [hargs] + grind + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + simp only [Bool.not_true, Bool.not_false, Bool.false_and, + Bool.false_eq_true, if_false] + rw [hzero] + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [hone] + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hargB] + simp only + rw [hextractA, hextractB] + simp only + rw [hcompute] + simp only [if_true] + rw [ReaderT.run_bind] + change EStateM.bind + ((finishAppResult (natExprFromValue result) args 2).run methods) _ s₂ = _ + unfold EStateM.bind + rw [hfinish] + rfl + +/-- A miss from the first arithmetic argument callback stops the inline +binary reducer at that callback's exact post-state. -/ +theorem tryReduceNatWithSuccMode_binArithArgAMiss + {methods : Methods .anon} {s s₁ : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok true s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok false s) + (hargA : (whnfNatReducerArg argA).run methods s = .ok none s₁) : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = .ok none s₁ := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + simp only [Bool.not_true, Bool.not_false, Bool.false_and, + Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + rfl + +/-- An error from the first arithmetic argument callback is propagated before +the second callback and retains the first callback's partial state. -/ +theorem tryReduceNatWithSuccMode_binArithArgAError + {methods : Methods .anon} {s s₁ : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB : KExpr .anon} {err : TcError .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok true s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok false s) + (hargA : (whnfNatReducerArg argA).run methods s = .error err s₁) : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = .error err s₁ := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + simp only [Bool.not_true, Bool.not_false, Bool.false_and, + Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + +/-- A miss from the second arithmetic argument callback retains both +callbacks' state and prevents literal extraction. -/ +theorem tryReduceNatWithSuccMode_binArithArgBMiss + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB argAResult : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok true s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok false s) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hargB : (whnfNatReducerArg argB).run methods s₁ = .ok none s₂) : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = .ok none s₂ := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + simp only [Bool.not_true, Bool.not_false, Bool.false_and, + Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hargB] + rfl + +/-- An error from the second arithmetic argument callback is propagated at +its exact partial state before either literal extraction. -/ +theorem tryReduceNatWithSuccMode_binArithArgBError + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB argAResult : KExpr .anon} {err : TcError .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok true s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok false s) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hargB : (whnfNatReducerArg argB).run methods s₁ = .error err s₂) : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = .error err s₂ := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + simp only [Bool.not_true, Bool.not_false, Bool.false_and, + Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hargB] + +/-- Arithmetic literal extraction happens only after both callbacks. A miss +on the first result therefore returns at the second callback's post-state. -/ +theorem tryReduceNatWithSuccMode_binArithExtractAMiss + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB argAResult argBResult : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok true s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok false s) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractA : extractNatLit argAResult prims = none) : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = .ok none s₂ := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + simp only [Bool.not_true, Bool.not_false, Bool.false_and, + Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hargB] + simp only + rw [hextractA] + rfl + +/-- A miss on the second normalized arithmetic literal likewise returns at +the second callback's post-state and performs no result construction. -/ +theorem tryReduceNatWithSuccMode_binArithExtractBMiss + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB argAResult argBResult : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} {a : Nat} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok true s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok false s) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractA : extractNatLit argAResult prims = some a) + (hextractB : extractNatLit argBResult prims = none) : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = .ok none s₂ := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + simp only [Bool.not_true, Bool.not_false, Bool.false_and, + Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hargB] + simp only + rw [hextractA, hextractB] + rfl + +/-- Bounded power/shift computations may deliberately decline a literal +pair. That computation miss is pure and returns at the second callback's +post-state. -/ +theorem tryReduceNatWithSuccMode_binArithComputeMiss + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {prims : Primitives .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB argAResult argBResult : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} {a b : Nat} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hprims : s.prims = prims) + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok true s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok false s) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractA : extractNatLit argAResult prims = some a) + (hextractB : extractNatLit argBResult prims = some b) + (hcompute : computeNatBin headId.addr PrimAddrs.canonical a b = none) : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = .ok none s₂ := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok prims s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok prims s + rw [hprims] + rw [hprimsRun] + simp only + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] + simp only [Bool.and_false, Bool.false_eq_true, if_false] + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [harith] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + unfold EStateM.bind + rw [hpred] + simp only [Bool.not_true, Bool.not_false, Bool.false_and, + Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + unfold EStateM.bind + rw [hargA] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hargB] + simp only + rw [hextractA, hextractB] + simp only + rw [hcompute] + simp + rfl + +/-- An execution-indexed account of every effect needed for a successful +exact two-argument Nat predicate reduction. In particular, literal B is +interpreted against the primitive table read after callback A, matching the +production helper rather than silently assuming a frozen state. -/ +inductive NatPredicateSuccessTrace + (methods : Methods .anon) (addr : Address) + (argA argB result : KExpr .anon) + (s s' : TcState .anon) : Prop + | intro {s₁ s₂ : TcState .anon} + {argAResult argBResult : KExpr .anon} {a b : Nat} + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hextractA : extractNatLit argAResult s₁.prims = some a) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractB : extractNatLit argBResult s₁.prims = some b) + (hintern : TcM.intern + (KExpr.mkConst + (if (if addr == s₁.prims.natBeq.addr then a == b else a.ble b) + then s₁.prims.boolTrue else s₁.prims.boolFalse) #[]) s₂ = + .ok result s') : + NatPredicateSuccessTrace methods addr argA argB result s s' + +namespace NatPredicateSuccessTrace + +/-- Erase a predicate success trace to the exact production-helper run. -/ +theorem eval + {methods : Methods .anon} {addr : Address} + {argA argB result : KExpr .anon} {s s' : TcState .anon} + (trace : NatPredicateSuccessTrace methods addr argA argB result s s') : + (tryReduceNatPredicate addr #[argA, argB]).run methods s = + .ok (some result) s' := by + cases trace with + | intro hargA hextractA hargB hextractB hintern => + exact tryReduceNatPredicate_exact hargA rfl hextractA + hargB hextractB rfl hintern + +/-- Every successful exact predicate-helper execution exposes a complete +callback/extraction/intern trace; there is no unclassified success path. -/ +theorem complete + {methods : Methods .anon} {addr : Address} + {argA argB result : KExpr .anon} {s s' : TcState .anon} + (hrun : (tryReduceNatPredicate addr #[argA, argB]).run methods s = + .ok (some result) s') : + NatPredicateSuccessTrace methods addr argA argB result s s' := by + unfold tryReduceNatPredicate at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ at hrun + unfold EStateM.bind at hrun + match hargA : (whnfNatReducerArg argA).run methods s with + | .error err s₁ => + rw [hargA] at hrun + contradiction + | .ok first s₁ => + rw [hargA] at hrun + cases first with + | none => + simp only at hrun + change EStateM.Result.ok none s₁ = .ok (some result) s' at hrun + cases hrun + | some argAResult => + simp only at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind (RecM.prims.run methods) _ s₁ = _ at hrun + unfold EStateM.bind at hrun + have hprims : RecM.prims.run methods s₁ = .ok s₁.prims s₁ := rfl + rw [hprims] at hrun + simp only at hrun + match hextractA : extractNatLit argAResult s₁.prims with + | none => + rw [hextractA] at hrun + change EStateM.Result.ok none s₁ = .ok (some result) s' at hrun + cases hrun + | some a => + rw [hextractA] at hrun + simp only at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = _ + at hrun + unfold EStateM.bind at hrun + match hargB : (whnfNatReducerArg argB).run methods s₁ with + | .error err s₂ => + rw [hargB] at hrun + contradiction + | .ok second s₂ => + rw [hargB] at hrun + cases second with + | none => + simp only at hrun + change EStateM.Result.ok none s₂ = .ok (some result) s' + at hrun + cases hrun + | some argBResult => + simp only at hrun + match hextractB : + extractNatLit argBResult s₁.prims with + | none => + rw [hextractB] at hrun + change EStateM.Result.ok none s₂ = + .ok (some result) s' at hrun + cases hrun + | some b => + rw [hextractB] at hrun + simp only at hrun + rw [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + change EStateM.bind (TcM.intern _) _ s₂ = _ at hrun + unfold EStateM.bind at hrun + match hintern : TcM.intern + (KExpr.mkConst + (if (if addr == s₁.prims.natBeq.addr then + a == b else a.ble b) + then s₁.prims.boolTrue + else s₁.prims.boolFalse) #[]) s₂ with + | .error err s₃ => + rw [hintern] at hrun + contradiction + | .ok interned s₃ => + rw [hintern] at hrun + simp [finishAppResult] at hrun + rcases hrun with ⟨rfl, rfl⟩ + exact .intro hargA hextractA hargB hextractB + hintern + +end NatPredicateSuccessTrace + +/-- The callback, extraction, and pure-computation witnesses for a successful +exact binary arithmetic reduction. The indices expose the only possible +result expression and final state. -/ +inductive NatArithmeticSuccessTrace + (methods : Methods .anon) (addr : Address) + (argA argB : KExpr .anon) (s : TcState .anon) : + KExpr .anon → TcState .anon → Prop + | intro {s₁ s₂ : TcState .anon} + {argAResult argBResult : KExpr .anon} {a b value : Nat} + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractA : extractNatLit argAResult s.prims = some a) + (hextractB : extractNatLit argBResult s.prims = some b) + (hcompute : computeNatBin addr PrimAddrs.canonical a b = some value) : + NatArithmeticSuccessTrace methods addr argA argB s + (natExprFromValue (m := .anon) value) s₂ + +/-- Successful production execution of an exact binary Nat application is +partitioned by the actual classifier results. Predicate precedence is +recorded explicitly; canonical-state semantics later proves its address is +one of `Nat.beq` or `Nat.ble`. -/ +inductive NatBinSuccessTrace + (methods : Methods .anon) (natSuccMode : NatSuccMode) + (headId : KId .anon) (us : Array (KUniv .anon)) + (argA argB : KExpr .anon) + (headInfo firstInfo secondInfo : ExprInfo .anon) + (s : TcState .anon) : KExpr .anon → TcState .anon → Prop + | arithmetic {result : KExpr .anon} {s' : TcState .anon} + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok true s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok false s) + (body : NatArithmeticSuccessTrace methods headId.addr argA argB s + result s') : + NatBinSuccessTrace methods natSuccMode headId us argA argB + headInfo firstInfo secondInfo s result s' + | predicate {result : KExpr .anon} {s' : TcState .anon} {isArith : Bool} + (harith : (isNatBinArithAddr headId.addr).run methods s = + .ok isArith s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok true s) + (body : NatPredicateSuccessTrace methods headId.addr argA argB + result s s') : + NatBinSuccessTrace methods natSuccMode headId us argA argB + headInfo firstInfo secondInfo s result s' + +namespace NatBinSuccessTrace + +/-- Erase either success branch to the exact production dispatcher run. -/ +theorem eval + {methods : Methods .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB result : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + {s s' : TcState .anon} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (trace : NatBinSuccessTrace methods natSuccMode headId us argA argB + headInfo firstInfo secondInfo s result s') : + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = + .ok (some result) s' := by + cases trace with + | arithmetic harith hpred body => + cases body with + | intro hargA hargB hextractA hextractB hcompute => + exact tryReduceNatWithSuccMode_binArithExact hspine rfl + harith hpred hargA hargB hextractA hextractB hcompute + | predicate harith hpred body => + exact tryReduceNatWithSuccMode_binPredAnyExact hspine rfl harith hpred + body.eval + +/-- Invert an arbitrary successful exact-binary production run into one of +the two exhaustive success traces. Every callback, extraction, computation, +and intern witness comes from evaluating the actual dispatcher. -/ +theorem complete + {methods : Methods .anon} {natSuccMode : NatSuccMode} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB result : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + {s s' : TcState .anon} + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hrun : (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s = + .ok (some result) s') : + NatBinSuccessTrace methods natSuccMode headId us argA argB + headInfo firstInfo secondInfo s result s' := by + let isArith := + headId.addr == s.prims.natAdd.addr || + headId.addr == s.prims.natSub.addr || + headId.addr == s.prims.natMul.addr || + headId.addr == s.prims.natDiv.addr || + headId.addr == s.prims.natMod.addr || + headId.addr == s.prims.natPow.addr || + headId.addr == s.prims.natGcd.addr || + headId.addr == s.prims.natLand.addr || + headId.addr == s.prims.natLor.addr || + headId.addr == s.prims.natXor.addr || + headId.addr == s.prims.natShiftLeft.addr || + headId.addr == s.prims.natShiftRight.addr + let isPred := headId.addr == s.prims.natBeq.addr || + headId.addr == s.prims.natBle.addr + have harith : (isNatBinArithAddr headId.addr).run methods s = + .ok isArith s := by + exact isNatBinArithAddr_eval methods s headId.addr + have hpred : (isNatBinPredAddr headId.addr).run methods s = + .ok isPred s := by + exact isNatBinPredAddr_eval methods s headId.addr + unfold tryReduceNatWithSuccMode at hrun + rw [hspine, ReaderT.run_bind] at hrun + change EStateM.bind (RecM.prims.run methods) _ s = _ at hrun + unfold EStateM.bind at hrun + have hprims : RecM.prims.run methods s = .ok s.prims s := rfl + rw [hprims] at hrun + simp only at hrun + have hnotSuccArity : + ((#[argA, argB] : Array (KExpr .anon)).size == 1) = false := by + simp + rw [hnotSuccArity] at hrun + simp only [Bool.and_false, Bool.false_eq_true, if_false] at hrun + have hnotShort : + ¬((#[argA, argB] : Array (KExpr .anon)).size < 2) := by + simp + rw [if_neg hnotShort] at hrun + simp only [pure_bind] at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + at hrun + unfold EStateM.bind at hrun + rw [harith] at hrun + simp only at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + at hrun + unfold EStateM.bind at hrun + rw [hpred] at hrun + cases hisArith : isArith with + | false => + cases hisPred : isPred with + | false => + simp only [hisArith, hisPred, Bool.not_false, + Bool.false_eq_true, if_false] at hrun + change EStateM.Result.ok none s = .ok (some result) s' at hrun + cases hrun + | true => + have harith' : (isNatBinArithAddr headId.addr).run methods s = + .ok false s := by simpa [hisArith] using harith + have hpred' : (isNatBinPredAddr headId.addr).run methods s = + .ok true s := by simpa [hisPred] using hpred + have hhelper : + (tryReduceNatPredicate headId.addr #[argA, argB]).run + methods s = .ok (some result) s' := by + simpa [hisArith, hisPred] using hrun + exact .predicate harith' hpred' + (NatPredicateSuccessTrace.complete hhelper) + | true => + cases hisPred : isPred with + | true => + have harith' : (isNatBinArithAddr headId.addr).run methods s = + .ok true s := by simpa [hisArith] using harith + have hpred' : (isNatBinPredAddr headId.addr).run methods s = + .ok true s := by simpa [hisPred] using hpred + have hhelper : + (tryReduceNatPredicate headId.addr #[argA, argB]).run + methods s = .ok (some result) s' := by + simpa [hisArith, hisPred] using hrun + exact .predicate harith' hpred' + (NatPredicateSuccessTrace.complete hhelper) + | false => + have harith' : (isNatBinArithAddr headId.addr).run methods s = + .ok true s := by simpa [hisArith] using harith + have hpred' : (isNatBinPredAddr headId.addr).run methods s = + .ok false s := by simpa [hisPred] using hpred + simp only [hisArith, hisPred, Bool.not_true, Bool.not_false, + Bool.false_and, Bool.false_eq_true, if_false] at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + at hrun + unfold EStateM.bind at hrun + match hargA : (whnfNatReducerArg argA).run methods s with + | .error err s₁ => + rw [hargA] at hrun + contradiction + | .ok first s₁ => + rw [hargA] at hrun + cases first with + | none => + change EStateM.Result.ok none s₁ = .ok (some result) s' + at hrun + cases hrun + | some argAResult => + simp only at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind + ((whnfNatReducerArg argB).run methods) _ s₁ = _ at hrun + unfold EStateM.bind at hrun + match hargB : (whnfNatReducerArg argB).run methods s₁ with + | .error err s₂ => + rw [hargB] at hrun + contradiction + | .ok second s₂ => + rw [hargB] at hrun + cases second with + | none => + change EStateM.Result.ok none s₂ = + .ok (some result) s' at hrun + cases hrun + | some argBResult => + simp only at hrun + match hextractA : + extractNatLit argAResult s.prims with + | none => + rw [hextractA] at hrun + change EStateM.Result.ok none s₂ = + .ok (some result) s' at hrun + cases hrun + | some a => + rw [hextractA] at hrun + simp only at hrun + match hextractB : + extractNatLit argBResult s.prims with + | none => + rw [hextractB] at hrun + change EStateM.Result.ok none s₂ = + .ok (some result) s' at hrun + cases hrun + | some b => + rw [hextractB] at hrun + simp only at hrun + match hcompute : computeNatBin headId.addr + PrimAddrs.canonical a b with + | none => + rw [hcompute] at hrun + change EStateM.Result.ok none s₂ = + .ok (some result) s' at hrun + cases hrun + | some value => + rw [hcompute] at hrun + simp [finishAppResult] at hrun + rcases hrun with ⟨rfl, rfl⟩ + exact .arithmetic harith' hpred' + (.intro hargA hargB hextractA + hextractB hcompute) + +end NatBinSuccessTrace + +/-- Semantic/state acceptance for the exact binary arithmetic hit. Both +recursive argument calls are checked through the strengthened callback +contract; the final generated-support fact comes from the execution-indexed +context field, and the Theory meaning is assembled from the canonical +primitive reflection proved above. -/ +theorem tryReduceNatWithSuccMode_binArithExact_acceptance + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Δ : KVLCtx} {methods : Methods .anon} + {s s₁ s₂ : TcState .anon} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB argAResult argBResult : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + {sourceV : VExpr} {a b result : Nat} + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Δ s) + (hsourceSupport : support + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) sourceV) + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractA : extractNatLit argAResult s.prims = some a) + (hextractB : extractNatLit argBResult s.prims = some b) + (hcompute : computeNatBin headId.addr PrimAddrs.canonical a b = + some result) : + let source := + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon) + let reduced := natExprFromValue (m := .anon) result + (tryReduceNatWithSuccMode source natSuccMode).run methods s = + .ok (some reduced) s₂ ∧ + WhnfStateInv .noAccel semantics trProj world support uvars Δ s₂ ∧ + support reduced ∧ + WhnfMeaning trProj world uvars Δ source reduced := by + dsimp only + have hcatalog := hI.1.core.trustedCatalog + have hΔ := hI.2.1.wf + have hcanonical := hI.noAccel_primitives + have htable := context.stateTable hI + obtain ⟨harith, hpred⟩ := context.computeNatBin_classifiers hI hcompute + obtain ⟨name, hname, hreflect⟩ := + context.computeNatBin_defeq hcatalog hcanonical hcompute + obtain ⟨argAV, argBV, hsourceV, hargATr, hargBTr⟩ := + hsource.natBinExact_inv hΔ hname hreflect + subst sourceV + have hinputSupport := context.inputs.spine hsourceSupport hspine + have hargASupport : support argA := by + simpa using hinputSupport.2 0 (by simp) + have hargBSupport : support argB := by + simpa using hinputSupport.2 1 (by simp) + have hargAPost := + whnfNatReducerArg_post_wf hargASupport hargATr methods hmethods hI + rw [hargA] at hargAPost + change WhnfStateInv .noAccel semantics trProj world support uvars Δ s₁ ∧ + support argAResult ∧ + WhnfPost trProj world uvars Δ argAV argAResult at hargAPost + have hargBPost := + whnfNatReducerArg_post_wf hargBSupport hargBTr methods hmethods + hargAPost.1 + rw [hargB] at hargBPost + change WhnfStateInv .noAccel semantics trProj world support uvars Δ s₂ ∧ + support argBResult ∧ + WhnfPost trProj world uvars Δ argBV argBResult at hargBPost + have hrun := tryReduceNatWithSuccMode_binArithExact + (natSuccMode := natSuccMode) hspine rfl + harith hpred hargA hargB hextractA hextractB hcompute + have hresultSupport := context.generated.nat hsourceSupport hrun + have hresultTr : TrKExprS world.venv uvars world.nameOf trProj Δ + (natExprFromValue (m := .anon) result) (.natLit result) := + TrKExprS.natExprFromValue hcatalog htable result + have hmeaning := WhnfMeaning.natBinExact hΔ htable + context.theoryPrimitives hsource hargAPost.2.2 hargBPost.2.2 + hextractA hextractB hreflect hresultTr + exact ⟨hrun, hargBPost.1, hresultSupport, hmeaning⟩ + +/-- End-to-end arithmetic acceptance for a production spine with an arbitrary +trailing argument suffix. The finite `FinishAppRequests` witness accounts +for every dynamically interned application node; `collectSpine` translation +inversion and application congruence transport the exact binary primitive +equation across that unchanged suffix. -/ +theorem tryReduceNatWithSuccMode_binArithSuffix_acceptance + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s s₁ s₂ : TcState .anon} + {source : KExpr .anon} {headId : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {args suffix : Array (KExpr .anon)} + {argA argB argAResult argBResult final : KExpr .anon} + {sourceV : VExpr} {a b result : Nat} + (hrun : RunAssumptions initial program requests support) + (theory : WhnfTheory trProj world uvars) + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Delta s) + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + source sourceV) + (hspine : source.collectSpine = (.const headId us headInfo, args)) + (hargs : args = #[argA, argB] ++ suffix) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractA : extractNatLit argAResult s.prims = some a) + (hextractB : extractNatLit argBResult s.prims = some b) + (hcompute : computeNatBin headId.addr PrimAddrs.canonical a b = + some result) + (hfinish : FinishAppRequests requests + (args.extract 2 args.size).toList + (natExprFromValue (m := .anon) result) final) : + ∃ s₃, + (tryReduceNatWithSuccMode source natSuccMode).run methods s = + .ok (some final) s₃ ∧ + WhnfStateInv .noAccel semantics trProj world support uvars Delta s₃ ∧ + support final ∧ + WhnfMeaning trProj world uvars Delta source final := by + have hcatalog := hI.1.core.trustedCatalog + have hDelta := hI.2.1.wf + have hcanonical := hI.noAccel_primitives + have htable := context.stateTable hI + obtain ⟨harith, hpred⟩ := context.computeNatBin_classifiers hI hcompute + obtain ⟨name, hname, hreflect⟩ := + context.computeNatBin_defeq hcatalog hcanonical hcompute + have hspineTr := trAppSpine_of_collectSpine hsource hspine + have hcanonicalSource : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkAppN (.const headId us headInfo) args) sourceV := by + rw [KExpr.mkAppN] + simpa only [Array.foldl_toList] using hspineTr.tr + have hcanonicalSuffix : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkAppN + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB) + suffix) sourceV := by + simpa [hargs, KExpr.mkAppN] using hcanonicalSource + have hcanonicalSuffixList : + TrKExprS world.venv uvars world.nameOf trProj Delta + (suffix.toList.foldl KExpr.mkApp + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB)) + sourceV := by + simpa only [KExpr.mkAppN, Array.foldl_toList] using hcanonicalSuffix + obtain ⟨baseV, hbaseTr⟩ := + TrKExprS.foldlMkApp_initial (rest := suffix.toList) + hcanonicalSuffixList + have hbaseTrExact := hbaseTr + rw [KExpr.mkApp_shape, KExpr.mkApp_shape] at hbaseTrExact + obtain ⟨argAV, argBV, hbaseV, hargATr, hargBTr⟩ := + hbaseTrExact.natBinExact_inv hDelta hname hreflect + subst baseV + have hinputSupport := context.inputs.spine hsourceSupport hspine + have hargASupport : support argA := by + simpa [hargs] using hinputSupport.2 0 (by + rw [hargs] + grind) + have hargBSupport : support argB := by + simpa [hargs] using hinputSupport.2 1 (by + rw [hargs] + grind) + have hargAPost := + whnfNatReducerArg_post_wf hargASupport hargATr methods hmethods hI + rw [hargA] at hargAPost + change WhnfStateInv .noAccel semantics trProj world support uvars Delta s₁ ∧ + support argAResult ∧ + WhnfPost trProj world uvars Delta argAV argAResult at hargAPost + have hargBPost := + whnfNatReducerArg_post_wf hargBSupport hargBTr methods hmethods + hargAPost.1 + rw [hargB] at hargBPost + change WhnfStateInv .noAccel semantics trProj world support uvars Delta s₂ ∧ + support argBResult ∧ + WhnfPost trProj world uvars Delta argBV argBResult at hargBPost + obtain ⟨s₃, hfinishRun, hI₃, _⟩ := hfinish.eval hrun hargBPost.1 + have hactualRun := tryReduceNatWithSuccMode_binArithSuffixExact + (natSuccMode := natSuccMode) hspine hargs rfl harith hpred hargA hargB + hextractA hextractB hcompute hfinishRun + have hresultSupport := context.generated.nat hsourceSupport hactualRun + have hresultTr : TrKExprS world.venv uvars world.nameOf trProj Delta + (natExprFromValue (m := .anon) result) (.natLit result) := + TrKExprS.natExprFromValue hcatalog htable result + have hbaseMeaningExact := WhnfMeaning.natBinExact hDelta htable + context.theoryPrimitives hbaseTrExact hargAPost.2.2 hargBPost.2.2 + hextractA hextractB hreflect hresultTr + have hbaseMeaning : WhnfMeaning trProj world uvars Delta + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB) + (natExprFromValue (m := .anon) result) := by + rw [KExpr.mkApp_shape, KExpr.mkApp_shape] + exact hbaseMeaningExact + have hcanonicalMeaning := WhnfMeaning.mkAppN theory hDelta + hcanonicalSuffix hbaseMeaning + have hsuffix : args.extract 2 args.size = suffix := by + rw [hargs] + grind + have hfinal := hfinish.final_eq_spec + rw [finishAppResultSpec, hsuffix] at hfinal + subst final + have hmeaning := WhnfMeaning.ofSharedSourceTranslation theory hDelta + hsource hcanonicalSuffix hcanonicalMeaning + exact ⟨s₃, hactualRun, hI₃, hresultSupport, hmeaning⟩ + +/-- End-to-end acceptance of an exact two-argument `Nat.beq` or `Nat.ble` +application. The first callback precedes the primitive-table read exactly as +in production; the selected Bool node is then interned through the finite +collision/support boundary before the reflected predicate equation is +composed with both callback posts. -/ +theorem tryReduceNatWithSuccMode_binPredExact_acceptance + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Δ : KVLCtx} {methods : Methods .anon} + {s s₁ s₂ : TcState .anon} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB argAResult argBResult : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + {sourceV : VExpr} {a b : Nat} + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Δ s) + (hsourceSupport : support + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) sourceV) + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (haddr : headId.addr = s.prims.natBeq.addr ∨ + headId.addr = s.prims.natBle.addr) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hextractA : extractNatLit argAResult s₁.prims = some a) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractB : extractNatLit argBResult s₁.prims = some b) : + let source := + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon) + let decision := + if headId.addr == s₁.prims.natBeq.addr then a == b else a.ble b + let reduced := KExpr.mkConst + (if decision then s₁.prims.boolTrue else s₁.prims.boolFalse) #[] + ∃ s₃, + (tryReduceNatWithSuccMode source natSuccMode).run methods s = + .ok (some reduced) s₃ ∧ + WhnfStateInv .noAccel semantics trProj world support uvars Δ s₃ ∧ + support reduced ∧ + WhnfMeaning trProj world uvars Δ source reduced := by + dsimp only + have hcatalog := hI.1.core.trustedCatalog + have hΔ := hI.2.1.wf + let .app _ _ hprefixTr hargBTr := hsource + let .app _ _ hheadTr hargATr := hprefixTr + have hinputSupport := context.inputs.spine hsourceSupport hspine + have hargASupport : support argA := by + simpa using hinputSupport.2 0 (by simp) + have hargBSupport : support argB := by + simpa using hinputSupport.2 1 (by simp) + have hargAPost := + whnfNatReducerArg_post_wf hargASupport hargATr methods hmethods hI + rw [hargA] at hargAPost + change WhnfStateInv .noAccel semantics trProj world support uvars Δ s₁ ∧ + support argAResult ∧ + WhnfPost trProj world uvars Δ _ argAResult at hargAPost + have hcanonical₀ := hI.noAccel_primitives + have hcanonical₁ := hargAPost.1.noAccel_primitives + have hbeq₀ : s.prims.natBeq.addr = PrimAddrs.canonical.natBeq := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natBeq hcanonical₀ + have hble₀ : s.prims.natBle.addr = PrimAddrs.canonical.natBle := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natBle hcanonical₀ + have hbeq₁ : s₁.prims.natBeq.addr = PrimAddrs.canonical.natBeq := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natBeq hcanonical₁ + have hble₁ : s₁.prims.natBle.addr = PrimAddrs.canonical.natBle := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natBle hcanonical₁ + have haddr₁ : headId.addr = s₁.prims.natBeq.addr ∨ + headId.addr = s₁.prims.natBle.addr := by + rcases haddr with hbeq | hble + · exact .inl (hbeq.trans (hbeq₀.trans hbeq₁.symm)) + · exact .inr (hble.trans (hble₀.trans hble₁.symm)) + obtain ⟨harith, hpred⟩ := context.natPredicate_classifiers hI haddr + obtain ⟨name, decision, hname, hdecision, hreflect⟩ := + context.natPredicate_defeq hcatalog hcanonical₁ haddr₁ + subst decision + obtain ⟨argAV, argBV, hsourceV, hargATrExact, hargBTrExact⟩ := + hsource.natBinExact_inv hΔ hname hreflect + subst sourceV + have hargAPostExact := + whnfNatReducerArg_post_wf hargASupport hargATrExact methods hmethods hI + rw [hargA] at hargAPostExact + change WhnfStateInv .noAccel semantics trProj world support uvars Δ s₁ ∧ + support argAResult ∧ + WhnfPost trProj world uvars Δ argAV argAResult at hargAPostExact + have hargBPost := + whnfNatReducerArg_post_wf hargBSupport hargBTrExact methods hmethods + hargAPostExact.1 + rw [hargB] at hargBPost + change WhnfStateInv .noAccel semantics trProj world support uvars Δ s₂ ∧ + support argBResult ∧ + WhnfPost trProj world uvars Δ _ argBResult at hargBPost + let reduced := KExpr.mkConst + (if (if headId.addr == s₁.prims.natBeq.addr then a == b else a.ble b) + then s₁.prims.boolTrue else s₁.prims.boolFalse) #[] + have hreducedSupport : support reduced := by + exact context.generated.boolConst hcanonical₁ _ + obtain ⟨s₃, hintern, hI₃, _⟩ := + TcM.intern_whnf_eval context.collisionFree hreducedSupport hargBPost.1 + have hhelper := tryReduceNatPredicate_exact + (prims := s₁.prims) (addr := headId.addr) + hargA rfl hextractA hargB hextractB rfl hintern + have hrun := tryReduceNatWithSuccMode_binPredExact + (natSuccMode := natSuccMode) hspine rfl harith hpred hhelper + have htable := context.stateTable hargAPostExact.1 + have hresultTr : TrKExprS world.venv uvars world.nameOf trProj Δ reduced + (.boolLit + (if headId.addr == s₁.prims.natBeq.addr then a == b else a.ble b)) := + TrKExprS.boolExprFromDecision hcatalog htable + context.theoryPrimitives _ + have hmeaning := WhnfMeaning.natBinExact hΔ htable + context.theoryPrimitives hsource hargAPostExact.2.2 hargBPost.2.2 + hextractA hextractB hreflect hresultTr + exact ⟨s₃, hrun, hI₃, hreducedSupport, hmeaning⟩ + +/-- End-to-end predicate acceptance for a binary Nat application with an +arbitrary trailing suffix. The selected Bool constant is interned first; +the finite suffix certificate then accounts for every rebuilt application. +Both phases preserve the checker invariant, and unchanged-argument +congruence transports the reflected predicate equation to the final spine. -/ +theorem tryReduceNatWithSuccMode_binPredSuffix_acceptance + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s s₁ s₂ : TcState .anon} + {source : KExpr .anon} {headId : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {args suffix : Array (KExpr .anon)} + {argA argB argAResult argBResult final : KExpr .anon} + {sourceV : VExpr} {a b : Nat} + (hrun : RunAssumptions initial program requests support) + (theory : WhnfTheory trProj world uvars) + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Delta s) + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + source sourceV) + (hspine : source.collectSpine = (.const headId us headInfo, args)) + (hargs : args = #[argA, argB] ++ suffix) + (haddr : headId.addr = s.prims.natBeq.addr ∨ + headId.addr = s.prims.natBle.addr) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hextractA : extractNatLit argAResult s₁.prims = some a) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractB : extractNatLit argBResult s₁.prims = some b) + (hfinish : FinishAppRequests requests + (args.extract 2 args.size).toList + (KExpr.mkConst + (if (if headId.addr == s₁.prims.natBeq.addr then a == b else a.ble b) + then s₁.prims.boolTrue else s₁.prims.boolFalse) #[]) + final) : + ∃ s₄, + (tryReduceNatWithSuccMode source natSuccMode).run methods s = + .ok (some final) s₄ ∧ + WhnfStateInv .noAccel semantics trProj world support uvars Delta s₄ ∧ + support final ∧ + WhnfMeaning trProj world uvars Delta source final := by + have hcatalog := hI.1.core.trustedCatalog + have hDelta := hI.2.1.wf + have hspineTr := trAppSpine_of_collectSpine hsource hspine + have hcanonicalSource : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkAppN (.const headId us headInfo) args) sourceV := by + rw [KExpr.mkAppN] + simpa only [Array.foldl_toList] using hspineTr.tr + have hcanonicalSuffix : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkAppN + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB) + suffix) sourceV := by + simpa [hargs, KExpr.mkAppN] using hcanonicalSource + have hcanonicalSuffixList : + TrKExprS world.venv uvars world.nameOf trProj Delta + (suffix.toList.foldl KExpr.mkApp + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB)) + sourceV := by + simpa only [KExpr.mkAppN, Array.foldl_toList] using hcanonicalSuffix + obtain ⟨baseV, hbaseTr⟩ := + TrKExprS.foldlMkApp_initial (rest := suffix.toList) + hcanonicalSuffixList + have hbaseTrExact := hbaseTr + rw [KExpr.mkApp_shape, KExpr.mkApp_shape] at hbaseTrExact + let .app _ _ hprefixTr hargBTr := hbaseTrExact + let .app _ _ _ hargATr := hprefixTr + have hinputSupport := context.inputs.spine hsourceSupport hspine + have hargASupport : support argA := by + simpa [hargs] using hinputSupport.2 0 (by + rw [hargs] + grind) + have hargBSupport : support argB := by + simpa [hargs] using hinputSupport.2 1 (by + rw [hargs] + grind) + have hargAPost := + whnfNatReducerArg_post_wf hargASupport hargATr methods hmethods hI + rw [hargA] at hargAPost + change WhnfStateInv .noAccel semantics trProj world support uvars Delta s₁ ∧ + support argAResult ∧ + WhnfPost trProj world uvars Delta _ argAResult at hargAPost + have hcanonical₀ := hI.noAccel_primitives + have hcanonical₁ := hargAPost.1.noAccel_primitives + have hbeq₀ : s.prims.natBeq.addr = PrimAddrs.canonical.natBeq := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natBeq hcanonical₀ + have hble₀ : s.prims.natBle.addr = PrimAddrs.canonical.natBle := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natBle hcanonical₀ + have hbeq₁ : s₁.prims.natBeq.addr = PrimAddrs.canonical.natBeq := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natBeq hcanonical₁ + have hble₁ : s₁.prims.natBle.addr = PrimAddrs.canonical.natBle := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natBle hcanonical₁ + have haddr₁ : headId.addr = s₁.prims.natBeq.addr ∨ + headId.addr = s₁.prims.natBle.addr := by + rcases haddr with hbeq | hble + · exact .inl (hbeq.trans (hbeq₀.trans hbeq₁.symm)) + · exact .inr (hble.trans (hble₀.trans hble₁.symm)) + obtain ⟨harith, hpred⟩ := context.natPredicate_classifiers hI haddr + obtain ⟨name, decision, hname, hdecision, hreflect⟩ := + context.natPredicate_defeq hcatalog hcanonical₁ haddr₁ + subst decision + obtain ⟨argAV, argBV, hbaseV, hargATrExact, hargBTrExact⟩ := + hbaseTrExact.natBinExact_inv hDelta hname hreflect + subst baseV + have hargAPostExact := + whnfNatReducerArg_post_wf hargASupport hargATrExact methods hmethods hI + rw [hargA] at hargAPostExact + change WhnfStateInv .noAccel semantics trProj world support uvars Delta s₁ ∧ + support argAResult ∧ + WhnfPost trProj world uvars Delta argAV argAResult at hargAPostExact + have hargBPost := + whnfNatReducerArg_post_wf hargBSupport hargBTrExact methods hmethods + hargAPostExact.1 + rw [hargB] at hargBPost + change WhnfStateInv .noAccel semantics trProj world support uvars Delta s₂ ∧ + support argBResult ∧ + WhnfPost trProj world uvars Delta argBV argBResult at hargBPost + let decision := + if headId.addr == s₁.prims.natBeq.addr then a == b else a.ble b + let reduced := KExpr.mkConst + (if decision then s₁.prims.boolTrue else s₁.prims.boolFalse) #[] + have hreducedSupport : support reduced := by + exact context.generated.boolConst hcanonical₁ _ + obtain ⟨s₃, hintern, hI₃, _⟩ := + TcM.intern_whnf_eval context.collisionFree hreducedSupport hargBPost.1 + change FinishAppRequests requests + (args.extract 2 args.size).toList reduced final at hfinish + obtain ⟨s₄, hfinishRun, hI₄, _⟩ := hfinish.eval hrun hI₃ + have hhelper := tryReduceNatPredicate_suffixExact + (prims := s₁.prims) (addr := headId.addr) + (decision := decision) (base := reduced) hargs hargA rfl hextractA + hargB hextractB rfl rfl hintern hfinishRun + have hactualRun := tryReduceNatWithSuccMode_binPredSuffixExact + (natSuccMode := natSuccMode) hspine hargs rfl harith hpred hhelper + have hresultSupport := context.generated.nat hsourceSupport hactualRun + have htable := context.stateTable hargAPostExact.1 + have hresultTr : TrKExprS world.venv uvars world.nameOf trProj Delta reduced + (.boolLit decision) := + TrKExprS.boolExprFromDecision hcatalog htable + context.theoryPrimitives _ + have hbaseMeaningExact := WhnfMeaning.natBinExact hDelta htable + context.theoryPrimitives hbaseTrExact hargAPostExact.2.2 hargBPost.2.2 + hextractA hextractB hreflect hresultTr + have hbaseMeaning : WhnfMeaning trProj world uvars Delta + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB) + reduced := by + rw [KExpr.mkApp_shape, KExpr.mkApp_shape] + exact hbaseMeaningExact + have hcanonicalMeaning := WhnfMeaning.mkAppN theory hDelta + hcanonicalSuffix hbaseMeaning + have hsuffix : args.extract 2 args.size = suffix := by + rw [hargs] + grind + have hfinal := hfinish.final_eq_spec + rw [finishAppResultSpec, hsuffix] at hfinal + subst final + have hmeaning := WhnfMeaning.ofSharedSourceTranslation theory hDelta + hsource hcanonicalSuffix hcanonicalMeaning + exact ⟨s₄, hactualRun, hI₄, hresultSupport, hmeaning⟩ + +/-- Exhaustive operational witness for a successful predicate helper on a +general application spine. Unlike the exact-binary trace, it records both +the expression returned by Bool interning and the subsequent suffix rebuild. -/ +inductive NatPredicateSuffixSuccessTrace + (methods : Methods .anon) (addr : Address) + (args : Array (KExpr .anon)) (argA argB : KExpr .anon) + (s : TcState .anon) : KExpr .anon → TcState .anon → Prop + | intro {s₁ s₂ s₃ s₄ : TcState .anon} + {argAResult argBResult requested base final : KExpr .anon} + {a b : Nat} + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hextractA : extractNatLit argAResult s₁.prims = some a) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractB : extractNatLit argBResult s₁.prims = some b) + (hrequested : requested = KExpr.mkConst + (if (if addr == s₁.prims.natBeq.addr then a == b else a.ble b) + then s₁.prims.boolTrue else s₁.prims.boolFalse) #[]) + (hintern : TcM.intern requested s₂ = .ok base s₃) + (hfinish : (finishAppResult base args 2).run methods s₃ = + .ok final s₄) : + NatPredicateSuffixSuccessTrace methods addr args argA argB s final s₄ + +namespace NatPredicateSuffixSuccessTrace + +/-- Erase a general predicate trace to the exact production helper run. -/ +theorem eval + {methods : Methods .anon} {addr : Address} + {args suffix : Array (KExpr .anon)} {argA argB result : KExpr .anon} + {s s' : TcState .anon} + (hargs : args = #[argA, argB] ++ suffix) + (trace : NatPredicateSuffixSuccessTrace methods addr args argA argB + s result s') : + (tryReduceNatPredicate addr args).run methods s = + .ok (some result) s' := by + cases trace with + | intro hargA hextractA hargB hextractB hrequested hintern hfinish => + exact tryReduceNatPredicate_suffixExact + (prims := _) (decision := _) hargs hargA rfl hextractA hargB + hextractB rfl hrequested hintern hfinish + +/-- Every successful general predicate-helper execution exposes its complete +callback, extraction, Bool-intern, and suffix-rebuild trace. -/ +theorem complete + {methods : Methods .anon} {addr : Address} + {args suffix : Array (KExpr .anon)} {argA argB result : KExpr .anon} + {s s' : TcState .anon} + (hargs : args = #[argA, argB] ++ suffix) + (hrun : (tryReduceNatPredicate addr args).run methods s = + .ok (some result) s') : + NatPredicateSuffixSuccessTrace methods addr args argA argB + s result s' := by + have hzero : args[0]! = argA := by + rw [hargs] + grind + have hone : args[1]! = argB := by + rw [hargs] + grind + unfold tryReduceNatPredicate at hrun + rw [hzero, hone, ReaderT.run_bind] at hrun + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ at hrun + unfold EStateM.bind at hrun + match hargA : (whnfNatReducerArg argA).run methods s with + | .error err s₁ => + rw [hargA] at hrun + contradiction + | .ok first s₁ => + rw [hargA] at hrun + cases first with + | none => + simp only at hrun + change EStateM.Result.ok none s₁ = .ok (some result) s' at hrun + cases hrun + | some argAResult => + simp only at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind (RecM.prims.run methods) _ s₁ = _ at hrun + unfold EStateM.bind at hrun + have hprims : RecM.prims.run methods s₁ = .ok s₁.prims s₁ := rfl + rw [hprims] at hrun + simp only at hrun + match hextractA : extractNatLit argAResult s₁.prims with + | none => + rw [hextractA] at hrun + change EStateM.Result.ok none s₁ = .ok (some result) s' + at hrun + cases hrun + | some a => + rw [hextractA] at hrun + simp only at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind + ((whnfNatReducerArg argB).run methods) _ s₁ = _ at hrun + unfold EStateM.bind at hrun + match hargB : (whnfNatReducerArg argB).run methods s₁ with + | .error err s₂ => + rw [hargB] at hrun + contradiction + | .ok second s₂ => + rw [hargB] at hrun + cases second with + | none => + simp only at hrun + change EStateM.Result.ok none s₂ = + .ok (some result) s' at hrun + cases hrun + | some argBResult => + simp only at hrun + match hextractB : + extractNatLit argBResult s₁.prims with + | none => + rw [hextractB] at hrun + change EStateM.Result.ok none s₂ = + .ok (some result) s' at hrun + cases hrun + | some b => + rw [hextractB] at hrun + simp only at hrun + rw [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + change EStateM.bind (TcM.intern _) _ s₂ = _ at hrun + unfold EStateM.bind at hrun + let requested := KExpr.mkConst + (if (if addr == s₁.prims.natBeq.addr then + a == b else a.ble b) + then s₁.prims.boolTrue + else s₁.prims.boolFalse) #[] + match hintern : TcM.intern requested s₂ with + | .error err s₃ => + rw [hintern] at hrun + contradiction + | .ok base s₃ => + rw [hintern] at hrun + simp only at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind + ((finishAppResult base args 2).run methods) _ s₃ = _ + at hrun + unfold EStateM.bind at hrun + match hfinish : + (finishAppResult base args 2).run methods s₃ with + | .error err s₄ => + rw [hfinish] at hrun + contradiction + | .ok final s₄ => + rw [hfinish] at hrun + simp only at hrun + rcases hrun with ⟨rfl, rfl⟩ + exact .intro hargA hextractA hargB hextractB + rfl hintern hfinish + +end NatPredicateSuffixSuccessTrace + +/-- Callback, extraction, computation, and suffix-rebuild witnesses for a +successful arithmetic branch on a general application spine. -/ +inductive NatArithmeticSuffixSuccessTrace + (methods : Methods .anon) (addr : Address) + (args : Array (KExpr .anon)) (argA argB : KExpr .anon) + (s : TcState .anon) : KExpr .anon → TcState .anon → Prop + | intro {s₁ s₂ s₃ : TcState .anon} + {argAResult argBResult final : KExpr .anon} {a b value : Nat} + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractA : extractNatLit argAResult s.prims = some a) + (hextractB : extractNatLit argBResult s.prims = some b) + (hcompute : computeNatBin addr PrimAddrs.canonical a b = some value) + (hfinish : + (finishAppResult (natExprFromValue (m := .anon) value) args 2).run + methods s₂ = .ok final s₃) : + NatArithmeticSuffixSuccessTrace methods addr args argA argB s final s₃ + +/-- Every successful production run on a spine with at least two arguments +is partitioned by the actual classifier results. The trace retains the +entire suffix-rebuild run instead of collapsing it to the exact-binary case. -/ +inductive NatSpineSuccessTrace + (methods : Methods .anon) (natSuccMode : NatSuccMode) + (source : KExpr .anon) (headId : KId .anon) + (us : Array (KUniv .anon)) (headInfo : ExprInfo .anon) + (args : Array (KExpr .anon)) (argA argB : KExpr .anon) + (s : TcState .anon) : KExpr .anon → TcState .anon → Prop + | arithmetic {result : KExpr .anon} {s' : TcState .anon} + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok true s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok false s) + (body : NatArithmeticSuffixSuccessTrace methods headId.addr args + argA argB s result s') : + NatSpineSuccessTrace methods natSuccMode source headId us headInfo + args argA argB s result s' + | predicate {result : KExpr .anon} {s' : TcState .anon} + {isArith : Bool} + (harith : (isNatBinArithAddr headId.addr).run methods s = + .ok isArith s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok true s) + (body : NatPredicateSuffixSuccessTrace methods headId.addr args + argA argB s result s') : + NatSpineSuccessTrace methods natSuccMode source headId us headInfo + args argA argB s result s' + +namespace NatSpineSuccessTrace + +/-- Erase either general-spine success trace to the production dispatcher. -/ +theorem eval + {methods : Methods .anon} {natSuccMode : NatSuccMode} + {source : KExpr .anon} {headId : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {args suffix : Array (KExpr .anon)} {argA argB result : KExpr .anon} + {s s' : TcState .anon} + (hspine : source.collectSpine = (.const headId us headInfo, args)) + (hargs : args = #[argA, argB] ++ suffix) + (trace : NatSpineSuccessTrace methods natSuccMode source headId us + headInfo args argA argB s result s') : + (tryReduceNatWithSuccMode source natSuccMode).run methods s = + .ok (some result) s' := by + cases trace with + | arithmetic harith hpred body => + cases body with + | intro hargA hargB hextractA hextractB hcompute hfinish => + exact tryReduceNatWithSuccMode_binArithSuffixExact hspine hargs rfl + harith hpred hargA hargB hextractA hextractB hcompute hfinish + | predicate harith hpred body => + exact tryReduceNatWithSuccMode_binPredSuffixExact hspine hargs rfl + harith hpred (body.eval hargs) + +/-- Invert an arbitrary successful general-spine production run. All +callback, extraction, computation, Bool-intern, and suffix-rebuild equations +come from evaluating the actual dispatcher. -/ +theorem complete + {methods : Methods .anon} {natSuccMode : NatSuccMode} + {source : KExpr .anon} {headId : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {args suffix : Array (KExpr .anon)} {argA argB result : KExpr .anon} + {s s' : TcState .anon} + (hspine : source.collectSpine = (.const headId us headInfo, args)) + (hargs : args = #[argA, argB] ++ suffix) + (hrun : (tryReduceNatWithSuccMode source natSuccMode).run methods s = + .ok (some result) s') : + NatSpineSuccessTrace methods natSuccMode source headId us headInfo + args argA argB s result s' := by + let isArith := + headId.addr == s.prims.natAdd.addr || + headId.addr == s.prims.natSub.addr || + headId.addr == s.prims.natMul.addr || + headId.addr == s.prims.natDiv.addr || + headId.addr == s.prims.natMod.addr || + headId.addr == s.prims.natPow.addr || + headId.addr == s.prims.natGcd.addr || + headId.addr == s.prims.natLand.addr || + headId.addr == s.prims.natLor.addr || + headId.addr == s.prims.natXor.addr || + headId.addr == s.prims.natShiftLeft.addr || + headId.addr == s.prims.natShiftRight.addr + let isPred := headId.addr == s.prims.natBeq.addr || + headId.addr == s.prims.natBle.addr + have harith : (isNatBinArithAddr headId.addr).run methods s = + .ok isArith s := isNatBinArithAddr_eval methods s headId.addr + have hpred : (isNatBinPredAddr headId.addr).run methods s = + .ok isPred s := isNatBinPredAddr_eval methods s headId.addr + have hzero : args[0]! = argA := by + rw [hargs] + grind + have hone : args[1]! = argB := by + rw [hargs] + grind + unfold tryReduceNatWithSuccMode at hrun + rw [hspine, ReaderT.run_bind] at hrun + change EStateM.bind (RecM.prims.run methods) _ s = _ at hrun + unfold EStateM.bind at hrun + have hprims : RecM.prims.run methods s = .ok s.prims s := rfl + rw [hprims] at hrun + simp only at hrun + have hnotSuccArity : (args.size == 1) = false := by + rw [hargs] + grind + rw [hnotSuccArity] at hrun + simp only [Bool.and_false, Bool.false_eq_true, if_false] at hrun + have hnotShort : ¬(args.size < 2) := by + rw [hargs] + grind + rw [if_neg hnotShort] at hrun + simp only [pure_bind] at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = _ + at hrun + unfold EStateM.bind at hrun + rw [harith] at hrun + simp only at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = _ + at hrun + unfold EStateM.bind at hrun + rw [hpred] at hrun + cases hisArith : isArith with + | false => + cases hisPred : isPred with + | false => + simp only [hisArith, hisPred, Bool.not_false, + Bool.false_eq_true, if_false] at hrun + change EStateM.Result.ok none s = .ok (some result) s' at hrun + cases hrun + | true => + have harith' : (isNatBinArithAddr headId.addr).run methods s = + .ok false s := by simpa [hisArith] using harith + have hpred' : (isNatBinPredAddr headId.addr).run methods s = + .ok true s := by simpa [hisPred] using hpred + have hhelper : (tryReduceNatPredicate headId.addr args).run + methods s = .ok (some result) s' := by + simpa [hisArith, hisPred] using hrun + exact .predicate harith' hpred' + (NatPredicateSuffixSuccessTrace.complete hargs hhelper) + | true => + cases hisPred : isPred with + | true => + have harith' : (isNatBinArithAddr headId.addr).run methods s = + .ok true s := by simpa [hisArith] using harith + have hpred' : (isNatBinPredAddr headId.addr).run methods s = + .ok true s := by simpa [hisPred] using hpred + have hhelper : (tryReduceNatPredicate headId.addr args).run + methods s = .ok (some result) s' := by + simpa [hisArith, hisPred] using hrun + exact .predicate harith' hpred' + (NatPredicateSuffixSuccessTrace.complete hargs hhelper) + | false => + have harith' : (isNatBinArithAddr headId.addr).run methods s = + .ok true s := by simpa [hisArith] using harith + have hpred' : (isNatBinPredAddr headId.addr).run methods s = + .ok false s := by simpa [hisPred] using hpred + simp only [hisArith, hisPred, Bool.not_true, Bool.not_false, + Bool.false_and, Bool.false_eq_true, if_false] at hrun + rw [hzero] at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = _ + at hrun + unfold EStateM.bind at hrun + match hargA : (whnfNatReducerArg argA).run methods s with + | .error err s₁ => + rw [hargA] at hrun + contradiction + | .ok first s₁ => + rw [hargA] at hrun + cases first with + | none => + change EStateM.Result.ok none s₁ = .ok (some result) s' + at hrun + cases hrun + | some argAResult => + simp only at hrun + rw [hone] at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind + ((whnfNatReducerArg argB).run methods) _ s₁ = _ at hrun + unfold EStateM.bind at hrun + match hargB : (whnfNatReducerArg argB).run methods s₁ with + | .error err s₂ => + rw [hargB] at hrun + contradiction + | .ok second s₂ => + rw [hargB] at hrun + cases second with + | none => + change EStateM.Result.ok none s₂ = + .ok (some result) s' at hrun + cases hrun + | some argBResult => + simp only at hrun + match hextractA : + extractNatLit argAResult s.prims with + | none => + rw [hextractA] at hrun + change EStateM.Result.ok none s₂ = + .ok (some result) s' at hrun + cases hrun + | some a => + rw [hextractA] at hrun + simp only at hrun + match hextractB : + extractNatLit argBResult s.prims with + | none => + rw [hextractB] at hrun + change EStateM.Result.ok none s₂ = + .ok (some result) s' at hrun + cases hrun + | some b => + rw [hextractB] at hrun + simp only at hrun + match hcompute : computeNatBin headId.addr + PrimAddrs.canonical a b with + | none => + rw [hcompute] at hrun + change EStateM.Result.ok none s₂ = + .ok (some result) s' at hrun + cases hrun + | some value => + rw [hcompute] at hrun + simp only [if_true] at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind + ((finishAppResult + (natExprFromValue value) args 2).run + methods) _ s₂ = _ at hrun + unfold EStateM.bind at hrun + match hfinish : + (finishAppResult + (natExprFromValue value) args 2).run + methods s₂ with + | .error err s₃ => + rw [hfinish] at hrun + contradiction + | .ok final s₃ => + rw [hfinish] at hrun + simp only at hrun + rcases hrun with ⟨rfl, rfl⟩ + exact .arithmetic harith' hpred' + (.intro hargA hargB hextractA + hextractB hcompute hfinish) + +end NatSpineSuccessTrace + +namespace NatBinSuccessTrace + +/-- Interpret either operational success trace in the fixed Theory world. +For predicates, determinism identifies the trace's concrete intern result +with the collision-safe canonical Bool result constructed by the semantic +acceptance theorem. -/ +theorem acceptance + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Δ : KVLCtx} {methods : Methods .anon} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB result : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} + {sourceV : VExpr} {s s' : TcState .anon} + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Δ s) + (hsourceSupport : support + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) sourceV) + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) + (trace : NatBinSuccessTrace methods natSuccMode headId us argA argB + headInfo firstInfo secondInfo s result s') : + WhnfStateInv .noAccel semantics trProj world support uvars Δ s' ∧ + support result ∧ + WhnfMeaning trProj world uvars Δ + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) result := by + cases trace with + | arithmetic harith hpred body => + cases body with + | intro hargA hargB hextractA hextractB hcompute => + have haccept := tryReduceNatWithSuccMode_binArithExact_acceptance + context hmethods hI hsourceSupport hsource hspine hargA hargB + hextractA hextractB hcompute + exact ⟨haccept.2.1, haccept.2.2.1, haccept.2.2.2⟩ + | predicate harith hpred body => + cases body with + | intro hargA hextractA hargB hextractB hintern => + have haddr := isNatBinPredAddr_true hpred + obtain ⟨s₃, hcanonicalRun, hI₃, hresultSupport, hmeaning⟩ := + tryReduceNatWithSuccMode_binPredExact_acceptance context + hmethods hI hsourceSupport hsource hspine haddr hargA + hextractA hargB hextractB + have hhelper := tryReduceNatPredicate_exact + (prims := _ ) (addr := headId.addr) hargA rfl hextractA + hargB hextractB rfl hintern + have hactualRun := tryReduceNatWithSuccMode_binPredAnyExact + (natSuccMode := natSuccMode) hspine rfl harith hpred hhelper + have heq := hactualRun.symm.trans hcanonicalRun + have hresultEq := Option.some.inj (EStateM.Result.ok.inj heq).1 + have hstateEq : s' = s₃ := (EStateM.Result.ok.inj heq).2 + subst result + subst s' + exact ⟨hI₃, hresultSupport, hmeaning⟩ + +end NatBinSuccessTrace + +/-- Exact-binary `OptionalReduction.WF` slice for the production Nat +dispatcher. Misses and errors use the exhaustive state-invariant theorem; +every hit is inverted into an exact binary success trace and interpreted +semantically. -/ +theorem tryReduceNatWithSuccMode_bin_optional_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Δ : KVLCtx} {s : TcState .anon} + {headId : KId .anon} {us : Array (KUniv .anon)} + {argA argB : KExpr .anon} + {headInfo firstInfo secondInfo : ExprInfo .anon} {sourceV : VExpr} + (hsourceSupport : support + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Δ + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) sourceV) + (hspine : + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo : KExpr .anon).collectSpine = + (.const headId us headInfo, #[argA, argB])) : + RecM.WF .noAccel semantics trProj world support uvars Δ s + (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode) + (fun outcome _ => match outcome with + | none => True + | some reduced => + support reduced ∧ + WhnfMeaning trProj world uvars Δ + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) reduced) := by + intro methods hmethods hI + have hinv := tryReduceNatWithSuccMode_bin_inv_wf context + hsourceSupport hsource hspine methods hmethods hI + match hrun : (tryReduceNatWithSuccMode + (.app (.app (.const headId us headInfo) argA firstInfo) + argB secondInfo) natSuccMode).run methods s with + | .error err s' => + rw [hrun] at hinv + simp only at hinv ⊢ + exact hinv + | .ok outcome s' => + rw [hrun] at hinv + cases outcome with + | none => + simp only at hinv ⊢ + exact hinv + | some result => + simp only at hinv ⊢ + have trace := NatBinSuccessTrace.complete hspine hrun + have haccept := trace.acceptance context hmethods hI + hsourceSupport hsource hspine + exact ⟨haccept.1, haccept.2⟩ + +/-! ### General-spine Nat state and finite-success closure -/ + +/-- Recover finite support and structural translations for the two consumed +Nat arguments from an arbitrary translated application spine. The proof +peels the unchanged suffix from the canonical spine rather than assuming +that the original application metadata was canonical. -/ +theorem natBinSpine_inputs + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Delta : KVLCtx} + {source : KExpr .anon} {headId : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {args suffix : Array (KExpr .anon)} {argA argB : KExpr .anon} + {sourceV : VExpr} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + source sourceV) + (hspine : source.collectSpine = (.const headId us headInfo, args)) + (hargs : args = #[argA, argB] ++ suffix) : + ∃ argAV argBV, + support argA ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta argA argAV ∧ + support argB ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta argB argBV := by + have hspineTr := trAppSpine_of_collectSpine hsource hspine + have hcanonicalSource : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkAppN (.const headId us headInfo) args) sourceV := by + rw [KExpr.mkAppN] + simpa only [Array.foldl_toList] using hspineTr.tr + have hcanonicalSuffix : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkAppN + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB) + suffix) sourceV := by + simpa [hargs, KExpr.mkAppN] using hcanonicalSource + have hcanonicalSuffixList : + TrKExprS world.venv uvars world.nameOf trProj Delta + (suffix.toList.foldl KExpr.mkApp + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB)) + sourceV := by + simpa only [KExpr.mkAppN, Array.foldl_toList] using hcanonicalSuffix + obtain ⟨baseV, hbaseTr⟩ := + TrKExprS.foldlMkApp_initial (rest := suffix.toList) + hcanonicalSuffixList + rw [KExpr.mkApp_shape, KExpr.mkApp_shape] at hbaseTr + let .app _ _ hprefixTr hargBTr := hbaseTr + let .app _ _ _ hargATr := hprefixTr + have hinputSupport := context.inputs.spine hsourceSupport hspine + have hargASupport : support argA := by + simpa [hargs] using hinputSupport.2 0 (by + rw [hargs] + grind) + have hargBSupport : support argB := by + simpa [hargs] using hinputSupport.2 1 (by + rw [hargs] + grind) + exact ⟨_, _, hargASupport, hargATr, hargBSupport, hargBTr⟩ + +/-- Postcondition used by the general-spine miss/error partition. Primitive +hits are intentionally vacuous here: the operational-trace and certified- +success layers interpret them separately from finite suffix certificates. -/ +def NatSpineNonHitInv + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) + (Delta : KVLCtx) + (outcome : EStateM.Result (TcError .anon) (TcState .anon) + (Option (KExpr .anon))) : Prop := + match outcome with + | .error _ s' => + WhnfStateInv .noAccel semantics trProj world support uvars Delta s' + | .ok none s' => + WhnfStateInv .noAccel semantics trProj world support uvars Delta s' + | .ok (some _) _ => True + +/-- Exhaustive miss/error invariant for the general predicate helper. Once +both literals are recognized, direct Bool interning and suffix rebuilding are +operationally total, so every remaining execution is a hit. -/ +theorem tryReduceNatPredicate_spine_nonhit_inv + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s : TcState .anon} {addr : Address} + {args suffix : Array (KExpr .anon)} {argA argB : KExpr .anon} + {argAV argBV : VExpr} + {outcome : EStateM.Result (TcError .anon) (TcState .anon) + (Option (KExpr .anon))} + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Delta s) + (hargASupport : support argA) + (hargATr : TrKExprS world.venv uvars world.nameOf trProj Delta argA argAV) + (hargBSupport : support argB) + (hargBTr : TrKExprS world.venv uvars world.nameOf trProj Delta argB argBV) + (hargs : args = #[argA, argB] ++ suffix) + (hrun : (tryReduceNatPredicate addr args).run methods s = outcome) : + NatSpineNonHitInv semantics trProj world support uvars Delta outcome := by + have hzero : args[0]! = argA := by rw [hargs]; grind + have hone : args[1]! = argB := by rw [hargs]; grind + unfold tryReduceNatPredicate at hrun + rw [hzero, ReaderT.run_bind] at hrun + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = outcome + at hrun + unfold EStateM.bind at hrun + match hargA : (whnfNatReducerArg argA).run methods s with + | .error err s₁ => + rw [hargA] at hrun + rw [← hrun] + exact whnfNatReducerArg_error_inv hargASupport hargATr hmethods hI hargA + | .ok first s₁ => + rw [hargA] at hrun + have hI₁ := whnfNatReducerArg_ok_inv hargASupport hargATr + hmethods hI hargA + cases first with + | none => + simp only at hrun + rw [← hrun] + exact hI₁ + | some argAResult => + simp only at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind (RecM.prims.run methods) _ s₁ = outcome at hrun + unfold EStateM.bind at hrun + have hprims₁ : RecM.prims.run methods s₁ = .ok s₁.prims s₁ := rfl + rw [hprims₁] at hrun + simp only at hrun + match hextractA : extractNatLit argAResult s₁.prims with + | none => + rw [hextractA] at hrun + rw [← hrun] + exact hI₁ + | some a => + rw [hextractA] at hrun + simp only at hrun + rw [hone, ReaderT.run_bind] at hrun + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = + outcome at hrun + unfold EStateM.bind at hrun + match hargB : (whnfNatReducerArg argB).run methods s₁ with + | .error err s₂ => + rw [hargB] at hrun + rw [← hrun] + exact whnfNatReducerArg_error_inv hargBSupport hargBTr + hmethods hI₁ hargB + | .ok second s₂ => + rw [hargB] at hrun + have hI₂ := whnfNatReducerArg_ok_inv hargBSupport hargBTr + hmethods hI₁ hargB + cases second with + | none => + simp only at hrun + rw [← hrun] + exact hI₂ + | some argBResult => + simp only at hrun + match hextractB : extractNatLit argBResult s₁.prims with + | none => + rw [hextractB] at hrun + rw [← hrun] + exact hI₂ + | some b => + rw [hextractB] at hrun + simp only at hrun + let decision := + if addr == s₁.prims.natBeq.addr then a == b + else a.ble b + let requested := KExpr.mkConst + (if decision then s₁.prims.boolTrue + else s₁.prims.boolFalse) #[] + have hrequestedSupport : support requested := + context.generated.boolConst + hI₁.noAccel_primitives decision + obtain ⟨s₃, hintern, hI₃, _⟩ := + TcM.intern_whnf_eval context.collisionFree + hrequestedSupport hI₂ + rw [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + change EStateM.bind (TcM.intern requested) _ s₂ = + outcome at hrun + unfold EStateM.bind at hrun + rw [hintern] at hrun + simp only at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind + ((finishAppResult requested args 2).run methods) _ + s₃ = outcome at hrun + unfold EStateM.bind at hrun + obtain ⟨final, s₄, hfinish⟩ := + finishAppResult_total + (methods := methods) (s := s₃) requested args 2 + rw [hfinish] at hrun + simp only at hrun + rw [← hrun] + trivial + +/-- The state partition lifted from exact binary syntax to every translated +spine with two consumed arguments and an arbitrary trailing suffix. All +callback errors retain their actual partial states; a hit remains outside +this theorem's semantic claim. -/ +theorem tryReduceNatWithSuccMode_spine_nonhit_inv + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s : TcState .anon} {source : KExpr .anon} {headId : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {args suffix : Array (KExpr .anon)} {argA argB : KExpr .anon} + {sourceV : VExpr} + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Delta s) + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + source sourceV) + (hspine : source.collectSpine = (.const headId us headInfo, args)) + (hargs : args = #[argA, argB] ++ suffix) : + match (tryReduceNatWithSuccMode source natSuccMode).run methods s with + | .error _ s' => + WhnfStateInv .noAccel semantics trProj world support uvars Delta s' + | .ok none s' => + WhnfStateInv .noAccel semantics trProj world support uvars Delta s' + | .ok (some _) _ => True := by + obtain ⟨argAV, argBV, hargASupport, hargATr, + hargBSupport, hargBTr⟩ := + natBinSpine_inputs context hsourceSupport hsource hspine hargs + generalize hrun : + (tryReduceNatWithSuccMode source natSuccMode).run methods s = outcome + change NatSpineNonHitInv semantics trProj world support uvars Delta outcome + let isArith := + headId.addr == s.prims.natAdd.addr || + headId.addr == s.prims.natSub.addr || + headId.addr == s.prims.natMul.addr || + headId.addr == s.prims.natDiv.addr || + headId.addr == s.prims.natMod.addr || + headId.addr == s.prims.natPow.addr || + headId.addr == s.prims.natGcd.addr || + headId.addr == s.prims.natLand.addr || + headId.addr == s.prims.natLor.addr || + headId.addr == s.prims.natXor.addr || + headId.addr == s.prims.natShiftLeft.addr || + headId.addr == s.prims.natShiftRight.addr + let isPred := headId.addr == s.prims.natBeq.addr || + headId.addr == s.prims.natBle.addr + have harith : (isNatBinArithAddr headId.addr).run methods s = + .ok isArith s := isNatBinArithAddr_eval methods s headId.addr + have hpred : (isNatBinPredAddr headId.addr).run methods s = + .ok isPred s := isNatBinPredAddr_eval methods s headId.addr + have hzero : args[0]! = argA := by + rw [hargs] + grind + have hone : args[1]! = argB := by + rw [hargs] + grind + unfold tryReduceNatWithSuccMode at hrun + rw [hspine, ReaderT.run_bind] at hrun + change EStateM.bind (RecM.prims.run methods) _ s = outcome at hrun + unfold EStateM.bind at hrun + have hprims : RecM.prims.run methods s = .ok s.prims s := rfl + rw [hprims] at hrun + simp only at hrun + have hnotSuccArity : (args.size == 1) = false := by + rw [hargs] + grind + rw [hnotSuccArity] at hrun + simp only [Bool.and_false, Bool.false_eq_true, if_false] at hrun + have hnotShort : ¬(args.size < 2) := by + rw [hargs] + grind + rw [if_neg hnotShort] at hrun + simp only [pure_bind] at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind ((isNatBinArithAddr headId.addr).run methods) _ s = + outcome at hrun + unfold EStateM.bind at hrun + rw [harith] at hrun + simp only at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind ((isNatBinPredAddr headId.addr).run methods) _ s = + outcome at hrun + unfold EStateM.bind at hrun + rw [hpred] at hrun + cases hisArith : isArith <;> cases hisPred : isPred + · simp only [hisArith, hisPred, Bool.not_false, Bool.false_eq_true, + if_false] at hrun + rw [← hrun] + exact hI + · simp only [hisArith, hisPred, Bool.not_false, Bool.not_true, + Bool.and_false, Bool.false_eq_true, if_false, if_true] at hrun + have hhelper : (tryReduceNatPredicate headId.addr args).run methods s = + outcome := by simpa using hrun + exact tryReduceNatPredicate_spine_nonhit_inv context hmethods hI + hargASupport hargATr hargBSupport hargBTr hargs hhelper + · simp only [hisArith, hisPred, Bool.not_true, Bool.not_false, + Bool.false_and, Bool.false_eq_true, if_false] at hrun + rw [hzero, ReaderT.run_bind] at hrun + change EStateM.bind ((whnfNatReducerArg argA).run methods) _ s = outcome + at hrun + unfold EStateM.bind at hrun + match hargA : (whnfNatReducerArg argA).run methods s with + | .error err s₁ => + rw [hargA] at hrun + rw [← hrun] + exact whnfNatReducerArg_error_inv hargASupport hargATr hmethods hI + hargA + | .ok first s₁ => + rw [hargA] at hrun + have hI₁ := whnfNatReducerArg_ok_inv hargASupport hargATr + hmethods hI hargA + cases first with + | none => + simp only at hrun + rw [← hrun] + exact hI₁ + | some argAResult => + simp only at hrun + rw [hone, ReaderT.run_bind] at hrun + change EStateM.bind ((whnfNatReducerArg argB).run methods) _ s₁ = + outcome at hrun + unfold EStateM.bind at hrun + match hargB : (whnfNatReducerArg argB).run methods s₁ with + | .error err s₂ => + rw [hargB] at hrun + rw [← hrun] + exact whnfNatReducerArg_error_inv hargBSupport hargBTr + hmethods hI₁ hargB + | .ok second s₂ => + rw [hargB] at hrun + have hI₂ := whnfNatReducerArg_ok_inv hargBSupport hargBTr + hmethods hI₁ hargB + cases second with + | none => + simp only at hrun + rw [← hrun] + exact hI₂ + | some argBResult => + simp only at hrun + match hextractA : extractNatLit argAResult s.prims with + | none => + rw [hextractA] at hrun + rw [← hrun] + exact hI₂ + | some a => + rw [hextractA] at hrun + simp only at hrun + match hextractB : extractNatLit argBResult s.prims with + | none => + rw [hextractB] at hrun + rw [← hrun] + exact hI₂ + | some b => + rw [hextractB] at hrun + simp only at hrun + match hcompute : computeNatBin headId.addr + PrimAddrs.canonical a b with + | none => + rw [hcompute] at hrun + rw [← hrun] + exact hI₂ + | some value => + rw [hcompute] at hrun + simp only [if_true] at hrun + obtain ⟨final, s₃, hfinish⟩ := + finishAppResult_total + (methods := methods) (s := s₂) + (natExprFromValue value) args 2 + rw [ReaderT.run_bind] at hrun + change EStateM.bind + ((finishAppResult (natExprFromValue value) args 2).run + methods) _ s₂ = outcome at hrun + unfold EStateM.bind at hrun + rw [hfinish] at hrun + simp only at hrun + rw [← hrun] + trivial + · simp only [hisArith, hisPred, Bool.not_true, + Bool.and_false, Bool.false_eq_true, if_false, if_true] at hrun + have hhelper : (tryReduceNatPredicate headId.addr args).run methods s = + outcome := by simpa using hrun + exact tryReduceNatPredicate_spine_nonhit_inv context hmethods hI + hargASupport hargATr hargBSupport hargBTr hargs hhelper + +/-- A successful general-spine trace paired with exactly the finite intern +requests needed to rebuild its observed suffix. The predicate certificate +starts from the requested canonical Bool node; collision-safe interning and +deterministic execution later identify it with production's returned base. -/ +inductive NatSpineCertifiedSuccess (requests : List WalkerRequest) + (methods : Methods .anon) (natSuccMode : NatSuccMode) + (source : KExpr .anon) (headId : KId .anon) + (us : Array (KUniv .anon)) (headInfo : ExprInfo .anon) + (args : Array (KExpr .anon)) (argA argB : KExpr .anon) + (s : TcState .anon) : KExpr .anon → TcState .anon → Prop + | arithmetic {s₁ s₂ s₃ : TcState .anon} + {argAResult argBResult final : KExpr .anon} {a b value : Nat} + (harith : (isNatBinArithAddr headId.addr).run methods s = .ok true s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok false s) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractA : extractNatLit argAResult s.prims = some a) + (hextractB : extractNatLit argBResult s.prims = some b) + (hcompute : computeNatBin headId.addr PrimAddrs.canonical a b = + some value) + (hfinishRun : + (finishAppResult (natExprFromValue (m := .anon) value) args 2).run + methods s₂ = .ok final s₃) + (hfinish : FinishAppRequests requests + (args.extract 2 args.size).toList + (natExprFromValue (m := .anon) value) final) : + NatSpineCertifiedSuccess requests methods natSuccMode source + headId us headInfo args argA argB s final s₃ + | predicate {s₁ s₂ s₃ s₄ : TcState .anon} + {argAResult argBResult requested base final : KExpr .anon} + {a b : Nat} {isArith : Bool} + (harith : (isNatBinArithAddr headId.addr).run methods s = + .ok isArith s) + (hpred : (isNatBinPredAddr headId.addr).run methods s = .ok true s) + (hargA : (whnfNatReducerArg argA).run methods s = + .ok (some argAResult) s₁) + (hextractA : extractNatLit argAResult s₁.prims = some a) + (hargB : (whnfNatReducerArg argB).run methods s₁ = + .ok (some argBResult) s₂) + (hextractB : extractNatLit argBResult s₁.prims = some b) + (hrequested : requested = KExpr.mkConst + (if (if headId.addr == s₁.prims.natBeq.addr then a == b else a.ble b) + then s₁.prims.boolTrue else s₁.prims.boolFalse) #[]) + (hintern : TcM.intern requested s₂ = .ok base s₃) + (hfinishRun : (finishAppResult base args 2).run methods s₃ = + .ok final s₄) + (hfinish : FinishAppRequests requests + (args.extract 2 args.size).toList requested final) : + NatSpineCertifiedSuccess requests methods natSuccMode source + headId us headInfo args argA argB s final s₄ + +namespace NatSpineCertifiedSuccess + +/-- Erase finite request coverage and recover the exhaustive operational +success trace. -/ +theorem trace + {requests : List WalkerRequest} {methods : Methods .anon} + {natSuccMode : NatSuccMode} {source : KExpr .anon} + {headId : KId .anon} {us : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {args : Array (KExpr .anon)} + {argA argB result : KExpr .anon} {s s' : TcState .anon} + (cert : NatSpineCertifiedSuccess requests methods natSuccMode + source headId us headInfo args argA argB s result s') : + NatSpineSuccessTrace methods natSuccMode source headId us headInfo + args argA argB s result s' := by + cases cert with + | arithmetic harith hpred hargA hargB hextractA hextractB hcompute + hfinishRun hfinish => + exact .arithmetic harith hpred + (.intro hargA hargB hextractA hextractB hcompute hfinishRun) + | predicate harith hpred hargA hextractA hargB hextractB hrequested + hintern hfinishRun hfinish => + exact .predicate harith hpred + (.intro hargA hextractA hargB hextractB hrequested hintern hfinishRun) + +/-- Interpret a finitely certified general-spine hit in Theory. The +certificate executes only the observed finite suffix; no global application +closure of `RunSupport` is assumed. -/ +theorem acceptance + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s : TcState .anon} {source : KExpr .anon} {headId : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {args suffix : Array (KExpr .anon)} {argA argB result : KExpr .anon} + {sourceV : VExpr} {s' : TcState .anon} + (hrun : RunAssumptions initial program requests support) + (theory : WhnfTheory trProj world uvars) + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Delta s) + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + source sourceV) + (hspine : source.collectSpine = (.const headId us headInfo, args)) + (hargs : args = #[argA, argB] ++ suffix) + (cert : NatSpineCertifiedSuccess requests methods natSuccMode + source headId us headInfo args argA argB s result s') : + WhnfStateInv .noAccel semantics trProj world support uvars Delta s' ∧ + support result ∧ + WhnfMeaning trProj world uvars Delta source result := by + have hactualRun := cert.trace.eval hspine hargs + cases cert with + | arithmetic harith hpred hargA hargB hextractA hextractB hcompute + hfinishRun hfinish => + obtain ⟨canonicalState, hcanonicalRun, hcanonicalInv, + hresultSupport, hmeaning⟩ := + tryReduceNatWithSuccMode_binArithSuffix_acceptance context hrun theory + hmethods hI hsourceSupport hsource hspine hargs hargA hargB + hextractA hextractB hcompute hfinish + have heq := hactualRun.symm.trans hcanonicalRun + have hstateEq : s' = canonicalState := (EStateM.Result.ok.inj heq).2 + subst canonicalState + exact ⟨hcanonicalInv, hresultSupport, hmeaning⟩ + | predicate harith hpred hargA hextractA hargB hextractB hrequested + hintern hfinishRun hfinish => + have haddr := isNatBinPredAddr_true hpred + rw [hrequested] at hfinish + obtain ⟨canonicalState, hcanonicalRun, hcanonicalInv, + hresultSupport, hmeaning⟩ := + tryReduceNatWithSuccMode_binPredSuffix_acceptance context hrun theory + hmethods hI hsourceSupport hsource hspine hargs haddr hargA + hextractA hargB hextractB hfinish + have heq := hactualRun.symm.trans hcanonicalRun + have hstateEq : s' = canonicalState := (EStateM.Result.ok.inj heq).2 + subst canonicalState + exact ⟨hcanonicalInv, hresultSupport, hmeaning⟩ + +end NatSpineCertifiedSuccess + +/-- Fixed-execution finite coverage for the only successful Nat reduction +that can be observed from these methods, source, and entry state. Although +the predicate is quantified over success traces, the production computation +is deterministic, so this does not require closure under infinitely many +hypothetical application bases. -/ +def NatSpineFinishCoverage (requests : List WalkerRequest) + (methods : Methods .anon) (natSuccMode : NatSuccMode) + (source : KExpr .anon) (headId : KId .anon) + (us : Array (KUniv .anon)) (headInfo : ExprInfo .anon) + (args : Array (KExpr .anon)) (argA argB : KExpr .anon) + (s : TcState .anon) : Prop := + ∀ {result s'}, + NatSpineSuccessTrace methods natSuccMode source headId us headInfo + args argA argB s result s' → + NatSpineCertifiedSuccess requests methods natSuccMode source headId us + headInfo args argA argB s result s' + +/-! ### Finite request census for Nat suffix rebuilding -/ + +/-- A finite request-list census for every suffix rebuild observable from a +supported, translated Nat dispatcher entry under the real method/state +invariants. Its fields stop at direct `FinishAppRequests`: neither field +assumes the semantic conclusion nor identifies production's result/state +with the certified fold. Keeping the arithmetic value and predicate Bool +request as ordinary field indices avoids extracting computational data from +a proof-irrelevant success trace. -/ +structure NatCollapseRequestCensus (requests : List WalkerRequest) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Prop where + arithmetic : ∀ {uvars : Nat} {Delta : KVLCtx} + {source : KExpr .anon} {sourceV : VExpr} + {headId : KId .anon} {us : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {args suffix : Array (KExpr .anon)} + {argA argB : KExpr .anon} {s s₁ s₂ s₃ : TcState .anon} + {methods : Methods .anon} + {argAResult argBResult final : KExpr .anon} {a b value : Nat}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + source.collectSpine = (.const headId us headInfo, args) → + args = #[argA, argB] ++ suffix → + Methods.WFAt .noAccel semantics trProj world support uvars methods → + WhnfStateInv .noAccel semantics trProj world support uvars Delta s → + (isNatBinArithAddr headId.addr).run methods s = .ok true s → + (isNatBinPredAddr headId.addr).run methods s = .ok false s → + (whnfNatReducerArg argA).run methods s = .ok (some argAResult) s₁ → + (whnfNatReducerArg argB).run methods s₁ = .ok (some argBResult) s₂ → + extractNatLit argAResult s.prims = some a → + extractNatLit argBResult s.prims = some b → + computeNatBin headId.addr PrimAddrs.canonical a b = some value → + (finishAppResult (natExprFromValue (m := .anon) value) args 2).run + methods s₂ = .ok final s₃ → + ∃ certifiedFinal, + FinishAppRequests requests (args.extract 2 args.size).toList + (natExprFromValue (m := .anon) value) certifiedFinal + predicate : ∀ {uvars : Nat} {Delta : KVLCtx} + {source : KExpr .anon} {sourceV : VExpr} + {headId : KId .anon} {us : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {args suffix : Array (KExpr .anon)} + {argA argB : KExpr .anon} {s s₁ s₂ s₃ s₄ : TcState .anon} + {methods : Methods .anon} + {argAResult argBResult requested base final : KExpr .anon} + {a b : Nat} {isArith : Bool}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + source.collectSpine = (.const headId us headInfo, args) → + args = #[argA, argB] ++ suffix → + Methods.WFAt .noAccel semantics trProj world support uvars methods → + WhnfStateInv .noAccel semantics trProj world support uvars Delta s → + (isNatBinArithAddr headId.addr).run methods s = .ok isArith s → + (isNatBinPredAddr headId.addr).run methods s = .ok true s → + (whnfNatReducerArg argA).run methods s = .ok (some argAResult) s₁ → + extractNatLit argAResult s₁.prims = some a → + (whnfNatReducerArg argB).run methods s₁ = .ok (some argBResult) s₂ → + extractNatLit argBResult s₁.prims = some b → + requested = KExpr.mkConst + (if (if headId.addr == s₁.prims.natBeq.addr then a == b else a.ble b) + then s₁.prims.boolTrue else s₁.prims.boolFalse) #[] → + TcM.intern requested s₂ = .ok base s₃ → + (finishAppResult base args 2).run methods s₃ = .ok final s₄ → + ∃ certifiedFinal, + FinishAppRequests requests (args.extract 2 args.size).toList requested + certifiedFinal + +namespace NatCollapseRequestCensus + +/-- The Theory fact actually needed to rule out a trailing application after +a successful binary Nat reduction. It is deliberately stated at the type +level: canonical `Nat` and `Bool` result types cannot be definitionally equal +to a function type in a well-formed context. + +This is strictly narrower than `ExactArity` below. It says nothing about +production classifiers, concrete spines, method tables, or run support, and +is the intended target for Lean4Lean's eventual canonical-type +no-confusion theorem. -/ +structure NatBoolResultShapeSeparation (world : VerifyWorld) : Prop where + nat : ∀ {uvars : Nat} {Gamma : List VExpr} {A B : VExpr}, + Lean4Lean.OnCtx Gamma (world.venv.IsType uvars) → + ¬ world.venv.IsDefEqU uvars Gamma .nat (.forallE A B) + bool : ∀ {uvars : Nat} {Gamma : List VExpr} {A B : VExpr}, + Lean4Lean.OnCtx Gamma (world.venv.IsType uvars) → + ¬ world.venv.IsDefEqU uvars Gamma .bool (.forallE A B) + +/-- A translated application suffix must be empty when its base has a +certified canonical result type that is not definitionally a function. + +If the suffix had a first argument, structural translation of that +application would type the base as a `forallE`. Translation uniqueness and +the base reduction meaning transport the separately certified result type +back to the same base expression. Theory type uniqueness then yields the +forbidden result-type/function-type equality. -/ +theorem suffix_eq_empty_of_result_shape + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + {Delta : KVLCtx} (hDelta : KVLCtx.WF world.venv uvars Delta) + {base result : KExpr .anon} {suffix : Array (KExpr .anon)} + {fullV resultV resultTy : VExpr} + (hfull : TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkAppN base suffix) fullV) + (hmeaning : WhnfMeaning trProj world uvars Delta base result) + (hresult : TrKExprS world.venv uvars world.nameOf trProj Delta + result resultV) + (hresultType : world.venv.HasType uvars Delta.toCtx resultV resultTy) + (hnotFunction : ∀ {A B : VExpr}, + ¬ world.venv.IsDefEqU uvars Delta.toCtx resultTy (.forallE A B)) : + suffix = #[] := by + by_contra hne + have hlistNe : suffix.toList ≠ [] := by + intro hnil + apply hne + apply Array.toList_inj.mp + simpa using hnil + obtain ⟨arg, rest, hlist⟩ := List.exists_cons_of_ne_nil hlistNe + have hfullList : + TrKExprS world.venv uvars world.nameOf trProj Delta + (suffix.toList.foldl KExpr.mkApp base) fullV := by + simpa only [KExpr.mkAppN, Array.foldl_toList] using hfull + rw [hlist] at hfullList + simp only [List.foldl_cons] at hfullList + obtain ⟨appV, happTr⟩ := + TrKExprS.foldlMkApp_initial (rest := rest) hfullList + rw [KExpr.mkApp_shape] at happTr + let .app hbaseFun _ hbaseTr _ := happTr + obtain ⟨meaningBaseV, meaningResultV, hmeaningBase, hmeaningResult, + hmeaningEq⟩ := hmeaning + have hctx := KVLCtx.IsDefEq.refl world.venvWF hDelta + have hbaseEq := hbaseTr.uniq world.venvWF theory.literalWF + theory.projections hctx hmeaningBase + have hresultEq := hmeaningResult.uniq world.venvWF theory.literalWF + theory.projections hctx hresult + have hbaseResultEq := hbaseEq.trans world.venvWF hDelta + (hmeaningEq.trans world.venvWF hDelta hresultEq) + have hbaseResultType := + (hbaseResultEq.of_r world.venvWF hDelta hresultType).hasType.1 + have htypes := hbaseResultType.uniqU world.venvWF hDelta hbaseFun + exact hnotFunction htypes + +/-- Typed-arity boundary for classifier-confirmed binary Nat primitives. +Only these heads are constrained: unrelated supported applications may have +arbitrary arity. A Theory shape-separation result for canonical Nat/Bool +result types can construct the weaker success-scoped census directly via +`of_result_shape`; this stronger classifier-only form remains as a +compatibility interface. -/ +def ExactArity + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Prop := + ∀ {uvars : Nat} {Delta : KVLCtx} + {source : KExpr .anon} {sourceV : VExpr} + {headId : KId .anon} {us : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {args suffix : Array (KExpr .anon)} + {argA argB : KExpr .anon} {s : TcState .anon} + {methods : Methods .anon}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + source.collectSpine = (.const headId us headInfo, args) → + args = #[argA, argB] ++ suffix → + Methods.WFAt .noAccel semantics trProj world support uvars methods → + WhnfStateInv .noAccel semantics trProj world support uvars Delta s → + ((isNatBinArithAddr headId.addr).run methods s = .ok true s ∨ + (isNatBinPredAddr headId.addr).run methods s = .ok true s) → + suffix = #[] + +/-- Runs whose supported Nat-success entries have no trailing arguments need +no suffix requests at all. This is the exact bridge expected from a future +typed-arity theorem: once the translated primitive application is known to +end after its two Nat arguments, both census fields reduce to +`FinishAppRequests.nil`. -/ +theorem of_no_suffix + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hnoSuffix : ExactArity semantics trProj world support) : + NatCollapseRequestCensus requests semantics trProj world support := by + constructor + · intro uvars Delta source sourceV headId us headInfo args suffix argA argB + s s₁ s₂ s₃ methods argAResult argBResult final a b value + hsourceSupport hsource hspine hargs hmethods hI harith _ _ _ _ _ _ _ + have hsuffix := hnoSuffix hsourceSupport hsource hspine hargs hmethods hI + (Or.inl harith) + have hrest : (args.extract 2 args.size).toList = [] := by + rw [hargs, hsuffix] + simp + refine ⟨natExprFromValue (m := .anon) value, ?_⟩ + rw [hrest] + exact .nil _ + · intro uvars Delta source sourceV headId us headInfo args suffix argA argB + s s₁ s₂ s₃ s₄ methods argAResult argBResult requested base final a b + isArith hsourceSupport hsource hspine hargs hmethods hI _ hpred _ _ _ _ + _ _ _ + have hsuffix := hnoSuffix hsourceSupport hsource hspine hargs hmethods hI + (Or.inr hpred) + have hrest : (args.extract 2 args.size).toList = [] := by + rw [hargs, hsuffix] + simp + refine ⟨requested, ?_⟩ + rw [hrest] + exact .nil _ + +/-- Construct the finite suffix census from the semantic result-shape fact +that is actually exercised by successful reducer traces. + +The arithmetic and predicate fields first replay their two successful +argument callbacks far enough to prove meaning for the exact binary prefix. +The canonical result literal gives that prefix type `Nat` or `Bool`. A +nonempty translated suffix would simultaneously give the prefix a function +type, so `NatBoolResultShapeSeparation` forces the suffix to be empty and the +request certificate is `FinishAppRequests.nil`. This removes the broader +classifier-only `ExactArity` assumption from the production closure path. -/ +theorem of_result_shape + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + (theory : ∀ uvars, WhnfTheory trProj world uvars) + (shape : NatBoolResultShapeSeparation world) : + NatCollapseRequestCensus requests semantics trProj world support := by + constructor + · intro uvars Delta source sourceV headId us headInfo args suffix argA argB + s s₁ s₂ s₃ methods argAResult argBResult final a b value + hsourceSupport hsource hspine hargs hmethods hI _ _ hargA hargB + hextractA hextractB hcompute _ + have hcatalog := hI.1.core.trustedCatalog + have hDelta := hI.2.1.wf + have hcanonical := hI.noAccel_primitives + have htable := context.stateTable hI + obtain ⟨name, hname, hreflect⟩ := + context.computeNatBin_defeq hcatalog hcanonical hcompute + have hspineTr := trAppSpine_of_collectSpine hsource hspine + have hcanonicalSource : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkAppN (.const headId us headInfo) args) sourceV := by + rw [KExpr.mkAppN] + simpa only [Array.foldl_toList] using hspineTr.tr + have hcanonicalSuffix : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkAppN + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB) + suffix) sourceV := by + simpa [hargs, KExpr.mkAppN] using hcanonicalSource + have hcanonicalSuffixList : + TrKExprS world.venv uvars world.nameOf trProj Delta + (suffix.toList.foldl KExpr.mkApp + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB)) + sourceV := by + simpa only [KExpr.mkAppN, Array.foldl_toList] using hcanonicalSuffix + obtain ⟨baseV, hbaseTr⟩ := + TrKExprS.foldlMkApp_initial (rest := suffix.toList) + hcanonicalSuffixList + have hbaseTrExact := hbaseTr + rw [KExpr.mkApp_shape, KExpr.mkApp_shape] at hbaseTrExact + obtain ⟨argAV, argBV, hbaseV, hargATr, hargBTr⟩ := + hbaseTrExact.natBinExact_inv hDelta hname hreflect + subst baseV + have hinputSupport := context.inputs.spine hsourceSupport hspine + have hargASupport : support argA := by + simpa [hargs] using hinputSupport.2 0 (by rw [hargs]; grind) + have hargBSupport : support argB := by + simpa [hargs] using hinputSupport.2 1 (by rw [hargs]; grind) + have hargAPost := + whnfNatReducerArg_post_wf hargASupport hargATr methods hmethods hI + rw [hargA] at hargAPost + change WhnfStateInv .noAccel semantics trProj world support uvars Delta s₁ ∧ + support argAResult ∧ + WhnfPost trProj world uvars Delta argAV argAResult at hargAPost + have hargBPost := + whnfNatReducerArg_post_wf hargBSupport hargBTr methods hmethods + hargAPost.1 + rw [hargB] at hargBPost + change WhnfStateInv .noAccel semantics trProj world support uvars Delta s₂ ∧ + support argBResult ∧ + WhnfPost trProj world uvars Delta argBV argBResult at hargBPost + have hresultTr : TrKExprS world.venv uvars world.nameOf trProj Delta + (natExprFromValue (m := .anon) value) (.natLit value) := + TrKExprS.natExprFromValue hcatalog htable value + have hbaseMeaningExact := WhnfMeaning.natBinExact hDelta htable + context.theoryPrimitives hbaseTrExact hargAPost.2.2 hargBPost.2.2 + hextractA hextractB hreflect hresultTr + have hbaseMeaning : WhnfMeaning trProj world uvars Delta + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB) + (natExprFromValue (m := .anon) value) := by + rw [KExpr.mkApp_shape, KExpr.mkApp_shape] + exact hbaseMeaningExact + have hnatType₀ : world.venv.HasType uvars [] (.natLit value) .nat := by + simpa using + (Lean4Lean.TrExprS.natLit + (Us := List.replicate uvars Lean.Name.anonymous) (Δ := []) + context.theoryPrimitives (htable.nat.contains hcatalog) value).2 + have hnatType : world.venv.HasType uvars Delta.toCtx + (.natLit value) .nat := + hnatType₀.weak0 world.venvWF + have hsuffix := suffix_eq_empty_of_result_shape (theory uvars) hDelta + hcanonicalSuffix hbaseMeaning hresultTr hnatType (shape.nat hDelta) + have hrest : (args.extract 2 args.size).toList = [] := by + rw [hargs, hsuffix] + simp + refine ⟨natExprFromValue (m := .anon) value, ?_⟩ + rw [hrest] + exact .nil _ + · intro uvars Delta source sourceV headId us headInfo args suffix argA argB + s s₁ s₂ s₃ s₄ methods argAResult argBResult requested base final a b + isArith hsourceSupport hsource hspine hargs hmethods hI _ hpred hargA + hextractA hargB hextractB hrequested _ _ + have hcatalog := hI.1.core.trustedCatalog + have hDelta := hI.2.1.wf + have hspineTr := trAppSpine_of_collectSpine hsource hspine + have hcanonicalSource : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkAppN (.const headId us headInfo) args) sourceV := by + rw [KExpr.mkAppN] + simpa only [Array.foldl_toList] using hspineTr.tr + have hcanonicalSuffix : + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkAppN + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB) + suffix) sourceV := by + simpa [hargs, KExpr.mkAppN] using hcanonicalSource + have hcanonicalSuffixList : + TrKExprS world.venv uvars world.nameOf trProj Delta + (suffix.toList.foldl KExpr.mkApp + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB)) + sourceV := by + simpa only [KExpr.mkAppN, Array.foldl_toList] using hcanonicalSuffix + obtain ⟨baseV, hbaseTr⟩ := + TrKExprS.foldlMkApp_initial (rest := suffix.toList) + hcanonicalSuffixList + have hbaseTrExact := hbaseTr + rw [KExpr.mkApp_shape, KExpr.mkApp_shape] at hbaseTrExact + let .app _ _ hprefixTr hargBTr := hbaseTrExact + let .app _ _ _ hargATr := hprefixTr + have hinputSupport := context.inputs.spine hsourceSupport hspine + have hargASupport : support argA := by + simpa [hargs] using hinputSupport.2 0 (by rw [hargs]; grind) + have hargBSupport : support argB := by + simpa [hargs] using hinputSupport.2 1 (by rw [hargs]; grind) + have hargAPost := + whnfNatReducerArg_post_wf hargASupport hargATr methods hmethods hI + rw [hargA] at hargAPost + change WhnfStateInv .noAccel semantics trProj world support uvars Delta s₁ ∧ + support argAResult ∧ + WhnfPost trProj world uvars Delta _ argAResult at hargAPost + have hcanonical₀ := hI.noAccel_primitives + have hcanonical₁ := hargAPost.1.noAccel_primitives + have hbeq₀ : s.prims.natBeq.addr = PrimAddrs.canonical.natBeq := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natBeq hcanonical₀ + have hble₀ : s.prims.natBle.addr = PrimAddrs.canonical.natBle := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natBle hcanonical₀ + have hbeq₁ : s₁.prims.natBeq.addr = PrimAddrs.canonical.natBeq := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natBeq hcanonical₁ + have hble₁ : s₁.prims.natBle.addr = PrimAddrs.canonical.natBle := by + simpa [Primitives.CanonicalAnon, Primitives.addressTable] using + congrArg PrimAddrs.natBle hcanonical₁ + have haddr := isNatBinPredAddr_true hpred + have haddr₁ : headId.addr = s₁.prims.natBeq.addr ∨ + headId.addr = s₁.prims.natBle.addr := by + rcases haddr with hbeq | hble + · exact .inl (hbeq.trans (hbeq₀.trans hbeq₁.symm)) + · exact .inr (hble.trans (hble₀.trans hble₁.symm)) + obtain ⟨name, decision, hname, hdecision, hreflect⟩ := + context.natPredicate_defeq hcatalog hcanonical₁ haddr₁ + subst decision + obtain ⟨argAV, argBV, hbaseV, hargATrExact, hargBTrExact⟩ := + hbaseTrExact.natBinExact_inv hDelta hname hreflect + subst baseV + have hargAPostExact := + whnfNatReducerArg_post_wf hargASupport hargATrExact methods hmethods hI + rw [hargA] at hargAPostExact + change WhnfStateInv .noAccel semantics trProj world support uvars Delta s₁ ∧ + support argAResult ∧ + WhnfPost trProj world uvars Delta argAV argAResult at hargAPostExact + have hargBPost := + whnfNatReducerArg_post_wf hargBSupport hargBTrExact methods hmethods + hargAPostExact.1 + rw [hargB] at hargBPost + change WhnfStateInv .noAccel semantics trProj world support uvars Delta s₂ ∧ + support argBResult ∧ + WhnfPost trProj world uvars Delta argBV argBResult at hargBPost + let decision := + if headId.addr == s₁.prims.natBeq.addr then a == b else a.ble b + let reduced := KExpr.mkConst + (if decision then s₁.prims.boolTrue else s₁.prims.boolFalse) #[] + have hrequested' : requested = reduced := by + simpa [decision, reduced] using hrequested + subst requested + have htable := context.stateTable hargAPostExact.1 + have hresultTr : TrKExprS world.venv uvars world.nameOf trProj Delta + reduced (.boolLit decision) := + TrKExprS.boolExprFromDecision hcatalog htable + context.theoryPrimitives _ + have hbaseMeaningExact := WhnfMeaning.natBinExact hDelta htable + context.theoryPrimitives hbaseTrExact hargAPostExact.2.2 hargBPost.2.2 + hextractA hextractB hreflect hresultTr + have hbaseMeaning : WhnfMeaning trProj world uvars Delta + (KExpr.mkApp (KExpr.mkApp (.const headId us headInfo) argA) argB) + reduced := by + rw [KExpr.mkApp_shape, KExpr.mkApp_shape] + exact hbaseMeaningExact + have hboolType₀ : world.venv.HasType uvars [] + (.boolLit decision) .bool := by + simpa using + (Lean4Lean.TrExprS.boolLit + (Us := List.replicate uvars Lean.Name.anonymous) (Δ := []) + context.theoryPrimitives (htable.boolType.contains hcatalog) + decision).2 + have hboolType : world.venv.HasType uvars Delta.toCtx + (.boolLit decision) .bool := + hboolType₀.weak0 world.venvWF + have hsuffix := suffix_eq_empty_of_result_shape (theory uvars) hDelta + hcanonicalSuffix hbaseMeaning hresultTr hboolType (shape.bool hDelta) + have hrest : (args.extract 2 args.size).toList = [] := by + rw [hargs, hsuffix] + simp + refine ⟨reduced, ?_⟩ + rw [hrest] + exact .nil _ + +/-- Turn the request-only census into the older fixed-entry success +certificate. The arithmetic and predicate callbacks first recover the +state invariant at the start of suffix rebuilding. The census fold is then +executed through `RunAssumptions`, and determinism identifies its result and +post-state with production's observed run. In the predicate case, the +collision-free direct Bool intern is separately replayed before the suffix +certificate is accepted. -/ +theorem certify + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + (hrun : RunAssumptions initial program requests support) + (census : NatCollapseRequestCensus requests semantics trProj world + support) + {uvars : Nat} {Delta : KVLCtx} + {source : KExpr .anon} {sourceV : VExpr} + {headId : KId .anon} {us : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {args suffix : Array (KExpr .anon)} + {argA argB : KExpr .anon} {s : TcState .anon} + {methods : Methods .anon} {result : KExpr .anon} {s' : TcState .anon} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + source sourceV) + (hspine : source.collectSpine = (.const headId us headInfo, args)) + (hargs : args = #[argA, argB] ++ suffix) + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Delta s) + (trace : NatSpineSuccessTrace methods natSuccMode source headId us + headInfo args argA argB s result s') : + NatSpineCertifiedSuccess requests methods natSuccMode source headId us + headInfo args argA argB s result s' := by + obtain ⟨argAV, argBV, hargASupport, hargATr, hargBSupport, hargBTr⟩ := + natBinSpine_inputs context hsourceSupport hsource hspine hargs + cases trace with + | arithmetic harith hpred body => + cases body with + | intro hargA hargB hextractA hextractB hcompute hfinishRun => + obtain ⟨certifiedFinal, hfinishCert⟩ := + census.arithmetic hsourceSupport hsource hspine hargs hmethods + hI harith hpred hargA hargB hextractA hextractB hcompute + hfinishRun + have hI₁ := whnfNatReducerArg_ok_inv hargASupport hargATr + hmethods hI hargA + have hI₂ := whnfNatReducerArg_ok_inv hargBSupport hargBTr + hmethods hI₁ hargB + obtain ⟨certifiedState, hcertifiedRun, _, _⟩ := + hfinishCert.eval hrun hI₂ + have heq := hfinishRun.symm.trans hcertifiedRun + have hresultEq : result = certifiedFinal := + (EStateM.Result.ok.inj heq).1 + have hstateEq : s' = certifiedState := + (EStateM.Result.ok.inj heq).2 + subst certifiedFinal + subst certifiedState + exact .arithmetic harith hpred hargA hargB hextractA hextractB + hcompute hfinishRun hfinishCert + | predicate harith hpred body => + cases body with + | intro hargA hextractA hargB hextractB hrequested hintern + hfinishRun => + rename_i isArith s₁ s₂ s₃ argAResult argBResult requested base a b + obtain ⟨certifiedFinal, hfinishCert⟩ := + census.predicate hsourceSupport hsource hspine hargs hmethods + hI harith hpred hargA hextractA hargB hextractB hrequested + hintern hfinishRun + have hI₁ := whnfNatReducerArg_ok_inv hargASupport hargATr + hmethods hI hargA + have hI₂ := whnfNatReducerArg_ok_inv hargBSupport hargBTr + hmethods hI₁ hargB + have hcanonical₁ := hI₁.noAccel_primitives + have hrequestedSupport : support requested := by + rw [hrequested] + exact context.generated.boolConst hcanonical₁ _ + obtain ⟨canonicalState, hcanonicalIntern, hI₃, _⟩ := + TcM.intern_whnf_eval context.collisionFree hrequestedSupport hI₂ + have hinternEq := hintern.symm.trans hcanonicalIntern + have hbaseEq : base = requested := + (EStateM.Result.ok.inj hinternEq).1 + have hstateEq : s₃ = canonicalState := + (EStateM.Result.ok.inj hinternEq).2 + subst base + subst canonicalState + obtain ⟨certifiedState, hcertifiedRun, _, _⟩ := + hfinishCert.eval hrun hI₃ + have heq := hfinishRun.symm.trans hcertifiedRun + have hresultEq : result = certifiedFinal := + (EStateM.Result.ok.inj heq).1 + have hfinalStateEq : s' = certifiedState := + (EStateM.Result.ok.inj heq).2 + subst certifiedFinal + subst certifiedState + exact .predicate harith hpred hargA hextractA hargB hextractB + hrequested hintern hfinishRun hfinishCert + +end NatCollapseRequestCensus + +/-- General-spine Nat optional-reduction contract for one fixed entry state. +Misses and errors are unconditional; only an observed hit consumes the finite +`NatSpineFinishCoverage` witness. The surrounding run assumptions supply +collision freedom and exact support for those requests. -/ +theorem tryReduceNatWithSuccMode_spine_optional_wf + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {headId : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {args suffix : Array (KExpr .anon)} {argA argB : KExpr .anon} + {sourceV : VExpr} + (hrun : RunAssumptions initial program requests support) + (theory : WhnfTheory trProj world uvars) + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + source sourceV) + (hspine : source.collectSpine = (.const headId us headInfo, args)) + (hargs : args = #[argA, argB] ++ suffix) + (hcoverage : ∀ methods, + Methods.WFAt .noAccel semantics trProj world support uvars methods → + WhnfStateInv .noAccel semantics trProj world support uvars Delta s → + NatSpineFinishCoverage requests methods natSuccMode source headId + us headInfo args argA argB s) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryReduceNatWithSuccMode source natSuccMode) + (fun outcome _ => match outcome with + | none => True + | some reduced => + support reduced ∧ + WhnfMeaning trProj world uvars Delta source reduced) := by + intro methods hmethods hI + have hnonhit := tryReduceNatWithSuccMode_spine_nonhit_inv context + hmethods hI hsourceSupport hsource hspine hargs + match hactual : (tryReduceNatWithSuccMode source natSuccMode).run methods s with + | .error err s' => + rw [hactual] at hnonhit + simp only at hnonhit ⊢ + exact ⟨hnonhit, trivial⟩ + | .ok outcome s' => + rw [hactual] at hnonhit + cases outcome with + | none => + simp only at hnonhit ⊢ + exact ⟨hnonhit, trivial⟩ + | some result => + simp only at hnonhit ⊢ + have trace := NatSpineSuccessTrace.complete hspine hargs hactual + have cert := hcoverage methods hmethods hI trace + have haccept := cert.acceptance context hrun theory hmethods hI + hsourceSupport hsource hspine hargs + exact ⟨haccept.1, haccept.2⟩ + +/-! ### Successor-collapse operational and memo-write closure -/ + +/-- A memo hit at successor-loop entry bypasses the bounded loop and returns +the original optional-reduction miss at the exact post-key state. -/ +theorem tryReduceNatSuccIter_entryHit + {methods : Methods .anon} {s s₁ : TcState .anon} + {arg : KExpr .anon} {key : Address × Address} + (hkey : TcM.whnfKey arg s = .ok key s₁) + (hhit : s₁.env.natSuccStuck.contains key = true) : + (tryReduceNatSuccIter arg).run methods s = .ok none s₁ := by + unfold tryReduceNatSuccIter + rw [ReaderT.run_bind] + change EStateM.bind (TcM.whnfKey arg) _ s = _ + unfold EStateM.bind + rw [hkey] + simp only + rw [ReaderT.run_bind] + have hget : ReaderT.run + (get : RecM .anon (TcState .anon)) methods s₁ = .ok s₁ s₁ := rfl + change EStateM.bind + (ReaderT.run (get : RecM .anon (TcState .anon)) methods) _ s₁ = _ + unfold EStateM.bind + rw [hget] + simp [hhit] + rfl + +/-- Failure of the initial context-key computation is propagated with its +actual partial state; the memo and bounded loop are not consulted. -/ +theorem tryReduceNatSuccIter_entryKeyError + {methods : Methods .anon} {s s₁ : TcState .anon} + {arg : KExpr .anon} {err : TcError .anon} + (hkey : TcM.whnfKey arg s = .error err s₁) : + (tryReduceNatSuccIter arg).run methods s = .error err s₁ := by + unfold tryReduceNatSuccIter + rw [ReaderT.run_bind] + change EStateM.bind (TcM.whnfKey arg) _ s = _ + unfold EStateM.bind + rw [hkey] + +/-- On an entry-memo miss, the public successor helper is exactly the named +bounded loop initialized with offset one and the entry key as its first +visited marker. -/ +theorem tryReduceNatSuccIter_entryMiss + {methods : Methods .anon} {s s₁ : TcState .anon} + {arg : KExpr .anon} {key : Address × Address} + (hkey : TcM.whnfKey arg s = .ok key s₁) + (hmiss : s₁.env.natSuccStuck.contains key = false) : + (tryReduceNatSuccIter arg).run methods s = + (runBounded tryReduceNatSuccIterStep maxWhnfFuel.toNat + (arg, 1, #[key])).run methods s₁ := by + unfold tryReduceNatSuccIter + rw [ReaderT.run_bind] + change EStateM.bind (TcM.whnfKey arg) _ s = _ + unfold EStateM.bind + rw [hkey] + simp only + rw [ReaderT.run_bind] + have hget : ReaderT.run + (get : RecM .anon (TcState .anon)) methods s₁ = .ok s₁ s₁ := rfl + change EStateM.bind + (ReaderT.run (get : RecM .anon (TcState .anon)) methods) _ s₁ = _ + unfold EStateM.bind + rw [hget] + simp [hmiss] + +/-- The linear-recognizer hit has strict precedence over recursive WHNF. -/ +theorem tryReduceNatSuccIterStep_linearHit + {methods : Methods .anon} {s s₁ : TcState .anon} + {cur result : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} + (hlinear : (tryReduceNatSuccLinearRec cur offset).run methods s = + .ok (some result) s₁) : + (tryReduceNatSuccIterStep (cur, offset, visited)).run methods s = + .ok (.done (some result)) s₁ := by + unfold tryReduceNatSuccIterStep + rw [ReaderT.run_bind] + change EStateM.bind ((tryReduceNatSuccLinearRec cur offset).run methods) + _ s = _ + unfold EStateM.bind + rw [hlinear] + rfl + +/-- A linear-recognizer error is propagated before recursive WHNF begins. -/ +theorem tryReduceNatSuccIterStep_linearError + {methods : Methods .anon} {s s₁ : TcState .anon} + {cur : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} {err : TcError .anon} + (hlinear : (tryReduceNatSuccLinearRec cur offset).run methods s = + .error err s₁) : + (tryReduceNatSuccIterStep (cur, offset, visited)).run methods s = + .error err s₁ := by + unfold tryReduceNatSuccIterStep + rw [ReaderT.run_bind] + change EStateM.bind ((tryReduceNatSuccLinearRec cur offset).run methods) + _ s = _ + unfold EStateM.bind + rw [hlinear] + +/-- After a linear miss, recursive-WHNF errors retain the callback's exact +partial state and never reach literal classification or a memo write. -/ +theorem tryReduceNatSuccIterStep_whnfError + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {cur : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} {err : TcError .anon} + (hlinear : (tryReduceNatSuccLinearRec cur offset).run methods s = + .ok none s₁) + (hwhnf : (whnfModeRec cur .stuck).run methods s₁ = .error err s₂) : + (tryReduceNatSuccIterStep (cur, offset, visited)).run methods s = + .error err s₂ := by + unfold tryReduceNatSuccIterStep + rw [ReaderT.run_bind] + change EStateM.bind ((tryReduceNatSuccLinearRec cur offset).run methods) + _ s = _ + unfold EStateM.bind + rw [hlinear] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfModeRec cur .stuck).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hwhnf] + +/-- Once both recursive phases have succeeded, the named classification seam +is used without changing or filtering any of its success/error outcomes. -/ +theorem tryReduceNatSuccIterStep_afterWhnf + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {cur w : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} + {outcome : EStateM.Result (TcError .anon) (TcState .anon) + (BoundedStep (KExpr .anon × Nat × Array (Address × Address)) + (Option (KExpr .anon)))} + (hlinear : (tryReduceNatSuccLinearRec cur offset).run methods s = + .ok none s₁) + (hwhnf : (whnfModeRec cur .stuck).run methods s₁ = .ok w s₂) + (hafter : (tryReduceNatSuccAfterWhnf w offset visited).run methods s₂ = + outcome) : + (tryReduceNatSuccIterStep (cur, offset, visited)).run methods s = + outcome := by + unfold tryReduceNatSuccIterStep + rw [ReaderT.run_bind] + change EStateM.bind ((tryReduceNatSuccLinearRec cur offset).run methods) + _ s = _ + unfold EStateM.bind + rw [hlinear] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((whnfModeRec cur .stuck).run methods) _ s₁ = _ + unfold EStateM.bind + rw [hwhnf] + simpa using hafter + +/-- Literal recognition terminates the iteration state-purely and adds the +accumulated successor offset exactly once. -/ +theorem tryReduceNatSuccAfterWhnf_literal + {methods : Methods .anon} {s : TcState .anon} + {w : KExpr .anon} {offset n : Nat} + {visited : Array (Address × Address)} {p : Primitives .anon} + (hprims : s.prims = p) + (hextract : extractNatLit w p = some n) : + (tryReduceNatSuccAfterWhnf w offset visited).run methods s = + .ok (.done (some (natExprFromValue (n + offset)))) s := by + unfold tryReduceNatSuccAfterWhnf + rw [ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok p s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok p s + rw [hprims] + rw [hprimsRun] + simp [hextract] + rfl + +/-- A normalized non-successor writes exactly the visited marker fold, then +returns `.done none`; it cannot proceed to either key computation. -/ +theorem tryReduceNatSuccAfterWhnf_stuck + {methods : Methods .anon} {s : TcState .anon} + {w : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} {p : Primitives .anon} + (hprims : s.prims = p) + (hextract : extractNatLit w p = none) + (hclass : (isNatSuccSpine w).run methods s = .ok false s) : + let after := {s with env := {s.env with natSuccStuck := + (visited.foldl (fun set key => set.insert key) s.env.natSuccStuck)}} + (tryReduceNatSuccAfterWhnf w offset visited).run methods s = + .ok (.done none) after := by + dsimp only + unfold tryReduceNatSuccAfterWhnf + rw [ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok p s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok p s + rw [hprims] + rw [hprimsRun] + simp only + rw [hextract] + simp only + rw [ReaderT.run_bind] + change EStateM.bind ((isNatSuccSpine w).run methods) _ s = _ + unfold EStateM.bind + rw [hclass] + simp only [Bool.false_eq_true, if_false] + rfl + +/-- Exact evaluator for the shared stuck-marker commit. -/ +theorem recordNatSuccStuck_eval + {methods : Methods .anon} {s : TcState .anon} + (visited : Array (Address × Address)) : + let after := {s with env := {s.env with natSuccStuck := + (visited.foldl (fun set key => set.insert key) s.env.natSuccStuck)}} + (recordNatSuccStuck visited).run methods s = .ok () after := by + rfl + +/-- The shared memo commit preserves every K1 state component when each +visited marker has explicit cache provenance. -/ +theorem recordNatSuccStuck_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + (visited : Array (Address × Address)) + (hnew : ∀ key ∈ visited, + CacheProvenance semantics (CacheAuthority.stable world) support + (.natSuccStuck key)) : + RecM.WF layer semantics trProj world support uvars Delta s + (recordNatSuccStuck visited) (fun _ _ => True) := by + unfold recordNatSuccStuck + apply RecM.WF.modify + · intro hI + exact NatSuccStuckCacheUpdate.fold_whnfStateInv visited hI hnew + · intro _ + trivial + +/-- The first peeled-argument key failure is propagated before memo lookup. -/ +theorem tryReduceNatSuccPeel_keyError + {methods : Methods .anon} {s s₁ : TcState .anon} + {w cur : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} {err : TcError .anon} + (hkey : TcM.whnfKey cur s = .error err s₁) : + (tryReduceNatSuccPeel w cur offset visited).run methods s = + .error err s₁ := by + unfold tryReduceNatSuccPeel + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.whnfKey cur) _ s = _ + unfold EStateM.bind + rw [hkey] + +/-- A successful peeled-argument key is handed to the memo-decision seam +without altering any of its possible outcomes. -/ +theorem tryReduceNatSuccPeel_afterKey + {methods : Methods .anon} {s s₁ : TcState .anon} + {w cur : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} {curKey : Address × Address} + {outcome : EStateM.Result (TcError .anon) (TcState .anon) + (BoundedStep (KExpr .anon × Nat × Array (Address × Address)) + (Option (KExpr .anon)))} + (hkey : TcM.whnfKey cur s = .ok curKey s₁) + (hafter : (tryReduceNatSuccPeelAfterKey w cur offset visited curKey).run + methods s₁ = outcome) : + (tryReduceNatSuccPeel w cur offset visited).run methods s = outcome := by + unfold tryReduceNatSuccPeel + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.whnfKey cur) _ s = _ + unfold EStateM.bind + rw [hkey] + simpa using hafter + +/-- A known-stuck suffix commits the visited prefix and terminates without +computing the normalized successor expression's key. -/ +theorem tryReduceNatSuccPeelAfterKey_hit + {methods : Methods .anon} {s : TcState .anon} + {w cur : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} {curKey : Address × Address} + (hhit : s.env.natSuccStuck.contains curKey = true) : + let after := {s with env := {s.env with natSuccStuck := + (visited.foldl (fun set key => set.insert key) s.env.natSuccStuck)}} + (tryReduceNatSuccPeelAfterKey w cur offset visited curKey).run methods s = + .ok (.done none) after := by + dsimp only + unfold tryReduceNatSuccPeelAfterKey + rw [ReaderT.run_bind] + have hget : ReaderT.run + (get : RecM .anon (TcState .anon)) methods s = .ok s s := rfl + change EStateM.bind + (ReaderT.run (get : RecM .anon (TcState .anon)) methods) _ s = _ + unfold EStateM.bind + rw [hget] + simp [hhit, recordNatSuccStuck] + rfl + +/-- A peeled-key memo miss delegates exactly to the second-key seam. -/ +theorem tryReduceNatSuccPeelAfterKey_miss + {methods : Methods .anon} {s : TcState .anon} + {w cur : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} {curKey : Address × Address} + (hmiss : s.env.natSuccStuck.contains curKey = false) : + (tryReduceNatSuccPeelAfterKey w cur offset visited curKey).run methods s = + (tryReduceNatSuccPeelMiss w cur offset visited curKey).run methods s := by + unfold tryReduceNatSuccPeelAfterKey + rw [ReaderT.run_bind] + have hget : ReaderT.run + (get : RecM .anon (TcState .anon)) methods s = .ok s s := rfl + change EStateM.bind + (ReaderT.run (get : RecM .anon (TcState .anon)) methods) _ s = _ + unfold EStateM.bind + rw [hget] + simp [hmiss] + +/-- The second key failure retains the partial state reached after the first +key and memo miss. -/ +theorem tryReduceNatSuccPeelMiss_keyError + {methods : Methods .anon} {s s₁ : TcState .anon} + {w cur : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} {curKey : Address × Address} + {err : TcError .anon} + (hkey : TcM.whnfKey w s = .error err s₁) : + (tryReduceNatSuccPeelMiss w cur offset visited curKey).run methods s = + .error err s₁ := by + unfold tryReduceNatSuccPeelMiss + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.whnfKey w) _ s = _ + unfold EStateM.bind + rw [hkey] + +/-- Both successor keys are appended in production order before the loop +continues, and the numeric offset is incremented exactly once. -/ +theorem tryReduceNatSuccPeelMiss_next + {methods : Methods .anon} {s s₁ : TcState .anon} + {w cur : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} {curKey wKey : Address × Address} + (hkey : TcM.whnfKey w s = .ok wKey s₁) : + (tryReduceNatSuccPeelMiss w cur offset visited curKey).run methods s = + .ok (.next (cur, offset + 1, (visited.push curKey).push wKey)) s₁ := by + unfold tryReduceNatSuccPeelMiss + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.whnfKey w) _ s = _ + unfold EStateM.bind + rw [hkey] + rfl + +/-- A positive successor classification delegates to the peel seam without +filtering either its successful action or its partial error state. -/ +theorem tryReduceNatSuccAfterWhnf_succ + {methods : Methods .anon} {s : TcState .anon} + {w head cur : KExpr .anon} {args : Array (KExpr .anon)} + {offset : Nat} {visited : Array (Address × Address)} + {p : Primitives .anon} + {outcome : EStateM.Result (TcError .anon) (TcState .anon) + (BoundedStep (KExpr .anon × Nat × Array (Address × Address)) + (Option (KExpr .anon)))} + (hprims : s.prims = p) + (hextract : extractNatLit w p = none) + (hspine : w.collectSpine = (head, args)) + (harg : args[0]! = cur) + (hclass : (isNatSuccSpine w).run methods s = .ok true s) + (hpeel : (tryReduceNatSuccPeel w cur offset visited).run methods s = + outcome) : + (tryReduceNatSuccAfterWhnf w offset visited).run methods s = outcome := by + unfold tryReduceNatSuccAfterWhnf + rw [ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok p s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok p s + rw [hprims] + rw [hprimsRun] + simp only + rw [hextract] + simp only + rw [hspine] + rw [ReaderT.run_bind] + change EStateM.bind ((isNatSuccSpine w).run methods) _ s = _ + unfold EStateM.bind + rw [hclass] + simp only [if_true] + rw [harg] + simpa using hpeel + +/-- In `stuck` mode the outer Nat dispatcher recognizes `Nat.succ` but +intentionally bypasses the successor loop. -/ +theorem tryReduceNatWithSuccMode_succ_stuck + {methods : Methods .anon} {s : TcState .anon} + {source arg : KExpr .anon} {id : KId .anon} + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {p : Primitives .anon} + (hspine : source.collectSpine = (.const id us info, #[arg])) + (hprims : s.prims = p) + (haddr : id.addr = p.natSucc.addr) : + (tryReduceNatWithSuccMode source .stuck).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok p s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok p s + rw [hprims] + rw [hprimsRun] + simp [haddr] + rfl + +/-- In collapse mode the exact same one-argument spine delegates to the +successor loop, preserving both successes and partial errors. -/ +theorem tryReduceNatWithSuccMode_succ_collapse + {methods : Methods .anon} {s : TcState .anon} + {source arg : KExpr .anon} {id : KId .anon} + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {p : Primitives .anon} + {outcome : EStateM.Result (TcError .anon) (TcState .anon) + (Option (KExpr .anon))} + (hspine : source.collectSpine = (.const id us info, #[arg])) + (hprims : s.prims = p) + (haddr : id.addr = p.natSucc.addr) + (hiter : (tryReduceNatSuccIter arg).run methods s = outcome) : + (tryReduceNatWithSuccMode source .collapse).run methods s = outcome := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok p s := by + unfold RecM.prims + change EStateM.Result.ok s.prims s = .ok p s + rw [hprims] + rw [hprimsRun] + simp [haddr] + simpa using hiter + +/-! ### Semantic successor-loop closure -/ + +/-- Theory expression obtained by applying `Nat.succ` `offset` times. The +successor loop's concrete state stores the inner expression and this offset +separately; this function is their ghost semantic reconstruction. -/ +def natSuccIterV : Nat → VExpr → VExpr + | 0, value => value + | offset + 1, value => .app .natSucc (natSuccIterV offset value) + +@[simp] theorem natSuccIterV_zero (value : VExpr) : + natSuccIterV 0 value = value := rfl + +@[simp] theorem natSuccIterV_succ (offset : Nat) (value : VExpr) : + natSuccIterV (offset + 1) value = + .app .natSucc (natSuccIterV offset value) := rfl + +/-- Peeling one concrete successor and incrementing the ghost offset are the +same Theory expression. -/ +theorem natSuccIterV_peel (offset : Nat) (value : VExpr) : + natSuccIterV offset (.app .natSucc value) = + natSuccIterV (offset + 1) value := by + induction offset with + | zero => rfl + | succ offset ih => + simp only [natSuccIterV_succ, ih] + +/-- Reconstructed successors over a numeral are exactly addition by the +stored offset. -/ +theorem natSuccIterV_natLit (offset n : Nat) : + natSuccIterV offset (.natLit n) = .natLit (n + offset) := by + induction offset with + | zero => simp + | succ offset ih => + rw [natSuccIterV_succ, ih, Nat.add_succ] + rfl + +/-- The catalog entry selected by the production successor address has the +canonical Theory type `Nat → Nat`. -/ +theorem natSucc_hasType + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Delta : KVLCtx} {prims : Primitives .anon} + (hcatalog : TrustedCatalogRel trProj world) + (htable : NoDeltaPrimitiveTableAgrees world prims) + (hprims : world.venv.HasPrimitives) : + world.venv.HasType uvars Delta.toCtx .natSucc + (.forallE .nat .nat) := by + obtain ⟨ci, hlookup⟩ := htable.natSucc.contains hcatalog + have hci := hprims.natSucc hlookup + subst ci + exact Lean4Lean.VEnv.HasType.const hlookup (by simp) rfl + +/-- Successor reconstruction preserves the canonical Nat type. -/ +theorem natSuccIterV_hasType + {env : Lean4Lean.VEnv} {uvars : Nat} {Gamma : List VExpr} + (hsucc : env.HasType uvars Gamma .natSucc (.forallE .nat .nat)) + {value : VExpr} (hvalue : env.HasType uvars Gamma value .nat) + (offset : Nat) : + env.HasType uvars Gamma (natSuccIterV offset value) .nat := by + induction offset with + | zero => exact hvalue + | succ offset ih => exact Lean4Lean.VEnv.HasType.app hsucc ih + +/-- Definitional equality of the current inner Nat lifts through every +successor already represented by the loop offset. -/ +theorem natSuccIterV_congr + {env : Lean4Lean.VEnv} (henv : env.WF) + {uvars : Nat} {Gamma : List VExpr} + (hGamma : Lean4Lean.OnCtx Gamma (env.IsType uvars)) + (hsucc : env.HasType uvars Gamma .natSucc (.forallE .nat .nat)) + {left right : VExpr} + (hleft : env.HasType uvars Gamma left .nat) + (heq : env.IsDefEqU uvars Gamma left right) + (offset : Nat) : + env.IsDefEqU uvars Gamma + (natSuccIterV offset left) (natSuccIterV offset right) := by + induction offset with + | zero => exact heq + | succ offset ih => + have hleftIter := natSuccIterV_hasType hsucc hleft offset + have hi := ih.of_l henv hGamma hleftIter + exact (hsucc.appDF hi).toU + +/-- Exact one-argument successor spine accepted by `isNatSuccSpine`. -/ +def NatSuccSpine (prims : Primitives .anon) + (source cur : KExpr .anon) : Prop := + ∃ id us info, + source.collectSpine = (.const id us info, #[cur]) ∧ + id.addr = prims.natSucc.addr + +/-- The successor classifier is a state-transparent read, and every positive +answer exposes the exact concrete spine that caused it. -/ +theorem isNatSuccSpine_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + (source : KExpr .anon) : + RecM.WF layer semantics trProj world support uvars Delta s + (isNatSuccSpine source) + (fun answer after => after = s ∧ + (answer = true → ∃ cur, NatSuccSpine s.prims source cur)) := by + unfold isNatSuccSpine + generalize hspine : source.collectSpine = spine + cases spine with + | mk head args => + cases head with + | const id us info => + apply RecM.WF.bind (prims_wf (s := s)) + intro prims after hread + rcases hread with ⟨hprims, hafter⟩ + apply RecM.WF.pure + intro _ + constructor + · exact hafter + · intro htrue + simp only [Bool.and_eq_true] at htrue + have haddr : id.addr = prims.natSucc.addr := + beq_iff_eq.mp htrue.1 + have hsize : args.size = 1 := beq_iff_eq.mp htrue.2 + obtain ⟨cur, hargs⟩ := Array.size_eq_one_iff.mp hsize + exact ⟨cur, id, us, info, + hspine.trans + (congrArg (fun a => (KExpr.const id us info, a)) hargs), + haddr.trans (congrArg (fun p : Primitives .anon => + p.natSucc.addr) hprims)⟩ + | var idx name info => + apply RecM.WF.pure + intro _ + exact ⟨rfl, by simp⟩ + | fvar id name info => + apply RecM.WF.pure + intro _ + exact ⟨rfl, by simp⟩ + | sort u info => + apply RecM.WF.pure + intro _ + exact ⟨rfl, by simp⟩ + | app f a info => + apply RecM.WF.pure + intro _ + exact ⟨rfl, by simp⟩ + | lam name bi ty body info => + apply RecM.WF.pure + intro _ + exact ⟨rfl, by simp⟩ + | all name bi ty body info => + apply RecM.WF.pure + intro _ + exact ⟨rfl, by simp⟩ + | letE name ty val body nondep info => + apply RecM.WF.pure + intro _ + exact ⟨rfl, by simp⟩ + | prj id field val info => + apply RecM.WF.pure + intro _ + exact ⟨rfl, by simp⟩ + | nat value blob info => + apply RecM.WF.pure + intro _ + exact ⟨rfl, by simp⟩ + | str value blob info => + apply RecM.WF.pure + intro _ + exact ⟨rfl, by simp⟩ + +/-- Singleton inversion for the typed application-spine view. -/ +theorem trAppSpine_singleton + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {Delta : KVLCtx} {head arg : KExpr .anon} + {resultV : VExpr} + (h : TrAppSpine env uvars nameOf trProj Delta head [arg] resultV) : + ∃ headV argV A B, + resultV = .app headV argV ∧ + TrKExprS env uvars nameOf trProj Delta head headV ∧ + env.HasType uvars Delta.toCtx headV (.forallE A B) ∧ + env.HasType uvars Delta.toCtx argV A ∧ + TrKExprS env uvars nameOf trProj Delta arg argV := by + generalize hargs : [arg] = args at h + cases h with + | head hhead => simp at hargs + | @app args fV arg' argV A B hprefix hfun harg htr => + have hshape : args = [] ∧ arg' = arg := by + have hsingleton := List.append_eq_singleton_iff.mp hargs.symm + rcases hsingleton with ⟨hargs, harg'⟩ | ⟨_, himpossible⟩ + · exact ⟨hargs, List.singleton_inj.mp harg'⟩ + · simp at himpossible + rcases hshape with ⟨rfl, rfl⟩ + have hhead : TrKExprS env uvars nameOf trProj Delta head fV := by + simpa using hprefix.tr + exact ⟨fV, argV, A, B, rfl, hhead, hfun, harg, htr⟩ + +/-- A translated concrete successor spine exposes a translated, Nat-typed +inner expression and the canonical Theory successor application. -/ +theorem natSuccSpine_tr + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Delta : KVLCtx} {prims : Primitives .anon} + {source cur : KExpr .anon} {sourceV : VExpr} + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hcatalog : TrustedCatalogRel trProj world) + (htable : NoDeltaPrimitiveTableAgrees world prims) + (hprims : world.venv.HasPrimitives) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + source sourceV) + (hspine : NatSuccSpine prims source cur) : + ∃ curV, + TrKExprS world.venv uvars world.nameOf trProj Delta cur curV ∧ + world.venv.HasType uvars Delta.toCtx curV .nat ∧ + sourceV = .app .natSucc curV := by + obtain ⟨id, us, info, hcollect, haddr⟩ := hspine + have hview := trAppSpine_of_collectSpine hsource hcollect + change TrAppSpine world.venv uvars world.nameOf trProj Delta + (.const id us info) [cur] sourceV at hview + obtain ⟨headV, curV, A, B, rfl, hhead, hfun, harg, hcur⟩ := + trAppSpine_singleton hview + let .const (c := c) (ci := ci) hname hlookup hunivs hsize := hhead + have hc : c = ``Nat.succ := by + rw [haddr, htable.natSucc.2] at hname + exact Option.some.inj hname.symm + subst c + have hci := hprims.natSucc hlookup + subst ci + have hus : us = #[] := Array.eq_empty_of_size_eq_zero hsize + subst us + have hsucc := natSucc_hasType (uvars := uvars) (Delta := Delta) + hcatalog htable hprims + have htypes := hfun.uniqU world.venvWF hDelta.toCtx hsucc + obtain ⟨⟨_, hdomain⟩, _⟩ := + htypes.forallE_inv world.venvWF hDelta.toCtx + have hargNat := Lean4Lean.VEnv.HasType.defeqU_r + world.venvWF hDelta.toCtx + ⟨_, hdomain⟩ harg + exact ⟨curV, hcur, hargNat, rfl⟩ + +/-- Authorization boundary for the negative successor memo. The second +context-key component is irrelevant to soundness because a marker suppresses +only an optional optimization; its source address, support, references, and +semantic cache family remain fully certified. -/ +structure NatSuccStuckWriteOracle (semantics : CacheSemantics) + (world : VerifyWorld) (support : RunSupport) : Prop where + authorize : ∀ {source : KExpr .anon} {key : Address × Address}, + support source → key.1 = source.addr → + CacheProvenance semantics (CacheAuthority.stable world) support + (.natSuccStuck key) + +namespace NatSuccStuckWriteOracle + +/-- Construct the marker oracle for K1's WHNF semantic overlay once every +finite-support expression is known to reference trusted declarations. -/ +theorem forWhnfCache + {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {world : VerifyWorld} + {support : RunSupport} + (hreferences : ∀ {source : KExpr .anon} {id : KId .anon}, + support source → source.References id → world.trusted id) : + NatSuccStuckWriteOracle (whnfCacheSemantics keys trProj fallback) + world support := by + constructor + intro source key hsource haddr + apply CacheProvenance.whnfNatSuccStuck + · exact ⟨source, hsource, haddr.symm⟩ + · intro id href + obtain ⟨found, hfound, _, hfoundRef⟩ := href + exact hreferences hfound hfoundRef + +end NatSuccStuckWriteOracle + +/-- Every marker accumulated by the current successor-loop execution already +has the exact provenance required by a later bulk commit. -/ +def NatSuccVisited (semantics : CacheSemantics) (world : VerifyWorld) + (support : RunSupport) (visited : Array (Address × Address)) : Prop := + ∀ key ∈ visited, + CacheProvenance semantics (CacheAuthority.stable world) support + (.natSuccStuck key) + +/-! ### Linear Nat-recognizer semantic boundary -/ + +/-- Structural fact retained by a successful `natRecLiteralParts` lookup. +The descriptor controls the returned indices, but the spine itself must be +the production spine of the expression being inspected. -/ +def NatRecLiteralPartsPost (source : KExpr .anon) : + Option (NatRecLiteralParts .anon) → Prop + | none => True + | some parts => source.collectSpine.2 = parts.spine + +/-- State-safety contract for the descriptor lookup inside the linear Nat +recognizer. This is deliberately separated from Nat.rec semantics: its only +nontrivial effect is the driver's lazy `tryGetConst` ingress. -/ +def NatRecLiteralPartsPreserves (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Prop := + ∀ {uvars : Nat} {Delta : KVLCtx} {source : KExpr .anon} + {s : TcState .anon}, + RecM.WF layer semantics trProj world support uvars Delta s + (natRecLiteralParts source) + (fun result _ => NatRecLiteralPartsPost source result) + +/-- A successful linear-recognition run has exactly one remaining semantic +claim: the numeral it returned denotes the successor-offset reconstruction +of the original Nat. State preservation, callback closure, misses, and +partial errors are not part of this boundary. -/ +structure NatSuccLinearReflection (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Prop where + success : ∀ {uvars : Nat} {Delta : KVLCtx} {cur reduced : KExpr .anon} + {curV : VExpr} {offset : Nat} {s after : TcState .anon} + {methods : Methods .anon}, + support cur → + TrKExprS world.venv uvars world.nameOf trProj Delta cur curV → + world.venv.HasType uvars Delta.toCtx curV .nat → + Methods.WFAt layer semantics trProj world support uvars methods → + WhnfStateInv layer semantics trProj world support uvars Delta s → + (tryReduceNatSuccLinearRec cur offset).run methods s = + .ok (some reduced) after → + ∃ reducedV, + TrKExprS world.venv uvars world.nameOf trProj Delta reduced reducedV ∧ + world.venv.IsDefEqU uvars Delta.toCtx + (natSuccIterV offset curV) reducedV + +/-- The syntactic step recognizer preserves K1 state through its sole +recursive WHNF callback. All later lambda/spine/address tests and primitive +reads are state-transparent. -/ +theorem isNatSuccIhStep_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {step : KExpr .anon} + {stepV : VExpr} {s : TcState .anon} + (hstep : support step) + (hstepTr : TrKExprS world.venv uvars world.nameOf trProj Delta + step stepV) : + RecM.WF layer semantics trProj world support uvars Delta s + (isNatSuccIhStep step) (fun _ _ => True) := by + unfold isNatSuccIhStep + apply RecM.WF.bind (whnfRec_wf hstep hstepTr) + intro reduced after hcallback + cases reduced <;> simp only + all_goals try exact RecM.WF.pure (fun _ => trivial) + case lam name bi ty body info => + cases body <;> simp only + all_goals try exact RecM.WF.pure (fun _ => trivial) + case lam name' bi' ty' body info' => + generalize hspine : body.collectSpine = spine + rcases spine with ⟨head, args⟩ + cases head <;> simp only + all_goals try exact RecM.WF.pure (fun _ => trivial) + case const id us info => + apply RecM.WF.bind (prims_wf (s := after)) + intro prims afterRead _ + split + · exact RecM.WF.pure fun _ => trivial + · generalize harg : args[0]! = arg + cases arg + all_goals try exact RecM.WF.pure (fun _ => trivial) + case var idx name info => + split <;> exact RecM.WF.pure fun _ => trivial + +/-- Once descriptor lookup preserves the invariant, the complete linear +recognizer preserves it too. The proof obtains support and translation for +the runtime-selected base and step positions from the original typed spine, +then uses the ordinary recursive-method contracts for both callbacks. -/ +theorem tryReduceNatSuccLinearRec_effect_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} + (context : NoDeltaPrimitiveContext world support flags .collapse) + (partsPreserve : NatRecLiteralPartsPreserves layer semantics trProj + world support) + {uvars : Nat} {Delta : KVLCtx} {cur : KExpr .anon} + {curV : VExpr} {offset : Nat} {s : TcState .anon} + (hcur : support cur) + (hcurTr : TrKExprS world.venv uvars world.nameOf trProj Delta cur curV) : + RecM.WF layer semantics trProj world support uvars Delta s + (tryReduceNatSuccLinearRec cur offset) (fun _ _ => True) := by + unfold tryReduceNatSuccLinearRec + apply RecM.WF.bind (partsPreserve (source := cur) (s := s)) + intro found afterParts hparts + cases found with + | none => + simp only + exact RecM.WF.pure fun _ => trivial + | some parts => + simp only + change cur.collectSpine.2 = parts.spine at hparts + have hspineSupport := context.inputs.spine hcur + (show cur.collectSpine = + (cur.collectSpine.1, cur.collectSpine.2) from rfl) + have hspineTr := trAppSpine_of_collectSpine hcurTr + (show cur.collectSpine = + (cur.collectSpine.1, cur.collectSpine.2) from rfl) + cases hbase : parts.spine[parts.baseIdx]? with + | none => + exact RecM.WF.pure fun _ => trivial + | some base => + obtain ⟨hbaseIdx, hbaseAt⟩ := getElem?_eq_some_iff.mp hbase + have hbaseSupport : support base := by + have := hspineSupport.2 parts.baseIdx (by + simpa only [← hparts] using hbaseIdx) + simpa only [hparts, hbaseAt] using this + obtain ⟨baseV, baseType, hbaseType, hbaseTr⟩ := + hspineTr.argument (arg := base) (by + rw [hparts] + exact Array.mem_toList_iff.mpr (Array.mem_of_getElem? hbase)) + cases hstep : parts.spine[parts.stepIdx]? with + | none => + exact RecM.WF.pure fun _ => trivial + | some step => + obtain ⟨hstepIdx, hstepAt⟩ := getElem?_eq_some_iff.mp hstep + have hstepSupport : support step := by + have := hspineSupport.2 parts.stepIdx (by + simpa only [← hparts] using hstepIdx) + simpa only [hparts, hstepAt] using this + obtain ⟨stepV, stepType, hstepType, hstepTr⟩ := + hspineTr.argument (arg := step) (by + rw [hparts] + exact Array.mem_toList_iff.mpr (Array.mem_of_getElem? hstep)) + apply RecM.WF.bind + (isNatSuccIhStep_wf hstepSupport hstepTr) + intro accepted afterStep _ + cases accepted with + | false => + exact RecM.WF.pure fun _ => trivial + | true => + apply RecM.WF.bind (whnfRec_wf hbaseSupport hbaseTr) + intro baseWhnf afterBase _ + apply RecM.WF.bind (prims_wf (s := afterBase)) + intro prims afterRead _ + cases hextract : extractNatValue baseWhnf prims with + | none => + cases hsize : + parts.spine.size != parts.majorIdx + 1 with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ => trivial + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + have hadd : RecM.WF layer semantics trProj world + support uvars Delta afterRead + (mkNatAdd baseWhnf + (natExprFromValue (parts.major + offset))) + (fun _ _ => True) := by + unfold mkNatAdd + apply RecM.WF.bind (prims_wf (s := afterRead)) + intro _ _ _ + exact RecM.WF.pure fun _ => trivial + apply RecM.WF.bind hadd + intro _ _ _ + exact RecM.WF.pure fun _ => trivial + | some baseVal => + exact RecM.WF.pure fun _ => trivial + +/-- Compatibility form consumed by the successor-loop proof. The preceding +recognizer decomposition derives this whole-computation contract from +separately audited operational effects and a success-only Nat.rec reflection +law. -/ +structure NatSuccLinearOracle (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Prop where + reduce : ∀ {uvars : Nat} {Delta : KVLCtx} {cur : KExpr .anon} + {curV : VExpr} {offset : Nat} {s : TcState .anon}, + support cur → + TrKExprS world.venv uvars world.nameOf trProj Delta cur curV → + world.venv.HasType uvars Delta.toCtx curV .nat → + RecM.WF layer semantics trProj world support uvars Delta s + (tryReduceNatSuccLinearRec cur offset) + (fun result _ => match result with + | none => True + | some reduced => ∃ reducedV, + TrKExprS world.venv uvars world.nameOf trProj Delta + reduced reducedV ∧ + world.venv.IsDefEqU uvars Delta.toCtx + (natSuccIterV offset curV) reducedV) + +namespace NatSuccLinearOracle + +/-- Construct the compatibility oracle from the proved operational effect +theorem and the one success-only Nat.rec reflection law. -/ +theorem of_reflection + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} + (context : NoDeltaPrimitiveContext world support flags .collapse) + (partsPreserve : NatRecLiteralPartsPreserves layer semantics trProj + world support) + (reflection : NatSuccLinearReflection layer semantics trProj world + support) : + NatSuccLinearOracle layer semantics trProj world support := by + constructor + intro uvars Delta cur curV offset s hcur hcurTr hcurType + have heffect := tryReduceNatSuccLinearRec_effect_wf context partsPreserve + (offset := offset) (s := s) hcur hcurTr + intro methods hmethods hI + have hpost := heffect methods hmethods hI + match hrun : (tryReduceNatSuccLinearRec cur offset).run methods s with + | .error err after => + rw [hrun] at hpost + exact hpost + | .ok result after => + rw [hrun] at hpost + cases result with + | none => exact ⟨hpost.1, trivial⟩ + | some reduced => + exact ⟨hpost.1, + reflection.success hcur hcurTr hcurType hmethods hI hrun⟩ + +end NatSuccLinearOracle + +/-- Ghost invariant carried by the actual bounded successor loop. It ties +the original source translation to the current inner expression plus offset, +and retains provenance for every key that either stuck exit may commit. -/ +def NatSuccLoopState (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (sourceV : VExpr) + (cur : KExpr .anon) (offset : Nat) + (visited : Array (Address × Address)) : Prop := + ∃ curV, + support cur ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta cur curV ∧ + world.venv.HasType uvars Delta.toCtx curV .nat ∧ + world.venv.IsDefEqU uvars Delta.toCtx sourceV + (natSuccIterV offset curV) ∧ + NatSuccVisited semantics world support visited + +/-- Semantic postcondition of the bounded loop before the outer concrete +source translation is reattached as `WhnfMeaning`. -/ +def NatSuccLoopResult (trProj : RawProjRel) (world : VerifyWorld) + (uvars : Nat) (Delta : KVLCtx) (sourceV : VExpr) : + Option (KExpr .anon) → Prop + | none => True + | some reduced => ∃ reducedV, + TrKExprS world.venv uvars world.nameOf trProj Delta reduced reducedV ∧ + world.venv.IsDefEqU uvars Delta.toCtx sourceV reducedV + +/-- Uniform semantic postcondition for one concrete successor-loop action. -/ +def NatSuccLoopAction (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (sourceV : VExpr) : + BoundedStep (KExpr .anon × Nat × Array (Address × Address)) + (Option (KExpr .anon)) → Prop + | .next (cur, offset, visited) => + NatSuccLoopState semantics trProj world support uvars Delta sourceV + cur offset visited + | .done result => NatSuccLoopResult trProj world uvars Delta sourceV result + +/-- On a peeled-key miss, the second key is certified and both new markers +extend the loop provenance before the next state is returned. -/ +theorem tryReduceNatSuccPeelMiss_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (writes : NatSuccStuckWriteOracle semantics world support) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {sourceV curV : VExpr} {w cur : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} + {curKey : Address × Address} + (hw : support w) (hcur : support cur) + (hcurTr : TrKExprS world.venv uvars world.nameOf trProj Delta cur curV) + (hcurType : world.venv.HasType uvars Delta.toCtx curV .nat) + (hsourceEq : world.venv.IsDefEqU uvars Delta.toCtx sourceV + (natSuccIterV (offset + 1) curV)) + (hvisited : NatSuccVisited semantics world support visited) + (hcurKey : curKey.1 = cur.addr) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryReduceNatSuccPeelMiss w cur offset visited curKey) + (fun action _ => NatSuccLoopAction semantics trProj world support + uvars Delta sourceV action) := by + unfold tryReduceNatSuccPeelMiss + apply RecM.WF.bind + (Q₁ := fun key after => key.1 = w.addr ∧ ContextKeyFrame s after) + (RecM.WF.liftTcM + (TcM.whnfKey_wf (layer := .noAccel) (semantics := semantics) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Δ := Delta) (source := w) (s := s))) + intro wKey after hwKey + apply RecM.WF.pure + intro _ + refine ⟨curV, hcur, hcurTr, hcurType, hsourceEq, ?_⟩ + intro key hmem + simp only [Array.mem_push] at hmem + rcases hmem with (hmem | hkey) | hkey + · exact hvisited key hmem + · subst key + exact writes.authorize hcur hcurKey + · subst key + exact writes.authorize hw hwKey.1 + +/-- A peeled key hit safely commits the old trace; a miss delegates to the +second-key path while retaining the strengthened semantic state. -/ +theorem tryReduceNatSuccPeelAfterKey_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (writes : NatSuccStuckWriteOracle semantics world support) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {sourceV curV : VExpr} {w cur : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} + {curKey : Address × Address} + (hw : support w) (hcur : support cur) + (hcurTr : TrKExprS world.venv uvars world.nameOf trProj Delta cur curV) + (hcurType : world.venv.HasType uvars Delta.toCtx curV .nat) + (hsourceEq : world.venv.IsDefEqU uvars Delta.toCtx sourceV + (natSuccIterV (offset + 1) curV)) + (hvisited : NatSuccVisited semantics world support visited) + (hcurKey : curKey.1 = cur.addr) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryReduceNatSuccPeelAfterKey w cur offset visited curKey) + (fun action _ => NatSuccLoopAction semantics trProj world support + uvars Delta sourceV action) := by + unfold tryReduceNatSuccPeelAfterKey + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s ∧ after = s) + (RecM.WF.get (s := s) fun _ => ⟨rfl, rfl⟩) + rintro observed after ⟨rfl, rfl⟩ + simp only + split + · apply RecM.WF.bind (recordNatSuccStuck_wf visited hvisited) + intro _ after _ + exact RecM.WF.pure fun _ => trivial + · exact tryReduceNatSuccPeelMiss_wf writes hw hcur hcurTr + hcurType hsourceEq hvisited hcurKey + +/-- The first peeled key is state-framed and its source address is retained +for either the hit or miss branch. -/ +theorem tryReduceNatSuccPeel_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (writes : NatSuccStuckWriteOracle semantics world support) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {sourceV curV : VExpr} {w cur : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} + (hw : support w) (hcur : support cur) + (hcurTr : TrKExprS world.venv uvars world.nameOf trProj Delta cur curV) + (hcurType : world.venv.HasType uvars Delta.toCtx curV .nat) + (hsourceEq : world.venv.IsDefEqU uvars Delta.toCtx sourceV + (natSuccIterV (offset + 1) curV)) + (hvisited : NatSuccVisited semantics world support visited) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryReduceNatSuccPeel w cur offset visited) + (fun action _ => NatSuccLoopAction semantics trProj world support + uvars Delta sourceV action) := by + unfold tryReduceNatSuccPeel + apply RecM.WF.bind + (Q₁ := fun key after => key.1 = cur.addr ∧ ContextKeyFrame s after) + (RecM.WF.liftTcM + (TcM.whnfKey_wf (layer := .noAccel) (semantics := semantics) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Δ := Delta) (source := cur) (s := s))) + intro curKey after hkey + exact tryReduceNatSuccPeelAfterKey_wf writes hw hcur hcurTr + hcurType hsourceEq hvisited hkey.1 + +/-- Literal, successor, and stuck classification after recursive WHNF all +preserve the loop invariant. A successor peel uses typing uniqueness to +recover the next inner Nat before incrementing the ghost offset. -/ +theorem tryReduceNatSuccAfterWhnf_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {flags : WhnfFlags} + (context : NoDeltaPrimitiveContext world support flags .collapse) + (writes : NatSuccStuckWriteOracle semantics world support) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {sourceV curV : VExpr} {w : KExpr .anon} {offset : Nat} + {visited : Array (Address × Address)} + (hw : support w) + (hpost : WhnfPost trProj world uvars Delta curV w) + (hcurType : world.venv.HasType uvars Delta.toCtx curV .nat) + (hsourceEq : world.venv.IsDefEqU uvars Delta.toCtx sourceV + (natSuccIterV offset curV)) + (hvisited : NatSuccVisited semantics world support visited) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryReduceNatSuccAfterWhnf w offset visited) + (fun action _ => NatSuccLoopAction semantics trProj world support + uvars Delta sourceV action) := by + unfold tryReduceNatSuccAfterWhnf + apply RecM.WF.bind + (Q₁ := fun p after => + WhnfStateInv .noAccel semantics trProj world support uvars Delta after ∧ + p = s.prims ∧ after = s) + (RecM.WF.withInv (prims_wf (s := s))) + rintro p after ⟨hI, hp, rfl⟩ + simp only + split + · rename_i n hextract + apply RecM.WF.pure + intro _ + have htable := context.stateTable hI + have htableP : NoDeltaPrimitiveTableAgrees world p := by + simpa only [hp] using htable + have hsucc := natSucc_hasType (uvars := uvars) (Delta := Delta) + hI.1.core.trustedCatalog htableP context.theoryPrimitives + have hcurLit := hpost.of_extractNatLit htableP + context.theoryPrimitives hextract + have hlift := natSuccIterV_congr world.venvWF hI.2.1.wf.toCtx + hsucc hcurType hcurLit offset + refine ⟨_, TrKExprS.natExprFromValue hI.1.core.trustedCatalog + htableP (n + offset), ?_⟩ + exact hsourceEq.trans world.venvWF hI.2.1.wf <| by + simpa only [natSuccIterV_natLit] using hlift + · rename_i hextract + generalize hcollect : w.collectSpine = spine + cases spine with + | mk head args => + apply RecM.WF.bind + (Q₁ := fun answer classified => + WhnfStateInv .noAccel semantics trProj world support uvars Delta + classified ∧ + classified = after ∧ + (answer = true → ∃ cur, NatSuccSpine after.prims w cur)) + (RecM.WF.withInv (isNatSuccSpine_wf (s := after) w)) + rintro answer classified ⟨hClassI, rfl, hclass⟩ + split + · rename_i htrue + obtain ⟨cur, hspine⟩ := hclass htrue + obtain ⟨wV, hwTr, hcurW⟩ := hpost + have htable := context.stateTable hClassI + obtain ⟨nextV, hnextTr, hnextType, hwV⟩ := + natSuccSpine_tr hClassI.2.1.wf + hClassI.1.core.trustedCatalog htable + context.theoryPrimitives hwTr hspine + obtain ⟨id, us, info, hnextSpine, haddr⟩ := hspine + have hnext := (context.inputs.spine hw hnextSpine).2 0 (by simp) + have hargs : args = #[cur] := congrArg Prod.snd + (hcollect.symm.trans hnextSpine) + have hcurAt : args[0]! = cur := by simp [hargs] + have hsucc := natSucc_hasType (uvars := uvars) (Delta := Delta) + hClassI.1.core.trustedCatalog htable context.theoryPrimitives + have hlift := natSuccIterV_congr world.venvWF + hClassI.2.1.wf.toCtx hsucc hcurType hcurW offset + have hnextEq : world.venv.IsDefEqU uvars Delta.toCtx sourceV + (natSuccIterV (offset + 1) nextV) := + hsourceEq.trans world.venvWF hClassI.2.1.wf <| by + rw [hwV, natSuccIterV_peel] at hlift + exact hlift + rw [hcurAt] + simp only [bind_pure] + exact tryReduceNatSuccPeel_wf writes hw hnext hnextTr + hnextType hnextEq hvisited + · simp only [pure_bind] + apply RecM.WF.bind (recordNatSuccStuck_wf visited hvisited) + intro _ committed _ + exact RecM.WF.pure fun _ => trivial + +/-- One actual successor-loop iteration satisfies the ghost action contract. +Linear recognition has precedence; on a miss, recursive stuck-mode WHNF and +the complete post-WHNF classifier preserve the same source meaning. -/ +theorem tryReduceNatSuccIterStep_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {flags : WhnfFlags} + (context : NoDeltaPrimitiveContext world support flags .collapse) + (writes : NatSuccStuckWriteOracle semantics world support) + (linear : NatSuccLinearOracle .noAccel semantics trProj world support) + {uvars : Nat} {Delta : KVLCtx} {sourceV : VExpr} + (state : KExpr .anon × Nat × Array (Address × Address)) + (s : TcState .anon) + (hstate : NatSuccLoopState semantics trProj world support uvars Delta + sourceV state.1 state.2.1 state.2.2) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryReduceNatSuccIterStep state) + (fun action _ => NatSuccLoopAction semantics trProj world support + uvars Delta sourceV action) := by + rcases state with ⟨cur, offset, visited⟩ + obtain ⟨curV, hcur, hcurTr, hcurType, hsourceEq, hvisited⟩ := hstate + unfold tryReduceNatSuccIterStep + apply RecM.WF.bind (linear.reduce hcur hcurTr hcurType) + intro result after hlinear + cases result with + | some reduced => + apply RecM.WF.pure + intro hI + obtain ⟨reducedV, hreducedTr, hreducedEq⟩ := hlinear + exact ⟨reducedV, hreducedTr, + hsourceEq.trans world.venvWF hI.2.1.wf hreducedEq⟩ + | none => + simp only [pure_bind] + apply RecM.WF.bind (whnfModeRec_wf hcur hcurTr) + intro w afterWhnf hwhnf + exact tryReduceNatSuccAfterWhnf_wf context writes hwhnf.1 + hwhnf.2 hcurType hsourceEq hvisited + +/-- The public successor-collapse helper satisfies its semantic result +contract for arbitrary successor chains. The entry memo hit is a safe miss; +the miss path seeds certified provenance and invokes the generic bounded-loop +driver, whose exhaustion and callback errors still preserve K1 state. -/ +theorem tryReduceNatSuccIter_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {flags : WhnfFlags} + (context : NoDeltaPrimitiveContext world support flags .collapse) + (writes : NatSuccStuckWriteOracle semantics world support) + (linear : NatSuccLinearOracle .noAccel semantics trProj world support) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {sourceV argV : VExpr} {arg : KExpr .anon} + (harg : support arg) + (hargTr : TrKExprS world.venv uvars world.nameOf trProj Delta arg argV) + (hargType : world.venv.HasType uvars Delta.toCtx argV .nat) + (hsourceEq : world.venv.IsDefEqU uvars Delta.toCtx sourceV + (natSuccIterV 1 argV)) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryReduceNatSuccIter arg) + (fun result _ => + NatSuccLoopResult trProj world uvars Delta sourceV result) := by + unfold tryReduceNatSuccIter + apply RecM.WF.bind + (Q₁ := fun key after => key.1 = arg.addr ∧ ContextKeyFrame s after) + (RecM.WF.liftTcM + (TcM.whnfKey_wf (layer := .noAccel) (semantics := semantics) + (trProj := trProj) (world := world) (support := support) + (uvars := uvars) (Δ := Delta) (source := arg) (s := s))) + intro entryKey afterKey hkey + apply RecM.WF.bind + (Q₁ := fun observed after => observed = afterKey ∧ after = afterKey) + (RecM.WF.get (s := afterKey) fun _ => ⟨rfl, rfl⟩) + rintro observed afterGet ⟨rfl, rfl⟩ + split + · exact RecM.WF.pure fun _ => trivial + · apply runBounded_wf + (P := fun state => NatSuccLoopState semantics trProj world support + uvars Delta sourceV state.1 state.2.1 state.2.2) + (Q := fun result _ => + NatSuccLoopResult trProj world uvars Delta sourceV result) + (E := fun _ _ => True) + · intro state loopState hloop + apply RecM.WF.mono + (tryReduceNatSuccIterStep_wf context writes linear + state loopState hloop) + · intro action after haction + cases action with + | next next => + rcases next with ⟨cur, offset, visited⟩ + exact haction + | done result => exact haction + · intro err after _ + trivial + · intro exhausted hI + trivial + · exact ⟨argV, harg, hargTr, hargType, hsourceEq, by + intro key hmem + simp only [Array.mem_singleton] at hmem + subst key + exact writes.authorize harg hkey.1⟩ + +/-! ### Outer and uniform Nat-dispatch closure -/ + +/-- The production Nat dispatcher preserves optional-reduction semantics on +an exact one-argument `Nat.succ` spine in collapse mode. Successful support +is recovered from the actual outer execution rather than assumed for the +inner loop result; absent results and partial-error states retain the loop's +full `RecM.WF` invariant. -/ +theorem tryReduceNatWithSuccMode_succ_optional_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {flags : WhnfFlags} + (context : NoDeltaPrimitiveContext world support flags .collapse) + (writes : NatSuccStuckWriteOracle semantics world support) + (linear : NatSuccLinearOracle .noAccel semantics trProj world support) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {source arg : KExpr .anon} {sourceV : VExpr} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + source sourceV) + (hspine : NatSuccSpine s.prims source arg) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryReduceNatWithSuccMode source .collapse) + (fun result _ => match result with + | none => True + | some reduced => + support reduced ∧ + WhnfMeaning trProj world uvars Delta source reduced) := by + intro methods hmethods hI + have hspineData := hspine + obtain ⟨id, us, info, hcollect, haddr⟩ := hspineData + have htable := context.stateTable hI + obtain ⟨argV, hargTr, hargType, hsourceV⟩ := + natSuccSpine_tr (source := source) (cur := arg) + hI.2.1.wf hI.1.core.trustedCatalog htable + context.theoryPrimitives hsource hspine + have hargSupport : support arg := by + simpa using (context.inputs.spine hsourceSupport hcollect).2 0 (by simp) + have hsucc := natSucc_hasType (uvars := uvars) (Delta := Delta) + hI.1.core.trustedCatalog htable context.theoryPrimitives + have happType : world.venv.HasType uvars Delta.toCtx + (.app .natSucc argV) .nat := + Lean4Lean.VEnv.HasType.app hsucc hargType + have hsourceEq : world.venv.IsDefEqU uvars Delta.toCtx sourceV + (natSuccIterV 1 argV) := by + rw [hsourceV] + simpa only [natSuccIterV_succ, natSuccIterV_zero] using + (show world.venv.IsDefEqU uvars Delta.toCtx + (.app .natSucc argV) (.app .natSucc argV) from ⟨_, happType⟩) + have hinnerWF := tryReduceNatSuccIter_wf context writes linear + hargSupport hargTr hargType hsourceEq methods hmethods hI + match hinner : (tryReduceNatSuccIter arg).run methods s with + | .error err after => + rw [hinner] at hinnerWF + have houter := tryReduceNatWithSuccMode_succ_collapse hcollect rfl + haddr hinner + rw [houter] + exact hinnerWF + | .ok result after => + rw [hinner] at hinnerWF + have houter := tryReduceNatWithSuccMode_succ_collapse hcollect rfl + haddr hinner + rw [houter] + cases result with + | none => exact hinnerWF + | some reduced => + obtain ⟨reducedV, hreducedTr, hreducedEq⟩ := hinnerWF.2 + exact ⟨hinnerWF.1, + context.generated.nat hsourceSupport houter, + sourceV, reducedV, hsource, hreducedTr, hreducedEq⟩ + +/-- Every array of at least two arguments is its binary prefix followed by +the exact production suffix consumed by `finishAppResult`. -/ +theorem natArgs_eq_binaryPrefix_append_extract + {args : Array (KExpr .anon)} (hsize : 2 ≤ args.size) : + args = #[args[0], args[1]] ++ args.extract 2 args.size := by + have hprefix : args.extract 0 2 = #[args[0], args[1]] := by + apply Array.ext + · simp [Array.size_extract] + omega + · intro i hi hi' + have hiCases : i = 0 ∨ i = 1 := by + simp at hi' + omega + rcases hiCases with hzero | hone + · subst i + simp [Array.getElem_extract] + · subst i + simp [Array.getElem_extract] + rfl + calc + args = args.extract 0 args.size := by simp + _ = args.extract 0 2 ++ args.extract 2 args.size := by + rw [Array.extract_append_extract] + rw [Nat.max_eq_right hsize] + rfl + _ = #[args[0], args[1]] ++ args.extract 2 args.size := by rw [hprefix] + +/-- Finite suffix-rebuild coverage for every supported binary-or-longer Nat +dispatcher entry. This is the global assembly form of the fixed-entry +certificate: it remains scoped to the finite run support and to successful +traces actually possible under a well-formed method table. -/ +def NatCollapseFinishCoverage (requests : List WalkerRequest) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Prop := + ∀ {uvars : Nat} {source : KExpr .anon} {headId : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {args suffix : Array (KExpr .anon)} {argA argB : KExpr .anon} + {s : TcState .anon}, + support source → + source.collectSpine = (.const headId us headInfo, args) → + args = #[argA, argB] ++ suffix → ∀ methods, + Methods.WFAt .noAccel semantics trProj world support uvars methods → + NatSpineFinishCoverage requests methods .collapse source headId us + headInfo args argA argB s + +/-! ### Uniform Nat closure for both successor policies -/ + +/-- In stuck-successor mode every constant-headed spine shorter than two +arguments is an exact state-transparent miss. This includes the canonical +one-argument `Nat.succ` case, which is deliberately reserved for the outer +successor loop. -/ +theorem tryReduceNatWithSuccMode_stuck_short + {methods : Methods .anon} {s : TcState .anon} + {source : KExpr .anon} {id : KId .anon} + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} + (hspine : source.collectSpine = (.const id us info, args)) + (hshort : args.size < 2) : + (tryReduceNatWithSuccMode source .stuck).run methods s = .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hspine, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + rw [show RecM.prims.run methods s = .ok s.prims s from rfl] + simp [hshort] + split <;> rfl + +/-- Exhaustive stuck-successor Nat optional-reduction contract. The reserved +one-argument successor is a miss; every successful binary primitive uses the +same finite request census and deterministic replay as collapse mode. -/ +theorem tryReduceNatWithSuccMode_stuck_optional_wf + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {flags : WhnfFlags} + (context : NoDeltaPrimitiveContext world support flags .stuck) + (hrun : RunAssumptions initial program requests support) + (theory : ∀ uvars, WhnfTheory trProj world uvars) + (census : NatCollapseRequestCensus requests semantics trProj world + support) : + OptionalReduction.WF .noAccel semantics trProj world support + (fun source => tryReduceNatWithSuccMode source .stuck) := by + intro uvars Delta source sourceV s hsourceSupport hsource + generalize hcollect : source.collectSpine = spine + rcases spine with ⟨head, args⟩ + cases head with + | const id us info => + by_cases hshort : args.size < 2 + · intro methods hmethods hI + rw [tryReduceNatWithSuccMode_stuck_short hcollect hshort] + exact ⟨hI, trivial⟩ + · have hsize : 2 ≤ args.size := by omega + have hargs := natArgs_eq_binaryPrefix_append_extract hsize + exact tryReduceNatWithSuccMode_spine_optional_wf context hrun + (theory uvars) hsourceSupport hsource hcollect hargs + (fun methods hmethods hI {_ _} trace => + NatCollapseRequestCensus.certify context hrun census + hsourceSupport hsource hcollect hargs hmethods hI trace) + | var idx name info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .stuck).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | fvar id name info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .stuck).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | sort u info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .stuck).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | app f a info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .stuck).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | lam name bi ty body info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .stuck).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | all name bi ty body info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .stuck).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | letE name ty val body nondep info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .stuck).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | prj id field val info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .stuck).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | nat value blob info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .stuck).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | str value blob info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .stuck).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + +/-- Exhaustive collapse-mode Nat optional-reduction contract. Non-constant +heads and short non-successor spines are state-transparent misses, the exact +one-argument successor branch uses the verified bounded loop, and every +binary-or-longer spine is recovered from the finite suffix-request census by +deterministic replay. -/ +theorem tryReduceNatWithSuccMode_collapse_optional_wf + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {flags : WhnfFlags} + (context : NoDeltaPrimitiveContext world support flags .collapse) + (hrun : RunAssumptions initial program requests support) + (theory : ∀ uvars, WhnfTheory trProj world uvars) + (writes : NatSuccStuckWriteOracle semantics world support) + (linear : NatSuccLinearOracle .noAccel semantics trProj world support) + (census : NatCollapseRequestCensus requests semantics trProj world + support) : + OptionalReduction.WF .noAccel semantics trProj world support + (fun source => tryReduceNatWithSuccMode source .collapse) := by + intro uvars Delta source sourceV s hsourceSupport hsource + generalize hcollect : source.collectSpine = spine + rcases spine with ⟨head, args⟩ + cases head with + | const id us info => + by_cases hsizeOne : args.size = 1 + · obtain ⟨arg, hargs⟩ := Array.size_eq_one_iff.mp hsizeOne + subst args + by_cases haddr : id.addr = s.prims.natSucc.addr + · exact tryReduceNatWithSuccMode_succ_optional_wf context writes + linear hsourceSupport hsource + ⟨id, us, info, hcollect, haddr⟩ + · intro methods hmethods hI + have hrun : + (tryReduceNatWithSuccMode source .collapse).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok s.prims s := rfl + rw [hprimsRun] + simp [haddr] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + · by_cases hshort : args.size < 2 + · intro methods hmethods hI + have hrun : + (tryReduceNatWithSuccMode source .collapse).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + have hprimsRun : RecM.prims.run methods s = .ok s.prims s := rfl + rw [hprimsRun] + simp [hsizeOne, hshort] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + · have hsize : 2 ≤ args.size := by omega + have hargs := natArgs_eq_binaryPrefix_append_extract hsize + exact tryReduceNatWithSuccMode_spine_optional_wf context hrun + (theory uvars) hsourceSupport hsource hcollect hargs + (fun methods hmethods hI {_ _} trace => + NatCollapseRequestCensus.certify context hrun census + hsourceSupport hsource hcollect hargs hmethods hI trace) + | var idx name info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .collapse).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | fvar id name info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .collapse).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | sort u info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .collapse).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | app f a info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .collapse).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | lam name bi ty body info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .collapse).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | all name bi ty body info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .collapse).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | letE name ty val body nondep info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .collapse).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | prj id field val info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .collapse).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | nat value blob info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .collapse).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + | str value blob info => + intro methods hmethods hI + have hrun : (tryReduceNatWithSuccMode source .collapse).run methods s = + .ok none s := by + unfold tryReduceNatWithSuccMode + rw [hcollect] + rfl + rw [hrun] + exact ⟨hI, trivial⟩ + +/-- K1's narrow collapse-mode Nat closure surface. The implementation proof +constructs both former whole-computation assumptions: descriptor ingress +plus callback closure yield the linear recognizer's effect contract, while +successful callback meaning plus canonical result-shape separation yields an +empty suffix census. What remains semantic is stated directly as Nat.rec +reflection and the `Nat`/`Bool`-versus-function Theory fact. -/ +theorem tryReduceNatWithSuccMode_collapse_optional_wf_of_boundaries + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {flags : WhnfFlags} + (context : NoDeltaPrimitiveContext world support flags .collapse) + (hrun : RunAssumptions initial program requests support) + (theory : ∀ uvars, WhnfTheory trProj world uvars) + (writes : NatSuccStuckWriteOracle semantics world support) + (partsPreserve : NatRecLiteralPartsPreserves .noAccel semantics trProj + world support) + (reflection : NatSuccLinearReflection .noAccel semantics trProj world + support) + (shape : NatCollapseRequestCensus.NatBoolResultShapeSeparation world) : + OptionalReduction.WF .noAccel semantics trProj world support + (fun source => tryReduceNatWithSuccMode source .collapse) := + tryReduceNatWithSuccMode_collapse_optional_wf context hrun theory writes + (NatSuccLinearOracle.of_reflection context partsPreserve reflection) + (NatCollapseRequestCensus.of_result_shape context theory shape) + +/-- K1's stuck-mode Nat closure surface. Unary `Nat.succ` is deliberately +reserved for the surrounding successor loop, so this mode needs neither the +linear Nat.rec reflection boundary nor stuck-cache writes. Canonical +Nat/Bool result-shape separation is the only semantic boundary beyond the +common primitive context, callback contracts, and run certificate. -/ +theorem tryReduceNatWithSuccMode_stuck_optional_wf_of_boundary + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {flags : WhnfFlags} + (context : NoDeltaPrimitiveContext world support flags .stuck) + (hrun : RunAssumptions initial program requests support) + (theory : ∀ uvars, WhnfTheory trProj world uvars) + (shape : NatCollapseRequestCensus.NatBoolResultShapeSeparation world) : + OptionalReduction.WF .noAccel semantics trProj world support + (fun source => tryReduceNatWithSuccMode source .stuck) := + tryReduceNatWithSuccMode_stuck_optional_wf context hrun theory + (NatCollapseRequestCensus.of_result_shape context theory shape) + +/-- Uniform Nat field for both production successor policies. Case analysis +on the finite policy type exposes that collapse mode alone consumes the +linear-recognizer and memo-write boundaries; both modes share the canonical +Nat/Bool result-shape theorem. -/ +theorem tryReduceNatWithSuccMode_optional_wf_of_boundaries + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {flags : WhnfFlags} + (context : ∀ mode, + NoDeltaPrimitiveContext world support flags mode) + (hrun : RunAssumptions initial program requests support) + (theory : ∀ uvars, WhnfTheory trProj world uvars) + (writes : NatSuccStuckWriteOracle semantics world support) + (partsPreserve : NatRecLiteralPartsPreserves .noAccel semantics trProj + world support) + (reflection : NatSuccLinearReflection .noAccel semantics trProj world + support) + (shape : NatCollapseRequestCensus.NatBoolResultShapeSeparation world) + (mode : NatSuccMode) : + OptionalReduction.WF .noAccel semantics trProj world support + (fun source => tryReduceNatWithSuccMode source mode) := by + cases mode with + | collapse => + exact tryReduceNatWithSuccMode_collapse_optional_wf_of_boundaries + (context .collapse) hrun theory writes partsPreserve reflection + shape + | stuck => + exact tryReduceNatWithSuccMode_stuck_optional_wf_of_boundary + (context .stuck) hrun theory shape + +end RecM + +/-! Uniform semantic contract for the structural result consumed by the +no-delta reducer tail. This is deliberately the production +`whnfCoreWithFlags`, not a method-table callback or an execution equation. -/ +namespace StructuralReduction + +def WF (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Δ : KVLCtx) (flags : WhnfFlags) : Prop := + ∀ {source sourceV s}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Δ source sourceV → + RecM.WF layer semantics trProj world support uvars Δ s + (RecM.whnfCoreWithFlags source flags) + (fun reduced _ => + support reduced ∧ + WhnfMeaning trProj world uvars Δ source reduced) + +end StructuralReduction + +/-- Exhaustive semantic boundary for the seven optional reducers in one +no-delta tail. The fields mirror production order and distinguish the +full-only projection-wrapper stage from the unconditional quotient stage. +This is proof debt, not an axiom: primitive, projection, quotient, and native +verification must construct the corresponding fields. -/ +structure NoDeltaReductionOracle (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) + (flags : WhnfFlags) (natSuccMode : NatSuccMode) : Prop where + projApp : OptionalReduction.WF layer semantics trProj world support + (fun source => RecM.tryProjAppReduceFinished source flags) + bitvec : OptionalReduction.WF layer semantics trProj world support + RecM.tryReduceBitvec + nat : OptionalReduction.WF layer semantics trProj world support + (fun source => RecM.tryReduceNatWithSuccMode source natSuccMode) + native : OptionalReduction.WF layer semantics trProj world support + RecM.tryReduceNative + string : OptionalReduction.WF layer semantics trProj world support + RecM.tryReduceString + projectionDef : OptionalReduction.WF layer semantics trProj world support + RecM.tryReduceProjectionDefinition + quot : OptionalReduction.WF layer semantics trProj world support + RecM.tryQuotReduce + +namespace RecM + +/-- With `noAccel` pinned, the general native helper returns `none` without +changing state and without consulting the method table. -/ +theorem tryReduceNative_noAccel {methods : Methods .anon} + {s : TcState .anon} (h : s.noAccel = true) (e : KExpr .anon) : + (tryReduceNative e).run methods s = .ok none s := by + unfold tryReduceNative + rw [ReaderT.run_bind] + change (EStateM.bind EStateM.get _) s = _ + simp [EStateM.bind, EStateM.get, h] + rfl + +/-- The BitVec acceleration gate is absent from the no-acceleration layer. -/ +theorem tryReduceBitvec_noAccel {methods : Methods .anon} + {s : TcState .anon} (h : s.noAccel = true) (e : KExpr .anon) : + (tryReduceBitvec e).run methods s = .ok none s := by + unfold tryReduceBitvec + rw [ReaderT.run_bind] + change (EStateM.bind EStateM.get _) s = _ + simp [EStateM.bind, EStateM.get, h] + rfl + +/-- The production native gate satisfies the complete optional-reducer Hoare +contract in the no-acceleration layer: it returns `none` before reading the +source shape, invoking callbacks, or changing state. -/ +theorem tryReduceNative_noAccel_optional_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} : + OptionalReduction.WF .noAccel semantics trProj world support + tryReduceNative := by + intro uvars Δ source sourceV s hsource htr + intro methods hmethods hI + rw [tryReduceNative_noAccel hI.2.2.1 source] + exact ⟨hI, trivial⟩ + +/-- The production BitVec gate has the same exact no-acceleration contract. +In particular, no support-closure or primitive semantic premise is smuggled +into this proof: a hit is operationally impossible under `StateOK`. -/ +theorem tryReduceBitvec_noAccel_optional_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} : + OptionalReduction.WF .noAccel semantics trProj world support + tryReduceBitvec := by + intro uvars Δ source sourceV s hsource htr + intro methods hmethods hI + rw [tryReduceBitvec_noAccel hI.2.2.1 source] + exact ⟨hI, trivial⟩ + +end RecM + +namespace NoDeltaBaseOracle + +/-- Complete the seven-field production oracle in the no-acceleration layer. +The two omitted fields are not assumptions: they are the concrete gate +proofs above. -/ +theorem toNoAccel + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (oracle : NoDeltaBaseOracle semantics trProj world support flags + natSuccMode) : + NoDeltaReductionOracle .noAccel semantics trProj world support flags + natSuccMode where + projApp := oracle.projApp + bitvec := RecM.tryReduceBitvec_noAccel_optional_wf + nat := oracle.nat + native := RecM.tryReduceNative_noAccel_optional_wf + string := oracle.string + projectionDef := oracle.projectionDef + quot := oracle.quot + +end NoDeltaBaseOracle + +namespace RecM + +/-- The Decidable synthesis acceleration gate is absent from the +no-acceleration layer. -/ +theorem tryReduceDecidable_noAccel {methods : Methods .anon} + {s : TcState .anon} (h : s.noAccel = true) (e : KExpr .anon) : + (tryReduceDecidable e).run methods s = .ok none s := by + unfold tryReduceDecidable + rw [ReaderT.run_bind] + change (EStateM.bind EStateM.get _) s = _ + simp [EStateM.bind, EStateM.get, h] + rfl + +/-- The specialized `Fin.val`/`Decidable.rec` acceleration gate is absent +from the no-acceleration layer. -/ +theorem tryReduceFinValDecidableRec_noAccel {methods : Methods .anon} + {s : TcState .anon} (h : s.noAccel = true) (id : KId .anon) + (field : UInt64) (head : KExpr .anon) (args : Array (KExpr .anon)) : + (tryReduceFinValDecidableRec id field head args).run methods s = + .ok none s := by + unfold tryReduceFinValDecidableRec + rw [ReaderT.run_bind] + change (EStateM.bind EStateM.get _) s = _ + simp [EStateM.bind, EStateM.get, h] + rfl + +/-! ### No-delta reducer seam -/ + +/-- Exact successful projection-app completion: the projection helper's +spine is rebuilt by the same certified left-to-right helper used by beta and +changed-head application reduction. -/ +theorem tryProjAppReduceFinished_some + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {e projResult result : KExpr .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} + (hproj : (tryProjAppReduce e flags).run methods s = + .ok (some (projResult, args)) s₁) + (hfinish : (finishAppResult projResult args 0).run methods s₁ = + .ok result s₂) : + (tryProjAppReduceFinished e flags).run methods s = + .ok (some result) s₂ := by + unfold tryProjAppReduceFinished + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryProjAppReduce e flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + change EStateM.bind + (ReaderT.run (finishAppResult projResult args 0) methods) _ s₁ = _ + unfold EStateM.bind + rw [hfinish] + rfl + +/-- A projection-app miss is state-transparent through the completion seam. -/ +theorem tryProjAppReduceFinished_none + {methods : Methods .anon} {s s₁ : TcState .anon} + {e : KExpr .anon} {flags : WhnfFlags} + (hproj : (tryProjAppReduce e flags).run methods s = .ok none s₁) : + (tryProjAppReduceFinished e flags).run methods s = .ok none s₁ := by + unfold tryProjAppReduceFinished + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryProjAppReduce e flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + rfl + +/-- Projection-app helper errors retain their exact partial state and prevent +the rebuilding helper from running. -/ +theorem tryProjAppReduceFinished_projError + {methods : Methods .anon} {s s₁ : TcState .anon} + {e : KExpr .anon} {flags : WhnfFlags} {err : TcError .anon} + (hproj : (tryProjAppReduce e flags).run methods s = .error err s₁) : + (tryProjAppReduceFinished e flags).run methods s = .error err s₁ := by + unfold tryProjAppReduceFinished + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryProjAppReduce e flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + +/-- Rebuilding errors, if the helper's implementation ever becomes fallible, +are propagated after projection success with the rebuild's partial state. -/ +theorem tryProjAppReduceFinished_finishError + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {e projResult : KExpr .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} {err : TcError .anon} + (hproj : (tryProjAppReduce e flags).run methods s = + .ok (some (projResult, args)) s₁) + (hfinish : (finishAppResult projResult args 0).run methods s₁ = + .error err s₂) : + (tryProjAppReduceFinished e flags).run methods s = + .error err s₂ := by + unfold tryProjAppReduceFinished + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryProjAppReduce e flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + change EStateM.bind + (ReaderT.run (finishAppResult projResult args 0) methods) _ s₁ = _ + unfold EStateM.bind + rw [hfinish] + +/-- Projection-app is the first no-delta reducer and short-circuits every +later helper on success. -/ +theorem whnfNoDeltaReducersStep_projApp + {methods : Methods .anon} {s s₁ : TcState .anon} + {cur result : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok (some result) s₁) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .ok (.next result) s₁ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + rfl + +/-- BitVec reduction is attempted exactly after a projection-app miss. -/ +theorem whnfNoDeltaReducersStep_bitvec + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {cur result : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = + .ok (some result) s₂) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .ok (.next result) s₂ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + rfl + +/-- Nat reduction follows projection-app and BitVec misses. -/ +theorem whnfNoDeltaReducersStep_nat + {methods : Methods .anon} {s s₁ s₂ s₃ : TcState .anon} + {cur result : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok (some result) s₃) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .ok (.next result) s₃ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + rfl + +/-- Native reduction follows projection-app, BitVec, and Nat misses. -/ +theorem whnfNoDeltaReducersStep_native + {methods : Methods .anon} {s s₁ s₂ s₃ s₄ : TcState .anon} + {cur result : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok none s₃) + (hnative : (tryReduceNative cur).run methods s₃ = + .ok (some result) s₄) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .ok (.next result) s₄ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceNative cur) methods) _ s₃ = _ + unfold EStateM.bind + rw [hnative] + rfl + +/-- String reduction follows projection-app, BitVec, Nat, and native misses. -/ +theorem whnfNoDeltaReducersStep_string + {methods : Methods .anon} {s s₁ s₂ s₃ s₄ s₅ : TcState .anon} + {cur result : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok none s₃) + (hnative : (tryReduceNative cur).run methods s₃ = .ok none s₄) + (hstring : (tryReduceString cur).run methods s₄ = + .ok (some result) s₅) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .ok (.next result) s₅ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceNative cur) methods) _ s₃ = _ + unfold EStateM.bind + rw [hnative] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceString cur) methods) _ s₄ = _ + unfold EStateM.bind + rw [hstring] + rfl + +/-- Full-mode projection-wrapper rewriting occurs only after all earlier +literal/native reducers miss. -/ +theorem whnfNoDeltaReducersStep_projectionDef + {methods : Methods .anon} + {s s₁ s₂ s₃ s₄ s₅ s₆ : TcState .anon} + {cur result : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok none s₃) + (hnative : (tryReduceNative cur).run methods s₃ = .ok none s₄) + (hstring : (tryReduceString cur).run methods s₄ = .ok none s₅) + (hfull : flags.isFull = true) + (hprojection : (tryReduceProjectionDefinition cur).run methods s₅ = + .ok (some result) s₆) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .ok (.next result) s₆ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceNative cur) methods) _ s₃ = _ + unfold EStateM.bind + rw [hnative] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceString cur) methods) _ s₄ = _ + unfold EStateM.bind + rw [hstring] + simp only + rw [hfull] + simp only [if_true] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceProjectionDefinition cur) methods) _ s₅ = _ + unfold EStateM.bind + rw [hprojection] + rfl + +/-- In full mode, quotient reduction follows a projection-wrapper miss. -/ +theorem whnfNoDeltaReducersStep_quotFull + {methods : Methods .anon} + {s s₁ s₂ s₃ s₄ s₅ s₆ s₇ : TcState .anon} + {cur result : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok none s₃) + (hnative : (tryReduceNative cur).run methods s₃ = .ok none s₄) + (hstring : (tryReduceString cur).run methods s₄ = .ok none s₅) + (hfull : flags.isFull = true) + (hprojection : (tryReduceProjectionDefinition cur).run methods s₅ = + .ok none s₆) + (hquot : (tryQuotReduce cur).run methods s₆ = + .ok (some result) s₇) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .ok (.next result) s₇ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceNative cur) methods) _ s₃ = _ + unfold EStateM.bind + rw [hnative] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceString cur) methods) _ s₄ = _ + unfold EStateM.bind + rw [hstring] + simp only + rw [hfull] + simp only [if_true] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceProjectionDefinition cur) methods) _ s₅ = _ + unfold EStateM.bind + rw [hprojection] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryQuotReduce cur) methods) _ s₆ = _ + unfold EStateM.bind + rw [hquot] + rfl + +/-- Cheap mode skips projection-wrapper rewriting and proceeds directly to +quotient reduction after the common reducer prefix. -/ +theorem whnfNoDeltaReducersStep_quotCheap + {methods : Methods .anon} + {s s₁ s₂ s₃ s₄ s₅ s₆ : TcState .anon} + {cur result : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok none s₃) + (hnative : (tryReduceNative cur).run methods s₃ = .ok none s₄) + (hstring : (tryReduceString cur).run methods s₄ = .ok none s₅) + (hcheap : flags.isFull = false) + (hquot : (tryQuotReduce cur).run methods s₅ = + .ok (some result) s₆) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .ok (.next result) s₆ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceNative cur) methods) _ s₃ = _ + unfold EStateM.bind + rw [hnative] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceString cur) methods) _ s₄ = _ + unfold EStateM.bind + rw [hstring] + simp only + rw [hcheap] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryQuotReduce cur) methods) _ s₅ = _ + unfold EStateM.bind + rw [hquot] + rfl + +/-- Full-mode stuck fallback records misses from every reducer, including +projection-wrapper and quotient helpers, and returns the structural result. -/ +theorem whnfNoDeltaReducersStep_doneFull + {methods : Methods .anon} + {s s₁ s₂ s₃ s₄ s₅ s₆ s₇ : TcState .anon} + {cur : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok none s₃) + (hnative : (tryReduceNative cur).run methods s₃ = .ok none s₄) + (hstring : (tryReduceString cur).run methods s₄ = .ok none s₅) + (hfull : flags.isFull = true) + (hprojection : (tryReduceProjectionDefinition cur).run methods s₅ = + .ok none s₆) + (hquot : (tryQuotReduce cur).run methods s₆ = .ok none s₇) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .ok (.done cur) s₇ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceNative cur) methods) _ s₃ = _ + unfold EStateM.bind + rw [hnative] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceString cur) methods) _ s₄ = _ + unfold EStateM.bind + rw [hstring] + simp only + rw [hfull] + simp only [if_true] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceProjectionDefinition cur) methods) _ s₅ = _ + unfold EStateM.bind + rw [hprojection] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryQuotReduce cur) methods) _ s₆ = _ + unfold EStateM.bind + rw [hquot] + rfl + +/-- Cheap-mode stuck fallback proves that the projection-wrapper helper was +not merely assumed to miss: it was not executed at all. -/ +theorem whnfNoDeltaReducersStep_doneCheap + {methods : Methods .anon} + {s s₁ s₂ s₃ s₄ s₅ s₆ : TcState .anon} + {cur : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok none s₃) + (hnative : (tryReduceNative cur).run methods s₃ = .ok none s₄) + (hstring : (tryReduceString cur).run methods s₄ = .ok none s₅) + (hcheap : flags.isFull = false) + (hquot : (tryQuotReduce cur).run methods s₅ = .ok none s₆) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .ok (.done cur) s₆ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceNative cur) methods) _ s₃ = _ + unfold EStateM.bind + rw [hnative] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceString cur) methods) _ s₄ = _ + unfold EStateM.bind + rw [hstring] + simp only + rw [hcheap] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryQuotReduce cur) methods) _ s₅ = _ + unfold EStateM.bind + rw [hquot] + rfl + +/-- Projection-app errors stop the reducer chain at its first helper. -/ +theorem whnfNoDeltaReducersStep_projError + {methods : Methods .anon} {s s₁ : TcState .anon} + {cur : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {err : TcError .anon} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .error err s₁) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .error err s₁ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + +/-- BitVec errors are propagated only after a projection-app miss. -/ +theorem whnfNoDeltaReducersStep_bitvecError + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {cur : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {err : TcError .anon} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .error err s₂) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .error err s₂ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + +/-- Nat-helper errors retain the state reached after both earlier misses. -/ +theorem whnfNoDeltaReducersStep_natError + {methods : Methods .anon} {s s₁ s₂ s₃ : TcState .anon} + {cur : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {err : TcError .anon} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .error err s₃) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .error err s₃ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + +/-- Native-helper errors occur only after all three preceding reducers miss. -/ +theorem whnfNoDeltaReducersStep_nativeError + {methods : Methods .anon} {s s₁ s₂ s₃ s₄ : TcState .anon} + {cur : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {err : TcError .anon} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok none s₃) + (hnative : (tryReduceNative cur).run methods s₃ = .error err s₄) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .error err s₄ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceNative cur) methods) _ s₃ = _ + unfold EStateM.bind + rw [hnative] + +/-- String-helper errors retain every earlier helper's post-state. -/ +theorem whnfNoDeltaReducersStep_stringError + {methods : Methods .anon} {s s₁ s₂ s₃ s₄ s₅ : TcState .anon} + {cur : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {err : TcError .anon} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok none s₃) + (hnative : (tryReduceNative cur).run methods s₃ = .ok none s₄) + (hstring : (tryReduceString cur).run methods s₄ = .error err s₅) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .error err s₅ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceNative cur) methods) _ s₃ = _ + unfold EStateM.bind + rw [hnative] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceString cur) methods) _ s₄ = _ + unfold EStateM.bind + rw [hstring] + +/-- Projection-wrapper errors are possible only in full mode and preserve +the exact state produced after the common reducer prefix. -/ +theorem whnfNoDeltaReducersStep_projectionDefError + {methods : Methods .anon} + {s s₁ s₂ s₃ s₄ s₅ s₆ : TcState .anon} + {cur : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {err : TcError .anon} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok none s₃) + (hnative : (tryReduceNative cur).run methods s₃ = .ok none s₄) + (hstring : (tryReduceString cur).run methods s₄ = .ok none s₅) + (hfull : flags.isFull = true) + (hprojection : (tryReduceProjectionDefinition cur).run methods s₅ = + .error err s₆) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .error err s₆ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceNative cur) methods) _ s₃ = _ + unfold EStateM.bind + rw [hnative] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceString cur) methods) _ s₄ = _ + unfold EStateM.bind + rw [hstring] + simp only + rw [hfull] + simp only [if_true] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceProjectionDefinition cur) methods) _ s₅ = _ + unfold EStateM.bind + rw [hprojection] + +/-- Full-mode quotient errors occur after an explicit projection-wrapper +miss and retain the quotient helper's partial state. -/ +theorem whnfNoDeltaReducersStep_quotFullError + {methods : Methods .anon} + {s s₁ s₂ s₃ s₄ s₅ s₆ s₇ : TcState .anon} + {cur : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {err : TcError .anon} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok none s₃) + (hnative : (tryReduceNative cur).run methods s₃ = .ok none s₄) + (hstring : (tryReduceString cur).run methods s₄ = .ok none s₅) + (hfull : flags.isFull = true) + (hprojection : (tryReduceProjectionDefinition cur).run methods s₅ = + .ok none s₆) + (hquot : (tryQuotReduce cur).run methods s₆ = .error err s₇) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .error err s₇ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceNative cur) methods) _ s₃ = _ + unfold EStateM.bind + rw [hnative] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceString cur) methods) _ s₄ = _ + unfold EStateM.bind + rw [hstring] + simp only + rw [hfull] + simp only [if_true] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceProjectionDefinition cur) methods) _ s₅ = _ + unfold EStateM.bind + rw [hprojection] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryQuotReduce cur) methods) _ s₆ = _ + unfold EStateM.bind + rw [hquot] + +/-- Cheap-mode quotient errors demonstrate that projection-wrapper rewriting +was skipped rather than assumed successful or missed. -/ +theorem whnfNoDeltaReducersStep_quotCheapError + {methods : Methods .anon} + {s s₁ s₂ s₃ s₄ s₅ s₆ : TcState .anon} + {cur : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {err : TcError .anon} + (hproj : (tryProjAppReduceFinished cur flags).run methods s = + .ok none s₁) + (hbitvec : (tryReduceBitvec cur).run methods s₁ = .ok none s₂) + (hnat : (tryReduceNatWithSuccMode cur natSuccMode).run methods s₂ = + .ok none s₃) + (hnative : (tryReduceNative cur).run methods s₃ = .ok none s₄) + (hstring : (tryReduceString cur).run methods s₄ = .ok none s₅) + (hcheap : flags.isFull = false) + (hquot : (tryQuotReduce cur).run methods s₅ = .error err s₆) : + (whnfNoDeltaReducersStep flags natSuccMode cur).run methods s = + .error err s₆ := by + unfold whnfNoDeltaReducersStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjAppReduceFinished cur flags) methods) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceBitvec cur) methods) _ s₁ = _ + unfold EStateM.bind + rw [hbitvec] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryReduceNatWithSuccMode cur natSuccMode) methods) _ s₂ = _ + unfold EStateM.bind + rw [hnat] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceNative cur) methods) _ s₃ = _ + unfold EStateM.bind + rw [hnative] + simp only + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryReduceString cur) methods) _ s₄ = _ + unfold EStateM.bind + rw [hstring] + simp only + rw [hcheap] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (tryQuotReduce cur) methods) _ s₅ = _ + unfold EStateM.bind + rw [hquot] + +/-- The outer no-delta step is exactly structural WHNF followed by the named +ordered reducer seam, with both intermediate states visible. -/ +theorem whnfNoDeltaImplStep_ofCore + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {source core : KExpr .anon} + {action : BoundedStep (KExpr .anon) (KExpr .anon)} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (hcore : (whnfCoreWithFlags source flags).run methods s = + .ok core s₁) + (htail : (whnfNoDeltaReducersStep flags natSuccMode core).run methods s₁ = + .ok action s₂) : + (whnfNoDeltaImplStep flags natSuccMode source).run methods s = + .ok action s₂ := by + unfold whnfNoDeltaImplStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (whnfCoreWithFlags source flags) methods) _ s = _ + unfold EStateM.bind + rw [hcore] + exact htail + +/-- A structural-WHNF error stops the no-delta iteration before any optional +reducer executes and retains the structural driver's partial state. -/ +theorem whnfNoDeltaImplStep_coreError + {methods : Methods .anon} {s s₁ : TcState .anon} + {source : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {err : TcError .anon} + (hcore : (whnfCoreWithFlags source flags).run methods s = + .error err s₁) : + (whnfNoDeltaImplStep flags natSuccMode source).run methods s = + .error err s₁ := by + unfold whnfNoDeltaImplStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (whnfCoreWithFlags source flags) methods) _ s = _ + unfold EStateM.bind + rw [hcore] + +/-- An error in the ordered reducer seam is propagated after structural WHNF +with the reducer's exact partial post-state. -/ +theorem whnfNoDeltaImplStep_reducerError + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {source core : KExpr .anon} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} {err : TcError .anon} + (hcore : (whnfCoreWithFlags source flags).run methods s = + .ok core s₁) + (htail : (whnfNoDeltaReducersStep flags natSuccMode core).run methods s₁ = + .error err s₂) : + (whnfNoDeltaImplStep flags natSuccMode source).run methods s = + .error err s₂ := by + unfold whnfNoDeltaImplStep + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (whnfCoreWithFlags source flags) methods) _ s = _ + unfold EStateM.bind + rw [hcore] + exact htail + +/-- Semantic acceptance for any successful reducer branch. Structural and +reducer meanings are composed in the fixed Theory context; support and the +post-state invariant remain branch-local evidence rather than consequences +of the operational equation alone. -/ +theorem whnfNoDeltaImplStep_next_acceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {methods : Methods .anon} + {s s₁ s₂ : TcState .anon} {source core result : KExpr .anon} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (theory : WhnfTheory trProj world uvars) + (hI : WhnfStateInv layer semantics trProj world support uvars Δ s) + (hpost : WhnfStateInv layer semantics trProj world support uvars Δ s₂) + (hcore : (whnfCoreWithFlags source flags).run methods s = + .ok core s₁) + (htail : (whnfNoDeltaReducersStep flags natSuccMode core).run methods s₁ = + .ok (.next result) s₂) + (hresultSupport : support result) + (hcoreMeaning : WhnfMeaning trProj world uvars Δ source core) + (hreducerMeaning : WhnfMeaning trProj world uvars Δ core result) : + (whnfNoDeltaImplStep flags natSuccMode source).run methods s = + .ok (.next result) s₂ ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s₂ ∧ + WhnfStep.Meaning trProj world support uvars Δ id source + (.next result) := by + exact ⟨whnfNoDeltaImplStep_ofCore hcore htail, hpost, + hresultSupport, + theory.transMeaning hI.2.1.wf hcoreMeaning hreducerMeaning⟩ + +/-- Semantic acceptance for the fully stuck reducer tail. The tail returns +the structural result unchanged, so its local semantic contribution is +reflexive and the structural driver's meaning is retained exactly. -/ +theorem whnfNoDeltaImplStep_done_acceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {methods : Methods .anon} + {s s₁ s₂ : TcState .anon} {source core : KExpr .anon} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (hpost : WhnfStateInv layer semantics trProj world support uvars Δ s₂) + (hcore : (whnfCoreWithFlags source flags).run methods s = + .ok core s₁) + (htail : (whnfNoDeltaReducersStep flags natSuccMode core).run methods s₁ = + .ok (.done core) s₂) + (hcoreSupport : support core) + (hcoreMeaning : WhnfMeaning trProj world uvars Δ source core) : + (whnfNoDeltaImplStep flags natSuccMode source).run methods s = + .ok (.done core) s₂ ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s₂ ∧ + WhnfStep.Meaning trProj world support uvars Δ id source + (.done core) := + ⟨whnfNoDeltaImplStep_ofCore hcore htail, hpost, + hcoreSupport, hcoreMeaning⟩ + +/-- Error acceptance keeps partial-state preservation explicit for both the +structural driver and all reducer helpers. Later exhaustive `WhnfStep.WF` +assembly discharges this premise from their individual Hoare contracts. -/ +theorem whnfNoDeltaImplStep_error_acceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {methods : Methods .anon} + {s s' : TcState .anon} {source : KExpr .anon} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} {err : TcError .anon} + (hrun : (whnfNoDeltaImplStep flags natSuccMode source).run methods s = + .error err s') + (hpost : WhnfStateInv layer semantics trProj world support uvars Δ s') : + (whnfNoDeltaImplStep flags natSuccMode source).run methods s = + .error err s' ∧ + WhnfStateInv layer semantics trProj world support uvars Δ s' := + ⟨hrun, hpost⟩ + +/-- The ordered optional-reducer seam satisfies the complete one-step +contract once each concrete helper supplies its uniform Hoare field. The +proof follows production order exactly, short-circuits on the first hit, and +uses reflexive meaning only after every reachable helper misses. -/ +theorem whnfNoDeltaReducersStep_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (theory : WhnfTheory trProj world uvars) + (oracle : NoDeltaReductionOracle layer semantics trProj world support + flags natSuccMode) : + WhnfStep.WF layer semantics trProj world support uvars Δ id + (whnfNoDeltaReducersStep flags natSuccMode) (fun _ _ => True) := by + intro source s hsource + obtain ⟨hsourceSupport, sourceV, hsourceTr⟩ := hsource + unfold whnfNoDeltaReducersStep + apply RecM.WF.bind (oracle.projApp hsourceSupport hsourceTr) + intro projResult s₁ hproj + cases projResult with + | some result => + apply RecM.WF.pure + intro _ + simpa [WhnfStep.Meaning] using hproj + | none => + simp only [pure_bind] + apply RecM.WF.bind (oracle.bitvec hsourceSupport hsourceTr) + intro bitvecResult s₂ hbitvec + cases bitvecResult with + | some result => + apply RecM.WF.pure + intro _ + simpa [WhnfStep.Meaning] using hbitvec + | none => + apply RecM.WF.bind (oracle.nat hsourceSupport hsourceTr) + intro natResult s₃ hnat + cases natResult with + | some result => + apply RecM.WF.pure + intro _ + simpa [WhnfStep.Meaning] using hnat + | none => + apply RecM.WF.bind (oracle.native hsourceSupport hsourceTr) + intro nativeResult s₄ hnative + cases nativeResult with + | some result => + apply RecM.WF.pure + intro _ + simpa [WhnfStep.Meaning] using hnative + | none => + apply RecM.WF.bind (oracle.string hsourceSupport hsourceTr) + intro stringResult s₅ hstring + cases stringResult with + | some result => + apply RecM.WF.pure + intro _ + simpa [WhnfStep.Meaning] using hstring + | none => + cases hfull : flags.isFull with + | false => + simp only [Bool.false_eq_true, if_false] + apply RecM.WF.bind + (oracle.quot hsourceSupport hsourceTr) + intro quotResult s₆ hquot + cases quotResult with + | some result => + apply RecM.WF.pure + intro _ + simpa [WhnfStep.Meaning] using hquot + | none => + apply RecM.WF.pure + intro hI + exact ⟨hsourceSupport, + WhnfMeaning.refl hsourceTr + (theory.exprWF hI.2.1 hsourceTr)⟩ + | true => + simp only [if_true] + apply RecM.WF.bind + (oracle.projectionDef hsourceSupport hsourceTr) + intro projectionResult s₆ hprojection + cases projectionResult with + | some result => + apply RecM.WF.pure + intro _ + simpa [WhnfStep.Meaning] using hprojection + | none => + apply RecM.WF.bind + (oracle.quot hsourceSupport hsourceTr) + intro quotResult s₇ hquot + cases quotResult with + | some result => + apply RecM.WF.pure + intro _ + simpa [WhnfStep.Meaning] using hquot + | none => + apply RecM.WF.pure + intro hI + exact ⟨hsourceSupport, + WhnfMeaning.refl hsourceTr + (theory.exprWF hI.2.1 hsourceTr)⟩ + +/-- The production reducer tail in the no-acceleration layer needs only the +five genuinely active helper contracts. Native and BitVec are discharged by +their concrete state gate, not carried as oracle premises. -/ +theorem whnfNoDeltaReducersStep_noAccel_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (theory : WhnfTheory trProj world uvars) + (oracle : NoDeltaBaseOracle semantics trProj world support flags + natSuccMode) : + WhnfStep.WF .noAccel semantics trProj world support uvars Δ id + (whnfNoDeltaReducersStep flags natSuccMode) (fun _ _ => True) := + whnfNoDeltaReducersStep_wf theory oracle.toNoAccel + +/-- Compose the actual structural reducer and the actual ordered no-delta +tail into one exhaustive `WhnfStep.WF`. The static context-WF premise is +exactly what Theory transitivity needs when the structural and tail +translations of their shared middle term are not definitionally identical. -/ +theorem whnfNoDeltaImplStep_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (theory : WhnfTheory trProj world uvars) + (hΔ : KVLCtx.WF world.venv uvars Δ) + (core : StructuralReduction.WF layer semantics trProj world support + uvars Δ flags) + (oracle : NoDeltaReductionOracle layer semantics trProj world support + flags natSuccMode) : + WhnfStep.WF layer semantics trProj world support uvars Δ id + (whnfNoDeltaImplStep flags natSuccMode) (fun _ _ => True) := by + intro source s hsource + obtain ⟨hsourceSupport, sourceV, hsourceTr⟩ := hsource + unfold whnfNoDeltaImplStep + apply RecM.WF.bind (core hsourceSupport hsourceTr) + intro reduced s₁ hreduced + obtain ⟨hreducedSupport, hreducedMeaning⟩ := hreduced + have hreducedMeaningCopy := hreducedMeaning + obtain ⟨_, reducedV, _, hreducedTr, _⟩ := hreducedMeaningCopy + have htail := + whnfNoDeltaReducersStep_wf (uvars := uvars) (Δ := Δ) + theory oracle reduced s₁ + ⟨hreducedSupport, reducedV, hreducedTr⟩ + apply RecM.WF.mono htail + · intro action s₂ haction + cases action with + | next result => + exact ⟨haction.1, + theory.transMeaning hΔ hreducedMeaning haction.2⟩ + | done result => + exact ⟨haction.1, + theory.transMeaning hΔ hreducedMeaning haction.2⟩ + · intro err s₂ herror + exact herror + +/-- No-acceleration specialization of the complete outer no-delta step. -/ +theorem whnfNoDeltaImplStep_noAccel_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Δ : KVLCtx} {flags : WhnfFlags} + {natSuccMode : NatSuccMode} + (theory : WhnfTheory trProj world uvars) + (hΔ : KVLCtx.WF world.venv uvars Δ) + (core : StructuralReduction.WF .noAccel semantics trProj world support + uvars Δ flags) + (oracle : NoDeltaBaseOracle semantics trProj world support flags + natSuccMode) : + WhnfStep.WF .noAccel semantics trProj world support uvars Δ id + (whnfNoDeltaImplStep flags natSuccMode) (fun _ _ => True) := + whnfNoDeltaImplStep_wf theory hΔ core oracle.toNoAccel + +/-- Feed the assembled no-acceleration step directly into the already proved +public no-delta cache/dispatcher shell. The remaining premises are now +separated by ownership: structural WHNF, the five active base reducers, +context-key/lazy-read framing, and collision-robust cache writes. -/ +theorem whnfNoDeltaImpl_noAccel_wf_of_base + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {Δ : KVLCtx} {flags : WhnfFlags} {natSuccMode : NatSuccMode} + {source : KExpr .anon} + (theory : WhnfTheory trProj world keys.uvars) + (hΔ : KVLCtx.WF world.venv keys.uvars Δ) + (core : StructuralReduction.WF .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Δ flags) + (oracle : NoDeltaBaseOracle (whnfCacheSemantics keys trProj fallback) + trProj world support flags natSuccMode) + (hkeyRep : WhnfKey.Represents keys trProj world source Δ) + (htransient : TransientNatWork.WF .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Δ source) + (hwrites : WhnfCacheWriteOracle keys trProj fallback world support) + (hsourceSupport : support source) + {sourceV : VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Δ source + sourceV) : + RecM.WF .noAccel (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Δ s (whnfNoDeltaImpl source flags natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Δ sourceV result) := + whnfNoDeltaImpl_wf theory hkeyRep htransient + (whnfNoDeltaImplStep_noAccel_wf theory hΔ core oracle) + hwrites hsourceSupport hsource end RecM diff --git a/Ix/Tc/Verify/Whnf/Beta/ArgumentAlignment.lean b/Ix/Tc/Verify/Whnf/Beta/ArgumentAlignment.lean new file mode 100644 index 000000000..262fb8489 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/ArgumentAlignment.lean @@ -0,0 +1,135 @@ +import Ix.Tc.Verify.Whnf.Beta.InstantiationChain + +/-! +# Align concrete and Theory beta arguments + +The application suffix stores arguments in production order, while the +simultaneous-substitution walker receives their reverse. This slice proves +the pointwise alignment once, including array/list indexing, so the one-pass +translation theorem can use the exact selected argument in its variable arm. +-/ + +namespace Ix.Tc + +open Lean4Lean + +namespace RecM + +/-- Pointwise structural translations for an argument list. -/ +inductive ArgTranslations (env : VEnv) (uvars : Nat) + (nameOf : Address → Option Lean.Name) (trProj : RawProjRel) + (Delta : KVLCtx) : List (KExpr .anon) → List VExpr → Prop + | nil : ArgTranslations env uvars nameOf trProj Delta [] [] + | cons {arg : KExpr .anon} {argV : VExpr} {args : List (KExpr .anon)} + {argValues : List VExpr} : + TrKExprS env uvars nameOf trProj Delta arg argV → + ArgTranslations env uvars nameOf trProj Delta args argValues → + ArgTranslations env uvars nameOf trProj Delta (arg :: args) + (argV :: argValues) + +namespace ArgTranslations + +theorem append + {env : VEnv} {uvars : Nat} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {Delta : KVLCtx} + {left right : List (KExpr .anon)} {leftV rightV : List VExpr} + (hleft : ArgTranslations env uvars nameOf trProj Delta left leftV) + (hright : ArgTranslations env uvars nameOf trProj Delta right rightV) : + ArgTranslations env uvars nameOf trProj Delta (left ++ right) + (leftV ++ rightV) := by + induction hleft with + | nil => exact hright + | cons harg htail ih => exact .cons harg ih + +theorem reverse + {env : VEnv} {uvars : Nat} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {Delta : KVLCtx} + {args : List (KExpr .anon)} {argValues : List VExpr} + (h : ArgTranslations env uvars nameOf trProj Delta args argValues) : + ArgTranslations env uvars nameOf trProj Delta args.reverse + argValues.reverse := by + induction h with + | nil => exact .nil + | cons harg htail ih => + simpa using ih.append (.cons harg .nil) + +theorem length_eq + {env : VEnv} {uvars : Nat} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {Delta : KVLCtx} + {args : List (KExpr .anon)} {argValues : List VExpr} + (h : ArgTranslations env uvars nameOf trProj Delta args argValues) : + args.length = argValues.length := by + induction h with + | nil => rfl + | cons harg htail ih => simp [ih] + +theorem getElemBang + {env : VEnv} {uvars : Nat} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {Delta : KVLCtx} + {args : List (KExpr .anon)} {argValues : List VExpr} + (h : ArgTranslations env uvars nameOf trProj Delta args argValues) + (index : Nat) (hindex : index < args.length) : + TrKExprS env uvars nameOf trProj Delta args[index]! argValues[index]! := by + induction h generalizing index with + | nil => simp at hindex + | cons harg htail ih => + cases index with + | zero => simpa + | succ index => + simp only [List.length_cons, Nat.succ_lt_succ_iff] at hindex + simpa using ih index hindex + +end ArgTranslations + +namespace TrAppSuffix.Values + +/-- Forget application typing while retaining the exact pointwise structural +translations of its concrete and Theory argument lists. -/ +theorem argumentTranslations + {env : VEnv} {uvars : Nat} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {Delta : KVLCtx} {start : VExpr} + {args : List (KExpr .anon)} {argValues : List VExpr} {resultV : VExpr} + (h : TrAppSuffix.Values env uvars nameOf trProj Delta start args + argValues resultV) : + ArgTranslations env uvars nameOf trProj Delta args argValues := by + induction h with + | nil => exact .nil + | app hprefix hfun harg hargTr ih => + exact ih.append (.cons hargTr .nil) + +end TrAppSuffix.Values + +/-- Exact pointwise relation between the walker's inner-to-outer array and +the reverse of the Theory argument list. -/ +structure SimulArgs (env : VEnv) (uvars : Nat) + (nameOf : Address → Option Lean.Name) (trProj : RawProjRel) + (Delta : KVLCtx) (substs : Array (KExpr .anon)) + (argValues : List VExpr) : Prop where + size_eq : substs.size = argValues.length + translate : ∀ index, index < substs.size → + TrKExprS env uvars nameOf trProj Delta substs[index]! + argValues.reverse[index]! + +namespace SimulArgs + +/-- A typed suffix supplies `SimulArgs` for production's exact reversed +concrete array. -/ +theorem ofValues + {env : VEnv} {uvars : Nat} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {Delta : KVLCtx} {start : VExpr} + {args : List (KExpr .anon)} {argValues : List VExpr} {resultV : VExpr} + (h : TrAppSuffix.Values env uvars nameOf trProj Delta start args + argValues resultV) : + SimulArgs env uvars nameOf trProj Delta args.toArray.reverse + argValues := by + have hargs := h.argumentTranslations + have hreverse := hargs.reverse + constructor + · simpa using hargs.length_eq + · intro index hindex + have hlistIndex : index < args.reverse.length := by simpa using hindex + simpa using hreverse.getElemBang index hlistIndex + +end SimulArgs +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/ConsumptionBoundary.lean b/Ix/Tc/Verify/Whnf/Beta/ConsumptionBoundary.lean new file mode 100644 index 000000000..6355c3b21 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/ConsumptionBoundary.lean @@ -0,0 +1,111 @@ +import Ix.Tc.Verify.Whnf.Beta.LambdaPeeling + +/-! +# Typed splitting at the multi-beta consumption boundary + +`consumeBetaLams` identifies an exact prefix of the production application +spine. This slice cuts the typed `TrAppSuffix` derivation at that same +position, retaining both the applications consumed by beta and every +unconsumed application rebuilt afterward. +-/ + +namespace Ix.Tc +namespace RecM +namespace TrAppSuffix + +/-- Transport the starting expression of a typed suffix across Theory +definitional equality while retaining the suffix as a `TrAppSuffix`. Unlike +`rebase`, this form is intended for a second structural transformation of the +replacement prefix before the original trailing arguments are reattached. -/ +theorem rebaseStart + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address -> Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start : Lean4Lean.VExpr} + {args : List (KExpr .anon)} {resultV : Lean4Lean.VExpr} + (h : TrAppSuffix env uvars nameOf trProj Delta start args resultV) + (henv : env.WF) (hDelta : KVLCtx.WF env uvars Delta) + {replacementV : Lean4Lean.VExpr} + (hreplacement : env.IsDefEqU uvars Delta.toCtx start replacementV) : + exists resultV', + TrAppSuffix env uvars nameOf trProj Delta replacementV args resultV' /\ + env.IsDefEqU uvars Delta.toCtx resultV resultV' := by + induction h generalizing replacementV with + | nil => exact ⟨replacementV, .nil, hreplacement⟩ + | @app args current arg argV A B hsuffix hfun harg hargTr ih => + obtain ⟨currentV', hcurrentSuffix, hcurrentEq⟩ := ih hreplacement + have hcurrentType : + env.HasType uvars Delta.toCtx currentV' (.forallE A B) := + hfun.defeqU_l henv hDelta.toCtx hcurrentEq + have hcurrentEqAt : + env.IsDefEq uvars Delta.toCtx current currentV' (.forallE A B) := + hcurrentEq.of_l henv hDelta.toCtx hfun + exact ⟨.app currentV' argV, + .app hcurrentSuffix hcurrentType harg hargTr, + (Lean4Lean.VEnv.IsDefEq.appDF hcurrentEqAt harg).toU⟩ + +/-- Split a typed application suffix after exactly `n` arguments. Both +pieces retain their original typing derivations and production order. -/ +theorem splitAt + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address -> Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start : Lean4Lean.VExpr} + {args : List (KExpr .anon)} {resultV : Lean4Lean.VExpr} + (h : TrAppSuffix env uvars nameOf trProj Delta start args resultV) + (n : Nat) (hn : n <= args.length) : + exists middleV, + TrAppSuffix env uvars nameOf trProj Delta start (args.take n) middleV /\ + TrAppSuffix env uvars nameOf trProj Delta middleV (args.drop n) + resultV := by + induction h generalizing n with + | nil => + have hn0 : n = 0 := by simpa using hn + subst n + exact ⟨start, .nil, .nil⟩ + | @app args current arg argV A B hprefix hfun harg hargTr ih => + by_cases hwhole : n = (args ++ [arg]).length + · subst n + refine ⟨.app current argV, ?_, ?_⟩ + · rw [List.take_length] + exact TrAppSuffix.app hprefix hfun harg hargTr + · rw [List.drop_length] + exact .nil + · have hnPrefix : n <= args.length := by + simp only [List.length_append, List.length_singleton] at hn hwhole + omega + obtain ⟨middleV, htake, hdrop⟩ := ih n hnPrefix + refine ⟨middleV, ?_, ?_⟩ + · rw [List.take_append_of_le_length hnPrefix] + exact htake + · rw [List.drop_append_of_le_length hnPrefix] + exact TrAppSuffix.app hdrop hfun harg hargTr + +/-- Cut a complete typed application spine at production's certified +`consumeBetaLams` result. The first derivation contains exactly the peeled +arguments; the second contains exactly the `Array.extract` rebuilt by +`finishAppResult`. -/ +theorem splitConsume + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address -> Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {startV resultV : Lean4Lean.VExpr} + {start body : KExpr .anon} {args consumed : Array (KExpr .anon)} + (hconsume : consumeBetaLams start args = (body, consumed)) + (h : TrAppSuffix env uvars nameOf trProj Delta startV args.toList + resultV) : + exists middleV, + BetaPeel start consumed.toList body /\ + TrAppSuffix env uvars nameOf trProj Delta startV consumed.toList + middleV /\ + TrAppSuffix env uvars nameOf trProj Delta middleV + (args.extract consumed.size args.size).toList resultV := by + obtain ⟨hpeel, hprefix, hsize⟩ := BetaPeel.of_consume hconsume + obtain ⟨middleV, hbefore, hafter⟩ := + h.splitAt consumed.size (by simpa using hsize) + refine ⟨middleV, hpeel, ?_, ?_⟩ + · rw [hprefix] + exact hbefore + · rw [BetaPeel.remaining_eq_drop hconsume] + exact hafter + +end TrAppSuffix +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/DependentContexts.lean b/Ix/Tc/Verify/Whnf/Beta/DependentContexts.lean new file mode 100644 index 000000000..fa5c6fa81 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/DependentContexts.lean @@ -0,0 +1,297 @@ +import Ix.Tc.Verify.Whnf.Beta.PrefixSemantics + +/-! +# Dependent context chains for simultaneous beta + +`simulSubstSpec` performs one structural pass, but its Theory meaning is a +sequence of dependent instantiations. `KVLCtx.KInsts` records that sequence +without materializing any intermediate concrete term. It composes under a +syntax binder and transports the abstract projection relation through every +Theory instantiation. +-/ + +namespace Lean4Lean.VLocalDecl + +/-- Instantiate a declaration by outer-to-inner beta arguments. -/ +def instBetaArgs (d : VLocalDecl) : List VExpr → (depth : Nat) → VLocalDecl + | [], _ => d + | arg :: args, depth => + instBetaArgs (d.inst arg (depth + args.length)) args depth + +@[simp] theorem instBetaArgs_nil (d : VLocalDecl) (depth : Nat) : + instBetaArgs d [] depth = d := rfl + +/-- Instantiation changes declaration contents but not whether the declaration +contributes a Theory binder. -/ +theorem instBetaArgs_depth (d : VLocalDecl) (args : List VExpr) + (depth : Nat) : + (instBetaArgs d args depth).depth = d.depth := by + induction args generalizing d depth with + | nil => rfl + | cons arg args ih => + rw [instBetaArgs, ih] + cases d <;> rfl + +@[simp] theorem instBetaArgs_vlam (A : VExpr) (args : List VExpr) + (depth : Nat) : + instBetaArgs (.vlam A) args depth = + .vlam (VExpr.instBetaArgs A args depth) := by + induction args generalizing A depth with + | nil => rfl + | cons arg args ih => + rw [instBetaArgs, VLocalDecl.inst, VExpr.instBetaArgs, ih] + +@[simp] theorem instBetaArgs_vlet (A value : VExpr) (args : List VExpr) + (depth : Nat) : + instBetaArgs (.vlet A value) args depth = + .vlet (VExpr.instBetaArgs A args depth) + (VExpr.instBetaArgs value args depth) := by + induction args generalizing A value depth with + | nil => rfl + | cons arg args ih => + rw [instBetaArgs, VLocalDecl.inst, VExpr.instBetaArgs, + VExpr.instBetaArgs, ih] + +end Lean4Lean.VLocalDecl + +namespace Ix.Tc + +open Lean4Lean + +namespace KVLCtx + +/-- A sequence of dependent `KInstN` steps. `arguments` are stored in +outer-to-inner order. `dk`/`k` are the mixed-context and Theory depths below +the syntax-local declarations retained by the batch operation. -/ +inductive KInsts (env : VEnv) (uvars : Nat) (base : KVLCtx) : + List VExpr → Nat → Nat → KVLCtx → KVLCtx → Prop + | nil (context : KVLCtx) (dk k : Nat) : + KInsts env uvars base [] dk k context context + | cons {arg : VExpr} {arguments : List VExpr} {A : VExpr} + {dk k : Nat} {source middle target : KVLCtx} : + KInstN base arg A (dk + arguments.length) (k + arguments.length) + source middle → + env.HasType uvars base.toCtx arg A → + KInsts env uvars base arguments dk k middle target → + KInsts env uvars base (arg :: arguments) dk k source target + +namespace KInsts + +/-- Retaining one syntax declaration above the substituted telescope extends +every constituent `KInstN` step and transforms that declaration pointwise. -/ +theorem succ + {env : VEnv} {uvars : Nat} {base : KVLCtx} + {arguments : List VExpr} {dk k : Nat} + {source target : KVLCtx} + (h : KInsts env uvars base arguments dk k source target) + (declaration : VLocalDecl) : + KInsts env uvars base arguments (dk + 1) (k + declaration.depth) + ((none, declaration) :: source) + ((none, declaration.instBetaArgs arguments k) :: target) := by + induction h generalizing declaration with + | nil => exact .nil _ _ _ + | @cons arg arguments A dk k source middle target hstep harg htail ih => + let declaration' := declaration.inst arg (k + arguments.length) + have hdepth : declaration'.depth = declaration.depth := by + cases declaration <;> rfl + have hstep' : + KInstN base arg A + ((dk + 1) + arguments.length) + ((k + declaration.depth) + arguments.length) + ((none, declaration) :: source) + ((none, declaration') :: middle) := by + have := KInstN.succ (d := declaration) hstep + simpa [declaration', Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] + using this + have htail' := ih declaration' + rw [hdepth] at htail' + exact .cons hstep' harg (by + simpa [VLocalDecl.instBetaArgs, declaration'] using htail') + +private theorem appendAux + {env : VEnv} {uvars : Nat} {base : KVLCtx} + {left right : List VExpr} + {dkLeft kLeft dk k : Nat} {source middle target : KVLCtx} + (hleft : KInsts env uvars base left dkLeft kLeft source middle) + (hdk : dkLeft = dk + right.length) + (hk : kLeft = k + right.length) + (hright : KInsts env uvars base right dk k middle target) : + KInsts env uvars base (left ++ right) dk k source target := by + induction hleft generalizing right dk k target with + | nil => simpa using hright + | @cons arg arguments A dkLeft kLeft source next middle hstep harg htail ih => + have hstep' : + KInstN base arg A + (dk + (arguments ++ right).length) + (k + (arguments ++ right).length) source next := by + rw [hdk, hk] at hstep + simpa [List.length_append, Nat.add_assoc, Nat.add_left_comm, + Nat.add_comm] using hstep + exact .cons hstep' harg (ih hdk hk hright) + +/-- Concatenate two chains when the first runs above all binders consumed by +the second. -/ +theorem append + {env : VEnv} {uvars : Nat} {base : KVLCtx} + {left right : List VExpr} {dk k : Nat} + {source middle target : KVLCtx} + (hleft : KInsts env uvars base left + (dk + right.length) (k + right.length) + source middle) + (hright : KInsts env uvars base right dk k middle target) : + KInsts env uvars base (left ++ right) dk k source target := + appendAux hleft rfl rfl hright + +/-- Fvar lookups are transformed pointwise by the whole chain. -/ +theorem find?_fvar + {env : VEnv} {uvars : Nat} {base : KVLCtx} + {arguments : List VExpr} {dk k : Nat} + {source target : KVLCtx} + (h : KInsts env uvars base arguments dk k source target) + {fv : FVarId} {value type : VExpr} + (hfind : source.find? (.inr fv) = some (value, type)) : + target.find? (.inr fv) = some + (VExpr.instBetaArgs value arguments k, + VExpr.instBetaArgs type arguments k) := by + induction h generalizing value type with + | nil => simpa using hfind + | @cons arg arguments A dk k source middle target hstep harg htail ih => + have hfirst := hstep.find?_fvar hfind + simpa [VExpr.instBetaArgs] using ih hfirst + +/-- Syntax-local bvars below the substituted telescope retain their concrete +index while their resolved Theory pair is instantiated pointwise. -/ +theorem find?_below + {env : VEnv} {uvars : Nat} {base : KVLCtx} + {arguments : List VExpr} {dk k : Nat} + {source target : KVLCtx} + (h : KInsts env uvars base arguments dk k source target) + {index : Nat} (hindex : index < dk) {value type : VExpr} + (hfind : source.find? (.inl index) = some (value, type)) : + target.find? (.inl index) = some + (VExpr.instBetaArgs value arguments k, + VExpr.instBetaArgs type arguments k) := by + induction h generalizing value type with + | nil => simpa using hfind + | @cons arg arguments A dk k source middle target hstep harg htail ih => + have hfirst := hstep.find?_lt (j := index) (by omega) hfind + simpa [VExpr.instBetaArgs] using ih hindex hfirst + +/-- Bvars above the substituted telescope shift down by its length, with +their resolved Theory pair instantiated pointwise. -/ +theorem find?_above + {env : VEnv} {uvars : Nat} {base : KVLCtx} + {arguments : List VExpr} {dk k : Nat} + {source target : KVLCtx} + (h : KInsts env uvars base arguments dk k source target) + {index : Nat} (hindex : dk + arguments.length ≤ index) + {value type : VExpr} + (hfind : source.find? (.inl index) = some (value, type)) : + target.find? (.inl (index - arguments.length)) = some + (VExpr.instBetaArgs value arguments k, + VExpr.instBetaArgs type arguments k) := by + induction h generalizing index value type with + | nil => simpa using hfind + | @cons arg arguments A dk k source middle target hstep harg htail ih => + have habove : dk + arguments.length < index := by + simpa only [List.length_cons] using hindex + have hfirst := hstep.find?_gt habove hfind + have hrest : dk + arguments.length ≤ index - 1 := by omega + have hfinal := ih hrest hfirst + have hshift : (index - 1) - arguments.length = + index - (arg :: arguments).length := by + simp only [List.length_cons] + omega + rw [← hshift] + simpa [VExpr.instBetaArgs] using hfinal + +/-- A lookup in the removed telescope is transformed to the corresponding +argument value, lifted only across the syntax-local Theory depth retained +below the batch operation. -/ +theorem find?_window + {env : VEnv} {uvars : Nat} {base : KVLCtx} + {arguments : List VExpr} {dk k : Nat} + {source target : KVLCtx} + (h : KInsts env uvars base arguments dk k source target) + {offset : Nat} (hoffset : offset < arguments.length) + {value type : VExpr} + (hfind : source.find? (.inl (dk + offset)) = some (value, type)) : + ∃ argument, + arguments.reverse[offset]? = some argument ∧ + VExpr.instBetaArgs value arguments k = argument.liftN k := by + induction h generalizing offset value type with + | nil => simp at hoffset + | @cons outer arguments A dk k source middle target hstep harg htail ih => + by_cases hlast : offset = arguments.length + · subst offset + have hhit := hstep.find?_hit hfind + refine ⟨outer, ?_, ?_⟩ + · simp + · rw [VExpr.instBetaArgs, hhit] + exact VExpr.instBetaArgs_liftN outer arguments k + · have hinner : offset < arguments.length := by + simp only [List.length_cons] at hoffset + omega + have hfirst := hstep.find?_lt (j := dk + offset) (by omega) hfind + obtain ⟨argument, hget, hmeaning⟩ := ih hinner hfirst + refine ⟨argument, ?_, ?_⟩ + · rw [List.reverse_cons, List.getElem?_append_left] + · exact hget + · simpa using hinner + · simpa [VExpr.instBetaArgs] using hmeaning + +/-- Typing derivations instantiate pointwise through the complete chain. -/ +theorem hasType + {env : VEnv} {uvars : Nat} {base : KVLCtx} + {arguments : List VExpr} {dk k : Nat} {source target : KVLCtx} + (h : KInsts env uvars base arguments dk k source target) + (henv : env.Ordered) {value type : VExpr} + (htype : env.HasType uvars source.toCtx value type) : + env.HasType uvars target.toCtx + (VExpr.instBetaArgs value arguments k) + (VExpr.instBetaArgs type arguments k) := by + induction h generalizing value type with + | nil => exact htype + | @cons arg arguments A dk k source middle target hstep harg htail ih => + have hfirst := htype.instN henv hstep.toCtx harg + simpa [VExpr.instBetaArgs] using ih hfirst + +/-- Typehood is stable through the chain. -/ +theorem isType + {env : VEnv} {uvars : Nat} {base : KVLCtx} + {arguments : List VExpr} {dk k : Nat} {source target : KVLCtx} + (h : KInsts env uvars base arguments dk k source target) + (henv : env.Ordered) {type : VExpr} + (htype : env.IsType uvars source.toCtx type) : + env.IsType uvars target.toCtx + (VExpr.instBetaArgs type arguments k) := by + obtain ⟨level, hlevel⟩ := htype + exact ⟨level, by simpa [VExpr.instBetaArgs] using h.hasType henv hlevel⟩ + +/-- The abstract projection relation is stable through the whole dependent +instantiation chain. -/ +theorem projection + {env : VEnv} {uvars : Nat} {base : KVLCtx} + {arguments : List VExpr} {dk k : Nat} + {source target : KVLCtx} + (h : KInsts env uvars base arguments dk k source target) + {trProj : RawProjRel} + (htpI : ∀ {Γ₀ : List VExpr} {e₀ A₀ : VExpr} {position : Nat} + {Γ₁ Γ : List VExpr} {s : Lean.Name} {i : Nat} {e e' : VExpr}, + Lean4Lean.Ctx.InstN Γ₀ e₀ A₀ position Γ₁ Γ → + trProj Γ₁ s i e e' → + trProj Γ s i (e.inst e₀ position) (e'.inst e₀ position)) + {structName : Lean.Name} {field : Nat} {value result : VExpr} + (hproj : trProj source.toCtx structName field value result) : + trProj target.toCtx structName field + (VExpr.instBetaArgs value arguments k) + (VExpr.instBetaArgs result arguments k) := by + induction h generalizing value result with + | nil => exact hproj + | @cons arg arguments A dk k source middle target hstep harg htail ih => + have hfirst := htpI hstep.toCtx hproj + simpa [VExpr.instBetaArgs] using ih hfirst + +end KInsts +end KVLCtx +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/InstantiationChain.lean b/Ix/Tc/Verify/Whnf/Beta/InstantiationChain.lean new file mode 100644 index 000000000..3cf8cf957 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/InstantiationChain.lean @@ -0,0 +1,78 @@ +import Ix.Tc.Verify.Whnf.Beta.DependentContexts + +/-! +# The peeled telescope induces a dependent instantiation chain + +The translated lambda peel and the typed suffix determine exactly how the +endpoint mixed context is reduced back to the caller context. This theorem +is purely structural: typing is used later for beta equality, while the +context chain itself follows from the recovered lambda declarations and the +exact Theory argument values. +-/ + +namespace Ix.Tc + +open Lean4Lean + +namespace RecM.BetaPeel.Tr + +/-- Every translated peel plus its exact Theory argument list induces the +dependent context-instantiation chain used by one-pass simultaneous +substitution. -/ +theorem contextInsts + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + {Delta : KVLCtx} {start : KExpr .anon} {startV : VExpr} + {consumed : List (KExpr .anon)} {body : KExpr .anon} + {bodyDelta : KVLCtx} {bodyV : VExpr} + {argValues : List VExpr} {appliedV : VExpr} + (h : BetaPeel.Tr world.venv uvars world.nameOf trProj Delta start startV + consumed body bodyDelta bodyV) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (happs : TrAppSuffix.Values world.venv uvars world.nameOf trProj Delta + startV consumed argValues appliedV) : + KVLCtx.KInsts world.venv uvars Delta argValues 0 0 bodyDelta Delta := by + induction h generalizing argValues appliedV with + | nil hstart => + obtain ⟨rfl, rfl⟩ := happs.nil_inv + exact .nil Delta 0 0 + | @snoc consumed name bi ty body info arg currentDelta A bodyV hprefix + hA hty hbody ih => + obtain ⟨priorValues, currentV, argV, domain, codomain, rfl, + hpriorApps, hfun, harg, hargTr, rfl⟩ := happs.unsnoc + have hprefixInsts := ih hpriorApps + have hprefixEq := hprefix.theoryMeaning theory hDelta hpriorApps + rw [VExpr.instBetaArgs_lam] at hprefixEq + let A' := VExpr.instBetaArgs A priorValues 0 + let bodyV' := VExpr.instBetaArgs bodyV priorValues 1 + have hfun' : world.venv.HasType uvars Delta.toCtx + (.lam A' bodyV') (.forallE domain codomain) := + hfun.defeqU_l world.venvWF hDelta.toCtx hprefixEq + obtain ⟨⟨level, hA'⟩, B', hbodyV'⟩ := + hfun'.lam_inv world.venvWF.ordered hDelta.toCtx + have hlam' : world.venv.HasType uvars Delta.toCtx + (.lam A' bodyV') (.forallE A' B') := + Lean4Lean.VEnv.HasType.lam hA' hbodyV' + have hforallEq : world.venv.IsDefEqU uvars Delta.toCtx + (.forallE domain codomain) (.forallE A' B') := + hfun'.uniqU world.venvWF hDelta.toCtx hlam' + have hdomainEq : world.venv.IsDefEqU uvars Delta.toCtx domain A' := + let ⟨uDomain, hdomain⟩ := + (hforallEq.forallE_inv world.venvWF hDelta.toCtx).1 + ⟨.sort uDomain, hdomain⟩ + have harg' : world.venv.HasType uvars Delta.toCtx argV A' := + harg.defeqU_r world.venvWF hDelta.toCtx hdomainEq + have hlifted := hprefixInsts.succ (.vlam A) + have hlifted' : KVLCtx.KInsts world.venv uvars Delta + priorValues 1 1 + ((none, .vlam A) :: currentDelta) + ((none, .vlam (VExpr.instBetaArgs A priorValues 0)) :: Delta) := by + simpa [VLocalDecl.instBetaArgs, VLocalDecl.depth] using hlifted + have hfinal : KVLCtx.KInsts world.venv uvars Delta [argV] 0 0 + ((none, .vlam (VExpr.instBetaArgs A priorValues 0)) :: Delta) + Delta := + .cons (.zero) harg' (.nil Delta 0 0) + exact hlifted'.append hfinal + +end RecM.BetaPeel.Tr +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/LambdaInstantiation.lean b/Ix/Tc/Verify/Whnf/Beta/LambdaInstantiation.lean new file mode 100644 index 000000000..8479224ea --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/LambdaInstantiation.lean @@ -0,0 +1,177 @@ +import Ix.Tc.Verify.Whnf.Beta.SimultaneousSubstitution + +/-! +# Walker-tight lambda instantiation + +The original `TrKExprS.instN` uses an ambient-context-size bound because its +hit case weakens the substituted argument through that context. Production's +walker contract instead records the exact loose-binder bound of the argument. +This slice replays the same structural proof using `TrKExprS.weakBV_lbr`, so +the theorem consumes precisely the final bound carried by `WalkerRequest`. +-/ + +namespace Ix.Tc + +open Lean4Lean + +private theorem instNatLit_bx (v : Nat) (e₀ : VExpr) (k : Nat) : + (Lean4Lean.VExpr.natLit v).inst e₀ k = Lean4Lean.VExpr.natLit v := by + induction v with + | zero => rfl + | succ v ih => + show Lean4Lean.VExpr.app _ _ = _ + rw [show ((Lean4Lean.VExpr.natLit v).inst e₀ k) = + Lean4Lean.VExpr.natLit v from ih] + rfl + +private theorem instListCharLit_bx (s : List Char) (e₀ : VExpr) (k : Nat) : + (Lean4Lean.VExpr.listCharLit s).inst e₀ k = + Lean4Lean.VExpr.listCharLit s := by + induction s with + | nil => rfl + | cons c s ih => + show Lean4Lean.VExpr.app (Lean4Lean.VExpr.app _ (Lean4Lean.VExpr.app _ + ((Lean4Lean.VExpr.natLit c.toNat).inst e₀ k))) + ((Lean4Lean.VExpr.listCharLit s).inst e₀ k) = _ + rw [instNatLit_bx, ih] + rfl + +private theorem instTrLiteral_bx (l : Lean.Literal) (e₀ : VExpr) (k : Nat) : + (Lean4Lean.VExpr.trLiteral l).inst e₀ k = + Lean4Lean.VExpr.trLiteral l := by + cases l with + | natVal v => exact instNatLit_bx v e₀ k + | strVal s => + show Lean4Lean.VExpr.app _ + ((Lean4Lean.VExpr.listCharLit _).inst e₀ k) = _ + rw [instListCharLit_bx] + rfl + +/-- `substSpec` tracks Theory instantiation under the exact loose-binder +bound carried by a substitution walker request. -/ +theorem TrKExprS.instN_lbr {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + (henv : env.Ordered) + (htp : ∀ {Γ Γ' : List VExpr} {n k : Nat} {s : Lean.Name} {i : Nat} + {e e' : VExpr}, Lean4Lean.Ctx.LiftN n k Γ Γ' → trProj Γ s i e e' → + trProj Γ' s i (e.liftN n k) (e'.liftN n k)) + (htpI : ∀ {Γ₀ : List VExpr} {e₀ A₀ : VExpr} {k : Nat} + {Γ₁ Γ : List VExpr} {s : Lean.Name} {i : Nat} {e e' : VExpr}, + Lean4Lean.Ctx.InstN Γ₀ e₀ A₀ k Γ₁ Γ → trProj Γ₁ s i e e' → + trProj Γ s i (e.inst e₀ k) (e'.inst e₀ k)) + {Δ₀ : KVLCtx} {arg : KExpr .anon} {e₀' A₀ : VExpr} + (harg : KExpr.Constructed arg) + (h₀ : TrKExprS env uvars nameOf trProj Δ₀ arg e₀') + (t₀ : env.HasType uvars Δ₀.toCtx e₀' A₀) + {Δ₁ : KVLCtx} {body : KExpr .anon} {body' : VExpr} + (H : TrKExprS env uvars nameOf trProj Δ₁ body body') : + ∀ {Δ : KVLCtx} {dk k : Nat} {depth : UInt64}, + KVLCtx.KInstN Δ₀ e₀' A₀ dk k Δ₁ Δ → + depth.toNat = dk → + arg.lbr.toNat + arg.size + depth.toNat + body.size < UInt64.size → + TrKExprS env uvars nameOf trProj Δ + (KExpr.substSpec body arg depth) (body'.inst e₀' k) := by + induction H with + | @var Δ₁' i nm md e A h => + intro Δ dk k depth W hdepth hbig + rw [KExpr.substSpec] + by_cases heq : (i == depth) = true + · have hik : i.toNat = dk := by rw [eq_of_beq heq]; exact hdepth + rw [if_pos heq] + rw [show e.inst e₀' k = e₀'.liftN k from + W.find?_hit (by rw [← hik]; exact h)] + exact TrKExprS.weakBV_lbr henv htp harg h₀ W.toKBVLift hdepth rfl + (by rw [show (0 : UInt64).toNat = 0 from rfl]; omega) (by omega) + · by_cases hgt : i > depth + · have hik : dk < i.toNat := by + have := UInt64.lt_iff_toNat_lt.mp hgt + omega + rw [if_neg heq, if_pos hgt, KExpr.mkVar_shape] + refine .var (A := A.inst e₀' k) ?_ + have h1i : (1 : UInt64) ≤ i := + UInt64.le_iff_toNat_le.mpr (by + rw [show (1 : UInt64).toNat = 1 from rfl] + omega) + rw [UInt64.toNat_sub_of_le i 1 h1i, + show (1 : UInt64).toNat = 1 from rfl] + exact W.find?_gt hik h + · have hik : i.toNat < dk := by + have hne : i.toNat ≠ depth.toNat := fun hh => + heq (beq_iff_eq.mpr (UInt64.toNat_inj.mp hh)) + have hnlt : ¬(depth.toNat < i.toNat) := fun hh => + hgt (UInt64.lt_iff_toNat_lt.mpr hh) + omega + rw [if_neg heq, if_neg hgt] + exact .var (A := A.inst e₀' k) (W.find?_lt hik h) + | @fvar Δ₁' fv nm md e A h => + intro Δ dk k depth W hdepth hbig + exact .fvar (A := A.inst e₀' k) (W.find?_fvar h) + | @sort Δ₁' u md h => + intro Δ dk k depth W hdepth hbig + exact .sort h + | @const Δ₁' id us md c ci h1 h2 h3 h4 => + intro Δ dk k depth W hdepth hbig + exact .const h1 h2 h3 h4 + | @app Δ₁' f a md f' a' A B h1 h2 htf hta ihf iha => + intro Δ dk k depth W hdepth hbig + have hbig' : arg.lbr.toNat + arg.size + depth.toNat + + (f.size + a.size + 1) < UInt64.size := hbig + rw [KExpr.substSpec, KExpr.mkApp_shape] + exact .app (h1.instN henv W.toCtx t₀) (h2.instN henv W.toCtx t₀) + (ihf W hdepth (by omega)) (iha W hdepth (by omega)) + | @lam Δ₁' nm bi ty body md ty' body' h1 htty htbody ihty ihbody => + intro Δ dk k depth W hdepth hbig + have hbig' : arg.lbr.toNat + arg.size + depth.toNat + + (ty.size + body.size + 1) < UInt64.size := hbig + have hc1 : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.substSpec, KExpr.mkLam_shape] + exact .lam (h1.instN henv W.toCtx t₀) + (ihty W hdepth (by omega)) + (ihbody (W.succ (d := .vlam ty')) hc1 (by rw [hc1]; omega)) + | @all Δ₁' nm bi ty body md ty' body' h1 h2 htty htbody ihty ihbody => + intro Δ dk k depth W hdepth hbig + have hbig' : arg.lbr.toNat + arg.size + depth.toNat + + (ty.size + body.size + 1) < UInt64.size := hbig + have hc1 : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.substSpec, KExpr.mkAll_shape] + exact .all (h1.instN henv W.toCtx t₀) + (h2.instN henv W.toCtx.succ t₀) + (ihty W hdepth (by omega)) + (ihbody (W.succ (d := .vlam ty')) hc1 (by rw [hc1]; omega)) + | @letE Δ₁' nm ty val body nd md ty' val' body' h1 htty htval htbody + ihty ihval ihbody => + intro Δ dk k depth W hdepth hbig + have hbig' : arg.lbr.toNat + arg.size + depth.toNat + + (ty.size + val.size + body.size + 1) < UInt64.size := hbig + have hc1 : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig') + rw [KExpr.substSpec, KExpr.mkLet_shape] + exact .letE (h1.instN henv W.toCtx t₀) + (ihty W hdepth (by omega)) + (ihval W hdepth (by omega)) + (ihbody (W.succ (d := .vlet ty' val')) hc1 (by rw [hc1]; omega)) + | @prj Δ₁' sid field val md sName e' e'' h1 htval htrp ihval => + intro Δ dk k depth W hdepth hbig + have hbig' : arg.lbr.toNat + arg.size + depth.toNat + + (val.size + 1) < UInt64.size := hbig + rw [KExpr.substSpec, KExpr.mkPrj_shape] + exact .prj h1 (ihval W hdepth (by omega)) (htpI W.toCtx htrp) + | @nat Δ₁' v blob md h => + intro Δ dk k depth W hdepth hbig + rw [show (Lean4Lean.VExpr.natLit v).inst e₀' k = + Lean4Lean.VExpr.natLit v from instNatLit_bx v e₀' k] + exact .nat h + | @str Δ₁' s blob md h => + intro Δ dk k depth W hdepth hbig + rw [show (Lean4Lean.VExpr.trLiteral (.strVal s)).inst e₀' k = + Lean4Lean.VExpr.trLiteral (.strVal s) from + instTrLiteral_bx (.strVal s) e₀' k] + exact .str h + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/LambdaPeeling.lean b/Ix/Tc/Verify/Whnf/Beta/LambdaPeeling.lean new file mode 100644 index 000000000..edeed4615 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/LambdaPeeling.lean @@ -0,0 +1,125 @@ +import Ix.Tc.Verify.Whnf.Structural.StepAssembly + +/-! +# Certified lambda peeling for general beta + +`consumeBetaLams` is an accumulator loop, so its result equation alone does +not expose which lambdas were removed or which prefix of the application +spine was consumed. This slice gives the loop a structural certificate and +proves that the returned array is exactly a prefix of the input arguments. +-/ + +namespace Ix.Tc +namespace RecM + +/-- A sequence of lambda bodies reached by consuming arguments in production +order. The snoc constructor matches `consumeBetaLamsFuel`'s accumulator. -/ +inductive BetaPeel : KExpr .anon -> List (KExpr .anon) -> KExpr .anon -> Prop + | nil (start) : BetaPeel start [] start + | snoc {start consumed name bi ty body info arg} : + BetaPeel start consumed (.lam name bi ty body info) -> + BetaPeel start (consumed ++ [arg]) body + +namespace BetaPeel + +/-- The accumulator loop preserves both its structural peel trace and its +exact-prefix invariant. -/ +theorem fuel + {start current : KExpr .anon} {args consumed : Array (KExpr .anon)} + (hpeel : BetaPeel start consumed.toList current) + (hprefix : consumed.toList = args.toList.take consumed.size) + (hsize : consumed.size <= args.size) : + forall fuel, + let result := consumeBetaLamsFuel fuel current args consumed + BetaPeel start result.2.toList result.1 /\ + result.2.toList = args.toList.take result.2.size /\ + result.2.size <= args.size := by + intro fuel + induction fuel generalizing current consumed with + | zero => + simpa only [consumeBetaLamsFuel_zero] using + And.intro hpeel (And.intro hprefix hsize) + | succ fuel ih => + rw [consumeBetaLamsFuel_succ] + by_cases hdone : consumed.size >= args.size + · simp only [hdone, if_true] + exact ⟨hpeel, hprefix, hsize⟩ + · simp only [hdone, if_false] + cases current with + | lam name bi ty body info => + have hlt : consumed.size < args.size := by omega + have hnextPrefix : + (consumed.push args[consumed.size]!).toList = + args.toList.take (consumed.push args[consumed.size]!).size := by + rw [Array.toList_push, Array.size_push, hprefix] + rw [List.take_succ_eq_append_getElem] + · rw [getElem!_pos args consumed.size hlt, + Array.getElem_toList hlt] + · simpa using hlt + have hnextSize : + (consumed.push args[consumed.size]!).size <= args.size := by + simp only [Array.size_push] + omega + have hnextPeel : + BetaPeel start + (consumed.push args[consumed.size]!).toList body := by + rw [Array.toList_push] + exact BetaPeel.snoc (arg := args[consumed.size]!) hpeel + exact ih hnextPeel hnextPrefix hnextSize + | var | fvar | sort | const | app | all | letE | prj | nat | str => + exact ⟨hpeel, hprefix, hsize⟩ + +/-- Public `consumeBetaLams` result: the returned body is reached by peeling +exactly the returned production-order argument prefix. -/ +theorem of_consume + {start body : KExpr .anon} {args consumed : Array (KExpr .anon)} + (hconsume : consumeBetaLams start args = (body, consumed)) : + BetaPeel start consumed.toList body /\ + consumed.toList = args.toList.take consumed.size /\ + consumed.size <= args.size := by + have h := fuel (start := start) (current := start) (args := args) + (consumed := Array.mkEmpty args.size) (.nil start) (by simp) (by simp) + args.size + dsimp only at h + rw [consumeBetaLams_equation] at hconsume + rw [hconsume] at h + exact h + +/-- Production's extracted remainder is exactly the list suffix after the +certified consumed prefix. -/ +theorem remaining_eq_drop + {start body : KExpr .anon} {args consumed : Array (KExpr .anon)} + (hconsume : consumeBetaLams start args = (body, consumed)) : + (args.extract consumed.size args.size).toList = + args.toList.drop consumed.size := by + obtain ⟨_, _, _⟩ := of_consume hconsume + rw [Array.toList_extract] + simp only [List.extract_eq_take_drop] + have hargsLength : args.toList.length = args.size := by + simpa using congrArg Array.size (Array.toArray_toList (xs := args)) + have hdropLength : + (args.toList.drop consumed.size).length = + args.size - consumed.size := by + rw [List.length_drop, hargsLength] + have htake : + (args.toList.drop consumed.size).take (args.size - consumed.size) = + args.toList.drop consumed.size := by + rw [← hdropLength] + exact List.take_length + exact htake + +/-- The unconsumed `extract` is precisely the suffix complementary to the +certified consumed prefix. -/ +theorem consumed_append_remaining + {start body : KExpr .anon} {args consumed : Array (KExpr .anon)} + (hconsume : consumeBetaLams start args = (body, consumed)) : + consumed.toList ++ (args.extract consumed.size args.size).toList = + args.toList := by + obtain ⟨_, hprefix, _⟩ := of_consume hconsume + rw [hprefix, remaining_eq_drop hconsume] + exact List.take_append_drop consumed.size args.toList + +end BetaPeel + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/LiftSubstitution.lean b/Ix/Tc/Verify/Whnf/Beta/LiftSubstitution.lean new file mode 100644 index 000000000..722f2e9f3 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/LiftSubstitution.lean @@ -0,0 +1,228 @@ +import Ix.Tc.Verify.Whnf.Beta.SingletonSubstitution + +/-! +# Lift/substitution cancellation for multi-beta + +Peeling one more lambda turns the previous simultaneous substitutions into +terms lifted across the new innermost binder. Applying that binder must +remove precisely the added lift. This file proves that pure syntactic law +with the same no-wrap discipline as the production walkers. +-/ + +namespace Ix.Tc +namespace KExpr + +private theorem toNat_max_bv (a b : UInt64) : + (max a b).toNat = max a.toNat b.toNat := by + show (if a ≤ b then b else a).toNat = max a.toNat b.toNat + rw [Nat.max_def] + by_cases h : a ≤ b + · rw [if_pos h, if_pos (UInt64.le_iff_toNat_le.mp h)] + · have hn : ¬a.toNat ≤ b.toNat := fun h' => + h (UInt64.le_iff_toNat_le.mpr h') + rw [if_neg h, if_neg hn] + +/-- Saturating predecessor changes the represented natural by at most one. -/ +private theorem toNat_le_sat1_add_one_bv (x : UInt64) : + x.toNat ≤ x.sat1.toNat + 1 := by + unfold UInt64.sat1 + split + · next h => rw [eq_of_beq h]; exact Nat.le_succ _ + · next h => + have hx0 : x ≠ 0 := fun he => h (beq_iff_eq.mpr he) + have hn0 : x.toNat ≠ 0 := fun h0 => + hx0 (UInt64.toNat_inj.mp (by simpa using h0)) + have hsub : (x - 1).toNat = x.toNat - 1 := by + rw [UInt64.toNat_sub_of_le x 1 (UInt64.le_iff_toNat_le.mpr (by + rw [show (1 : UInt64).toNat = 1 from rfl] + omega))] + rfl + rw [hsub] + omega + +/-- Substituting at `shift + cutoff` cancels the extra unit in a lift by +`shift + 1` above `cutoff`. The deliberately strong bound is stable under +syntax descent and is implied by the simultaneous-substitution request bound +at every use in multi-beta. -/ +private theorem substSpec_liftSpec_succ_aux + {e arg : KExpr .anon} (he : Constructed e) + {shift cutoff : UInt64} + (hbig : shift.toNat + cutoff.toNat + e.lbr.toNat + e.size + 1 < + UInt64.size) : + substSpec (liftSpec e (shift + 1) cutoff) arg (shift + cutoff) = + liftSpec e shift cutoff := by + induction he generalizing shift cutoff with + | @var idx name md hidx => + rw [mkVar_lbr, mkVar_shape, size] at hbig + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + Nat.mod_eq_of_lt hidx] at hbig + have hshiftLt : shift.toNat + 1 < UInt64.size := by omega + have hsumLt : shift.toNat + cutoff.toNat < UInt64.size := by omega + have hshift1 : (shift + 1).toNat = shift.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt hshiftLt + have hshiftCutoff : (shift + cutoff).toNat = + shift.toNat + cutoff.toNat := by + rw [UInt64.toNat_add] + exact Nat.mod_eq_of_lt hsumLt + by_cases hidxCutoff : idx ≥ cutoff + · have hidxShiftLt : idx.toNat + shift.toNat + 1 < + UInt64.size := by omega + have hidxShift0Lt : idx.toNat + shift.toNat < UInt64.size := by + omega + have hidxShift : (idx + (shift + 1)).toNat = + idx.toNat + shift.toNat + 1 := by + rw [UInt64.toNat_add, hshift1] + exact Nat.mod_eq_of_lt hidxShiftLt + have hidxShift0 : (idx + shift).toNat = + idx.toNat + shift.toNat := by + rw [UInt64.toNat_add] + exact Nat.mod_eq_of_lt hidxShift0Lt + have hgt : idx + (shift + 1) > shift + cutoff := + UInt64.lt_iff_toNat_lt.mpr (by + rw [hidxShift, hshiftCutoff] + have := UInt64.le_iff_toNat_le.mp hidxCutoff + omega) + have hone : (1 : UInt64) ≤ idx + (shift + 1) := + UInt64.le_iff_toNat_le.mpr (by + rw [show (1 : UInt64).toNat = 1 from rfl, hidxShift] + omega) + have hsub : idx + (shift + 1) - 1 = idx + shift := by + apply UInt64.toNat_inj.mp + rw [UInt64.toNat_sub_of_le _ _ hone, + show (1 : UInt64).toNat = 1 from rfl, hidxShift, hidxShift0] + omega + have hne : ¬((idx + (shift + 1) == shift + cutoff) = true) := by + intro heq + have heq' := congrArg UInt64.toNat (eq_of_beq heq) + rw [hidxShift, hshiftCutoff] at heq' + have hge' := UInt64.le_iff_toNat_le.mp hidxCutoff + omega + rw [mkVar_shape, liftSpec, if_pos hidxCutoff, mkVar_shape, + substSpec, if_neg hne, if_pos hgt, hsub, + liftSpec, if_pos hidxCutoff] + · have hidxLtNat : idx.toNat < cutoff.toNat := by + have hnle : ¬cutoff.toNat ≤ idx.toNat := fun h => + hidxCutoff (UInt64.le_iff_toNat_le.mpr h) + omega + have hidxLt : idx < cutoff := + UInt64.lt_iff_toNat_lt.mpr hidxLtNat + have hlt : idx < shift + cutoff := by + apply UInt64.lt_iff_toNat_lt.mpr + rw [hshiftCutoff] + omega + have hne : ¬((idx == shift + cutoff) = true) := by + intro heq + have heq' := congrArg UInt64.toNat (eq_of_beq heq) + have hlt' := UInt64.lt_iff_toNat_lt.mp hlt + omega + have hngt : ¬idx > shift + cutoff := fun hgt => by + have hgt' := UInt64.lt_iff_toNat_lt.mp hgt + have hlt' := UInt64.lt_iff_toNat_lt.mp hlt + omega + rw [mkVar_shape, liftSpec, if_neg hidxCutoff, substSpec, + if_neg hne, if_neg hngt, liftSpec, if_neg hidxCutoff] + | fvar => rfl + | sort => rfl + | const => rfl + | @app f a md hf ha ihf iha => + rw [mkApp_lbr, mkApp_shape, size] at hbig + have hmax := toNat_max_bv f.lbr a.lbr + rw [mkApp_shape, liftSpec, mkApp_shape, substSpec, + ihf (shift := shift) (cutoff := cutoff) (by + rw [hmax] at hbig + omega), + iha (shift := shift) (cutoff := cutoff) (by + rw [hmax] at hbig + omega), + liftSpec] + | @lam name bi ty body md hty hbody ihty ihbody => + rw [mkLam_lbr, mkLam_shape, size] at hbig + have hmax := toNat_max_bv ty.lbr body.lbr.sat1 + rw [hmax] at hbig + have hsat := toNat_le_sat1_add_one_bv body.lbr + have hszty := size_pos ty + have hszbody := size_pos body + have hcut1 : (cutoff + 1).toNat = cutoff.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt + (Nat.lt_of_le_of_lt (by omega) hbig) + have hsum1 : (shift + cutoff + 1) = shift + (cutoff + 1) := by + exact UInt64.add_assoc shift cutoff 1 + rw [mkLam_shape, liftSpec, mkLam_shape, substSpec, + ihty (shift := shift) (cutoff := cutoff) (by + exact Nat.lt_of_le_of_lt (by omega) hbig), + hsum1, + ihbody (shift := shift) (cutoff := cutoff + 1) (by + rw [hcut1] + exact Nat.lt_of_le_of_lt (by omega) hbig), + liftSpec] + | @all name bi ty body md hty hbody ihty ihbody => + rw [mkAll_lbr, mkAll_shape, size] at hbig + have hmax := toNat_max_bv ty.lbr body.lbr.sat1 + rw [hmax] at hbig + have hsat := toNat_le_sat1_add_one_bv body.lbr + have hszty := size_pos ty + have hszbody := size_pos body + have hcut1 : (cutoff + 1).toNat = cutoff.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt + (Nat.lt_of_le_of_lt (by omega) hbig) + have hsum1 : (shift + cutoff + 1) = shift + (cutoff + 1) := by + exact UInt64.add_assoc shift cutoff 1 + rw [mkAll_shape, liftSpec, mkAll_shape, substSpec, + ihty (shift := shift) (cutoff := cutoff) (by + exact Nat.lt_of_le_of_lt (by omega) hbig), + hsum1, + ihbody (shift := shift) (cutoff := cutoff + 1) (by + rw [hcut1] + exact Nat.lt_of_le_of_lt (by omega) hbig), + liftSpec] + | @letE name ty val body nondep md hty hval hbody ihty ihval ihbody => + rw [mkLet_lbr, mkLet_shape, size] at hbig + have hmax1 := toNat_max_bv ty.lbr val.lbr + have hmax2 := toNat_max_bv (max ty.lbr val.lbr) body.lbr.sat1 + rw [hmax2, hmax1] at hbig + have hsat := toNat_le_sat1_add_one_bv body.lbr + have hszty := size_pos ty + have hszval := size_pos val + have hszbody := size_pos body + have hcut1 : (cutoff + 1).toNat = cutoff.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt + (Nat.lt_of_le_of_lt (by omega) hbig) + have hsum1 : (shift + cutoff + 1) = shift + (cutoff + 1) := by + exact UInt64.add_assoc shift cutoff 1 + rw [mkLet_shape, liftSpec, mkLet_shape, substSpec, + ihty (shift := shift) (cutoff := cutoff) (by + exact Nat.lt_of_le_of_lt (by omega) hbig), + ihval (shift := shift) (cutoff := cutoff) (by + exact Nat.lt_of_le_of_lt (by omega) hbig), + hsum1, + ihbody (shift := shift) (cutoff := cutoff + 1) (by + rw [hcut1] + exact Nat.lt_of_le_of_lt (by omega) hbig), + liftSpec] + | @prj id field val md hval ihval => + rw [mkPrj_lbr, mkPrj_shape, size] at hbig + rw [mkPrj_shape, liftSpec, mkPrj_shape, substSpec, + ihval (shift := shift) (cutoff := cutoff) (by omega), + liftSpec] + | nat => rfl + | str => rfl + +/-- Depth-indexed public cancellation form used by the variable-hit case of +the simultaneous-substitution cons law. -/ +theorem substSpec_liftSpec_succ + {e arg : KExpr .anon} (he : Constructed e) {depth : UInt64} + (hbig : e.lbr.toNat + e.size + depth.toNat + 1 < UInt64.size) : + substSpec (liftSpec e (depth + 1) 0) arg depth = + liftSpec e depth 0 := by + have h := substSpec_liftSpec_succ_aux (arg := arg) he + (shift := depth) (cutoff := 0) (by + simp only [show (0 : UInt64).toNat = 0 from rfl] + omega) + simpa only [UInt64.add_zero] using h + +end KExpr +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/Meaning.lean b/Ix/Tc/Verify/Whnf/Beta/Meaning.lean new file mode 100644 index 000000000..c5c25ddeb --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/Meaning.lean @@ -0,0 +1,45 @@ +import Ix.Tc.Verify.Whnf.Beta.Translation + +/-! +# Constructive multi-beta meaning + +The preceding slices recover the translated lambda telescope, its dependent +context-instantiation chain, the exact Theory argument values, and a one-pass +translation theorem for production's simultaneous-substitution walker. This +file assembles those pieces into `BetaPrefixMeaning`, eliminating the last +semantic oracle specific to general multi-beta. +-/ + +namespace Ix.Tc + +open Lean4Lean + +namespace RecM + +/-- Production's consumed beta prefix has the exact structural translation +and Theory meaning required by `BetaPrefixMeaning`. -/ +theorem betaPrefixMeaning (trProj : RawProjRel) (world : VerifyWorld) : + BetaPrefixMeaning trProj world := by + intro uvars theory Delta start body consumed startV consumedV hDelta + hstart hpeel hsuffix hbounds + obtain ⟨argValues, hvalues⟩ := TrAppSuffix.Values.ofSuffix hsuffix + obtain ⟨bodyDelta, bodyV, htrace⟩ := hpeel.translate hstart + have hinsts := htrace.contextInsts theory hDelta hvalues + have harguments : + SimulArgs world.venv uvars world.nameOf trProj Delta + consumed.reverse argValues := by + simpa using SimulArgs.ofValues hvalues + have hresult := TrKExprS.simulSubstBeta + world.venvWF.ordered theory.projections.weakN theory.projections.instN + harguments htrace.result hinsts KVLCtx.KBVLift.refl hbounds rfl + have hmeaning := htrace.theoryMeaning theory hDelta hvalues + exact ⟨VExpr.instBetaArgs bodyV argValues 0, hresult, hmeaning⟩ + +/-- The old complete application-branch interface is now a theorem rather +than an independent semantic assumption. -/ +theorem betaManyMeaning (trProj : RawProjRel) (world : VerifyWorld) : + BetaManyMeaningOracle trProj world := + BetaManyMeaningOracle.of_prefix (betaPrefixMeaning trProj world) + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/PeelTrace.lean b/Ix/Tc/Verify/Whnf/Beta/PeelTrace.lean new file mode 100644 index 000000000..472647ada --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/PeelTrace.lean @@ -0,0 +1,103 @@ +import Ix.Tc.Verify.Whnf.Beta.SemanticCore + +/-! +# Translated lambda-peel traces + +The operational `BetaPeel` trace records concrete lambda bodies but not the +mixed translation contexts introduced by those binders. This slice recovers +the exact nested `vlam` contexts and the structural translation of the final +body. Subsequent simultaneous-instantiation proofs can therefore reason from +the actual binder stack rather than only from the number of consumed terms. +-/ + +namespace Ix.Tc +namespace RecM + +namespace BetaPeel + +/-- Structural translation data for every stage of a concrete lambda peel. +The final context is the original `Delta` extended by one `vlam` entry per +consumed argument, in the same innermost-first order used by de Bruijn +indices. -/ +inductive Tr (env : Lean4Lean.VEnv) (uvars : Nat) + (nameOf : Address -> Option Lean.Name) (trProj : RawProjRel) + (Delta : KVLCtx) (start : KExpr .anon) (startV : Lean4Lean.VExpr) : + List (KExpr .anon) -> KExpr .anon -> KVLCtx -> Lean4Lean.VExpr -> Prop + | nil + (hstart : TrKExprS env uvars nameOf trProj Delta start startV) : + Tr env uvars nameOf trProj Delta start startV [] start Delta startV + | snoc {consumed : List (KExpr .anon)} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body : KExpr .anon} {info : ExprInfo .anon} + {arg : KExpr .anon} {currentDelta : KVLCtx} + {A bodyV : Lean4Lean.VExpr} + (hprefix : Tr env uvars nameOf trProj Delta start startV consumed + (.lam name bi ty body info) currentDelta (.lam A bodyV)) + (hA : env.IsType uvars currentDelta.toCtx A) + (hty : TrKExprS env uvars nameOf trProj currentDelta ty A) + (hbody : TrKExprS env uvars nameOf trProj + ((none, .vlam A) :: currentDelta) body bodyV) : + Tr env uvars nameOf trProj Delta start startV (consumed ++ [arg]) + body ((none, .vlam A) :: currentDelta) bodyV + +namespace Tr + +/-- The final concrete body in a translated peel trace has the structural +translation stored at the trace endpoint. -/ +theorem result + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address -> Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start : KExpr .anon} {startV : Lean4Lean.VExpr} + {consumed : List (KExpr .anon)} {body : KExpr .anon} + {bodyDelta : KVLCtx} {bodyV : Lean4Lean.VExpr} + (h : Tr env uvars nameOf trProj Delta start startV consumed body + bodyDelta bodyV) : + TrKExprS env uvars nameOf trProj bodyDelta body bodyV := by + cases h with + | nil hstart => exact hstart + | snoc _ _ _ hbody => exact hbody + +/-- Every consumed lambda contributes exactly one Theory binder to the final +mixed context. -/ +theorem bvars + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address -> Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start : KExpr .anon} {startV : Lean4Lean.VExpr} + {consumed : List (KExpr .anon)} {body : KExpr .anon} + {bodyDelta : KVLCtx} {bodyV : Lean4Lean.VExpr} + (h : Tr env uvars nameOf trProj Delta start startV consumed body + bodyDelta bodyV) : + bodyDelta.bvars = Delta.bvars + consumed.length := by + induction h with + | nil => simp + | snoc hp hA hty hbody ih => + simp [KVLCtx.bvars, ih] + omega + +end Tr + +/-- A structural translation of the initial lambda chain determines a +translated peel trace and an exact structural translation of the final raw +body under the recovered binder context. -/ +theorem translate + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address -> Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start body : KExpr .anon} + {consumed : List (KExpr .anon)} {startV : Lean4Lean.VExpr} + (hpeel : BetaPeel start consumed body) + (hstart : TrKExprS env uvars nameOf trProj Delta start startV) : + exists bodyDelta bodyV, + Tr env uvars nameOf trProj Delta start startV consumed body + bodyDelta bodyV := by + induction hpeel with + | nil => exact ⟨Delta, startV, .nil hstart⟩ + | snoc hprefix ih => + obtain ⟨currentDelta, currentV, htrace⟩ := ih + have hcurrent := htrace.result + cases hcurrent with + | lam hA hty hbody => + exact ⟨_, _, .snoc htrace hA hty hbody⟩ + +end BetaPeel +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/PrefixSemantics.lean b/Ix/Tc/Verify/Whnf/Beta/PrefixSemantics.lean new file mode 100644 index 000000000..5bbfb809a --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/PrefixSemantics.lean @@ -0,0 +1,306 @@ +import Ix.Tc.Verify.Whnf.Beta.LambdaInstantiation + +/-! +# Theory semantics of a peeled beta prefix + +This slice records the Theory expression obtained by instantiating a lambda +telescope in production order. It proves the list algebra and the exact +typed `TrAppSuffix` unsnoc view needed to reduce a `BetaPeel.Tr` one argument +at a time. The concrete simultaneous-substitution translation is kept as a +separate one-pass theorem so it need not pretend that sequential intermediate +terms satisfy production's size bound. +-/ + +namespace Ix.Tc + +open Lean4Lean + +end Ix.Tc + +namespace Lean4Lean.VExpr + +/-- Instantiate outer-to-inner beta arguments. The first argument removes +the outermost remaining binder; the final argument removes the binder at +`depth`. -/ +def instBetaArgs (e : VExpr) : List VExpr → (depth : Nat) → VExpr + | [], _ => e + | arg :: args, depth => + instBetaArgs (e.inst arg (depth + args.length)) args depth + +@[simp] theorem instBetaArgs_nil (e : VExpr) (depth : Nat) : + instBetaArgs e [] depth = e := rfl + +@[simp] theorem instBetaArgs_sort (level : VLevel) (args : List VExpr) + (depth : Nat) : + instBetaArgs (.sort level) args depth = .sort level := by + induction args generalizing depth with + | nil => rfl + | cons arg args ih => + rw [instBetaArgs, VExpr.inst, ih] + +@[simp] theorem instBetaArgs_const (name : Lean.Name) (levels : List VLevel) + (args : List VExpr) (depth : Nat) : + instBetaArgs (.const name levels) args depth = .const name levels := by + induction args generalizing depth with + | nil => rfl + | cons arg args ih => + rw [instBetaArgs, VExpr.inst, ih] + +theorem instBetaArgs_app (fn arg : VExpr) (args : List VExpr) + (depth : Nat) : + instBetaArgs (.app fn arg) args depth = + .app (instBetaArgs fn args depth) (instBetaArgs arg args depth) := by + induction args generalizing fn arg depth with + | nil => rfl + | cons replacement args ih => + rw [instBetaArgs, VExpr.inst, ih] + simp only [instBetaArgs] + +/-- Beta-prefix instantiation distributes through a lambda, incrementing the +body cutoff exactly once. -/ +theorem instBetaArgs_lam (A body : VExpr) (args : List VExpr) + (depth : Nat) : + instBetaArgs (.lam A body) args depth = + .lam (instBetaArgs A args depth) + (instBetaArgs body args (depth + 1)) := by + induction args generalizing A body depth with + | nil => rfl + | cons arg args ih => + rw [instBetaArgs, VExpr.inst, ih] + simp only [instBetaArgs] + have hpos : depth + args.length + 1 = depth + 1 + args.length := by + omega + rw [hpos] + +theorem instBetaArgs_forallE (A body : VExpr) (args : List VExpr) + (depth : Nat) : + instBetaArgs (.forallE A body) args depth = + .forallE (instBetaArgs A args depth) + (instBetaArgs body args (depth + 1)) := by + induction args generalizing A body depth with + | nil => rfl + | cons arg args ih => + rw [instBetaArgs, VExpr.inst, ih] + simp only [instBetaArgs] + have hpos : depth + args.length + 1 = depth + 1 + args.length := by + omega + rw [hpos] + +/-- Appending the innermost argument is one final instantiation after the +older prefix has been processed one binder deeper. -/ +theorem instBetaArgs_append_singleton (e arg : VExpr) + (args : List VExpr) (depth : Nat) : + instBetaArgs e (args ++ [arg]) depth = + (instBetaArgs e args (depth + 1)).inst arg depth := by + induction args generalizing e depth with + | nil => rfl + | cons first rest ih => + rw [List.cons_append, instBetaArgs, List.length_append, + List.length_singleton, instBetaArgs] + have hpos : depth + (rest.length + 1) = depth + 1 + rest.length := by + omega + rw [hpos, ih] + +private theorem inst_liftN_total (e replacement : VExpr) (amount : Nat) : + (e.liftN (amount + 1)).inst replacement amount = e.liftN amount := by + have hcompose : + (e.liftN amount).liftN 1 amount = e.liftN (amount + 1) := + VExpr.liftN'_liftN' (e := e) (n1 := amount) (n2 := 1) + (k1 := 0) (k2 := amount) (Nat.zero_le _) (Nat.le_refl _) + rw [← hcompose] + exact VExpr.inst_liftN _ _ + +/-- Removing every beta binder from an expression lifted across the whole +telescope leaves exactly the syntax-local lift below that telescope. -/ +theorem instBetaArgs_liftN (e : VExpr) (args : List VExpr) (depth : Nat) : + instBetaArgs (e.liftN (depth + args.length)) args depth = + e.liftN depth := by + induction args generalizing e depth with + | nil => simp + | cons arg args ih => + rw [instBetaArgs] + simp only [List.length_cons] + have hamount : depth + (args.length + 1) = + (depth + args.length) + 1 := by omega + rw [hamount, inst_liftN_total, ih] + +end Lean4Lean.VExpr + +namespace Ix.Tc + +open Lean4Lean + +namespace RecM.TrAppSuffix + +/-- A typed suffix together with the exact Theory argument values in the same +production order as its concrete arguments. -/ +inductive Values (env : Lean4Lean.VEnv) (uvars : Nat) + (nameOf : Address → Option Lean.Name) (trProj : RawProjRel) + (Delta : KVLCtx) (start : VExpr) : + List (KExpr .anon) → List VExpr → VExpr → Prop + | nil : Values env uvars nameOf trProj Delta start [] [] start + | app {args : List (KExpr .anon)} {argValues : List VExpr} + {current argV A B : VExpr} {arg : KExpr .anon} : + Values env uvars nameOf trProj Delta start args argValues current → + env.HasType uvars Delta.toCtx current (.forallE A B) → + env.HasType uvars Delta.toCtx argV A → + TrKExprS env uvars nameOf trProj Delta arg argV → + Values env uvars nameOf trProj Delta start (args ++ [arg]) + (argValues ++ [argV]) (.app current argV) + +namespace Values + +/-- Every typed suffix exposes its exact Theory argument list. -/ +theorem ofSuffix + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start : VExpr} + {args : List (KExpr .anon)} {resultV : VExpr} + (h : TrAppSuffix env uvars nameOf trProj Delta start args resultV) : + ∃ argValues, + Values env uvars nameOf trProj Delta start args argValues resultV := by + induction h with + | nil => exact ⟨[], .nil⟩ + | app hprefix hfun harg hargTr ih => + obtain ⟨argValues, hvalues⟩ := ih + exact ⟨argValues ++ [_], .app hvalues hfun harg hargTr⟩ + +/-- The empty concrete suffix has no Theory arguments and leaves its start +expression unchanged. -/ +theorem nil_inv + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start resultV : VExpr} {argValues : List VExpr} + (h : Values env uvars nameOf trProj Delta start [] argValues resultV) : + argValues = [] ∧ resultV = start := by + generalize heq : ([] : List (KExpr .anon)) = args at h + induction h with + | nil => exact ⟨rfl, rfl⟩ + | app => simp at heq + +/-- Exact last-argument view, retaining the Theory-value list. -/ +theorem unsnoc + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start : VExpr} + {args : List (KExpr .anon)} {arg : KExpr .anon} + {argValues : List VExpr} {resultV : VExpr} + (h : Values env uvars nameOf trProj Delta start (args ++ [arg]) + argValues resultV) : + ∃ priorValues currentV argV A B, + argValues = priorValues ++ [argV] ∧ + Values env uvars nameOf trProj Delta start args priorValues currentV ∧ + env.HasType uvars Delta.toCtx currentV (.forallE A B) ∧ + env.HasType uvars Delta.toCtx argV A ∧ + TrKExprS env uvars nameOf trProj Delta arg argV ∧ + resultV = .app currentV argV := by + generalize heq : args ++ [arg] = allArgs at h + induction h with + | nil => simp at heq + | @app priorArgs priorValues currentV argV A B concreteArg hprefix hfun + harg hargTr ih => + obtain ⟨rfl, rfl⟩ := List.append_singleton_inj.mp heq + exact ⟨priorValues, currentV, argV, A, B, rfl, hprefix, hfun, + harg, hargTr, rfl⟩ + +end Values + +/-- Exact last-argument view of a typed suffix. -/ +theorem unsnoc + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start : VExpr} + {args : List (KExpr .anon)} {arg : KExpr .anon} {resultV : VExpr} + (h : TrAppSuffix env uvars nameOf trProj Delta start + (args ++ [arg]) resultV) : + ∃ currentV argV A B, + TrAppSuffix env uvars nameOf trProj Delta start args currentV ∧ + env.HasType uvars Delta.toCtx currentV (.forallE A B) ∧ + env.HasType uvars Delta.toCtx argV A ∧ + TrKExprS env uvars nameOf trProj Delta arg argV ∧ + resultV = .app currentV argV := by + generalize heq : args ++ [arg] = allArgs at h + induction h with + | nil => simp at heq + | @app priorArgs current lastArg argV A B hprefix hfun hargTy hargTr ih => + obtain ⟨rfl, rfl⟩ := List.append_singleton_inj.mp heq + exact ⟨_, _, _, _, hprefix, hfun, hargTy, hargTr, rfl⟩ + +end RecM.TrAppSuffix + +namespace RecM.BetaPeel.Tr + +/-- The endpoint context of a translated lambda peel is well formed. -/ +theorem endpointWF + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {start : KExpr .anon} {startV : VExpr} + {consumed : List (KExpr .anon)} {body : KExpr .anon} + {bodyDelta : KVLCtx} {bodyV : VExpr} + (h : BetaPeel.Tr world.venv uvars world.nameOf trProj Delta start startV + consumed body bodyDelta bodyV) + (hDelta : KVLCtx.WF world.venv uvars Delta) : + KVLCtx.WF world.venv uvars bodyDelta := by + induction h with + | nil => exact hDelta + | snoc hprefix hA hty hbody ih => exact ⟨ih, nofun, hA⟩ + +/-- A typed application of every peeled lambda is definitionally equal to +the endpoint Theory body instantiated by the same argument values. -/ +theorem theoryMeaning + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + {Delta : KVLCtx} {start : KExpr .anon} {startV : VExpr} + {consumed : List (KExpr .anon)} {body : KExpr .anon} + {bodyDelta : KVLCtx} {bodyV : VExpr} + {argValues : List VExpr} {appliedV : VExpr} + (h : BetaPeel.Tr world.venv uvars world.nameOf trProj Delta start startV + consumed body bodyDelta bodyV) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (happs : TrAppSuffix.Values world.venv uvars world.nameOf trProj Delta + startV consumed argValues appliedV) : + world.venv.IsDefEqU uvars Delta.toCtx appliedV + (VExpr.instBetaArgs bodyV argValues 0) := by + induction h generalizing argValues appliedV with + | nil hstart => + obtain ⟨rfl, rfl⟩ := happs.nil_inv + exact Lean4Lean.VEnv.IsDefEqU.refl + (hstart.wf world.venvWF.ordered theory.literalWF + theory.projections.wf hDelta) + | @snoc consumed name bi ty body info arg currentDelta A bodyV hprefix + hA hty hbody ih => + obtain ⟨priorValues, currentV, argV, domain, codomain, rfl, + hpriorApps, hfun, harg, hargTr, rfl⟩ := happs.unsnoc + have hprefixEq := ih hpriorApps + rw [VExpr.instBetaArgs_lam] at hprefixEq + let A' := VExpr.instBetaArgs A priorValues 0 + let bodyV' := VExpr.instBetaArgs bodyV priorValues 1 + have hfun' : world.venv.HasType uvars Delta.toCtx + (.lam A' bodyV') (.forallE domain codomain) := + hfun.defeqU_l world.venvWF hDelta.toCtx hprefixEq + obtain ⟨⟨u, hA'⟩, B', hbodyV'⟩ := + hfun'.lam_inv world.venvWF.ordered hDelta.toCtx + have hlam' : world.venv.HasType uvars Delta.toCtx + (.lam A' bodyV') (.forallE A' B') := + Lean4Lean.VEnv.HasType.lam hA' hbodyV' + have hforallEq : world.venv.IsDefEqU uvars Delta.toCtx + (.forallE domain codomain) (.forallE A' B') := + hfun'.uniqU world.venvWF hDelta.toCtx hlam' + have hdomainEq : world.venv.IsDefEqU uvars Delta.toCtx domain A' := + let ⟨u, hdomain⟩ := + (hforallEq.forallE_inv world.venvWF hDelta.toCtx).1 + ⟨.sort u, hdomain⟩ + have harg' : world.venv.HasType uvars Delta.toCtx argV A' := + harg.defeqU_r world.venvWF hDelta.toCtx hdomainEq + have happCong : world.venv.IsDefEqU uvars Delta.toCtx + (.app currentV argV) (.app (.lam A' bodyV') argV) := + (Lean4Lean.VEnv.IsDefEq.appDF + (hprefixEq.of_l world.venvWF hDelta.toCtx hfun) harg).toU + have hbeta : world.venv.IsDefEqU uvars Delta.toCtx + (.app (.lam A' bodyV') argV) (bodyV'.inst argV) := + ⟨_, .beta hbodyV' harg'⟩ + rw [VExpr.instBetaArgs_append_singleton] + exact happCong.trans world.venvWF hDelta.toCtx hbeta + +end RecM.BetaPeel.Tr + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/SemanticCore.lean b/Ix/Tc/Verify/Whnf/Beta/SemanticCore.lean new file mode 100644 index 000000000..e9523bb74 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/SemanticCore.lean @@ -0,0 +1,66 @@ +import Ix.Tc.Verify.Whnf.Beta.ConsumptionBoundary + +/-! +# Isolate the semantic core of general multi-beta + +The original `BetaManyMeaningOracle` bundled four independent concerns: +changed-head congruence, splitting the consumed application prefix, semantic +multi-beta, and rebuilding the unconsumed suffix. ConsumptionBoundary proves the exact typed +split. This slice discharges every concern except the actual simultaneous +substitution theorem, leaving `BetaPrefixMeaning` as the minimal semantic +statement that must be proved structurally. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Semantic core of production multi-beta. Starting from a translated +lambda chain and exactly the arguments peeled by `consumeBetaLams`, the direct +simultaneous-substitution result translates and is definitionally equal to +the fully applied prefix. -/ +def BetaPrefixMeaning (trProj : RawProjRel) (world : VerifyWorld) : Prop := + forall {uvars : Nat}, WhnfTheory trProj world uvars -> + forall {Delta : KVLCtx} {start body : KExpr .anon} + {consumed : Array (KExpr .anon)} + {startV consumedV : Lean4Lean.VExpr}, + KVLCtx.WF world.venv uvars Delta -> + TrKExprS world.venv uvars world.nameOf trProj Delta start startV -> + BetaPeel start consumed.toList body -> + TrAppSuffix world.venv uvars world.nameOf trProj Delta startV + consumed.toList consumedV -> + (WalkerRequest.simulSubst body consumed.reverse 0).Bounds -> + exists resultV, + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.simulSubstSpec body consumed.reverse 0) resultV /\ + world.venv.IsDefEqU uvars Delta.toCtx consumedV resultV + +namespace BetaManyMeaningOracle + +/-- The minimal consumed-prefix theorem implies the original complete +multi-beta branch contract. Changed-head equality is transported through +the consumed prefix, the beta result is transported through the untouched +suffix, and `FinishAppRequests` identifies the exact rebuilt concrete term. -/ +theorem of_prefix {trProj : RawProjRel} {world : VerifyWorld} + (hprefix : BetaPrefixMeaning trProj world) : + BetaManyMeaningOracle trProj world := by + intro uvars theory Delta requests f arg info args name bi ty body body0 + lamInfo consumed result sourceV headV hDelta hsource hsuffix hheadPost + hconsume hbounds hfinish + obtain ⟨lambdaV, hlambdaTr, hheadEq⟩ := hheadPost + obtain ⟨middleV, hpeel, hconsumed, hremaining⟩ := + hsuffix.splitConsume hconsume + obtain ⟨appliedV, happliedSuffix, hmiddleApplied⟩ := + hconsumed.rebaseStart world.venvWF hDelta hheadEq + obtain ⟨reducedV, hreducedTr, happliedReduced⟩ := + hprefix theory hDelta hlambdaTr hpeel happliedSuffix hbounds + have hmiddleReduced : + world.venv.IsDefEqU uvars Delta.toCtx middleV reducedV := + hmiddleApplied.trans world.venvWF hDelta.toCtx happliedReduced + obtain ⟨finalV, hfinalTr, hsourceFinal⟩ := + hremaining.rebase world.venvWF hDelta hreducedTr hmiddleReduced + rw [hfinish.result_eq_foldl] + exact ⟨sourceV, finalV, hsource, hfinalTr, hsourceFinal⟩ + +end BetaManyMeaningOracle +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/SimultaneousSubstitution.lean b/Ix/Tc/Verify/Whnf/Beta/SimultaneousSubstitution.lean new file mode 100644 index 000000000..b4f6ce3e5 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/SimultaneousSubstitution.lean @@ -0,0 +1,694 @@ +import Ix.Tc.Verify.Whnf.Beta.LiftSubstitution + +/-! +# Simultaneous-substitution decomposition + +When one more lambda is peeled, production prepends its argument to the +reverse-order simultaneous-substitution array. This slice proves that the +result is exactly the older simultaneous substitution one binder deeper, +followed by ordinary beta substitution for the newly peeled argument. +-/ + +namespace Ix.Tc +namespace KExpr + +private theorem toNat_toUInt64_bw (k : Nat) : + k.toUInt64.toNat = k % UInt64.size := by + unfold Nat.toUInt64 + rfl + +private theorem getElemBang_singleton_append_zero_bw + (a : α) (xs : Array α) [Inhabited α] : + (#[a] ++ xs)[0]! = a := by + rw [getElem!_pos (#[a] ++ xs) 0 (by simp; omega)] + exact Array.getElem_append_left (by simp) + +private theorem getElemBang_singleton_append_succ_bw + (a : α) (xs : Array α) [Inhabited α] + (j : Nat) (hj : j < xs.size) : + (#[a] ++ xs)[j + 1]! = xs[j]! := by + rw [getElem!_pos (#[a] ++ xs) (j + 1) (by simp; omega), + getElem!_pos xs j hj] + simpa using + (Array.getElem_append_right (xs := #[a]) (ys := xs) (i := j + 1) + (by simp)) + +private theorem simulSubstSpec_mkApp_bw (f a : KExpr .anon) (md) + (xs : Array (KExpr .anon)) (d : UInt64) : + simulSubstSpec (mkApp f a md) xs d = + mkApp (simulSubstSpec f xs d) (simulSubstSpec a xs d) := by + rw [mkApp_shape, simulSubstSpec] + +private theorem substSpec_mkApp_bw (f a arg : KExpr .anon) (md) + (d : UInt64) : + substSpec (mkApp f a md) arg d = + mkApp (substSpec f arg d) (substSpec a arg d) := by + rw [mkApp_shape, substSpec] + +private theorem simulSubstSpec_mkLam_bw (name bi) (ty inner : KExpr .anon) + (md) (xs : Array (KExpr .anon)) (d : UInt64) : + simulSubstSpec (mkLam name bi ty inner md) xs d = + mkLam name bi (simulSubstSpec ty xs d) + (simulSubstSpec inner xs (d + 1)) := by + rw [mkLam_shape, simulSubstSpec] + +private theorem substSpec_mkLam_bw (name bi) (ty inner arg : KExpr .anon) + (md) (d : UInt64) : + substSpec (mkLam name bi ty inner md) arg d = + mkLam name bi (substSpec ty arg d) + (substSpec inner arg (d + 1)) := by + rw [mkLam_shape, substSpec] + +private theorem simulSubstSpec_mkAll_bw (name bi) (ty inner : KExpr .anon) + (md) (xs : Array (KExpr .anon)) (d : UInt64) : + simulSubstSpec (mkAll name bi ty inner md) xs d = + mkAll name bi (simulSubstSpec ty xs d) + (simulSubstSpec inner xs (d + 1)) := by + rw [mkAll_shape, simulSubstSpec] + +private theorem substSpec_mkAll_bw (name bi) (ty inner arg : KExpr .anon) + (md) (d : UInt64) : + substSpec (mkAll name bi ty inner md) arg d = + mkAll name bi (substSpec ty arg d) + (substSpec inner arg (d + 1)) := by + rw [mkAll_shape, substSpec] + +private theorem simulSubstSpec_mkLet_bw (name) (ty val inner : KExpr .anon) + (nondep) (md) (xs : Array (KExpr .anon)) (d : UInt64) : + simulSubstSpec (mkLet name ty val inner nondep md) xs d = + mkLet name (simulSubstSpec ty xs d) (simulSubstSpec val xs d) + (simulSubstSpec inner xs (d + 1)) nondep := by + rw [mkLet_shape, simulSubstSpec] + +private theorem substSpec_mkLet_bw (name) (ty val inner arg : KExpr .anon) + (nondep) (md) (d : UInt64) : + substSpec (mkLet name ty val inner nondep md) arg d = + mkLet name (substSpec ty arg d) (substSpec val arg d) + (substSpec inner arg (d + 1)) nondep := by + rw [mkLet_shape, substSpec] + +private theorem simulSubstSpec_mkPrj_bw (id field) (val : KExpr .anon) + (md) (xs : Array (KExpr .anon)) (d : UInt64) : + simulSubstSpec (mkPrj id field val md) xs d = + mkPrj id field (simulSubstSpec val xs d) := by + rw [mkPrj_shape, simulSubstSpec] + +private theorem substSpec_mkPrj_bw (id field) (val arg : KExpr .anon) + (md) (d : UInt64) : + substSpec (mkPrj id field val md) arg d = + mkPrj id field (substSpec val arg d) := by + rw [mkPrj_shape, substSpec] + +/-- Simultaneous substitution by an empty array is the identity at every +depth. Unlike the loose-binder fast-path lemma, this needs no `lbr` premise. -/ +theorem simulSubstSpec_empty {body : KExpr .anon} + {substs : Array (KExpr .anon)} {depth : UInt64} + (hbody : Constructed body) (hempty : substs.size = 0) : + simulSubstSpec body substs depth = body := by + induction hbody generalizing depth with + | @var idx name info hidx => + have hsize : substs.size.toUInt64 = 0 := by rw [hempty]; rfl + rw [mkVar_shape, simulSubstSpec, hsize, UInt64.add_zero] + have hwindow : ¬((idx ≥ depth && idx < depth) = true) := fun h => by + obtain ⟨hge, hlt⟩ := Bool.and_eq_true_iff.mp h + have hge' := UInt64.le_iff_toNat_le.mp (of_decide_eq_true hge) + have hlt' := UInt64.lt_iff_toNat_lt.mp (of_decide_eq_true hlt) + omega + rw [if_neg hwindow] + by_cases hge : idx ≥ depth + · rw [if_pos hge, UInt64.sub_zero] + exact (mkVar_shape idx name info).symm ▸ rfl + · rw [if_neg hge] + | fvar => rfl + | sort => rfl + | const => rfl + | @app f arg info hf harg ihf iharg => + rw [mkApp_shape, simulSubstSpec, ihf (depth := depth), + iharg (depth := depth)] + exact mkApp_shape f arg info + | @lam name bi ty body info hty hbody ihty ihbody => + rw [mkLam_shape, simulSubstSpec, ihty (depth := depth), + ihbody (depth := depth + 1)] + exact mkLam_shape name bi ty body info + | @all name bi ty body info hty hbody ihty ihbody => + rw [mkAll_shape, simulSubstSpec, ihty (depth := depth), + ihbody (depth := depth + 1)] + exact mkAll_shape name bi ty body info + | @letE name ty val body nd info hty hval hbody ihty ihval ihbody => + rw [mkLet_shape, simulSubstSpec, ihty (depth := depth), + ihval (depth := depth), ihbody (depth := depth + 1)] + exact mkLet_shape name ty val body nd info + | @prj id field val info hval ihval => + rw [mkPrj_shape, simulSubstSpec, ihval (depth := depth)] + exact mkPrj_shape id field val info + | nat => rfl + | str => rfl + +/-- Prepending one substitution is equivalent to applying the older array one +binder deeper and then substituting the new head argument. -/ +theorem simulSubstSpec_cons + {body arg : KExpr .anon} {rest : Array (KExpr .anon)} + {depth : UInt64} + (hbounds : WalkerRequest.Bounds + (.simulSubst body (#[arg] ++ rest) depth)) : + simulSubstSpec body (#[arg] ++ rest) depth = + substSpec (simulSubstSpec body rest (depth + 1)) arg depth := by + obtain ⟨hbody, hconstructed, hsizes, hbig, helem⟩ := hbounds + induction hbody generalizing depth with + | @var idx name info hidx => + rw [mkVar_shape, size] at hbig + have htotalSize : (#[arg] ++ rest).size = rest.size + 1 := by + simp [Array.size_append, Nat.add_comm] + have hrestSizeNat : rest.size.toUInt64.toNat = rest.size := by + rw [toNat_toUInt64_bw] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig) + have htotalSizeNat : (#[arg] ++ rest).size.toUInt64.toNat = + (#[arg] ++ rest).size := by + rw [toNat_toUInt64_bw] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig) + have hd1 : (depth + 1).toNat = depth.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig) + have hdirectBoundary : + (depth + (#[arg] ++ rest).size.toUInt64).toNat = + depth.toNat + (#[arg] ++ rest).size := by + rw [UInt64.toNat_add, htotalSizeNat] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig) + have hrestBoundary : + (depth + 1 + rest.size.toUInt64).toNat = + depth.toNat + 1 + rest.size := by + rw [UInt64.toNat_add, hd1, hrestSizeNat] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by + rw [htotalSize] at hbig + omega) hbig) + have hboundary : depth + (#[arg] ++ rest).size.toUInt64 = + depth + 1 + rest.size.toUInt64 := by + apply UInt64.toNat_inj.mp + rw [hdirectBoundary, hrestBoundary, htotalSize] + omega + by_cases hlt : idx < depth + · have hnge : ¬idx ≥ depth := fun h => by + have := UInt64.le_iff_toNat_le.mp h + have := UInt64.lt_iff_toNat_lt.mp hlt + omega + have hnge1 : ¬idx ≥ depth + 1 := fun h => by + have h' := UInt64.le_iff_toNat_le.mp h + have hlt' := UInt64.lt_iff_toNat_lt.mp hlt + rw [hd1] at h' + omega + have hngeBoundary : + ¬idx ≥ depth + (#[arg] ++ rest).size.toUInt64 := fun h => by + have h' := UInt64.le_iff_toNat_le.mp h + have hlt' := UInt64.lt_iff_toNat_lt.mp hlt + rw [hdirectBoundary] at h' + omega + have hngeRestBoundary : ¬idx ≥ depth + 1 + rest.size.toUInt64 := by + rw [← hboundary] + exact hngeBoundary + have hdirectWindow : ¬((idx ≥ depth && + idx < depth + (#[arg] ++ rest).size.toUInt64) = true) := by + simp [hnge] + have hrestWindow : ¬((idx ≥ depth + 1 && + idx < depth + 1 + rest.size.toUInt64) = true) := by + simp [hnge1] + have hne : ¬(idx == depth) = true := by + intro heq + have heq' := eq_of_beq heq + subst idx + have := UInt64.lt_irrefl depth hlt + contradiction + have hngt : ¬idx > depth := fun h => by + have h' := UInt64.lt_iff_toNat_lt.mp h + have hlt' := UInt64.lt_iff_toNat_lt.mp hlt + omega + have hdirectEval : simulSubstSpec (mkVar idx name info) + (#[arg] ++ rest) depth = mkVar idx name info := by + rw [mkVar_shape, simulSubstSpec, if_neg hdirectWindow, + if_neg hngeBoundary] + have hrestEval : simulSubstSpec (mkVar idx name info) rest + (depth + 1) = mkVar idx name info := by + rw [mkVar_shape, simulSubstSpec, if_neg hrestWindow, + if_neg hngeRestBoundary] + have hsubstEval : substSpec (mkVar idx name info) arg depth = + mkVar idx name info := by + rw [mkVar_shape, substSpec, if_neg hne, if_neg hngt] + calc + simulSubstSpec (mkVar idx name info) (#[arg] ++ rest) depth = + mkVar idx name info := hdirectEval + _ = substSpec (mkVar idx name info) arg depth := hsubstEval.symm + _ = substSpec + (simulSubstSpec (mkVar idx name info) rest (depth + 1)) arg + depth := congrArg (fun e => substSpec e arg depth) + hrestEval.symm + · by_cases heq : idx = depth + · subst idx + have hdepthLtBoundary : + depth < depth + (#[arg] ++ rest).size.toUInt64 := by + apply UInt64.lt_iff_toNat_lt.mpr + rw [hdirectBoundary, htotalSize] + omega + have hdepthLtRestBoundary : + depth < depth + 1 + rest.size.toUInt64 := by + rw [← hboundary] + exact hdepthLtBoundary + have hdepthLtNormalized : + depth < depth + (1 + rest.size.toUInt64) := by + rw [← UInt64.add_assoc] + exact hdepthLtRestBoundary + have hdirectWindow : ((depth ≥ depth && + depth < depth + (#[arg] ++ rest).size.toUInt64) = true) := by + simp [hdepthLtNormalized] + have hnge1 : ¬depth ≥ depth + 1 := fun h => by + have h' := UInt64.le_iff_toNat_le.mp h + rw [hd1] at h' + omega + have hrestWindow : ¬((depth ≥ depth + 1 && + depth < depth + 1 + rest.size.toUInt64) = true) := by + simp [hnge1] + have hngeRestBoundary : ¬depth ≥ + depth + 1 + rest.size.toUInt64 := fun h => by + have h' := UInt64.le_iff_toNat_le.mp h + rw [hrestBoundary] at h' + omega + have heqBool : (depth == depth) = true := beq_iff_eq.mpr rfl + have hsubZero : (depth - depth).toNat = 0 := by simp + have hdirectEval : simulSubstSpec (mkVar depth name info) + (#[arg] ++ rest) depth = liftSpec arg depth 0 := by + rw [mkVar_shape, simulSubstSpec, if_pos hdirectWindow, hsubZero, + getElemBang_singleton_append_zero_bw] + have hrestEval : simulSubstSpec (mkVar depth name info) rest + (depth + 1) = mkVar depth name info := by + rw [mkVar_shape, simulSubstSpec, if_neg hrestWindow, + if_neg hngeRestBoundary] + have hsubstEval : substSpec (mkVar depth name info) arg depth = + liftSpec arg depth 0 := by + rw [mkVar_shape, substSpec, if_pos heqBool] + calc + simulSubstSpec (mkVar depth name info) (#[arg] ++ rest) depth = + liftSpec arg depth 0 := hdirectEval + _ = substSpec (mkVar depth name info) arg depth := hsubstEval.symm + _ = substSpec + (simulSubstSpec (mkVar depth name info) rest (depth + 1)) arg + depth := congrArg (fun e => substSpec e arg depth) + hrestEval.symm + · by_cases hwindow : idx < + depth + (#[arg] ++ rest).size.toUInt64 + · have hgeNat : depth.toNat ≤ idx.toNat := by + have hnlt := fun h : idx.toNat < depth.toNat => + hlt (UInt64.lt_iff_toNat_lt.mpr h) + exact Nat.le_of_not_gt hnlt + have hneNat : idx.toNat ≠ depth.toNat := fun h => + heq (UInt64.toNat_inj.mp h) + have hgtNat : depth.toNat < idx.toNat := by omega + have hge : idx ≥ depth := UInt64.le_iff_toNat_le.mpr hgeNat + have hge1 : idx ≥ depth + 1 := + UInt64.le_iff_toNat_le.mpr (by rw [hd1]; omega) + have hwindowRest : idx < depth + 1 + rest.size.toUInt64 := by + rw [← hboundary] + exact hwindow + have hwindowNormalized : + idx < depth + (1 + rest.size.toUInt64) := by + rw [← UInt64.add_assoc] + exact hwindowRest + have hdirectGuard : ((idx ≥ depth && + idx < depth + (#[arg] ++ rest).size.toUInt64) = true) := by + simp [hge, hwindowNormalized] + have hrestGuard : ((idx ≥ depth + 1 && + idx < depth + 1 + rest.size.toUInt64) = true) := by + simp [hge1, hwindowRest] + have hsubDepth : (idx - depth).toNat = + idx.toNat - depth.toNat := + UInt64.toNat_sub_of_le idx depth hge + have hsubDepth1 : (idx - (depth + 1)).toNat = + idx.toNat - (depth.toNat + 1) := by + rw [UInt64.toNat_sub_of_le idx (depth + 1) hge1, hd1] + have hindexSucc : (idx - depth).toNat = + (idx - (depth + 1)).toNat + 1 := by + rw [hsubDepth, hsubDepth1] + omega + have hwindowNat := UInt64.lt_iff_toNat_lt.mp hwindowRest + rw [hrestBoundary] at hwindowNat + have hindexRest : (idx - (depth + 1)).toNat < rest.size := by + rw [hsubDepth1] + omega + have hindexTotal : (idx - depth).toNat < + (#[arg] ++ rest).size := by + rw [hindexSucc, htotalSize] + omega + have hselected : + (#[arg] ++ rest)[(idx - depth).toNat]! = + rest[(idx - (depth + 1)).toNat]! := by + rw [hindexSucc] + exact getElemBang_singleton_append_succ_bw arg rest _ + hindexRest + have hselectedCon : + Constructed rest[(idx - (depth + 1)).toNat]! := by + rw [← hselected] + exact hconstructed _ hindexTotal + have hcancelBig : + rest[(idx - (depth + 1)).toNat]!.lbr.toNat + + rest[(idx - (depth + 1)).toNat]!.size + depth.toNat + 1 < + UInt64.size := by + have h := helem _ hindexTotal + rw [hselected, mkVar_shape, size] at h + omega + have hdirectEval : simulSubstSpec (mkVar idx name info) + (#[arg] ++ rest) depth = + liftSpec rest[(idx - (depth + 1)).toNat]! depth 0 := by + rw [mkVar_shape, simulSubstSpec, if_pos hdirectGuard, + hselected] + have hrestEval : simulSubstSpec (mkVar idx name info) rest + (depth + 1) = + liftSpec rest[(idx - (depth + 1)).toNat]! (depth + 1) 0 := by + rw [mkVar_shape, simulSubstSpec, if_pos hrestGuard] + have hcancel := substSpec_liftSpec_succ (arg := arg) + hselectedCon hcancelBig + calc + simulSubstSpec (mkVar idx name info) (#[arg] ++ rest) depth = + liftSpec rest[(idx - (depth + 1)).toNat]! depth 0 := + hdirectEval + _ = substSpec + (liftSpec rest[(idx - (depth + 1)).toNat]! (depth + 1) 0) + arg depth := hcancel.symm + _ = substSpec + (simulSubstSpec (mkVar idx name info) rest (depth + 1)) arg + depth := congrArg (fun e => substSpec e arg depth) + hrestEval.symm + · have hnotRestBoundary : + ¬idx < depth + 1 + rest.size.toUInt64 := by + intro h + apply hwindow + rw [hboundary] + exact h + have hnotNormalized : + ¬idx < depth + (1 + rest.size.toUInt64) := by + rw [← UInt64.add_assoc] + exact hnotRestBoundary + have hgeBoundary : + idx ≥ depth + (#[arg] ++ rest).size.toUInt64 := by + apply UInt64.le_iff_toNat_le.mpr + exact Nat.le_of_not_gt (fun h => + hwindow (UInt64.lt_iff_toNat_lt.mpr h)) + have hgeRestBoundary : + idx ≥ depth + 1 + rest.size.toUInt64 := by + rw [← hboundary] + exact hgeBoundary + have hgeRestNat := UInt64.le_iff_toNat_le.mp hgeRestBoundary + rw [hrestBoundary] at hgeRestNat + have hrestLeNat : rest.size ≤ idx.toNat := by omega + have htotalLeNat : (#[arg] ++ rest).size ≤ idx.toNat := by + rw [htotalSize] + omega + have hrestLe : rest.size.toUInt64 ≤ idx := + UInt64.le_iff_toNat_le.mpr (by rw [hrestSizeNat]; omega) + have htotalLe : (#[arg] ++ rest).size.toUInt64 ≤ idx := + UInt64.le_iff_toNat_le.mpr (by rw [htotalSizeNat]; omega) + have hsubRest : (idx - rest.size.toUInt64).toNat = + idx.toNat - rest.size := by + rw [UInt64.toNat_sub_of_le idx rest.size.toUInt64 hrestLe, + hrestSizeNat] + have hsubTotal : + (idx - (#[arg] ++ rest).size.toUInt64).toNat = + idx.toNat - (#[arg] ++ rest).size := by + rw [UInt64.toNat_sub_of_le idx + (#[arg] ++ rest).size.toUInt64 htotalLe, + htotalSizeNat] + have hqgtNat : depth.toNat < + (idx - rest.size.toUInt64).toNat := by + rw [hsubRest] + omega + have hqgt : idx - rest.size.toUInt64 > depth := + UInt64.lt_iff_toNat_lt.mpr hqgtNat + have hqne : ¬((idx - rest.size.toUInt64 == depth) = true) := by + intro h + have h' := congrArg UInt64.toNat (eq_of_beq h) + omega + have hqOne : (1 : UInt64) ≤ idx - rest.size.toUInt64 := + UInt64.le_iff_toNat_le.mpr (by + rw [show (1 : UInt64).toNat = 1 from rfl] + omega) + have hsubOne : (idx - rest.size.toUInt64 - 1).toNat = + (idx.toNat - rest.size) - 1 := by + rw [UInt64.toNat_sub_of_le (idx - rest.size.toUInt64) 1 hqOne, + show (1 : UInt64).toNat = 1 from rfl, hsubRest] + have hindexEq : idx - (#[arg] ++ rest).size.toUInt64 = + idx - rest.size.toUInt64 - 1 := by + apply UInt64.toNat_inj.mp + rw [hsubTotal, hsubOne, htotalSize] + omega + have hdirectGuard : ¬((idx ≥ depth && + idx < depth + (#[arg] ++ rest).size.toUInt64) = true) := by + simp [hnotNormalized] + have hrestGuard : ¬((idx ≥ depth + 1 && + idx < depth + 1 + rest.size.toUInt64) = true) := by + simp [hnotRestBoundary] + have hdirectEval : simulSubstSpec (mkVar idx name info) + (#[arg] ++ rest) depth = + mkVar (idx - (#[arg] ++ rest).size.toUInt64) + (anonName (m := .anon)) := by + rw [mkVar_shape, simulSubstSpec, if_neg hdirectGuard, + if_pos hgeBoundary] + have hrestEval : simulSubstSpec (mkVar idx name info) rest + (depth + 1) = + mkVar (idx - rest.size.toUInt64) + (anonName (m := .anon)) := by + rw [mkVar_shape, simulSubstSpec, if_neg hrestGuard, + if_pos hgeRestBoundary] + have hsubstEval : + substSpec + (mkVar (idx - rest.size.toUInt64) + (anonName (m := .anon))) arg depth = + mkVar (idx - rest.size.toUInt64 - 1) + (anonName (m := .anon)) := by + rw [mkVar_shape, substSpec, if_neg hqne, if_pos hqgt] + calc + simulSubstSpec (mkVar idx name info) (#[arg] ++ rest) depth = + mkVar (idx - (#[arg] ++ rest).size.toUInt64) + (anonName (m := .anon)) := hdirectEval + _ = mkVar (idx - rest.size.toUInt64 - 1) + (anonName (m := .anon)) := by rw [hindexEq] + _ = substSpec + (mkVar (idx - rest.size.toUInt64) + (anonName (m := .anon))) arg depth := hsubstEval.symm + _ = substSpec + (simulSubstSpec (mkVar idx name info) rest (depth + 1)) arg + depth := congrArg (fun e => substSpec e arg depth) + hrestEval.symm + | fvar => rfl + | sort => rfl + | const => rfl + | @app f a info hf ha ihf iha => + rw [mkApp_shape, size] at hbig + have hfElem : ∀ k, k < (#[arg] ++ rest).size → + (#[arg] ++ rest)[k]!.lbr.toNat + + (#[arg] ++ rest)[k]!.size + depth.toNat + f.size < + UInt64.size := by + intro k hk + have h := helem k hk + rw [mkApp_shape, size] at h + omega + have haElem : ∀ k, k < (#[arg] ++ rest).size → + (#[arg] ++ rest)[k]!.lbr.toNat + + (#[arg] ++ rest)[k]!.size + depth.toNat + a.size < + UInt64.size := by + intro k hk + have h := helem k hk + rw [mkApp_shape, size] at h + omega + calc + simulSubstSpec (mkApp f a info) (#[arg] ++ rest) depth = + mkApp (simulSubstSpec f (#[arg] ++ rest) depth) + (simulSubstSpec a (#[arg] ++ rest) depth) := + simulSubstSpec_mkApp_bw f a info _ _ + _ = mkApp + (substSpec (simulSubstSpec f rest (depth + 1)) arg depth) + (substSpec (simulSubstSpec a rest (depth + 1)) arg depth) := by + rw [ihf (depth := depth) (by omega) hfElem, + iha (depth := depth) (by omega) haElem] + _ = substSpec + (mkApp (simulSubstSpec f rest (depth + 1)) + (simulSubstSpec a rest (depth + 1))) arg depth := + (substSpec_mkApp_bw _ _ arg _ depth).symm + _ = substSpec + (simulSubstSpec (mkApp f a info) rest (depth + 1)) arg depth := + congrArg (fun e => substSpec e arg depth) + (simulSubstSpec_mkApp_bw f a info rest (depth + 1)).symm + | @lam name bi ty inner info hty hinner ihty ihinner => + rw [mkLam_shape, size] at hbig + have hd1 : (depth + 1).toNat = depth.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig) + have htyElem : ∀ k, k < (#[arg] ++ rest).size → + (#[arg] ++ rest)[k]!.lbr.toNat + + (#[arg] ++ rest)[k]!.size + depth.toNat + ty.size < + UInt64.size := by + intro k hk + have h := helem k hk + rw [mkLam_shape, size] at h + omega + have hinnerElem : ∀ k, k < (#[arg] ++ rest).size → + (#[arg] ++ rest)[k]!.lbr.toNat + + (#[arg] ++ rest)[k]!.size + (depth + 1).toNat + inner.size < + UInt64.size := by + intro k hk + have h := helem k hk + rw [mkLam_shape, size] at h + rw [hd1] + omega + calc + simulSubstSpec (mkLam name bi ty inner info) + (#[arg] ++ rest) depth = + mkLam name bi + (simulSubstSpec ty (#[arg] ++ rest) depth) + (simulSubstSpec inner (#[arg] ++ rest) (depth + 1)) := + simulSubstSpec_mkLam_bw name bi ty inner info _ _ + _ = mkLam name bi + (substSpec (simulSubstSpec ty rest (depth + 1)) arg depth) + (substSpec (simulSubstSpec inner rest (depth + 1 + 1)) arg + (depth + 1)) := by + rw [ihty (depth := depth) (by omega) htyElem, + ihinner (depth := depth + 1) (by rw [hd1]; omega) hinnerElem] + _ = substSpec + (mkLam name bi (simulSubstSpec ty rest (depth + 1)) + (simulSubstSpec inner rest (depth + 1 + 1))) arg depth := + (substSpec_mkLam_bw name bi _ _ arg _ depth).symm + _ = substSpec + (simulSubstSpec (mkLam name bi ty inner info) rest (depth + 1)) + arg depth := + congrArg (fun e => substSpec e arg depth) + (simulSubstSpec_mkLam_bw name bi ty inner info rest + (depth + 1)).symm + | @all name bi ty inner info hty hinner ihty ihinner => + rw [mkAll_shape, size] at hbig + have hd1 : (depth + 1).toNat = depth.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig) + have htyElem : ∀ k, k < (#[arg] ++ rest).size → + (#[arg] ++ rest)[k]!.lbr.toNat + + (#[arg] ++ rest)[k]!.size + depth.toNat + ty.size < + UInt64.size := by + intro k hk + have h := helem k hk + rw [mkAll_shape, size] at h + omega + have hinnerElem : ∀ k, k < (#[arg] ++ rest).size → + (#[arg] ++ rest)[k]!.lbr.toNat + + (#[arg] ++ rest)[k]!.size + (depth + 1).toNat + inner.size < + UInt64.size := by + intro k hk + have h := helem k hk + rw [mkAll_shape, size] at h + rw [hd1] + omega + calc + simulSubstSpec (mkAll name bi ty inner info) + (#[arg] ++ rest) depth = + mkAll name bi + (simulSubstSpec ty (#[arg] ++ rest) depth) + (simulSubstSpec inner (#[arg] ++ rest) (depth + 1)) := + simulSubstSpec_mkAll_bw name bi ty inner info _ _ + _ = mkAll name bi + (substSpec (simulSubstSpec ty rest (depth + 1)) arg depth) + (substSpec (simulSubstSpec inner rest (depth + 1 + 1)) arg + (depth + 1)) := by + rw [ihty (depth := depth) (by omega) htyElem, + ihinner (depth := depth + 1) (by rw [hd1]; omega) hinnerElem] + _ = substSpec + (mkAll name bi (simulSubstSpec ty rest (depth + 1)) + (simulSubstSpec inner rest (depth + 1 + 1))) arg depth := + (substSpec_mkAll_bw name bi _ _ arg _ depth).symm + _ = substSpec + (simulSubstSpec (mkAll name bi ty inner info) rest (depth + 1)) + arg depth := + congrArg (fun e => substSpec e arg depth) + (simulSubstSpec_mkAll_bw name bi ty inner info rest + (depth + 1)).symm + | @letE name ty val inner nondep info hty hval hinner ihty ihval ihinner => + rw [mkLet_shape, size] at hbig + have hd1 : (depth + 1).toNat = depth.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig) + have htyElem : ∀ k, k < (#[arg] ++ rest).size → + (#[arg] ++ rest)[k]!.lbr.toNat + + (#[arg] ++ rest)[k]!.size + depth.toNat + ty.size < + UInt64.size := by + intro k hk + have h := helem k hk + rw [mkLet_shape, size] at h + omega + have hvalElem : ∀ k, k < (#[arg] ++ rest).size → + (#[arg] ++ rest)[k]!.lbr.toNat + + (#[arg] ++ rest)[k]!.size + depth.toNat + val.size < + UInt64.size := by + intro k hk + have h := helem k hk + rw [mkLet_shape, size] at h + omega + have hinnerElem : ∀ k, k < (#[arg] ++ rest).size → + (#[arg] ++ rest)[k]!.lbr.toNat + + (#[arg] ++ rest)[k]!.size + (depth + 1).toNat + inner.size < + UInt64.size := by + intro k hk + have h := helem k hk + rw [mkLet_shape, size] at h + rw [hd1] + omega + calc + simulSubstSpec (mkLet name ty val inner nondep info) + (#[arg] ++ rest) depth = + mkLet name + (simulSubstSpec ty (#[arg] ++ rest) depth) + (simulSubstSpec val (#[arg] ++ rest) depth) + (simulSubstSpec inner (#[arg] ++ rest) (depth + 1)) nondep := + simulSubstSpec_mkLet_bw name ty val inner nondep info _ _ + _ = mkLet name + (substSpec (simulSubstSpec ty rest (depth + 1)) arg depth) + (substSpec (simulSubstSpec val rest (depth + 1)) arg depth) + (substSpec (simulSubstSpec inner rest (depth + 1 + 1)) arg + (depth + 1)) nondep := by + rw [ihty (depth := depth) (by omega) htyElem, + ihval (depth := depth) (by omega) hvalElem, + ihinner (depth := depth + 1) (by rw [hd1]; omega) hinnerElem] + _ = substSpec + (mkLet name (simulSubstSpec ty rest (depth + 1)) + (simulSubstSpec val rest (depth + 1)) + (simulSubstSpec inner rest (depth + 1 + 1)) nondep) arg + depth := + (substSpec_mkLet_bw name _ _ _ arg nondep _ depth).symm + _ = substSpec + (simulSubstSpec (mkLet name ty val inner nondep info) rest + (depth + 1)) arg depth := + congrArg (fun e => substSpec e arg depth) + (simulSubstSpec_mkLet_bw name ty val inner nondep info rest + (depth + 1)).symm + | @prj id field val info hval ihval => + rw [mkPrj_shape, size] at hbig + have hvalElem : ∀ k, k < (#[arg] ++ rest).size → + (#[arg] ++ rest)[k]!.lbr.toNat + + (#[arg] ++ rest)[k]!.size + depth.toNat + val.size < + UInt64.size := by + intro k hk + have h := helem k hk + rw [mkPrj_shape, size] at h + omega + calc + simulSubstSpec (mkPrj id field val info) (#[arg] ++ rest) depth = + mkPrj id field (simulSubstSpec val (#[arg] ++ rest) depth) := + simulSubstSpec_mkPrj_bw id field val info _ _ + _ = mkPrj id field + (substSpec (simulSubstSpec val rest (depth + 1)) arg depth) := by + rw [ihval (depth := depth) (by omega) hvalElem] + _ = substSpec (mkPrj id field + (simulSubstSpec val rest (depth + 1))) arg depth := + (substSpec_mkPrj_bw id field _ arg _ depth).symm + _ = substSpec + (simulSubstSpec (mkPrj id field val info) rest (depth + 1)) arg + depth := + congrArg (fun e => substSpec e arg depth) + (simulSubstSpec_mkPrj_bw id field val info rest + (depth + 1)).symm + | nat => rfl + | str => rfl + +end KExpr +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/SingletonSubstitution.lean b/Ix/Tc/Verify/Whnf/Beta/SingletonSubstitution.lean new file mode 100644 index 000000000..d621c0169 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/SingletonSubstitution.lean @@ -0,0 +1,121 @@ +import Ix.Tc.Verify.Whnf.Beta.PeelTrace + +/-! +# Singleton simultaneous substitution + +Production uses the simultaneous-substitution walker even when exactly one +lambda is consumed. The existing semantic bridge accepted equality with +single substitution as a premise. This slice proves that equality uniformly +from the same no-wrap bound required by the walker. +-/ + +namespace Ix.Tc +namespace KExpr + +/-- A one-element simultaneous substitution is exactly the ordinary single +substitution at the same depth. -/ +theorem simulSubstSpec_singleton + {body arg : KExpr .anon} {depth : UInt64} + (hbody : Constructed body) + (hbig : depth.toNat + body.size + 1 < UInt64.size) : + simulSubstSpec body #[arg] depth = substSpec body arg depth := by + induction hbody generalizing depth with + | @var idx name info hidx => + have hdepth : depth.toNat + 1 < UInt64.size := by + rw [mkVar_shape, size] at hbig + omega + have hsucc : (depth + 1).toNat = depth.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt hdepth + have hdepthLt : depth < depth + 1 := + UInt64.lt_iff_toNat_lt.mpr (by rw [hsucc]; omega) + rw [mkVar_shape, simulSubstSpec, substSpec] + have hsize : (#[arg].size.toUInt64 : UInt64) = 1 := rfl + rw [hsize] + change (if idx >= depth && idx < depth + 1 then + liftSpec #[arg][(idx - depth).toNat]! depth 0 + else if idx >= depth + 1 then + mkVar (idx - 1) (anonName (m := .anon)) + else .var idx name (mkVar idx name info).info) = + if idx == depth then liftSpec arg depth 0 + else if idx > depth then mkVar (idx - 1) name + else .var idx name (mkVar idx name info).info + by_cases heq : (idx == depth) = true + · have hidx : idx = depth := eq_of_beq heq + subst idx + have hwindow : ((depth >= depth && depth < depth + 1) = true) := by + simp [hdepthLt] + rw [if_pos hwindow, if_pos heq] + simp + · by_cases hgt : idx > depth + · have hgeSucc : depth + 1 <= idx := by + apply UInt64.le_iff_toNat_le.mpr + rw [hsucc] + have hgt' := UInt64.lt_iff_toNat_lt.mp hgt + omega + have hnltSucc : ¬(idx < depth + 1) := fun hlt => by + have hlt' := UInt64.lt_iff_toNat_lt.mp hlt + have hge' := UInt64.le_iff_toNat_le.mp hgeSucc + omega + have hwindow : + ¬((idx >= depth && idx < depth + 1) = true) := by + simp [hnltSucc] + rw [if_neg hwindow, if_pos hgeSucc, if_neg heq, if_pos hgt] + · have hne : idx.toNat ≠ depth.toNat := fun h => + heq (beq_iff_eq.mpr (UInt64.toNat_inj.mp h)) + have hngt : ¬(depth.toNat < idx.toNat) := fun h => + hgt (UInt64.lt_iff_toNat_lt.mpr h) + have hlt : idx.toNat < depth.toNat := by omega + have hnge : ¬(idx >= depth) := fun h => by + have h' := UInt64.le_iff_toNat_le.mp h + omega + have hgeSucc : ¬(idx >= depth + 1) := fun h => by + have h' := UInt64.le_iff_toNat_le.mp h + rw [hsucc] at h' + omega + have hwindow : + ¬((idx >= depth && idx < depth + 1) = true) := by + simp [hnge] + rw [if_neg hwindow, if_neg hgeSucc, if_neg heq, if_neg hgt] + | fvar => rfl + | sort => rfl + | const => rfl + | @app f arg info hf harg ihf iharg => + rw [mkApp_shape, size] at hbig + rw [mkApp_shape, simulSubstSpec, substSpec, + ihf (depth := depth) (Nat.lt_of_le_of_lt (by omega) hbig), + iharg (depth := depth) (Nat.lt_of_le_of_lt (by omega) hbig)] + | @lam name bi ty body info hty hbody ihty ihbody => + rw [mkLam_shape, size] at hbig + have hsucc : (depth + 1).toNat = depth.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig) + rw [mkLam_shape, simulSubstSpec, substSpec, + ihty (depth := depth) (Nat.lt_of_le_of_lt (by omega) hbig), + ihbody (depth := depth + 1) (by rw [hsucc]; omega)] + | @all name bi ty body info hty hbody ihty ihbody => + rw [mkAll_shape, size] at hbig + have hsucc : (depth + 1).toNat = depth.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig) + rw [mkAll_shape, simulSubstSpec, substSpec, + ihty (depth := depth) (Nat.lt_of_le_of_lt (by omega) hbig), + ihbody (depth := depth + 1) (by rw [hsucc]; omega)] + | @letE name ty val body nondep info hty hval hbody ihty ihval ihbody => + rw [mkLet_shape, size] at hbig + have hsucc : (depth + 1).toNat = depth.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hbig) + rw [mkLet_shape, simulSubstSpec, substSpec, + ihty (depth := depth) (Nat.lt_of_le_of_lt (by omega) hbig), + ihval (depth := depth) (Nat.lt_of_le_of_lt (by omega) hbig), + ihbody (depth := depth + 1) (by rw [hsucc]; omega)] + | @prj id field value info hvalue ihvalue => + rw [mkPrj_shape, size] at hbig + rw [mkPrj_shape, simulSubstSpec, substSpec, + ihvalue (depth := depth) (Nat.lt_of_le_of_lt (by omega) hbig)] + | nat => rfl + | str => rfl + +end KExpr +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Beta/Translation.lean b/Ix/Tc/Verify/Whnf/Beta/Translation.lean new file mode 100644 index 000000000..6964604f2 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Beta/Translation.lean @@ -0,0 +1,354 @@ +import Ix.Tc.Verify.Whnf.Beta.ArgumentAlignment + +/-! +# One-pass translation of simultaneous beta substitution + +This is the concrete half of `BetaPrefixMeaning`. It follows +`simulSubstSpec` structurally once, using the dependent `KInsts` lookup +theorems for variables. No sequential concrete intermediate is constructed, +so the proof consumes exactly production's original `WalkerRequest.Bounds`. +-/ + +namespace Ix.Tc + +open Lean4Lean + +private theorem toNat_toUInt64_cc (value : Nat) : + value.toUInt64.toNat = value % UInt64.size := by + unfold Nat.toUInt64 + rfl + +private theorem instBetaArgs_natLit_cc (value : Nat) + (arguments : List VExpr) (depth : Nat) : + VExpr.instBetaArgs (VExpr.natLit value) arguments depth = + VExpr.natLit value := by + induction value with + | zero => exact VExpr.instBetaArgs_const _ _ _ _ + | succ value ih => + rw [VExpr.natLit, VExpr.instBetaArgs_app, ih] + exact congrArg (fun fn => VExpr.app fn (VExpr.natLit value)) + (VExpr.instBetaArgs_const _ _ _ _) + +private theorem instBetaArgs_listCharLit_cc (value : List Char) + (arguments : List VExpr) (depth : Nat) : + VExpr.instBetaArgs (VExpr.listCharLit value) arguments depth = + VExpr.listCharLit value := by + induction value with + | nil => + simp [VExpr.listCharLit, VExpr.listCharNil, VExpr.char, + VExpr.instBetaArgs_app] + | cons char value ih => + simp [VExpr.listCharLit, VExpr.listCharCons, VExpr.charOfNat, + VExpr.char, VExpr.instBetaArgs_app, ih, + instBetaArgs_natLit_cc] + +private theorem instBetaArgs_trLiteral_cc (literal : Lean.Literal) + (arguments : List VExpr) (depth : Nat) : + VExpr.instBetaArgs (VExpr.trLiteral literal) arguments depth = + VExpr.trLiteral literal := by + cases literal with + | natVal value => exact instBetaArgs_natLit_cc value arguments depth + | strVal value => + rw [VExpr.trLiteral, VExpr.instBetaArgs_app, + instBetaArgs_listCharLit_cc] + exact congrArg (fun fn => VExpr.app fn (VExpr.listCharLit value.toList)) + (VExpr.instBetaArgs_const _ _ _ _) + +/-- Structural translation commutes with one production simultaneous- +substitution pass under its exact request bound. -/ +theorem TrKExprS.simulSubstBeta + {env : VEnv} {uvars : Nat} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} + (henv : env.Ordered) + (htp : ∀ {Γ Γ' : List VExpr} {n k : Nat} {s : Lean.Name} {i : Nat} + {e e' : VExpr}, Lean4Lean.Ctx.LiftN n k Γ Γ' → + trProj Γ s i e e' → trProj Γ' s i (e.liftN n k) (e'.liftN n k)) + (htpI : ∀ {Γ₀ : List VExpr} {e₀ A₀ : VExpr} {position : Nat} + {Γ₁ Γ : List VExpr} {s : Lean.Name} {i : Nat} {e e' : VExpr}, + Lean4Lean.Ctx.InstN Γ₀ e₀ A₀ position Γ₁ Γ → + trProj Γ₁ s i e e' → + trProj Γ s i (e.inst e₀ position) (e'.inst e₀ position)) + {base : KVLCtx} {substs : Array (KExpr .anon)} + {arguments : List VExpr} + (harguments : RecM.SimulArgs env uvars nameOf trProj base substs arguments) + {source : KVLCtx} {body : KExpr .anon} {bodyV : VExpr} + (H : TrKExprS env uvars nameOf trProj source body bodyV) : + ∀ {target : KVLCtx} {dk k : Nat} {depth : UInt64}, + KVLCtx.KInsts env uvars base arguments dk k source target → + KVLCtx.KBVLift base target dk 0 k 0 → + WalkerRequest.Bounds (.simulSubst body substs depth) → + depth.toNat = dk → + TrKExprS env uvars nameOf trProj target + (KExpr.simulSubstSpec body substs depth) + (VExpr.instBetaArgs bodyV arguments k) := by + induction H with + | @var source index name info value type hfind => + intro target dk k depth hinsts hlift hbounds hdepth + obtain ⟨hbody, hsubsts, hsizes, hwalk, helem⟩ := hbounds + cases hbody with + | @var _ _ _ hindex => + rw [KExpr.size] at hwalk + have hsizeNat : substs.size.toUInt64.toNat = substs.size := by + rw [toNat_toUInt64_cc] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hwalk) + have hboundary : (depth + substs.size.toUInt64).toNat = + depth.toNat + substs.size := by + rw [UInt64.toNat_add, hsizeNat] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hwalk) + rw [KExpr.simulSubstSpec] + split + · next hwindow => + obtain ⟨hgeB, hltB⟩ := Bool.and_eq_true_iff.mp hwindow + have hge : depth.toNat ≤ index.toNat := + UInt64.le_iff_toNat_le.mp (of_decide_eq_true hgeB) + have hlt : index.toNat < depth.toNat + substs.size := by + have hlt' := UInt64.lt_iff_toNat_lt.mp + (of_decide_eq_true hltB) + rwa [hboundary] at hlt' + have hoffsetNat : (index - depth).toNat = + index.toNat - depth.toNat := + UInt64.toNat_sub_of_le index depth + (UInt64.le_iff_toNat_le.mpr hge) + have hoffset : (index - depth).toNat < substs.size := by omega + have hvalueBound : (index - depth).toNat < arguments.length := by + rw [← harguments.size_eq] + exact hoffset + have hlookupIndex : index.toNat = + dk + (index - depth).toNat := by + rw [← hdepth, hoffsetNat] + omega + obtain ⟨argumentV, hget, hmeaning⟩ := + hinsts.find?_window hvalueBound (hlookupIndex ▸ hfind) + have hvalueEq : + arguments.reverse[(index - depth).toNat]! = argumentV := by + have hreverseBound : + (index - depth).toNat < arguments.reverse.length := by + simpa using hvalueBound + rw [getElem!_pos arguments.reverse (index - depth).toNat + hreverseBound] + rw [getElem?_pos arguments.reverse (index - depth).toNat + hreverseBound] at hget + exact Option.some.inj hget + have hargumentTr := harguments.translate _ hoffset + rw [hvalueEq] at hargumentTr + have hliftTr := TrKExprS.weakBV_lbr henv htp + (hsubsts _ hoffset) hargumentTr hlift hdepth rfl + (by rw [show (0 : UInt64).toNat = 0 from rfl]; + simpa using hsizes _ hoffset) + (by have := helem _ hoffset; omega) + rw [hmeaning] + exact hliftTr + · next hnotWindow => + split + · next haboveU => + have habove : dk + arguments.length ≤ index.toNat := by + have h := UInt64.le_iff_toNat_le.mp haboveU + rw [hboundary, hdepth, harguments.size_eq] at h + exact h + have htargetFind := hinsts.find?_above habove hfind + have hsubNat : (index - substs.size.toUInt64).toNat = + index.toNat - arguments.length := by + rw [UInt64.toNat_sub_of_le index substs.size.toUInt64 + (UInt64.le_iff_toNat_le.mpr (by + rw [hsizeNat, harguments.size_eq] + omega)), hsizeNat, harguments.size_eq] + rw [KExpr.mkVar_shape] + exact .var (hsubNat ▸ htargetFind) + · next hnotAbove => + have hbelow : index.toNat < dk := by + by_contra hnotBelow + have hge : depth ≤ index := + UInt64.le_iff_toNat_le.mpr (by + rw [hdepth] + omega) + have hlt : index < depth + substs.size.toUInt64 := by + exact UInt64.lt_iff_toNat_lt.mpr (by + rw [hboundary, hdepth] + have hnle : ¬depth.toNat + substs.size ≤ index.toNat := + fun hle => hnotAbove + (UInt64.le_iff_toNat_le.mpr (by + rw [hboundary] + exact hle)) + omega) + exact hnotWindow (Bool.and_eq_true_iff.mpr + ⟨decide_eq_true hge, decide_eq_true hlt⟩) + exact .var (hinsts.find?_below hbelow hfind) + | @fvar source fv name info value type hfind => + intro target dk k depth hinsts hlift hbounds hdepth + exact .fvar (hinsts.find?_fvar hfind) + | @sort source level info hlevel => + intro target dk k depth hinsts hlift hbounds hdepth + simpa only [KExpr.simulSubstSpec, VExpr.instBetaArgs_sort] using + (TrKExprS.sort (env := env) (nameOf := nameOf) (trProj := trProj) + (Δ := target) (md := info) hlevel) + | @const source id levels info constName ci hname hconst hlevels hlength => + intro target dk k depth hinsts hlift hbounds hdepth + simpa only [KExpr.simulSubstSpec, VExpr.instBetaArgs_const] using + (TrKExprS.const (env := env) (nameOf := nameOf) (trProj := trProj) + (Δ := target) (md := info) hname hconst hlevels hlength) + | @app source fn arg info fnV argV A B hfun harg hfnTr hargTr ihfn iharg => + intro target dk k depth hinsts hlift hbounds hdepth + obtain ⟨hbody, hsubsts, hsizes, hwalk, helem⟩ := hbounds + cases hbody with + | app hfn hargCon => + rw [KExpr.size] at hwalk + have hfnBounds : WalkerRequest.Bounds (.simulSubst fn substs depth) := + ⟨hfn, hsubsts, hsizes, by omega, fun index hindex => by + have h := helem index hindex + rw [KExpr.size] at h + omega⟩ + have hargBounds : WalkerRequest.Bounds (.simulSubst arg substs depth) := + ⟨hargCon, hsubsts, hsizes, by omega, fun index hindex => by + have h := helem index hindex + rw [KExpr.size] at h + omega⟩ + rw [KExpr.simulSubstSpec, KExpr.mkApp_shape, + VExpr.instBetaArgs_app] + have hfun' := hinsts.hasType henv hfun + rw [VExpr.instBetaArgs_forallE] at hfun' + exact .app hfun' (hinsts.hasType henv harg) + (ihfn hinsts hlift hfnBounds hdepth) + (iharg hinsts hlift hargBounds hdepth) + | @lam source name bi ty body info tyV bodyV hty htyTr hbodyTr + ihty ihbody => + intro target dk k depth hinsts hlift hbounds hdepth + obtain ⟨hcon, hsubsts, hsizes, hwalk, helem⟩ := hbounds + cases hcon with + | lam htyCon hbodyCon => + rw [KExpr.size] at hwalk + have htyBounds : WalkerRequest.Bounds (.simulSubst ty substs depth) := + ⟨htyCon, hsubsts, hsizes, by omega, fun index hindex => by + have h := helem index hindex + rw [KExpr.size] at h + omega⟩ + have hdepth1 : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hwalk) + have hbodyBounds : + WalkerRequest.Bounds (.simulSubst body substs (depth + 1)) := + ⟨hbodyCon, hsubsts, hsizes, by rw [hdepth1]; omega, + fun index hindex => by + have h := helem index hindex + rw [KExpr.size] at h + rw [hdepth1] + omega⟩ + let tyV' := VExpr.instBetaArgs tyV arguments k + have hinstsBody := hinsts.succ (.vlam tyV) + have hliftBody := KVLCtx.KBVLift.skip + ((VLocalDecl.vlam tyV).instBetaArgs arguments k) hlift + rw [VLocalDecl.instBetaArgs_depth] at hliftBody + rw [KExpr.simulSubstSpec, KExpr.mkLam_shape, + VExpr.instBetaArgs_lam] + exact .lam (hinsts.isType henv hty) + (ihty hinsts hlift htyBounds hdepth) + (by + simpa [tyV', VLocalDecl.instBetaArgs, VLocalDecl.depth] using + ihbody hinstsBody hliftBody hbodyBounds hdepth1) + | @all source name bi ty body info tyV bodyV hty hbodyTy htyTr hbodyTr + ihty ihbody => + intro target dk k depth hinsts hlift hbounds hdepth + obtain ⟨hcon, hsubsts, hsizes, hwalk, helem⟩ := hbounds + cases hcon with + | all htyCon hbodyCon => + rw [KExpr.size] at hwalk + have htyBounds : WalkerRequest.Bounds (.simulSubst ty substs depth) := + ⟨htyCon, hsubsts, hsizes, by omega, fun index hindex => by + have h := helem index hindex + rw [KExpr.size] at h + omega⟩ + have hdepth1 : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hwalk) + have hbodyBounds : + WalkerRequest.Bounds (.simulSubst body substs (depth + 1)) := + ⟨hbodyCon, hsubsts, hsizes, by rw [hdepth1]; omega, + fun index hindex => by + have h := helem index hindex + rw [KExpr.size] at h + rw [hdepth1] + omega⟩ + let tyV' := VExpr.instBetaArgs tyV arguments k + have hinstsBody := hinsts.succ (.vlam tyV) + have hliftBody := KVLCtx.KBVLift.skip + ((VLocalDecl.vlam tyV).instBetaArgs arguments k) hlift + rw [VLocalDecl.instBetaArgs_depth] at hliftBody + rw [KExpr.simulSubstSpec, KExpr.mkAll_shape, + VExpr.instBetaArgs_forallE] + exact .all (hinsts.isType henv hty) + (by + simpa [tyV', VLocalDecl.instBetaArgs, VLocalDecl.depth] using + hinstsBody.isType henv hbodyTy) + (ihty hinsts hlift htyBounds hdepth) + (by + simpa [tyV', VLocalDecl.instBetaArgs, VLocalDecl.depth] using + ihbody hinstsBody hliftBody hbodyBounds hdepth1) + | @letE source name ty val body nondep info tyV valV bodyV hvalTy htyTr + hvalTr hbodyTr ihty ihval ihbody => + intro target dk k depth hinsts hlift hbounds hdepth + obtain ⟨hcon, hsubsts, hsizes, hwalk, helem⟩ := hbounds + cases hcon with + | letE htyCon hvalCon hbodyCon => + rw [KExpr.size] at hwalk + have htyBounds : WalkerRequest.Bounds (.simulSubst ty substs depth) := + ⟨htyCon, hsubsts, hsizes, by omega, fun index hindex => by + have h := helem index hindex + rw [KExpr.size] at h + omega⟩ + have hvalBounds : WalkerRequest.Bounds (.simulSubst val substs depth) := + ⟨hvalCon, hsubsts, hsizes, by omega, fun index hindex => by + have h := helem index hindex + rw [KExpr.size] at h + omega⟩ + have hdepth1 : (depth + 1).toNat = dk + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl, + hdepth] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hwalk) + have hbodyBounds : + WalkerRequest.Bounds (.simulSubst body substs (depth + 1)) := + ⟨hbodyCon, hsubsts, hsizes, by rw [hdepth1]; omega, + fun index hindex => by + have h := helem index hindex + rw [KExpr.size] at h + rw [hdepth1] + omega⟩ + let tyV' := VExpr.instBetaArgs tyV arguments k + let valV' := VExpr.instBetaArgs valV arguments k + have hinstsBody := hinsts.succ (.vlet tyV valV) + have hliftBody := KVLCtx.KBVLift.skip + ((VLocalDecl.vlet tyV valV).instBetaArgs arguments k) hlift + rw [VLocalDecl.instBetaArgs_depth] at hliftBody + rw [KExpr.simulSubstSpec, KExpr.mkLet_shape] + exact .letE (hinsts.hasType henv hvalTy) + (ihty hinsts hlift htyBounds hdepth) + (ihval hinsts hlift hvalBounds hdepth) + (by + simpa [tyV', valV', VLocalDecl.instBetaArgs, + VLocalDecl.depth] using + ihbody hinstsBody hliftBody hbodyBounds hdepth1) + | @prj source id field val info structName valueV resultV hname hvalTr + hproj ihval => + intro target dk k depth hinsts hlift hbounds hdepth + obtain ⟨hcon, hsubsts, hsizes, hwalk, helem⟩ := hbounds + cases hcon with + | prj hvalCon => + rw [KExpr.size] at hwalk + have hvalBounds : WalkerRequest.Bounds (.simulSubst val substs depth) := + ⟨hvalCon, hsubsts, hsizes, by omega, fun index hindex => by + have h := helem index hindex + rw [KExpr.size] at h + omega⟩ + rw [KExpr.simulSubstSpec, KExpr.mkPrj_shape] + exact .prj hname (ihval hinsts hlift hvalBounds hdepth) + (hinsts.projection htpI hproj) + | @nat source value blob info hlit => + intro target dk k depth hinsts hlift hbounds hdepth + rw [instBetaArgs_natLit_cc] + exact .nat hlit + | @str source value blob info hlit => + intro target dk k depth hinsts hlift hbounds hdepth + rw [instBetaArgs_trLiteral_cc] + exact .str hlit + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Closure.lean b/Ix/Tc/Verify/Whnf/Closure.lean new file mode 100644 index 000000000..b9d9b284c --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Closure.lean @@ -0,0 +1,143 @@ +import Ix.Tc.Verify.Whnf.Delta.OptionalReduction +import Ix.Tc.Verify.Knot + +/-! +# Four-field fixed-universe WHNF closure + +The structural, no-delta, full-WHNF, and trusted-delta reducers now expose +fixed-universe contracts. This module assembles those contracts into the +four K1 fields of one unfolded production method-table layer. + +The context retains the exact construction boundary: + +* no-delta contexts are supplied for every caller local context; +* the compact symbolic-Nat guard carries its exact optional-reduction + contract; +* one trusted delta context is shared by those callers; +* arbitrary-flag structural contexts are supplied for the fourth public + method field. + +In particular, the full reducer is constructed with +`FullWhnfStepContext.ofTrustedDelta`; callers cannot replace delta unfolding +with a free successful-reduction oracle. The `tryNatOffsetStuck` stage added +after the original K1 driver proof remains an explicit closure obligation +until its callbacks and intern operations are decomposed into finite +run-scoped inputs. + +## K1 acceptance boundary + +`K1ClosureContext.closedAt` below is the K1 closure result: it supplies exactly +the four fixed-universe WHNF fields of `Methods.next`. It deliberately does +not tie the complete six-method production knot. That later step also needs +K2's `infer` and `isDefEq` fields before `Methods.ClosedAt.of_parts`, +`Methods.methodsN_wfAt`, and the public runner can be used. + +The universally quantified caller context is not assumed well formed merely +to construct `K1ClosureContext`. Each reducer instead recovers that fact from +the `CtxRecon` component of the runtime invariant at its point of use. The +concrete successful, absent, stuck, and partial-error executions in +`NatFixture` separately keep the branch contracts inhabited; they are not a +substitute for K2's two missing recursive fields. +-/ + +namespace Ix.Tc + +/-- The final K1 cache composition at the universe count encoded by `keys`: +WHNF expression entries outside, universe-sensitive delta bodies underneath, +and the caller's remaining cache families as the base. -/ +def k1CacheSemantics (keys : WhnfContextKeys) (trProj : RawProjRel) + (fallback : CacheSemantics) : CacheSemantics := + whnfCacheSemantics keys trProj + (unfoldCacheSemantics keys.uvars trProj fallback) + +namespace RecM + +/-- Complete input family needed to prove the four K1 method-table fields at +one universe count. -/ +structure K1ClosureContext + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) (keys : WhnfContextKeys) + (fallback : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Type where + noDelta : ∀ Delta : KVLCtx, + NoDeltaDriverContext initial program requests keys + (unfoldCacheSemantics keys.uvars trProj fallback) + trProj world support Delta .FULL + /-- Exact closure obligation for the compact symbolic-Nat stage introduced + after the original K1 driver proof. -/ + natOffsetStuck : OptionalReduction.WFAt .noAccel + (k1CacheSemantics keys trProj fallback) trProj world support + keys.uvars tryNatOffsetStuck + delta : + TrustedDeltaContext initial program requests keys fallback trProj world + support + structuralFlags : ∀ (Delta : KVLCtx) (flags : WhnfFlags), + StructuralCoreContext initial program requests keys + (unfoldCacheSemantics keys.uvars trProj fallback) + trProj world support Delta flags + +namespace K1ClosureContext + +/-- Assemble K1's four fixed-universe fields for one smaller, already +well-formed method table. -/ +theorem layer + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {keys : WhnfContextKeys} + {fallback : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : K1ClosureContext initial program requests keys fallback trProj + world support) + (methods : Methods .anon) + (hmethods : Methods.WFAt .noAccel + (k1CacheSemantics keys trProj fallback) + trProj world support keys.uvars methods) : + Methods.WhnfLayerWFAt .noAccel + (k1CacheSemantics keys trProj fallback) + trProj world support keys.uvars methods := by + refine ⟨?_, ?_, ?_, ?_⟩ + · intro Delta s source sourceV hsourceSupport hsource + let full := + FullWhnfStepContext.ofTrustedDelta + (context.noDelta Delta) context.natOffsetStuck context.delta + exact + (FullWhnfStepContext.publicWhnf_wf full hsourceSupport hsource) + methods hmethods + · intro Delta s source sourceV hsourceSupport hsource + let full := + FullWhnfStepContext.ofTrustedDelta + (context.noDelta Delta) context.natOffsetStuck context.delta + exact + (FullWhnfStepContext.publicCore_wf full hsourceSupport hsource) + methods hmethods + · intro Delta s source sourceV mode hsourceSupport hsource + let full := + FullWhnfStepContext.ofTrustedDelta + (context.noDelta Delta) context.natOffsetStuck context.delta + exact + (FullWhnfStepContext.publicMode_wf full mode hsourceSupport hsource) + methods hmethods + · intro Delta s source sourceV flags hsourceSupport hsource + exact + (StructuralCoreContext.publicFlags_wf + (context.structuralFlags Delta flags) hsourceSupport hsource) + methods hmethods + +/-- K1's headline fixed-universe closure result: any semantically valid +smaller method table proves all four WHNF fields of the next production +layer. -/ +theorem closedAt + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {keys : WhnfContextKeys} + {fallback : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : K1ClosureContext initial program requests keys fallback trProj + world support) : + Methods.WhnfClosedAt .noAccel + (k1CacheSemantics keys trProj fallback) + trProj world support keys.uvars := by + intro methods hmethods + exact context.layer methods hmethods + +end K1ClosureContext +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Delta/CacheExecution.lean b/Ix/Tc/Verify/Whnf/Delta/CacheExecution.lean new file mode 100644 index 000000000..ddb379603 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Delta/CacheExecution.lean @@ -0,0 +1,143 @@ +import Ix.Tc.Verify.Whnf.Delta.StableCache + +/-! +# Certified production unfold-cache execution + +The public K1 cache contract is a WHNF overlay whose fallback owns delta +entries. StableCache constructs the exact fallback provenance for a trusted body; +this module transports that provenance through the overlay and verifies both +physical paths of production's `unfoldConstValue`: + +* a warm hit obtains its meaning from the existing certified cache entry; +* a cold hit runs the request-covered universe walker, constructs stable + provenance from the exact declaration certificate, and only then writes the + cache. + +No arbitrary head/result write authority is used. +-/ + +namespace Ix.Tc + +namespace CacheProvenance + +/-- Install a certified delta entry underneath the public WHNF cache overlay. +For `.unfold`, `WhnfCacheValid` delegates definitionally to its fallback. -/ +theorem underWhnf + {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {key : Address} {value : KExpr .anon} + (h : CacheProvenance + (unfoldCacheSemantics keys.uvars trProj fallback) + authority support (.unfold key value)) : + CacheProvenance + (whnfCacheSemantics keys trProj + (unfoldCacheSemantics keys.uvars trProj fallback)) + authority support (.unfold key value) := + ⟨h.supported, h.references, h.valid⟩ + +/-- Project the delegated delta meaning from a public WHNF cache entry. -/ +theorem fromWhnfUnfold + {keys : WhnfContextKeys} {trProj : RawProjRel} + {fallback : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {key : Address} {value : KExpr .anon} + (h : CacheProvenance + (whnfCacheSemantics keys trProj + (unfoldCacheSemantics keys.uvars trProj fallback)) + authority support (.unfold key value)) : + CacheProvenance + (unfoldCacheSemantics keys.uvars trProj fallback) + authority support (.unfold key value) := + ⟨h.supported, h.references, h.valid⟩ + +end CacheProvenance + +namespace RecM + +/-- Exact state, support, and Theory contract for production's +`unfoldConstValue` on one certified reducible constant. + +The source translation supplies universe well-formedness and arity. The run +census supplies reachability of the concrete instantiation request, while +the declaration-specific resource package supplies the level bounds omitted +by the generic request-bound relation. -/ +theorem unfoldConstValue_trusted_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} + (theory : StableWhnfTheory trProj world keys.uvars) + (hreferences : TrustedReferences world support) + {id : KId .anon} {concrete : KConst .anon} + {ci : Lean4Lean.VDefVal} {kind : Ix.DefKind} + {lvls : UInt64} {body : KExpr .anon} + (trusted : TrustedDeltaBody trProj world id concrete ci kind lvls body) + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + (resources : DeltaInstantiationResources us body) + (hheadSupport : support (.const id us info)) + (hrequest : WalkerRequest.instUniv body us ∈ requests) + {Delta : KVLCtx} {headV : Lean4Lean.VExpr} + (hhead : TrKExprS world.venv keys.uvars world.nameOf trProj Delta + (.const id us info) headV) + {s : TcState .anon} : + RecM.WF .noAccel + (whnfCacheSemantics keys trProj + (unfoldCacheSemantics keys.uvars trProj fallback)) + trProj world support keys.uvars Delta s + (unfoldConstValue (.const id us info) body us) + (fun result _ => + support result ∧ + WhnfMeaning trProj world keys.uvars Delta + (.const id us info) result) := by + obtain ⟨_, hus, harity⟩ := trusted.sourceInputs hhead + unfold unfoldConstValue + apply RecM.WF.bind + (Q₁ := fun observed after => observed = after) + (RecM.WF.get fun _ => rfl) + intro observed after hread + subst observed + cases hcache : after.env.unfoldCache[ + (.const id us info : KExpr .anon).addr]? with + | some cached => + simp only + apply RecM.WF.pure + intro hI + have hhit := hI.1.caches.hit (.unfold hcache) + have hunfold := hhit.fromWhnfUnfold + exact ⟨hhit.supported.2, + hunfold.unfoldMeaning hheadSupport rfl hI.2.1.wf⟩ + | none => + simp only + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.instantiateUnivParams_whnf_wf hrun.collisionFree + (hrun.coverage.instUniv hrequest) + intro result afterInst hresult + obtain ⟨hspec, hresultSupport⟩ := hresult + apply RecM.WF.bind + (Q₁ := fun _ next => + next = + {afterInst with env := {afterInst.env with + unfoldCache := + afterInst.env.unfoldCache.insert + (.const id us info : KExpr .anon).addr result}}) + · apply RecM.WF.modify + · intro hI + have hnew := + trusted.unfoldCacheProvenance (fallback := fallback) + theory hrun.collisionFree + hreferences hheadSupport hresultSupport hus harity hspec + resources + exact unfoldCacheInsert_whnfStateInv hI hnew.underWhnf + · intro _ + rfl + · intro _ next hnext + subst next + apply RecM.WF.pure + intro hI + exact ⟨hresultSupport, + trusted.futureMeaning theory hus harity hspec resources + VerifyWorld.LE.rfl hI.2.1.wf⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Delta/CacheSemantics.lean b/Ix/Tc/Verify/Whnf/Delta/CacheSemantics.lean new file mode 100644 index 000000000..52869e80e --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Delta/CacheSemantics.lean @@ -0,0 +1,123 @@ +import Ix.Tc.Verify.Whnf.Delta.Integration + +/-! +# Semantic unfold-cache entries + +`UnfoldingState` proves the operational state and support behavior of the production +unfold cache, but deliberately leaves cache provenance abstract. This module +gives the `.unfold` family its actual fixed-universe meaning. + +Unlike the WHNF expression caches, the unfold cache has no local-context key: +it stores the universe-instantiated body of a closed constant head. Its +semantic contract must therefore hold in every mixed local context. The +universe count is fixed, matching the `Methods.WFAt` contract used by the +recursive reducer. +-/ + +namespace Ix.Tc + +/-- Exact fixed-universe validity for one unfold-cache entry. Every +finite-support source sharing the stored address must reduce to the cached +body in every mixed local context. All other cache families are delegated to +the caller-supplied fallback. -/ +def UnfoldCacheValid (uvars : Nat) (trProj : RawProjRel) + (fallback : CacheSemantics) (authority : CacheAuthority) + (support : RunSupport) : CacheEntry → Prop + | .unfold key value => + ∀ later, authority ≤ later → + ∀ source, support source → source.addr = key → + ∀ Delta, KVLCtx.WF later.world.venv uvars Delta → + WhnfMeaning trProj later.world uvars Delta source value + | entry => fallback.Valid authority support entry + +namespace UnfoldCacheValid + +/-- A valid unfold entry remains valid as the trusted Theory world grows. +The concrete support and fixed universe count do not change. -/ +theorem mono {uvars : Nat} {trProj : RawProjRel} + {fallback : CacheSemantics} {before after : CacheAuthority} + {support : RunSupport} {entry : CacheEntry} (hle : before ≤ after) + (h : UnfoldCacheValid uvars trProj fallback before support entry) : + UnfoldCacheValid uvars trProj fallback after support entry := by + cases entry with + | unfold key value => + intro later hlater source hsource haddr Delta hDelta + exact h later (CacheAuthority.LE.trans hle hlater) + source hsource haddr Delta hDelta + | expr | defEq | defEqFailure | natSuccStuck | isProp | isRec | + recursor | recMajors | blockPeer | blockResult => + exact fallback.mono hle h + +/-- Project the concrete reduction meaning carried by one unfold entry. -/ +theorem unfold {uvars : Nat} {trProj : RawProjRel} + {fallback : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {key : Address} {value source : KExpr .anon} + (h : UnfoldCacheValid uvars trProj fallback authority support + (.unfold key value)) + (hsource : support source) (haddr : source.addr = key) + {Delta : KVLCtx} (hDelta : KVLCtx.WF authority.world.venv uvars Delta) : + WhnfMeaning trProj authority.world uvars Delta source value := + h authority CacheAuthority.LE.rfl source hsource haddr Delta hDelta + +end UnfoldCacheValid + +/-- Overlay semantic unfold entries on an arbitrary fallback cache contract. -/ +def unfoldCacheSemantics (uvars : Nat) (trProj : RawProjRel) + (fallback : CacheSemantics) : CacheSemantics where + Valid := UnfoldCacheValid uvars trProj fallback + mono := UnfoldCacheValid.mono + Equiv := fallback.Equiv + equivEquivalence := fallback.equivEquivalence + equivMono := fallback.equivMono + blockError := by + intro authority support block err + exact fallback.blockError authority support block err + +namespace CacheProvenance + +/-- A provenance-certified unfold hit exposes its fixed-universe Theory +meaning in the caller's current mixed local context. -/ +theorem unfoldMeaning {uvars : Nat} {trProj : RawProjRel} + {fallback : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {key : Address} {value source : KExpr .anon} + (h : CacheProvenance (unfoldCacheSemantics uvars trProj fallback) + authority support (.unfold key value)) + (hsource : support source) (haddr : source.addr = key) + {Delta : KVLCtx} (hDelta : KVLCtx.WF authority.world.venv uvars Delta) : + WhnfMeaning trProj authority.world uvars Delta source value := + UnfoldCacheValid.unfold (fallback := fallback) h.valid hsource haddr hDelta + +/-- Build complete stable-world provenance for one semantic unfold result. + +Address collision freedom is used only to recover the exact anonymous source +from the address-only cache key. Direct references from both possible source +witnesses and the cached value are justified independently by the run-scoped +trusted-reference boundary. -/ +theorem unfoldOfMeaning {uvars : Nat} {trProj : RawProjRel} + {fallback : CacheSemantics} {world : VerifyWorld} + {support : RunSupport} {head value : KExpr .anon} + (hcollision : support.CollisionFree) + (hreferences : RecM.TrustedReferences world support) + (hhead : support head) (hvalue : support value) + (hmeaning : ∀ {later : VerifyWorld}, world ≤ later → + ∀ {Delta}, KVLCtx.WF later.venv uvars Delta → + WhnfMeaning trProj later uvars Delta head value) : + CacheProvenance (unfoldCacheSemantics uvars trProj fallback) + (CacheAuthority.stable world) support (.unfold head.addr value) := by + refine ⟨⟨⟨head, hhead, rfl⟩, hvalue⟩, ?_, ?_⟩ + · intro id href + apply Or.inl + rcases href with href | href + · obtain ⟨source, hsource, _, hsourceReferences⟩ := href + exact hreferences hsource hsourceReferences + · exact hreferences hvalue href + · intro later hlater source hsource haddr Delta hDelta + have hsourceEq : source = head := by + have herase := hcollision.expr hsource hhead haddr + simpa only [KExpr.eraseMeta_anon] using herase + subst source + exact hmeaning hlater.world hDelta + +end CacheProvenance + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Delta/ClosedTranslation.lean b/Ix/Tc/Verify/Whnf/Delta/ClosedTranslation.lean new file mode 100644 index 000000000..92db9d639 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Delta/ClosedTranslation.lean @@ -0,0 +1,218 @@ +import Ix.Tc.Verify.Whnf.Delta.CacheSemantics + +/-! +# Closed-expression translation under caller contexts + +Definition bodies are admitted in the empty mixed context, while delta +unfolding runs in the caller's current context. Appending an outer mixed +context does not change any variable already resolved in the inner prefix. +This module proves that fact for `KVLCtx`, then transports both structural and +defeq-quotiented expression translations across the append. + +The theorem is intentionally stronger than the empty-prefix specialization +needed by delta: it preserves any well-formed inner prefix. That makes binder +cases compositional and exposes exactly where projection weakening and +closedness are used. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr VEnv) + +namespace KVLCtx + +/-- Append declarations outside every entry of an existing mixed context. -/ +def appendOuter : KVLCtx → KVLCtx → KVLCtx + | [], outer => outer + | entry :: inner, outer => entry :: appendOuter inner outer + +/-- Erasing `vlet` entries and retaining `vlam` types commutes with appending +an outer mixed context. -/ +@[simp] theorem toCtx_appendOuter : ∀ (inner outer : KVLCtx), + (appendOuter inner outer).toCtx = inner.toCtx ++ outer.toCtx + | [], _ => rfl + | (ofv, .vlam type) :: inner, outer => by + simp only [appendOuter, toCtx, List.cons_append, toCtx_appendOuter] + | (ofv, .vlet type value) :: inner, outer => by + simp only [appendOuter, toCtx, toCtx_appendOuter] + +/-- A successful lookup in an inner prefix is unchanged when an outer mixed +context is appended. -/ +theorem find?_append_of_some : ∀ {inner : KVLCtx} + {v : Nat ⊕ FVarId} {e A : VExpr} (outer : KVLCtx), + inner.find? v = some (e, A) → + (appendOuter inner outer).find? v = some (e, A) + | [], _, _, _, _, h => by + simp only [find?] at h + cases h + | (ofv, d) :: inner, v, e, A, outer, h => by + simp only [appendOuter, find?] at h ⊢ + cases hnext : next ofv v with + | none => + simpa only [hnext] using h + | some v' => + simp only [hnext, Option.bind_eq_bind] at h ⊢ + cases hfind : find? inner v' with + | none => + simp only [hfind, Option.bind_none] at h + cases h + | some value => + rcases value with ⟨value, type⟩ + have hfind' := + find?_append_of_some (inner := inner) outer hfind + simpa only [hfind, hfind', Option.bind_some] using h + +end KVLCtx + +namespace TrKExprS + +/-- Structural translation is unchanged by appending an arbitrary outer mixed +context to a well-formed inner prefix. Concrete de Bruijn indices do not +shift: the new context is outside every variable already resolved by the +prefix. -/ +theorem weakRight {env : VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + (henv : env.Ordered) + (hlit : ∀ l, env.ContainsLits l → + VExpr.WF env uvars [] (VExpr.trLiteral l)) + (htp : TrProjOK env uvars trProj) + {m : Mode} {inner : KVLCtx} {e : KExpr m} {e' : VExpr} + (H : TrKExprS env uvars nameOf trProj inner e e') + (hinner : KVLCtx.WF env uvars inner) + (outer : KVLCtx) : + TrKExprS env uvars nameOf trProj (KVLCtx.appendOuter inner outer) e e' := by + induction H generalizing outer with + | var h => + exact .var (KVLCtx.find?_append_of_some outer h) + | fvar h => + exact .fvar (KVLCtx.find?_append_of_some outer h) + | sort h => + exact .sort h + | const hname hlookup hlevels harity => + exact .const hname hlookup hlevels harity + | @app inner f arg info f' arg' A B + hfunTy hargTy hfun harg ihfun iharg => + have hclosed : Lean4Lean.CtxClosed inner.toCtx := + Lean4Lean.VEnv.CtxWF.closed henv hinner.toCtx + refine .app (A := A) (B := B) ?_ ?_ + (ihfun hinner outer) (iharg hinner outer) + · simpa only [KVLCtx.toCtx_appendOuter] using + hfunTy.weakR henv hclosed outer.toCtx + · simpa only [KVLCtx.toCtx_appendOuter] using + hargTy.weakR henv hclosed outer.toCtx + | @lam inner name bi ty body info ty' body' + hty htyTr hbodyTr ihty ihbody => + have hclosed : Lean4Lean.CtxClosed inner.toCtx := + Lean4Lean.VEnv.CtxWF.closed henv hinner.toCtx + have htyOriginal := hty + obtain ⟨level, htyHasType⟩ := hty + have hty' : + env.IsType uvars (KVLCtx.appendOuter inner outer).toCtx ty' := by + refine ⟨level, ?_⟩ + simpa only [KVLCtx.toCtx_appendOuter] using + htyHasType.weakR henv hclosed outer.toCtx + have hbodyInner : + KVLCtx.WF env uvars ((none, .vlam ty') :: inner) := + ⟨hinner, nofun, htyOriginal⟩ + exact .lam hty' (ihty hinner outer) (ihbody hbodyInner outer) + | @all inner name bi ty body info ty' body' + hty hbodyTy htyTr hbodyTr ihty ihbody => + have hclosed : Lean4Lean.CtxClosed inner.toCtx := + Lean4Lean.VEnv.CtxWF.closed henv hinner.toCtx + have htyOriginal := hty + obtain ⟨level, htyHasType⟩ := hty + have hty' : + env.IsType uvars (KVLCtx.appendOuter inner outer).toCtx ty' := by + refine ⟨level, ?_⟩ + simpa only [KVLCtx.toCtx_appendOuter] using + htyHasType.weakR henv hclosed outer.toCtx + have hbodyInner : + KVLCtx.WF env uvars ((none, .vlam ty') :: inner) := + ⟨hinner, nofun, htyOriginal⟩ + have hbodyClosed : + Lean4Lean.CtxClosed + (KVLCtx.toCtx ((none, Lean4Lean.VLocalDecl.vlam ty') :: inner)) := + Lean4Lean.VEnv.CtxWF.closed henv hbodyInner.toCtx + obtain ⟨bodyLevel, hbodyHasType⟩ := hbodyTy + have hbodyTy' : + env.IsType uvars + (KVLCtx.appendOuter + ((none, Lean4Lean.VLocalDecl.vlam ty') :: inner) outer).toCtx + body' := by + refine ⟨bodyLevel, ?_⟩ + simpa only [KVLCtx.toCtx_appendOuter] using + hbodyHasType.weakR henv hbodyClosed outer.toCtx + exact .all hty' hbodyTy' (ihty hinner outer) + (ihbody hbodyInner outer) + | @letE inner name ty val body nondep info ty' val' body' + hvalTy htyTr hvalTr hbodyTr ihty ihval ihbody => + have hclosed : Lean4Lean.CtxClosed inner.toCtx := + Lean4Lean.VEnv.CtxWF.closed henv hinner.toCtx + have hvalTy' : + env.HasType uvars (KVLCtx.appendOuter inner outer).toCtx val' ty' := by + simpa only [KVLCtx.toCtx_appendOuter] using + hvalTy.weakR henv hclosed outer.toCtx + have hbodyInner : + KVLCtx.WF env uvars ((none, .vlet ty' val') :: inner) := + ⟨hinner, nofun, hvalTy⟩ + exact .letE hvalTy' (ihty hinner outer) (ihval hinner outer) + (ihbody hbodyInner outer) + | @prj inner sid field val info structName val' result' + hname hvalTr hproj ihval => + have hclosed : Lean4Lean.CtxClosed inner.toCtx := + Lean4Lean.VEnv.CtxWF.closed henv hinner.toCtx + have hvalWF : VExpr.WF env uvars inner.toCtx val' := + hvalTr.wf henv hlit htp.wf hinner + have hresultWF : VExpr.WF env uvars inner.toCtx result' := + htp.wf hproj hvalWF + have hvalClosed : val'.ClosedN inner.toCtx.length := + hvalWF.closedN henv hclosed + have hresultClosed : result'.ClosedN inner.toCtx.length := + hresultWF.closedN henv hclosed + have hlift : + Lean4Lean.Ctx.LiftN outer.toCtx.length inner.toCtx.length + inner.toCtx (inner.toCtx ++ outer.toCtx) := + Lean4Lean.Ctx.LiftN.right hclosed outer.toCtx + have hproj' := htp.weakN hlift hproj + have hproj'' : + trProj (KVLCtx.appendOuter inner outer).toCtx structName field.toNat + val' result' := by + simpa only [KVLCtx.toCtx_appendOuter, + hvalClosed.liftN_eq (Nat.le_refl _), + hresultClosed.liftN_eq (Nat.le_refl _)] using hproj' + exact .prj hname (ihval hinner outer) hproj'' + | nat h => + exact .nat h + | str h => + exact .str h + +end TrKExprS + +namespace TrKExpr + +/-- Defeq-quotiented translation is likewise stable under an arbitrary outer +mixed context. -/ +theorem weakRight {env : VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + (henv : env.Ordered) + (hlit : ∀ l, env.ContainsLits l → + VExpr.WF env uvars [] (VExpr.trLiteral l)) + (htp : TrProjOK env uvars trProj) + {m : Mode} {inner : KVLCtx} {e : KExpr m} {e' : VExpr} + (H : TrKExpr env uvars nameOf trProj inner e e') + (hinner : KVLCtx.WF env uvars inner) + (outer : KVLCtx) : + TrKExpr env uvars nameOf trProj (KVLCtx.appendOuter inner outer) e e' := by + obtain ⟨structural, hstructural, targetTy, htarget⟩ := H + have hclosed : Lean4Lean.CtxClosed inner.toCtx := + Lean4Lean.VEnv.CtxWF.closed henv hinner.toCtx + refine ⟨structural, hstructural.weakRight henv hlit htp hinner outer, + targetTy, ?_⟩ + simpa only [KVLCtx.toCtx_appendOuter] using + htarget.weakR henv hclosed outer.toCtx + +end TrKExpr + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Delta/Integration.lean b/Ix/Tc/Verify/Whnf/Delta/Integration.lean new file mode 100644 index 000000000..82f13c2e0 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Delta/Integration.lean @@ -0,0 +1,119 @@ +import Ix.Tc.Verify.Whnf.Delta.UnfoldingState + +/-! +# Package delta and the fourth public WHNF field + +UnfoldingState separates delta unfolding into four independently reviewable inputs: +finite execution coverage, lazy-ingress state preservation, certified +unfold-cache writes, and successful-definition reflection. This module +packages those inputs into the exact optional-reducer field consumed by +FullStep's full-WHNF step. + +The public method table also exposes `whnfCoreWithFlags`, not only the +full-flags `whnfCore` specialization already wrapped by PublicReducers. The final +theorem below upgrades Reducer's arbitrary-flags `WhnfMeaning` result to the +`WhnfPost` shape required by `Methods.WhnfLayerWF`. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Complete run-scoped authority for production delta unfolding. The +structure contains no opaque operational callback: UnfoldingState constructs all state +and support behavior from the finite run, leaving only successful semantic +reflection and certified cache provenance as explicit admission inputs. -/ +structure DeltaUnfoldContext + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Type where + run : RunAssumptions initial program requests support + census : DeltaUnfoldRequestCensus requests world support + lazyFault : ∀ {uvars : Nat} {Delta : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) + writes : UnfoldCacheWriteOracle semantics world support + reflection : DeltaUnfoldReflection semantics trProj world support + +namespace DeltaUnfoldContext + +/-- Discharge FullStep's complete optional-reducer contract from the packaged +delta authorities. -/ +theorem wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} + (context : DeltaUnfoldContext initial program requests semantics trProj + world support) : + OptionalReduction.WF .noAccel semantics trProj world support + deltaUnfoldOne := + deltaUnfoldOne_optional_wf_of_contexts context.run context.census + context.lazyFault context.writes context.reflection + +end DeltaUnfoldContext + +namespace FullWhnfStepContext + +/-- Construct FullStep's full-WHNF step context without accepting a free +`OptionalReduction.WF`: the delta field must come through UnfoldingState's audited +operational decomposition. -/ +def ofDelta + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {keys : WhnfContextKeys} + {fallback : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {Delta : KVLCtx} + (noDelta : NoDeltaDriverContext initial program requests keys fallback + trProj world support Delta .FULL) + (natOffsetStuck : OptionalReduction.WFAt .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars tryNatOffsetStuck) + (delta : DeltaUnfoldContext initial program requests + (whnfCacheSemantics keys trProj fallback) trProj world support) : + FullWhnfStepContext initial program requests keys fallback trProj world + support Delta where + noDelta := noDelta + natOffsetStuck := natOffsetStuck + delta := OptionalReduction.WF.atUvars delta.wf keys.uvars + +end FullWhnfStepContext + +namespace StructuralCoreContext + +/-- The fourth WHNF method-table field: the actual public +`whnfCoreWithFlags` reducer, for an arbitrary production flag bundle, returns +the complete `WhnfPost` expected by `Methods.WF`. -/ +theorem publicFlags_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {keys : WhnfContextKeys} + {fallback : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {Delta : KVLCtx} {flags : WhnfFlags} + (context : StructuralCoreContext initial program requests keys fallback + trProj world support Delta flags) + {source : KExpr .anon} (hsourceSupport : support source) + {sourceV : Lean4Lean.VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta s + (whnfCoreWithFlags source flags) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + have hcore := + context.wf (source := source) (s := s) hsourceSupport hsource + apply RecM.WF.mono (RecM.WF.withInv hcore) + · intro result _ hresult + rcases hresult with ⟨hI, hresultSupport, hmeaning⟩ + refine ⟨hresultSupport, ?_⟩ + exact (WhnfPost.refl hsource + (context.theory.exprWF hI.2.1 hsource)).transMeaning + context.theory hI.2.1.wf hmeaning + · intro _ _ _ + trivial + +end StructuralCoreContext +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Delta/OptionalReduction.lean b/Ix/Tc/Verify/Whnf/Delta/OptionalReduction.lean new file mode 100644 index 000000000..15232910c --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Delta/OptionalReduction.lean @@ -0,0 +1,187 @@ +import Ix.Tc.Verify.Whnf.Delta.SpineUnfolding + +/-! +# Exact delta optional-reducer closure + +SpineUnfolding closes the spine-aware first half of `deltaUnfoldOne`. Production then +retains a bare-constant fallback. This module proves that fallback through +the same trusted declaration census and packages the complete reducer in the +fixed-universe optional contract consumed by the full-WHNF step. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Local run-equation strengthening used to connect a successful lazy +constant lookup to the exact catalog entry retained by the state invariant. -/ +private theorem deltaOne_wf_with_run_eq + {I : TcState .anon → Prop} {s : TcState .anon} {x : TcM .anon α} + {Q : α → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (hx : TcM.WF I s x Q E) : + TcM.WF I s x + (fun value after => Q value after ∧ x s = .ok value after) + (fun err after => E err after ∧ x s = .error err after) := by + intro hI + have hpost := hx hI + cases hrun : x s with + | ok value after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, rfl⟩ + | error err after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, rfl⟩ + +/-- Complete fixed-universe contract for production's `deltaUnfoldOne`. + +The first successful result already carries SpineUnfolding's rebuilt-spine meaning. +After a first-stage miss, only the concrete bare-constant branch can perform +more work; its second lookup, body instantiation, cache hit/write, support, +and Theory meaning are discharged by the same exact certificates. -/ +theorem deltaUnfoldOne_trusted_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} + (operational : DeltaUnfoldRequestCensus requests world support) + (trustedCensus : TrustedDeltaCensus trProj world support) + (theory : StableWhnfTheory trProj world keys.uvars) + {Delta : KVLCtx} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel + (whnfCacheSemantics keys trProj + (unfoldCacheSemantics keys.uvars trProj fallback)) + trProj world support keys.uvars Delta)) + (hreferences : TrustedReferences world support) + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + {s : TcState .anon} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta + source sourceV) : + RecM.WF .noAccel + (whnfCacheSemantics keys trProj + (unfoldCacheSemantics keys.uvars trProj fallback)) + trProj world support keys.uvars Delta s + (deltaUnfoldOne source) + (fun result _ => match result with + | none => True + | some reduced => + support reduced ∧ + WhnfMeaning trProj world keys.uvars Delta source reduced) := by + unfold deltaUnfoldOne + apply RecM.WF.bind <| + tryDeltaUnfold_trusted_wf hrun operational trustedCensus theory hfault + hreferences hsourceSupport hsource + intro first afterFirst hfirst + cases first with + | some result => + simp only + exact RecM.WF.pure fun _ => hfirst + | none => + simp only [pure_bind] + cases source with + | const id us info => + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.WF.mono + (deltaOne_wf_with_run_eq + (TcM.tryGetConst_wf hfault id afterFirst)) + (fun _ _ hpost => hpost.2) + (fun _ _ _ => trivial) + intro entry afterLookup hlookup + rcases hlookup with ⟨hILookup, hlookupRun⟩ + cases entry with + | none => + exact RecM.WF.pure fun _ => trivial + | some entry => + cases entry with + | defn name levelParams kind safety hints lvls ty body leanAll + block => + cases kind with + | opaq => + exact RecM.WF.pure fun _ => trivial + | defn | thm => + have hloaded := + TcM.tryGetConst_success_loaded hlookupRun + have hcatalog := + hILookup.1.core.loaded hloaded + obtain ⟨hheadSupport, hrequest, _⟩ := + operational.reduce hsourceSupport rfl rfl hcatalog + obtain ⟨ci, htrusted, hresources⟩ := + trustedCensus.resolve hheadSupport .defn hcatalog + (by simp) + apply RecM.WF.bind <| + unfoldConstValue_trusted_wf hrun theory hreferences + htrusted hresources hheadSupport hrequest hsource + intro result afterUnfold hresult + exact RecM.WF.pure fun _ => hresult + | recr | axio | quot | indc | ctor => + exact RecM.WF.pure fun _ => trivial + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact RecM.WF.pure fun _ => trivial + +/-- Exact fixed-universe inputs for the trusted delta reducer. -/ +structure TrustedDeltaContext + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) (keys : WhnfContextKeys) + (fallback : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Type where + run : RunAssumptions initial program requests support + operational : DeltaUnfoldRequestCensus requests world support + trusted : TrustedDeltaCensus trProj world support + theory : StableWhnfTheory trProj world keys.uvars + references : TrustedReferences world support + ingress : + AnonLazyIngressContext .noAccel + (whnfCacheSemantics keys trProj + (unfoldCacheSemantics keys.uvars trProj fallback)) + trProj world support + +namespace TrustedDeltaContext + +/-- Construct the complete delta field required by one fixed-universe +full-WHNF context, with no broad write or success-reflection authority. -/ +theorem wfAt + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {keys : WhnfContextKeys} + {fallback : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : TrustedDeltaContext initial program requests keys fallback + trProj world support) : + OptionalReduction.WFAt .noAccel + (whnfCacheSemantics keys trProj + (unfoldCacheSemantics keys.uvars trProj fallback)) + trProj world support keys.uvars deltaUnfoldOne := by + intro Delta source sourceV s hsourceSupport hsource + exact deltaUnfoldOne_trusted_wf context.run context.operational + context.trusted context.theory context.ingress.preserves context.references + hsourceSupport hsource + +end TrustedDeltaContext + +/-- Build the production full-WHNF step context with the universe-sensitive +delta fallback installed beneath the public WHNF cache semantics. -/ +def FullWhnfStepContext.ofTrustedDelta + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {keys : WhnfContextKeys} + {fallback : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {Delta : KVLCtx} + (noDelta : NoDeltaDriverContext initial program requests keys + (unfoldCacheSemantics keys.uvars trProj fallback) + trProj world support Delta .FULL) + (natOffsetStuck : OptionalReduction.WFAt .noAccel + (whnfCacheSemantics keys trProj + (unfoldCacheSemantics keys.uvars trProj fallback)) + trProj world support keys.uvars tryNatOffsetStuck) + (delta : TrustedDeltaContext initial program requests keys fallback + trProj world support) : + FullWhnfStepContext initial program requests keys + (unfoldCacheSemantics keys.uvars trProj fallback) + trProj world support Delta where + noDelta := noDelta + natOffsetStuck := natOffsetStuck + delta := delta.wfAt + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Delta/SpineUnfolding.lean b/Ix/Tc/Verify/Whnf/Delta/SpineUnfolding.lean new file mode 100644 index 000000000..f3793bb80 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Delta/SpineUnfolding.lean @@ -0,0 +1,193 @@ +import Ix.Tc.Verify.Whnf.Delta.CacheExecution + +/-! +# Trusted spine-aware delta unfolding + +CacheExecution verifies the cached body selected for one exact constant head. The +first production delta helper accepts an arbitrary application, peels its +head, unfolds that head, and rebuilds every argument. This module connects +the operational catalog hit to a declaration-specific certificate and uses +the typed spine to prove that rebuilding preserves the complete source +meaning. +-/ + +namespace Ix.Tc + +/-- Run-scoped trusted resolution and resource bounds for every supported +reducible constant head that delta unfolding may reach. + +The immutable catalog equation is repeated deliberately: it ties the +certificate to the exact concrete entry observed by `tryGetConst`. Resource +bounds are indexed by the actual universe array at the supported head, rather +than asserted for every possible instantiation of the declaration. -/ +structure TrustedDeltaCensus (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Prop where + resolve : ∀ {id : KId .anon} {us : Array (KUniv .anon)} + {info : ExprInfo .anon} {concrete : KConst .anon} + {kind : Ix.DefKind} {lvls : UInt64} {body : KExpr .anon}, + support (.const id us info) → + DeltaBodyShape kind lvls body concrete → + world.catalog id = some concrete → + kind ≠ .opaq → + ∃ ci : Lean4Lean.VDefVal, + TrustedDeltaBody trProj world id concrete ci kind lvls body ∧ + DeltaInstantiationResources us body + +namespace WhnfMeaning + +/-- Re-index a concrete reduction meaning by a caller-retained structural +translation of its source. Structural uniqueness supplies the bridge; no +syntactic equality between Theory representatives is assumed. -/ +theorem toPost + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + {Delta : KVLCtx} (hDelta : KVLCtx.WF world.venv uvars Delta) + {source result : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (h : WhnfMeaning trProj world uvars Delta source result) : + WhnfPost trProj world uvars Delta sourceV result := by + apply WhnfPost.transMeaning theory hDelta + (WhnfPost.refl hsource + (hsource.wf world.venvWF.ordered theory.literalWF + theory.projections.wf hDelta)) + exact h + +end WhnfMeaning + +namespace RecM + +/-- Strengthen a checker Hoare triple with the exact successful or erroneous +execution equation. -/ +private theorem delta_wf_with_run_eq + {I : TcState .anon → Prop} {s : TcState .anon} {x : TcM .anon α} + {Q : α → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (hx : TcM.WF I s x Q E) : + TcM.WF I s x + (fun value after => Q value after ∧ x s = .ok value after) + (fun err after => E err after ∧ x s = .error err after) := by + intro hI + have hpost := hx hI + cases hrun : x s with + | ok value after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, rfl⟩ + | error err after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, rfl⟩ + +/-- Delta's application loop is exactly the shared, certified suffix +finisher. -/ +private theorem deltaFinish_eq (base : KExpr m) + (args : Array (KExpr m)) : + (forIn args base fun arg result => do + let result ← TcM.intern (KExpr.mkApp result arg) + pure (.yield result) : RecM m (KExpr m)) = + finishAppResult base args 0 := by + rw [finishAppResult_eq_foldlM] + simp [Array.forIn_yield_eq_foldlM] + +/-- Complete state, support, and semantic closure for the spine-aware +production delta helper. + +Every successful definition/theorem branch is resolved through +`TrustedDeltaCensus`; warm and cold body paths use CacheExecution; and the exact typed +application suffix is rebuilt through `FinishAppRequests`. Misses and +partial errors retain the invariant through the ordinary `RecM.WF` bind +rules. -/ +theorem tryDeltaUnfold_trusted_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} + (operational : DeltaUnfoldRequestCensus requests world support) + (trustedCensus : TrustedDeltaCensus trProj world support) + (theory : StableWhnfTheory trProj world keys.uvars) + {Delta : KVLCtx} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel + (whnfCacheSemantics keys trProj + (unfoldCacheSemantics keys.uvars trProj fallback)) + trProj world support keys.uvars Delta)) + (hreferences : TrustedReferences world support) + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + {s : TcState .anon} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta + source sourceV) : + RecM.WF .noAccel + (whnfCacheSemantics keys trProj + (unfoldCacheSemantics keys.uvars trProj fallback)) + trProj world support keys.uvars Delta s + (tryDeltaUnfold source) + (fun result _ => match result with + | none => True + | some reduced => + support reduced ∧ + WhnfMeaning trProj world keys.uvars Delta source reduced) := by + unfold tryDeltaUnfold + generalize hspine : source.collectSpine = spine + rcases spine with ⟨head, args⟩ + cases head with + | const id us headInfo => + have htyped := trAppSpine_of_collectSpine hsource hspine + obtain ⟨headV, hheadTr, hsuffix⟩ := htyped.toSuffix + simp only [pure_bind] + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.WF.mono + (delta_wf_with_run_eq (TcM.tryGetConst_wf hfault id s)) + (fun _ _ hpost => hpost.2) + (fun _ _ _ => trivial) + intro entry afterLookup hlookup + rcases hlookup with ⟨hILookup, hlookupRun⟩ + cases entry with + | none => + exact RecM.WF.pure fun _ => trivial + | some entry => + cases entry with + | defn name levelParams kind safety hints lvls ty body leanAll block => + cases kind with + | opaq => + exact RecM.WF.pure fun _ => trivial + | defn | thm => + have hloaded := + TcM.tryGetConst_success_loaded hlookupRun + have hcatalog := + hILookup.1.core.loaded hloaded + obtain ⟨hheadSupport, hrequest, hfinish⟩ := + operational.reduce hsourceSupport hspine rfl hcatalog + obtain ⟨ci, htrusted, hresources⟩ := + trustedCensus.resolve hheadSupport .defn hcatalog + (by simp) + apply RecM.WF.bind <| + unfoldConstValue_trusted_wf hrun theory hreferences + htrusted hresources hheadSupport hrequest hheadTr + intro base afterUnfold hbase + obtain ⟨hbaseSupport, hbaseMeaning⟩ := hbase + obtain ⟨final, plan⟩ := hfinish hbaseSupport + have plan' : FinishAppRequests requests + (args.extract 0 args.size).toList base final := by + simpa using plan + rw [deltaFinish_eq base args] + apply RecM.WF.bind + (plan'.finishAppResult_wf hrun hbaseSupport) + intro actual afterFinish hactual + rcases hactual with ⟨hactualEq, hfinalSupport⟩ + subst actual + apply RecM.WF.pure + intro hI + have hheadPost := + hbaseMeaning.toPost theory.current hI.2.1.wf hheadTr + exact ⟨hfinalSupport, + WhnfMeaning.appHeadRebuild hI.2.1.wf hsource hsuffix + hheadPost plan'⟩ + | recr | axio | quot | indc | ctor => + exact RecM.WF.pure fun _ => trivial + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact RecM.WF.pure fun _ => trivial + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Delta/StableCache.lean b/Ix/Tc/Verify/Whnf/Delta/StableCache.lean new file mode 100644 index 000000000..33f925cb7 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Delta/StableCache.lean @@ -0,0 +1,147 @@ +import Ix.Tc.Verify.Whnf.Delta.TrustedBody + +/-! +# Stable trusted delta-cache provenance + +TrustedBody proves that one exact trusted definition or theorem body has the Theory +meaning required by delta unfolding. An unfold-cache entry has a stronger +lifetime, however: it is stored under stable-world authority and may be read +after the trusted Theory environment grows. This module makes that +persistence obligation explicit and turns the declaration certificate into +the exact `CacheProvenance` consumed by the production cache invariant. + +Two facts are intentionally not inferred from the generic instantiation +request: + +* `WalkerRequest.Bounds (.instUniv _ _)` is vacuous, so address faithfulness + and `UInt64` level-size bounds must be supplied by the run's exact delta + census; +* `WhnfTheory` is not automatically monotone, because a later world may add + literal and projection obligations. A stable theory family supplies those + obligations at every permitted extension. +-/ + +namespace Ix.Tc + +/-- Theory closure at one universe count for every extension of the world in +which a stable cache entry may be interpreted. -/ +def StableWhnfTheory (trProj : RawProjRel) (world : VerifyWorld) + (uvars : Nat) : Prop := + ∀ ⦃later : VerifyWorld⦄, world ≤ later → + WhnfTheory trProj later uvars + +namespace StableWhnfTheory + +/-- Project the current-world theory from its stable family. -/ +theorem current {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (h : StableWhnfTheory trProj world uvars) : + WhnfTheory trProj world uvars := + h VerifyWorld.LE.rfl + +/-- A stable theory family remains stable after advancing its lower world +bound. -/ +theorem mono {trProj : RawProjRel} {before after : VerifyWorld} {uvars : Nat} + (h : StableWhnfTheory trProj before uvars) (hle : before ≤ after) : + StableWhnfTheory trProj after uvars := by + intro later hlater + exact h (VerifyWorld.LE.trans hle hlater) + +end StableWhnfTheory + +/-- The two non-vacuous resource obligations used by the universe +instantiation proof for one exact body and universe array. -/ +structure DeltaInstantiationResources (us : Array (KUniv .anon)) + (body : KExpr .anon) : Prop where + addrFaithful : ∀ left right, + KExpr.LevelReach us body left → + KExpr.LevelReach us body right → + left.AddrFaithful right + levelSize : ∀ level, + KExpr.LevelReach us body level → + level.size < UInt64.size + +namespace TrustedDeltaBody + +/-- Invert the structural translation of the concrete constant selected by a +trusted delta certificate. + +The translation's name and `VConstant` are not accepted independently: +determinism of `nameOf` and the Theory constant map identifies them with the +certificate's exact `VDefVal`. Consequently the returned universe arity is +the arity of the registered definition, not merely that of an unrelated +constant found at the same source node. -/ +theorem sourceInputs + {trProj : RawProjRel} {world : VerifyWorld} + {id : KId .anon} {concrete : KConst .anon} + {ci : Lean4Lean.VDefVal} {kind : Ix.DefKind} + {lvls : UInt64} {body : KExpr .anon} + (h : TrustedDeltaBody trProj world id concrete ci kind lvls body) + {uvars : Nat} {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {Delta : KVLCtx} {sourceV : Lean4Lean.VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.const id us info) sourceV) : + sourceV = + .const ci.name (us.toList.map KUniv.toVLevel) ∧ + (∀ level ∈ us, (KUniv.toVLevel level).WF uvars) ∧ + us.size = ci.uvars := by + cases hsource with + | const hname hlookup hus harity => + have hnameEq := Option.some.inj (hname.symm.trans h.nameEq) + subst hnameEq + have hconstantEq := Option.some.inj (hlookup.symm.trans h.lookup) + subst hconstantEq + exact ⟨rfl, hus, harity⟩ + +/-- The exact body meaning remains available in every future world accepted +by the stable cache authority. -/ +theorem futureMeaning + {trProj : RawProjRel} {world : VerifyWorld} + {id : KId .anon} {concrete : KConst .anon} + {ci : Lean4Lean.VDefVal} {kind : Ix.DefKind} + {lvls : UInt64} {body : KExpr .anon} + (h : TrustedDeltaBody trProj world id concrete ci kind lvls body) + {uvars : Nat} (theory : StableWhnfTheory trProj world uvars) + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {result : KExpr .anon} + (hus : ∀ level ∈ us, (KUniv.toVLevel level).WF uvars) + (harity : us.size = ci.uvars) + (hspec : KExpr.instantiateUnivParamsSpec body us = .ok result) + (resources : DeltaInstantiationResources us body) + {later : VerifyWorld} (hle : world ≤ later) + {Delta : KVLCtx} (hDelta : KVLCtx.WF later.venv uvars Delta) : + WhnfMeaning trProj later uvars Delta (.const id us info) result := + (h.mono hle).meaning (theory hle) hus harity hspec + resources.addrFaithful resources.levelSize hDelta + +/-- Construct the collision-robust, stable-world provenance installed by a +cold `unfoldConstValue` run. This is the declaration-specific replacement +for `UnfoldCacheWriteOracle.write`. -/ +theorem unfoldCacheProvenance + {trProj : RawProjRel} {world : VerifyWorld} + {id : KId .anon} {concrete : KConst .anon} + {ci : Lean4Lean.VDefVal} {kind : Ix.DefKind} + {lvls : UInt64} {body : KExpr .anon} + (h : TrustedDeltaBody trProj world id concrete ci kind lvls body) + {uvars : Nat} {fallback : CacheSemantics} + (theory : StableWhnfTheory trProj world uvars) + {support : RunSupport} + (hcollision : support.CollisionFree) + (hreferences : RecM.TrustedReferences world support) + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {result : KExpr .anon} + (hhead : support (.const id us info)) + (hresult : support result) + (hus : ∀ level ∈ us, (KUniv.toVLevel level).WF uvars) + (harity : us.size = ci.uvars) + (hspec : KExpr.instantiateUnivParamsSpec body us = .ok result) + (resources : DeltaInstantiationResources us body) : + CacheProvenance (unfoldCacheSemantics uvars trProj fallback) + (CacheAuthority.stable world) support + (.unfold (.const id us info : KExpr .anon).addr result) := by + apply CacheProvenance.unfoldOfMeaning hcollision hreferences hhead hresult + intro later hle Delta hDelta + exact h.futureMeaning theory hus harity hspec resources hle hDelta + +end TrustedDeltaBody + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Delta/TrustedBody.lean b/Ix/Tc/Verify/Whnf/Delta/TrustedBody.lean new file mode 100644 index 000000000..9ecc5a35a --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Delta/TrustedBody.lean @@ -0,0 +1,286 @@ +import Ix.Tc.Verify.Whnf.Delta.UniverseMonotonicity + +/-! +# Exact trusted delta-body semantics + +`UnfoldingState` closes the operational state and support behavior of delta unfolding, +but its two remaining semantic inputs are intentionally too broad for final +K1 closure: one can certify an unfold-cache write for an arbitrary supported +head/result pair, and the other can reflect any observed successful delta +run. + +This module replaces that shape with a declaration-specific certificate. A +certificate is tied to one exact immutable catalog entry, its trusted id, the +assigned Theory name and lookup, the concrete body, its typed structural +translation, and the semantic reason that the body may be unfolded: + +* an ordinary definition carries its registered Theory equation; +* a theorem carries evidence that its type is a proposition, so unfolding is + justified by proof irrelevance; +* opaque definitions have no constructor. + +The universe-instantiation theorem covers both production paths. Nonempty +universe arrays use the verified walker quotient; the empty fast path uses +UniverseMonotonicity's universe-count monotonicity because production returns the admitted +body unchanged. ClosedTranslation then weakens the closed body translation into the +caller's arbitrary mixed context. +-/ + +namespace Ix.Tc + +open Lean4Lean (VDefVal VEnv VExpr VLevel) + +/-- The exact definition-shaped catalog fields relevant to delta unfolding. +Keeping this as an indexed proposition lets a certificate retain the complete +catalog entry without storing proof-irrelevant data inside `Prop`. -/ +inductive DeltaBodyShape (kind : Ix.DefKind) (lvls : UInt64) + (body : KExpr .anon) : KConst .anon → Prop where + | defn + {name : Mode.anon.F Name} + {levelParams : Mode.anon.F (Array Name)} + {safety : Ix.DefinitionSafety} + {hints : Lean.ReducibilityHints} + {type : KExpr .anon} + {leanAll : Mode.anon.F (Array (KId .anon))} + {block : KId .anon} : + DeltaBodyShape kind lvls body + (.defn name levelParams kind safety hints lvls type body leanAll block) + +/-- The Theory fact that permits production to unfold one definition-shaped +catalog entry. There is deliberately no opaque case. -/ +inductive DeltaBodyEquation (env : VEnv) (ci : VDefVal) : + Ix.DefKind → Prop where + | defn : + env.defeqs ci.toDefEq → + DeltaBodyEquation env ci .defn + | thm : + env.HasType ci.uvars [] ci.type (.sort .zero) → + DeltaBodyEquation env ci .thm + +namespace DeltaBodyEquation + +/-- A delta equation remains available when the trusted Theory environment +grows. -/ +theorem mono {before after : VEnv} (hle : before ≤ after) + {ci : VDefVal} {kind : Ix.DefKind} + (h : DeltaBodyEquation before ci kind) : + DeltaBodyEquation after ci kind := by + cases h with + | defn hregistered => + exact .defn (hle.defeqs hregistered) + | thm hprop => + exact .thm (hprop.mono hle) + +end DeltaBodyEquation + +/-- Admission-owned semantic certificate for one exact reducible catalog +entry. + +The Theory name is `ci.name` throughout. This is stronger than separately +recording an arbitrary lookup name: the registered equation's left-hand side +is headed by `ci.name`, so allowing a different source name would be +unsound. -/ +structure TrustedDeltaBody (trProj : RawProjRel) (world : VerifyWorld) + (id : KId .anon) (concrete : KConst .anon) (ci : VDefVal) + (kind : Ix.DefKind) (lvls : UInt64) (body : KExpr .anon) : Prop where + shape : DeltaBodyShape kind lvls body concrete + catalog : world.catalog id = some concrete + trusted : world.trusted id + nameEq : world.nameOf id.addr = some ci.name + lookup : world.venv.constants ci.name = some ci.toVConstant + uvars : lvls.toNat = ci.uvars + bodyStructural : + TrKExprS world.venv ci.uvars world.nameOf trProj [] body ci.value + wf : ci.WF world.venv + equation : DeltaBodyEquation world.venv ci kind + +namespace TrustedDeltaBody + +/-- The same exact catalog/body certificate survives trusted-world +extension. Catalog and address-name assignments are immutable under +`VerifyWorld.LE`; only trusted membership and Theory facts grow. -/ +theorem mono {trProj : RawProjRel} {before after : VerifyWorld} + (hle : before ≤ after) + {id : KId .anon} {concrete : KConst .anon} {ci : VDefVal} + {kind : Ix.DefKind} {lvls : UInt64} {body : KExpr .anon} + (h : TrustedDeltaBody trProj before id concrete ci kind lvls body) : + TrustedDeltaBody trProj after id concrete ci kind lvls body := by + refine ⟨h.shape, ?_, hle.trusted h.trusted, ?_, + hle.venv.constants h.lookup, h.uvars, ?_, + h.wf.mono hle.venv, h.equation.mono hle.venv⟩ + · rw [← hle.catalog] + exact h.catalog + · rw [← hle.nameOf] + exact h.nameEq + · simpa only [← hle.nameOf] using h.bodyStructural.mono hle.venv + +/-- The list of Theory levels selected by one concrete universe array. -/ +private def instantiatedLevels (us : Array (KUniv .anon)) : List VLevel := + us.toList.map KUniv.toVLevel + +/-- Universe-instantiating a certified closed body yields a quotient +translation to the instantiated Theory body in every caller context. + +For the nonempty path this is `TrKExprS.instL` followed by right weakening. +For the empty production fast path, arity forces the admitted body to have +zero universe parameters; UniverseMonotonicity raises that structural derivation to the +caller's universe count before ClosedTranslation weakens it into `Delta`. -/ +theorem instantiatedBody + {trProj : RawProjRel} {world : VerifyWorld} + {id : KId .anon} {concrete : KConst .anon} {ci : VDefVal} + {kind : Ix.DefKind} {lvls : UInt64} {body : KExpr .anon} + (h : TrustedDeltaBody trProj world id concrete ci kind lvls body) + {uvars : Nat} (theory : WhnfTheory trProj world uvars) + {us : Array (KUniv .anon)} {result : KExpr .anon} + (hus : ∀ level ∈ us, (KUniv.toVLevel level).WF uvars) + (harity : us.size = ci.uvars) + (hspec : KExpr.instantiateUnivParamsSpec body us = .ok result) + (hfaithful : ∀ left right, + KExpr.LevelReach us body left → + KExpr.LevelReach us body right → left.AddrFaithful right) + (hsize : ∀ level, KExpr.LevelReach us body level → + level.size < UInt64.size) + {Delta : KVLCtx} (hDelta : KVLCtx.WF world.venv uvars Delta) : + TrKExpr world.venv uvars world.nameOf trProj Delta result + (ci.value.instL (instantiatedLevels us)) := by + by_cases hempty : us.isEmpty + · have husEmpty : us = #[] := Array.empty_of_isEmpty hempty + subst us + have hresult : result = body := by + simpa [KExpr.instantiateUnivParamsSpec] using hspec.symm + subst result + have hzero : ci.uvars = 0 := by + simpa using harity.symm + have hbody0 : + TrKExprS world.venv 0 world.nameOf trProj [] body ci.value := by + simpa only [hzero] using h.bodyStructural + have hbodyU : + TrKExprS world.venv uvars world.nameOf trProj [] body ci.value := + hbody0.monoU (Nat.zero_le uvars) (by trivial) + have hbodyDelta : + TrKExprS world.venv uvars world.nameOf trProj Delta body ci.value := by + simpa only [KVLCtx.appendOuter] using + hbodyU.weakRight world.venvWF.ordered theory.literalWF + theory.projections (by trivial) Delta + have hwf := h.wf + change world.venv.HasType ci.uvars [] ci.value ci.type at hwf + have hwf0 : world.venv.HasType 0 [] ci.value ci.type := by + simpa only [hzero] using hwf + have hvalueLevels : ci.value.LevelWF 0 := + (hwf0.levelWF (by trivial)).1 + have hinst : ci.value.instL [] = ci.value := by + simpa [VLevel.params] using hvalueLevels.instL_id + simpa [instantiatedLevels, hinst] using + hbodyDelta.trKExpr world.venvWF.ordered theory.literalWF + theory.projections.wf hDelta + · have hspec' : KExpr.instUnivSpec body us = .ok result := by + simpa [KExpr.instantiateUnivParamsSpec, hempty] using hspec + have hresult := + TrKExprS.instL world.venvWF theory.literalWF theory.projections + hus harity.symm h.bodyStructural (by trivial) hspec' + hfaithful hsize + simpa only [KVLCtx.instL, KVLCtx.appendOuter, instantiatedLevels] using + hresult.weakRight world.venvWF.ordered theory.literalWF + theory.projections (by trivial) Delta + +/-- The concrete constant head has the exact structural Theory translation +selected by a trusted delta-body certificate. -/ +private theorem sourceStructural + {trProj : RawProjRel} {world : VerifyWorld} + {id : KId .anon} {concrete : KConst .anon} {ci : VDefVal} + {kind : Ix.DefKind} {lvls : UInt64} {body : KExpr .anon} + (h : TrustedDeltaBody trProj world id concrete ci kind lvls body) + {uvars : Nat} {us : Array (KUniv .anon)} {info : ExprInfo .anon} + (hus : ∀ level ∈ us, (KUniv.toVLevel level).WF uvars) + (harity : us.size = ci.uvars) + {Delta : KVLCtx} : + TrKExprS world.venv uvars world.nameOf trProj Delta + (.const id us info) (.const ci.name (instantiatedLevels us)) := + .const h.nameEq h.lookup hus harity + +/-- Exact K1 semantics of unfolding one trusted definition or theorem body. + +Ordinary definitions use their registered equation. Theorem constants are +not registered as reducible Theory equations, so the proof uses the +certificate's proposition-typing fact and Theory proof irrelevance. -/ +theorem meaning + {trProj : RawProjRel} {world : VerifyWorld} + {id : KId .anon} {concrete : KConst .anon} {ci : VDefVal} + {kind : Ix.DefKind} {lvls : UInt64} {body : KExpr .anon} + (h : TrustedDeltaBody trProj world id concrete ci kind lvls body) + {uvars : Nat} (theory : WhnfTheory trProj world uvars) + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {result : KExpr .anon} + (hus : ∀ level ∈ us, (KUniv.toVLevel level).WF uvars) + (harity : us.size = ci.uvars) + (hspec : KExpr.instantiateUnivParamsSpec body us = .ok result) + (hfaithful : ∀ left right, + KExpr.LevelReach us body left → + KExpr.LevelReach us body right → left.AddrFaithful right) + (hsize : ∀ level, KExpr.LevelReach us body level → + level.size < UInt64.size) + {Delta : KVLCtx} (hDelta : KVLCtx.WF world.venv uvars Delta) : + WhnfMeaning trProj world uvars Delta (.const id us info) result := by + let levels := instantiatedLevels us + have hlevels : ∀ level ∈ levels, level.WF uvars := by + intro level hlevel + obtain ⟨source, hsource, rfl⟩ := List.mem_map.1 hlevel + exact hus source (by simpa [levels, instantiatedLevels] using hsource) + have hlength : levels.length = ci.uvars := by + simpa [levels, instantiatedLevels] using harity + have hsource : + TrKExprS world.venv uvars world.nameOf trProj Delta + (.const id us info) (.const ci.name levels) := by + simpa only [levels] using h.sourceStructural hus harity + have hresult : + TrKExpr world.venv uvars world.nameOf trProj Delta result + (ci.value.instL levels) := by + simpa only [levels] using + h.instantiatedBody theory hus harity hspec hfaithful hsize hDelta + cases h.equation with + | defn hregistered => + have hstep : + world.venv.IsDefEq uvars Delta.toCtx + (.const ci.name levels) (ci.value.instL levels) + (ci.type.instL levels) := by + simpa [VDefVal.toDefEq, VExpr.instL, + VLevel.inst_map_id hlength] using + (VEnv.IsDefEq.extra (Γ := Delta.toCtx) + hregistered hlevels hlength) + have hsourceQ : + TrKExpr world.venv uvars world.nameOf trProj Delta + (.const id us info) (ci.value.instL levels) := + ⟨_, hsource, ⟨_, hstep⟩⟩ + exact WhnfMeaning.ofQuot hDelta hsourceQ hresult + | thm hprop => + obtain ⟨resultV, hresultS, hresultEq⟩ := hresult + have hsourceType : + world.venv.HasType uvars Delta.toCtx + (.const ci.name levels) (ci.type.instL levels) := + VEnv.HasType.const h.lookup hlevels hlength + have hbodyType0 : + world.venv.HasType uvars [] + (ci.value.instL levels) (ci.type.instL levels) := by + simpa using h.wf.instL hlevels + have hbodyType : + world.venv.HasType uvars Delta.toCtx + (ci.value.instL levels) (ci.type.instL levels) := + hbodyType0.weak0 world.venvWF.ordered + have hresultType : + world.venv.HasType uvars Delta.toCtx resultV + (ci.type.instL levels) := + (hresultEq.of_r world.venvWF hDelta.toCtx hbodyType).hasType.1 + have hprop0 : + world.venv.HasType uvars [] + (ci.type.instL levels) (.sort .zero) := by + simpa [VExpr.instL, VLevel.inst] using hprop.instL hlevels + have hpropDelta : + world.venv.HasType uvars Delta.toCtx + (ci.type.instL levels) (.sort .zero) := + hprop0.weak0 world.venvWF.ordered + exact ⟨_, _, hsource, hresultS, + ⟨_, .proofIrrel hpropDelta hsourceType hresultType⟩⟩ + +end TrustedDeltaBody + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Delta/UnfoldingState.lean b/Ix/Tc/Verify/Whnf/Delta/UnfoldingState.lean new file mode 100644 index 000000000..c7b7538c1 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Delta/UnfoldingState.lean @@ -0,0 +1,353 @@ +import Ix.Tc.Verify.Whnf.Driver.PublicReducers + +/-! +# Delta unfolding state and support closure + +Successful delta unfolding has three independent obligations: + +* lazy constant lookup must preserve the fixed-world invariant; +* a cache miss must run a request-covered universe-instantiation walk and + install a certified `unfoldCache` entry; +* rebuilding the original application spine must use a finite sequence of + request-covered intern operations. + +This module proves those operational obligations for the production +`deltaUnfoldOne`. The final Theory equation remains an admission-owned +reflection field: a loaded definition-shaped catalog entry is not by itself +evidence that its body is the trusted definition installed in `VerifyWorld`. +-/ + +namespace Ix.Tc + +/-- Collision-robust provenance for the universe-instantiated definition body +cached under the concrete constant-head address. -/ +structure UnfoldCacheWriteOracle (semantics : CacheSemantics) + (world : VerifyWorld) (support : RunSupport) : Prop where + write : ∀ {head result : KExpr .anon}, + support head → + support result → + CacheProvenance semantics (CacheAuthority.stable world) support + (.unfold head.addr result) + +/-- Finite operational plan for every reducible definition lookup reachable +from the run support. The suffix field is quantified over any supported +unfold-cache result, so a warm hit cannot bypass the request census. -/ +structure DeltaUnfoldRequestCensus + (requests : List WalkerRequest) (world : VerifyWorld) + (support : RunSupport) : Prop where + reduce : ∀ {source head : KExpr .anon} + {args : Array (KExpr .anon)} {id : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {name : Mode.anon.F Name} {levelParams : Mode.anon.F (Array Name)} + {kind : Ix.DefKind} {safety : Ix.DefinitionSafety} + {hints : Lean.ReducibilityHints} {lvls : UInt64} + {ty val : KExpr .anon} + {leanAll : Mode.anon.F (Array (KId .anon))} + {block : KId .anon}, + support source → + source.collectSpine = (head, args) → + head = .const id us headInfo → + world.catalog id = + some (.defn name levelParams kind safety hints lvls ty val leanAll + block) → + support head ∧ + WalkerRequest.instUniv val us ∈ requests ∧ + ∀ {base}, support base → + ∃ final, RecM.FinishAppRequests requests args.toList base final + +/-- Semantic authority for an observed successful delta unfold. Operational +state preservation and generated-result support are proved below; this field +asserts only the definition equation selected by the exact production run. -/ +structure DeltaUnfoldReflection (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Prop where + success : ∀ {uvars : Nat} {Delta : KVLCtx} + {methods : Methods .anon} {source result : KExpr .anon} + {sourceV : Lean4Lean.VExpr} {s sf : TcState .anon}, + Methods.WFAt .noAccel semantics trProj world support uvars methods → + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + WhnfStateInv .noAccel semantics trProj world support uvars Delta s → + (RecM.deltaUnfoldOne source).run methods s = .ok (some result) sf → + WhnfMeaning trProj world uvars Delta source result + +namespace RecM + +/-- Strengthen a checker Hoare triple with the concrete equation selected by +its actual success or error outcome. -/ +private theorem wf_with_run_eq + {I : TcState .anon → Prop} {s : TcState .anon} {x : TcM .anon α} + {Q : α → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (hx : TcM.WF I s x Q E) : + TcM.WF I s x + (fun value after => Q value after ∧ x s = .ok value after) + (fun err after => E err after ∧ x s = .error err after) := by + intro hI + have hpost := hx hI + cases hrun : x s with + | ok value after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, rfl⟩ + | error err after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, rfl⟩ + +/-- Delta rebuilding traverses the complete collected spine, which is the +zero-consumed specialization of the shared application finisher. -/ +private theorem deltaDefinitionFinish_eq (base : KExpr m) + (args : Array (KExpr m)) : + (forIn args base fun arg result => do + let result ← TcM.intern (KExpr.mkApp result arg) + pure (.yield result) : RecM m (KExpr m)) = + finishAppResult base args 0 := by + rw [finishAppResult_eq_foldlM] + simp [Array.forIn_yield_eq_foldlM] + +/-- Installing a certified unfold entry changes no logical checker state and +preserves the complete WHNF invariant. -/ +theorem unfoldCacheInsert_whnfStateInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {key : Address} {result : KExpr .anon} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hnew : CacheProvenance semantics (CacheAuthority.stable world) support + (.unfold key result)) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with env := {s.env with + unfoldCache := s.env.unfoldCache.insert key result}} := by + rcases hI with ⟨hkernel, hctx, hlayer⟩ + refine ⟨?_, ?_, ?_⟩ + · exact { + core := hkernel.core.of_consts_eq rfl (by + simpa using hkernel.core.intern) + internSupport := by simpa using hkernel.internSupport + caches := hkernel.caches.insertUnfold hnew + equivalences := hkernel.equivalences } + · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer + +/-- The production `unfoldConstValue` preserves state and returns a supported +body on both warm hits and request-covered misses. -/ +theorem unfoldConstValue_inv_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Delta : KVLCtx} + (writes : UnfoldCacheWriteOracle semantics world support) + {head val : KExpr .anon} {us : Array (KUniv .anon)} + (hheadSupport : support head) + (hrequest : WalkerRequest.instUniv val us ∈ requests) + {s : TcState .anon} : + RecM.WF layer semantics trProj world support uvars Delta s + (unfoldConstValue head val us) + (fun result _ => support result) := by + unfold unfoldConstValue + apply RecM.WF.bind + (Q₁ := fun observed after => observed = after) + (RecM.WF.get fun _ => rfl) + intro observed after hread + subst observed + cases hcache : after.env.unfoldCache[head.addr]? with + | some cached => + simp only + exact RecM.WF.pure fun hI => + (hI.1.caches.hit (.unfold hcache)).supported.2 + | none => + simp only + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.instantiateUnivParams_whnf_wf hrun.collisionFree + (hrun.coverage.instUniv hrequest) + intro result afterInst hresult + obtain ⟨_, hresultSupport⟩ := hresult + apply RecM.WF.bind + (Q₁ := fun _ next => + next = + {afterInst with env := {afterInst.env with + unfoldCache := + afterInst.env.unfoldCache.insert head.addr result}}) + · apply RecM.WF.modify + · intro hI + exact unfoldCacheInsert_whnfStateInv hI + (writes.write hheadSupport hresultSupport) + · intro _ + rfl + · intro _ next hnext + subst next + exact RecM.WF.pure fun _ => hresultSupport + +/-- State and finite-support closure for the first, spine-aware delta helper. -/ +theorem tryDeltaUnfold_inv_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + {world : VerifyWorld} + (hrun : RunAssumptions initial program requests support) + (census : DeltaUnfoldRequestCensus requests world support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {uvars : Nat} {Delta : KVLCtx} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (writes : UnfoldCacheWriteOracle semantics world support) + {source : KExpr .anon} {s : TcState .anon} + (hsourceSupport : support source) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryDeltaUnfold source) + (fun result _ => match result with + | none => True + | some reduced => support reduced) := by + unfold tryDeltaUnfold + generalize hspine : source.collectSpine = spine + rcases spine with ⟨head, args⟩ + cases head with + | const id us headInfo => + simp only [pure_bind] + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.WF.mono + (wf_with_run_eq (TcM.tryGetConst_wf hfault id s)) + (fun _ _ hpost => hpost.2) + (fun _ _ _ => trivial) + intro entry afterLookup hlookup + rcases hlookup with ⟨hILookup, hlookupRun⟩ + cases entry with + | none => + exact RecM.WF.pure fun _ => trivial + | some entry => + cases entry with + | defn name levelParams kind safety hints lvls ty val leanAll block => + cases kind with + | opaq => + exact RecM.WF.pure fun _ => trivial + | defn | thm => + have hloaded := + TcM.tryGetConst_success_loaded hlookupRun + have hcatalog := + hILookup.1.core.loaded hloaded + obtain ⟨hheadSupport, hrequest, hfinish⟩ := + census.reduce hsourceSupport hspine rfl hcatalog + apply RecM.WF.bind <| + unfoldConstValue_inv_wf hrun writes hheadSupport hrequest + intro base afterUnfold hbaseSupport + obtain ⟨final, plan⟩ := hfinish hbaseSupport + have plan' : FinishAppRequests requests + (args.extract 0 args.size).toList base final := by + simpa using plan + rw [deltaDefinitionFinish_eq base args] + apply RecM.WF.bind + (plan'.finishAppResult_wf hrun hbaseSupport) + intro actual afterFinish hactual + rcases hactual with ⟨hactualEq, hfinalSupport⟩ + subst actual + exact RecM.WF.pure fun _ => hfinalSupport + | recr | axio | quot | indc | ctor => + exact RecM.WF.pure fun _ => trivial + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact RecM.WF.pure fun _ => trivial + +/-- Complete operational closure of `deltaUnfoldOne`, including its bare- +constant fallback after a spine-aware miss. -/ +theorem deltaUnfoldOne_inv_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + {world : VerifyWorld} + (hrun : RunAssumptions initial program requests support) + (census : DeltaUnfoldRequestCensus requests world support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {uvars : Nat} {Delta : KVLCtx} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (writes : UnfoldCacheWriteOracle semantics world support) + {source : KExpr .anon} {s : TcState .anon} + (hsourceSupport : support source) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (deltaUnfoldOne source) + (fun result _ => match result with + | none => True + | some reduced => support reduced) := by + unfold deltaUnfoldOne + apply RecM.WF.bind <| + tryDeltaUnfold_inv_wf hrun census hfault writes hsourceSupport + intro first afterFirst hfirst + cases first with + | some result => + simp only + exact RecM.WF.pure fun _ => hfirst + | none => + simp only [pure_bind] + cases source with + | const id us info => + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.WF.mono + (wf_with_run_eq + (TcM.tryGetConst_wf hfault id afterFirst)) + (fun _ _ hpost => hpost.2) + (fun _ _ _ => trivial) + intro entry afterLookup hlookup + rcases hlookup with ⟨hILookup, hlookupRun⟩ + cases entry with + | none => + exact RecM.WF.pure fun _ => trivial + | some entry => + cases entry with + | defn name levelParams kind safety hints lvls ty val leanAll + block => + cases kind with + | opaq => + exact RecM.WF.pure fun _ => trivial + | defn | thm => + have hloaded := + TcM.tryGetConst_success_loaded hlookupRun + have hcatalog := + hILookup.1.core.loaded hloaded + obtain ⟨hheadSupport, hrequest, _⟩ := + census.reduce hsourceSupport rfl rfl hcatalog + apply RecM.WF.bind <| + unfoldConstValue_inv_wf hrun writes hheadSupport + hrequest + intro result afterUnfold hresultSupport + exact RecM.WF.pure fun _ => hresultSupport + | recr | axio | quot | indc | ctor => + exact RecM.WF.pure fun _ => trivial + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact RecM.WF.pure fun _ => trivial + +/-- Complete optional-reducer contract: operational state and support facts +come from the finite plan; only an observed successful hit consults semantic +definition reflection. -/ +theorem deltaUnfoldOne_optional_wf_of_contexts + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + {world : VerifyWorld} + (hrun : RunAssumptions initial program requests support) + (census : DeltaUnfoldRequestCensus requests world support) + {semantics : CacheSemantics} {trProj : RawProjRel} + (hfault : ∀ {uvars : Nat} {Delta : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (writes : UnfoldCacheWriteOracle semantics world support) + (reflection : DeltaUnfoldReflection semantics trProj world support) : + OptionalReduction.WF .noAccel semantics trProj world support + deltaUnfoldOne := by + intro uvars Delta source sourceV s hsourceSupport hsource + have hstate := + deltaUnfoldOne_inv_wf hrun census + (hfault (uvars := uvars) (Delta := Delta)) writes + (s := s) hsourceSupport + intro methods hmethods hI + have hpost := hstate methods hmethods hI + match hrunDelta : (deltaUnfoldOne source).run methods s with + | .error err sf => + rw [hrunDelta] at hpost + exact ⟨hpost.1, trivial⟩ + | .ok none sf => + rw [hrunDelta] at hpost + exact ⟨hpost.1, trivial⟩ + | .ok (some result) sf => + rw [hrunDelta] at hpost + exact ⟨hpost.1, hpost.2, + reflection.success hmethods hsourceSupport hsource hI hrunDelta⟩ + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Delta/UniverseMonotonicity.lean b/Ix/Tc/Verify/Whnf/Delta/UniverseMonotonicity.lean new file mode 100644 index 000000000..9166005b6 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Delta/UniverseMonotonicity.lean @@ -0,0 +1,161 @@ +import Ix.Tc.Verify.Whnf.Delta.ClosedTranslation + +/-! +# Universe-count monotonicity for structural translation + +`instantiateUnivParams` deliberately returns a parameter-free body unchanged +when its universe array is empty. Its admitted translation is indexed by +universe count zero, while the caller may itself have universe parameters. +This module proves the required monotonicity instead of modeling the skipped +walker as an execution. + +The Theory proof is obtained by instantiating a typing derivation with its own +parameter list and then observing that well-formed levels are unchanged. +Structural translation follows by induction, carrying the source mixed +context's well-formedness through binder cases. +-/ + +namespace Ix.Tc + +open Lean4Lean (OnCtx VEnv VExpr VLevel) + +/-- A well-formed universe level remains well-formed when the available +parameter count grows. -/ +private theorem vlevelWF_mono {before after : Nat} (hle : before ≤ after) : + ∀ {level : VLevel}, level.WF before → level.WF after := by + intro level h + induction level with + | zero => trivial + | succ level ih => exact ih h + | max left right ihLeft ihRight => + exact ⟨ihLeft h.1, ihRight h.2⟩ + | imax left right ihLeft ihRight => + exact ⟨ihLeft h.1, ihRight h.2⟩ + | param index => exact Nat.lt_of_lt_of_le h hle + +/-- A well-formed Theory context has universe-well-formed entry types. -/ +private theorem ctx_levelWF {env : VEnv} {uvars : Nat} : + ∀ {ctx : List VExpr}, + OnCtx ctx (env.IsType uvars) → + OnCtx ctx (fun _ type => type.LevelWF uvars) + | [], _ => trivial + | type :: ctx, h => by + rcases h with ⟨hctx, level, htype⟩ + have hctxLevels := ctx_levelWF hctx + exact ⟨hctxLevels, (htype.levelWF hctxLevels).1⟩ + +/-- Instantiating a universe-well-formed context with its own parameters is +the identity. -/ +private theorem ctx_instParams_eq {uvars : Nat} : + ∀ {ctx : List VExpr}, + OnCtx ctx (fun _ type => type.LevelWF uvars) → + ctx.map (VExpr.instL (VLevel.params uvars)) = ctx + | [], _ => rfl + | type :: ctx, h => by + rcases h with ⟨hctx, htype⟩ + simp only [List.map_cons, ctx_instParams_eq hctx, htype.instL_id] + +/-- Theory definitional equality is monotone in the number of available +universe parameters. -/ +private theorem isDefEq_monoU {env : VEnv} {before after : Nat} + (hle : before ≤ after) {ctx : List VExpr} {left right type : VExpr} + (hctx : OnCtx ctx (env.IsType before)) + (h : env.IsDefEq before ctx left right type) : + env.IsDefEq after ctx left right type := by + have hlevels : ∀ level ∈ VLevel.params before, level.WF after := by + intro level hlevel + exact vlevelWF_mono hle (VLevel.params_wf hlevel) + have hctxLevels := ctx_levelWF hctx + have hterms := h.levelWF hctxLevels + have hinst := h.instL hlevels + rw [ctx_instParams_eq hctxLevels, + hterms.1.instL_id, + hterms.2.1.instL_id, + hterms.2.2.instL_id] at hinst + exact hinst + +private theorem hasType_monoU {env : VEnv} {before after : Nat} + (hle : before ≤ after) {ctx : List VExpr} {term type : VExpr} + (hctx : OnCtx ctx (env.IsType before)) + (h : env.HasType before ctx term type) : + env.HasType after ctx term type := + isDefEq_monoU hle hctx h + +private theorem isType_monoU {env : VEnv} {before after : Nat} + (hle : before ≤ after) {ctx : List VExpr} {type : VExpr} + (hctx : OnCtx ctx (env.IsType before)) + (h : env.IsType before ctx type) : + env.IsType after ctx type := by + obtain ⟨level, htype⟩ := h + exact ⟨level, isDefEq_monoU hle hctx htype⟩ + +namespace TrKExprS + +/-- Structural translation remains valid when the universe-parameter budget +grows. The source mixed context is required to be well-formed at the smaller +budget so the embedded Theory typing premises can be transported. -/ +theorem monoU {env : VEnv} {before after : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : List VExpr → Lean.Name → Nat → VExpr → VExpr → Prop} + (hle : before ≤ after) + {m : Mode} {Delta : KVLCtx} {e : KExpr m} {e' : VExpr} + (H : TrKExprS env before nameOf trProj Delta e e') + (hDelta : KVLCtx.WF env before Delta) : + TrKExprS env after nameOf trProj Delta e e' := by + induction H with + | var h => + exact .var h + | fvar h => + exact .fvar h + | sort h => + exact .sort (vlevelWF_mono hle h) + | const hname hlookup hlevels harity => + exact .const hname hlookup + (fun level hlevel => + vlevelWF_mono hle (hlevels level hlevel)) + harity + | @app Delta f arg info f' arg' A B + hfunTy hargTy hfun harg ihfun iharg => + exact .app (A := A) (B := B) + (hasType_monoU hle hDelta.toCtx hfunTy) + (hasType_monoU hle hDelta.toCtx hargTy) + (ihfun hDelta) (iharg hDelta) + | @lam Delta name bi ty body info ty' body' + hty htyTr hbodyTr ihty ihbody => + have hbodyDelta : + KVLCtx.WF env before ((none, .vlam ty') :: Delta) := + ⟨hDelta, nofun, hty⟩ + exact .lam + (isType_monoU hle hDelta.toCtx hty) + (ihty hDelta) + (ihbody hbodyDelta) + | @all Delta name bi ty body info ty' body' + hty hbodyTy htyTr hbodyTr ihty ihbody => + have hbodyDelta : + KVLCtx.WF env before ((none, .vlam ty') :: Delta) := + ⟨hDelta, nofun, hty⟩ + exact .all + (isType_monoU hle hDelta.toCtx hty) + (isType_monoU hle hbodyDelta.toCtx hbodyTy) + (ihty hDelta) + (ihbody hbodyDelta) + | @letE Delta name ty value body nondep info ty' value' body' + hvalueTy htyTr hvalueTr hbodyTr ihty ihvalue ihbody => + have hbodyDelta : + KVLCtx.WF env before ((none, .vlet ty' value') :: Delta) := + ⟨hDelta, nofun, hvalueTy⟩ + exact .letE + (hasType_monoU hle hDelta.toCtx hvalueTy) + (ihty hDelta) + (ihvalue hDelta) + (ihbody hbodyDelta) + | prj hname hvalue hproj ihvalue => + exact .prj hname (ihvalue hDelta) hproj + | nat h => + exact .nat h + | str h => + exact .str h + +end TrKExprS + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Driver/FullStep.lean b/Ix/Tc/Verify/Whnf/Driver/FullStep.lean new file mode 100644 index 000000000..a8745f155 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Driver/FullStep.lean @@ -0,0 +1,206 @@ +import Ix.Tc.Verify.Whnf.NoDelta.Reducer + +/-! +# Full-WHNF one-step closure + +Reducer closes the public no-delta reducer. A full-WHNF iteration first runs +that reducer with full flags, then performs cycle detection and the outer +native, BitVec, Nat, Decidable, String, compact-Nat-offset, and delta stages. + +In the no-acceleration layer the native, BitVec, and Decidable stages are +operationally impossible hits. Nat and String reuse the exact contracts +already packaged by BaseReductions. Delta unfolding remains a distinct semantic +boundary: unlike a miss, successful unfolding must justify both support for +the generated expression and its Theory meaning. +-/ + +namespace Ix.Tc +namespace RecM + +/-- The Decidable acceleration gate satisfies the optional-reducer contract +in the no-acceleration layer because production returns `none` before +inspecting the expression or invoking a callback. -/ +theorem tryReduceDecidable_noAccel_optional_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} : + OptionalReduction.WF .noAccel semantics trProj world support + tryReduceDecidable := by + intro uvars Delta source sourceV s hsource htr + intro methods hmethods hI + rw [tryReduceDecidable_noAccel hI.2.2.1 source] + exact ⟨hI, trivial⟩ + +/-- Complete fixed-context input for one production full-WHNF iteration. + +All stages except delta are constructed from the same concrete no-delta +driver context. Keeping delta as an `OptionalReduction.WF` field makes the +remaining admission obligation exact: a successful unfold must preserve the +state invariant, remain in finite run support, and denote a definitionally +equal Theory expression. -/ +structure FullWhnfStepContext + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) (keys : WhnfContextKeys) + (fallback : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) + (Delta : KVLCtx) : Type where + noDelta : + NoDeltaDriverContext initial program requests keys fallback trProj world + support Delta .FULL + /-- Main's compact symbolic-Nat guard is a distinct reduction stage. Its + exact state/support/meaning contract remains explicit until its callback and + intern paths are decomposed into finite run-scoped inputs. -/ + natOffsetStuck : + OptionalReduction.WFAt .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars tryNatOffsetStuck + delta : + OptionalReduction.WFAt .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars deltaUnfoldOne + +namespace FullWhnfStepContext + +/-- The actual production full-WHNF step satisfies the exhaustive local +semantic contract for either successor policy in the no-acceleration layer. +Cycle hits and the final stuck branch retain the meaning established by +no-delta normalization; every successful outer reduction composes its own +meaning with that prefix through Theory transitivity. -/ +theorem wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {keys : WhnfContextKeys} + {fallback : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {Delta : KVLCtx} + (context : FullWhnfStepContext initial program requests keys fallback + trProj world support Delta) + (natSuccMode : NatSuccMode) : + WhnfStep.WF .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta + (fun state : KExpr .anon × Std.HashSet Address => state.1) + (whnfWithNatSuccModeStep natSuccMode) (fun _ _ => True) := by + intro state s hsource + rcases state with ⟨source, seen⟩ + obtain ⟨hsourceSupport, sourceV, hsourceTr⟩ := hsource + unfold whnfWithNatSuccModeStep + apply RecM.WF.bind + (RecM.WF.withInv + (context.noDelta.wf natSuccMode hsourceSupport hsourceTr)) + intro reduced s₁ hreduced + obtain ⟨_, hreducedSupport, hreducedPost⟩ := hreduced + have hprefix : + WhnfMeaning trProj world keys.uvars Delta source reduced := + WhnfPost.meaning hsourceTr hreducedPost + obtain ⟨reducedV, hreducedTr, _⟩ := hreducedPost + cases hcycle : seen.contains reduced.addr with + | true => + simp only [if_true] + apply RecM.WF.pure + intro _ + exact ⟨hreducedSupport, hprefix⟩ + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + apply RecM.WF.bind + (RecM.WF.withInv + (tryReduceNative_noAccel_optional_wf + hreducedSupport hreducedTr)) + intro nativeResult s₂ hnative + obtain ⟨hI₂, hnative⟩ := hnative + cases nativeResult with + | some result => + apply RecM.WF.pure + intro _ + exact ⟨hnative.1, + context.noDelta.structural.theory.transMeaning + hI₂.2.1.wf hprefix hnative.2⟩ + | none => + apply RecM.WF.bind + (RecM.WF.withInv + (tryReduceBitvec_noAccel_optional_wf + hreducedSupport hreducedTr)) + intro bitvecResult s₃ hbitvec + obtain ⟨hI₃, hbitvec⟩ := hbitvec + cases bitvecResult with + | some result => + apply RecM.WF.pure + intro _ + exact ⟨hbitvec.1, + context.noDelta.structural.theory.transMeaning + hI₃.2.1.wf hprefix hbitvec.2⟩ + | none => + apply RecM.WF.bind + (RecM.WF.withInv + ((context.noDelta.base.oracle natSuccMode).nat + hreducedSupport hreducedTr)) + intro natResult s₄ hnat + obtain ⟨hI₄, hnat⟩ := hnat + cases natResult with + | some result => + apply RecM.WF.pure + intro _ + exact ⟨hnat.1, + context.noDelta.structural.theory.transMeaning + hI₄.2.1.wf hprefix hnat.2⟩ + | none => + apply RecM.WF.bind + (RecM.WF.withInv + (tryReduceDecidable_noAccel_optional_wf + hreducedSupport hreducedTr)) + intro decidableResult s₅ hdecidable + obtain ⟨hI₅, hdecidable⟩ := hdecidable + cases decidableResult with + | some result => + apply RecM.WF.pure + intro _ + exact ⟨hdecidable.1, + context.noDelta.structural.theory.transMeaning + hI₅.2.1.wf hprefix hdecidable.2⟩ + | none => + apply RecM.WF.bind + (RecM.WF.withInv + ((context.noDelta.base.oracle natSuccMode).string + hreducedSupport hreducedTr)) + intro stringResult s₆ hstring + obtain ⟨hI₆, hstring⟩ := hstring + cases stringResult with + | some result => + apply RecM.WF.pure + intro _ + exact ⟨hstring.1, + context.noDelta.structural.theory.transMeaning + hI₆.2.1.wf hprefix hstring.2⟩ + | none => + apply RecM.WF.bind + (RecM.WF.withInv + (context.natOffsetStuck hreducedSupport + hreducedTr)) + intro offsetResult s₇ hoffset + obtain ⟨hI₇, hoffset⟩ := hoffset + cases offsetResult with + | some result => + apply RecM.WF.pure + intro _ + exact ⟨hoffset.1, + context.noDelta.structural.theory.transMeaning + hI₇.2.1.wf hprefix hoffset.2⟩ + | none => + apply RecM.WF.bind + (RecM.WF.withInv + (context.delta hreducedSupport hreducedTr)) + intro deltaResult s₈ hdelta + obtain ⟨hI₈, hdelta⟩ := hdelta + cases deltaResult with + | some result => + apply RecM.WF.pure + intro _ + exact ⟨hdelta.1, + context.noDelta.structural.theory.transMeaning + hI₈.2.1.wf hprefix hdelta.2⟩ + | none => + apply RecM.WF.pure + intro _ + exact ⟨hreducedSupport, hprefix⟩ + +end FullWhnfStepContext +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Driver/PublicReducers.lean b/Ix/Tc/Verify/Whnf/Driver/PublicReducers.lean new file mode 100644 index 000000000..220d51446 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Driver/PublicReducers.lean @@ -0,0 +1,103 @@ +import Ix.Tc.Verify.Whnf.Driver.FullStep + +/-! +# Public full-WHNF reducers + +FullStep constructs the exhaustive one-iteration contract for the production +full-WHNF loop. The generic bounded-driver and cache-shell theorems in +`Verify.Whnf` already cover loop exhaustion, cycle sets, public fast paths, +instrumentation, cache hits and writes, and both Nat successor policies. +This slice supplies FullStep's concrete step to those theorems. +-/ + +namespace Ix.Tc +namespace RecM +namespace FullWhnfStepContext + +/-- The actual public `whnfWithNatSuccMode` reducer satisfies its semantic +Hoare contract for either successor policy in the no-acceleration layer. -/ +theorem publicMode_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {keys : WhnfContextKeys} + {fallback : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {Delta : KVLCtx} + (context : FullWhnfStepContext initial program requests keys fallback + trProj world support Delta) + (natSuccMode : NatSuccMode) {source : KExpr .anon} + (hsourceSupport : support source) + {sourceV : Lean4Lean.VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta s + (whnfWithNatSuccMode source natSuccMode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + whnfWithNatSuccMode_wf + context.noDelta.structural.theory + (context.noDelta.structural.keyRep source hsourceSupport) + (TransientNatWork.preserving + (context.noDelta.structural.iotaIngress.preserves + (uvars := keys.uvars) (Delta := Delta)) + source) + (context.wf natSuccMode) + context.noDelta.cacheWrites hsourceSupport hsource + +/-- The production `whnf` entry is the collapse-policy specialization of the +same complete public proof. -/ +theorem publicWhnf_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {keys : WhnfContextKeys} + {fallback : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {Delta : KVLCtx} + (context : FullWhnfStepContext initial program requests keys fallback + trProj world support Delta) + {source : KExpr .anon} (hsourceSupport : support source) + {sourceV : Lean4Lean.VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta s (whnf source) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + publicMode_wf context .collapse hsourceSupport hsource + +/-- The structural `whnfCore` entry is the full-flags specialization already +contained in the same context. -/ +theorem publicCore_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {keys : WhnfContextKeys} + {fallback : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {Delta : KVLCtx} + (context : FullWhnfStepContext initial program requests keys fallback + trProj world support Delta) + {source : KExpr .anon} (hsourceSupport : support source) + {sourceV : Lean4Lean.VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta s (whnfCore source) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + have hcore := + context.noDelta.structural.wf + (source := source) (s := s) hsourceSupport hsource + apply RecM.WF.mono (RecM.WF.withInv hcore) + · intro result _ hresult + rcases hresult with ⟨hI, hresultSupport, hmeaning⟩ + refine ⟨hresultSupport, ?_⟩ + exact (WhnfPost.refl hsource + (context.noDelta.structural.theory.exprWF hI.2.1 hsource)).transMeaning + context.noDelta.structural.theory hI.2.1.wf hmeaning + · intro _ _ _ + trivial + +end FullWhnfStepContext +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/ApplicationRequests.lean b/Ix/Tc/Verify/Whnf/Iota/ApplicationRequests.lean new file mode 100644 index 000000000..ec61b5aa8 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/ApplicationRequests.lean @@ -0,0 +1,270 @@ +import Ix.Tc.Verify.Whnf.Iota.NatOffset + +/-! +# Finite request closure for ordinary iota application + +`NatOffset` leaves the selected ordinary-constructor tail behind the state-only +`TryApplyIotaCtorPreserves` boundary. This slice replaces that whole-helper +premise with the finite requests actually made by production: + +* one universe-instantiation request for the selected rule RHS; +* one expression-intern request for each non-transient application; and +* no request at all for transient application, which is state-pure even when + it performs `substNoIntern`. + +The census is indexed by the exact three production argument slices. Thus a +certificate for a convenient argument order cannot justify the real helper. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Exact non-transient intern requests for one left-to-right iota argument +fold. The final expression is an index, so the next production segment must +start from the actual result of the preceding segment. -/ +inductive IotaArgsInternRequests (requests : List WalkerRequest) : + KExpr .anon → List (KExpr .anon) → KExpr .anon → Prop + | nil (result : KExpr .anon) : + IotaArgsInternRequests requests result [] result + | cons {result arg final : KExpr .anon} + {rest : List (KExpr .anon)} + (request : + WalkerRequest.internExpr (KExpr.mkApp result arg) ∈ requests) + (tail : IotaArgsInternRequests requests + (KExpr.mkApp result arg) rest final) : + IotaArgsInternRequests requests result (arg :: rest) final + +namespace IotaArgsInternRequests + +/-- A certified non-transient list fold preserves the complete K1 invariant +and returns its indexed final application. -/ +theorem wfList + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + {start final : KExpr .anon} {args : List (KExpr .anon)} + (h : IotaArgsInternRequests requests start args final) + (s : TcState .anon) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((args.foldlM (m := RecM .anon) + (fun result arg => applyIotaArg result arg false) start).run methods) + (fun result _ => result = final) := by + induction h generalizing s with + | nil result => + exact TcM.WF.pure (fun _ => rfl) + | @cons result arg final rest request tail ih => + rw [List.foldlM_cons, ReaderT.run_bind] + apply TcM.WF.bind + (Q₁ := fun next _ => next = KExpr.mkApp result arg) + · rw [Ix.Tc.RecM.applyIotaArg_false, ReaderT.run_monadLift] + exact TcM.WF.mono + (TcM.intern_whnf_wf hrun.collisionFree + (hrun.coverage.internExpr request)) + (fun _ _ hpost => hpost.1) + (fun _ _ _ => trivial) + · intro next after hnext + subst next + exact ih after + +/-- Array wrapper matching production's extracted `applyIotaArgs`. -/ +theorem wfArray + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + {start final : KExpr .anon} {args : Array (KExpr .anon)} + (h : IotaArgsInternRequests requests start args.toList final) + (s : TcState .anon) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((applyIotaArgs start args false).run methods) + (fun result _ => result = final) := by + rw [applyIotaArgs_eq_foldlM] + simpa only [← Array.foldlM_toList] using h.wfList hrun s + +end IotaArgsInternRequests + +/-- One transient argument application performs no checker-state effect. +This statement intentionally imposes no construction or arithmetic premise: +those are needed for semantic identification, not state preservation. -/ +theorem applyIotaArg_true_state_wf + {I : TcState .anon → Prop} (methods : Methods .anon) + (result arg : KExpr .anon) (s : TcState .anon) : + TcM.WF I s ((applyIotaArg result arg true).run methods) + (fun _ _ => True) := by + unfold applyIotaArg + cases result <;> exact TcM.WF.pure (fun _ => trivial) + +private theorem applyIotaArgsTrueList_state_wf + {I : TcState .anon → Prop} (methods : Methods .anon) : + ∀ (args : List (KExpr .anon)) (start : KExpr .anon) + (s : TcState .anon), + TcM.WF I s + ((args.foldlM (m := RecM .anon) + (fun result arg => applyIotaArg result arg true) start).run methods) + (fun _ _ => True) + | [], start, s => TcM.WF.pure (fun _ => trivial) + | arg :: rest, start, s => by + rw [List.foldlM_cons, ReaderT.run_bind] + apply TcM.WF.bind (applyIotaArg_true_state_wf methods start arg s) + intro next after _ + exact applyIotaArgsTrueList_state_wf methods rest next after + +/-- Every transient production argument fold is state-safe without a request +census because it never enters the intern table. -/ +theorem applyIotaArgs_true_state_wf + {I : TcState .anon → Prop} (methods : Methods .anon) + (start : KExpr .anon) (args : Array (KExpr .anon)) + (s : TcState .anon) : + TcM.WF I s ((applyIotaArgs start args true).run methods) + (fun _ _ => True) := by + rw [applyIotaArgs_eq_foldlM] + simpa only [← Array.foldlM_toList] using + applyIotaArgsTrueList_state_wf methods args.toList start s + +/-- Finite request plan for one exact selected production rule. Successful +universe instantiation determines the starting RHS for the three chained +application plans. -/ +structure IotaRuleRequests (requests : List WalkerRequest) + (rule : RecRule .anon) (recUs : Array (KUniv .anon)) + (recr : IotaInfo .anon) (spine ctorArgs : Array (KExpr .anon)) + (ctorFields : Nat) : Prop where + instantiate : WalkerRequest.instUniv rule.rhs recUs ∈ requests + nonTransient : ∀ {rhs}, + KExpr.instantiateUnivParamsSpec rule.rhs recUs = .ok rhs → + ∃ middle₁ middle₂ final, + IotaArgsInternRequests requests rhs + (iotaPrefixArgs recr spine).toList middle₁ ∧ + IotaArgsInternRequests requests middle₁ + (iotaFieldArgs ctorArgs ctorFields).toList middle₂ ∧ + IotaArgsInternRequests requests middle₂ + (iotaTrailingArgs recr spine).toList final + +/-- Run-wide finite census at the precise successful rule-selection point. +Guard failures require no plan because production returns before executing +`applyIotaRule`. -/ +structure IotaRuleRequestCensus (requests : List WalkerRequest) : Prop where + selected : ∀ {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} + {spine ctorArgs : Array (KExpr .anon)} + {cidx ctorFields : Nat} {rule : RecRule .anon}, + recr.rules[cidx]? = some rule → + IotaRuleRequests requests rule recUs recr spine ctorArgs ctorFields + +/-- State closure of the exact three-segment production rule helper. -/ +theorem applyIotaRule_state_wf_of_requests + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + {rule : RecRule .anon} {recUs : Array (KUniv .anon)} + {recr : IotaInfo .anon} {spine ctorArgs : Array (KExpr .anon)} + {ctorFields : Nat} {transient : Bool} + (plan : IotaRuleRequests requests rule recUs recr spine ctorArgs + ctorFields) + (s : TcState .anon) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((applyIotaRule rule recUs recr spine ctorArgs ctorFields transient).run + methods) + (fun _ _ => True) := by + unfold applyIotaRule + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (TcM.instantiateUnivParams_whnf_wf hrun.collisionFree + (hrun.coverage.instUniv plan.instantiate)) + intro rhs afterInst hrhs + cases transient with + | false => + obtain ⟨middle₁, middle₂, final, hfirst, hsecond, hthird⟩ := + plan.nonTransient hrhs.1 + rw [ReaderT.run_bind] + apply TcM.WF.bind (hfirst.wfArray hrun afterInst) + intro actual₁ afterFirst hactual₁ + subst actual₁ + rw [ReaderT.run_bind] + apply TcM.WF.bind (hsecond.wfArray hrun afterFirst) + intro actual₂ afterSecond hactual₂ + subst actual₂ + exact TcM.WF.mono (hthird.wfArray hrun afterSecond) + (fun _ _ _ => trivial) (fun _ _ _ => trivial) + | true => + rw [ReaderT.run_bind] + apply TcM.WF.bind + (applyIotaArgs_true_state_wf methods rhs + (iotaPrefixArgs recr spine) afterInst) + intro middle₁ afterFirst _ + rw [ReaderT.run_bind] + apply TcM.WF.bind + (applyIotaArgs_true_state_wf methods middle₁ + (iotaFieldArgs ctorArgs ctorFields) afterFirst) + intro middle₂ afterSecond _ + exact applyIotaArgs_true_state_wf methods middle₂ + (iotaTrailingArgs recr spine) afterSecond + +/-- Exhaustive rule lookup and both production guards, with the successful +tail discharged from the finite request census. -/ +theorem tryApplyIotaCtor_state_wf_of_requests + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (census : IotaRuleRequestCensus requests) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + (recr : IotaInfo .anon) (recUs : Array (KUniv .anon)) + (spine ctorArgs : Array (KExpr .anon)) (cidx ctorFields : Nat) + (transient : Bool) (s : TcState .anon) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields + transient).run methods) + (fun _ _ => True) := by + unfold tryApplyIotaCtor + cases hselected : recr.rules[cidx]? with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some rule => + simp only [pure_bind] + by_cases hlevels : (recUs.size.toUInt64 != recr.lvls) = true + · simp only [hlevels, if_true] + exact TcM.WF.pure (fun _ => trivial) + · simp only [hlevels, Bool.false_eq_true, if_false] + by_cases hfields : ctorFields > ctorArgs.size + · simp only [hfields, if_pos] + exact TcM.WF.pure (fun _ => trivial) + · simp only [hfields, if_false] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (applyIotaRule_state_wf_of_requests hrun + (census.selected hselected) s) + intro result after _ + exact TcM.WF.pure (fun _ => trivial) + +namespace TryApplyIotaCtorPreserves + +/-- NatOffset's ordinary-constructor boundary is fully constructed from a finite +run request census. -/ +theorem of_requests + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (census : IotaRuleRequestCensus requests) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} : + TryApplyIotaCtorPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods := by + intro recr recUs spine ctorArgs cidx ctorFields transient s + exact tryApplyIotaCtor_state_wf_of_requests hrun census recr recUs spine + ctorArgs cidx ctorFields transient s + +end TryApplyIotaCtorPreserves + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/ArgumentBranches.lean b/Ix/Tc/Verify/Whnf/Iota/ArgumentBranches.lean new file mode 100644 index 000000000..390f1e5ff --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/ArgumentBranches.lean @@ -0,0 +1,168 @@ +import Ix.Tc.Verify.Whnf.Iota.Substitution + +/-! +# Remaining production iota-argument branches + +Substitution identifies transient lambda application with verified beta +substitution. Production `applyIotaArg` has two other behaviors: transient +non-lambdas are rebuilt directly with `KExpr.mkApp`, while ordinary iota +applications intern that same rebuilt node. + +This slice gives both branches exact execution theorems and a shared semantic +application lemma. The non-transient theorem records the precise intern-only +state frame and preserves the full WHNF invariant. These per-argument +contracts are the branch-local inputs needed for the subsequent proof of the +three production application loops. +-/ + +namespace Ix.Tc + +/-- Every expression shape that bypasses transient beta in `applyIotaArg`. +Unlike `WhnfCoreNonLambda`, this includes `app`: an intermediate recursor RHS +may itself be an application. -/ +inductive IotaArgNonLambda : KExpr .anon → Prop + | var {idx name info} : IotaArgNonLambda (.var idx name info) + | fvar {id name info} : IotaArgNonLambda (.fvar id name info) + | sort {u info} : IotaArgNonLambda (.sort u info) + | const {id us info} : IotaArgNonLambda (.const id us info) + | app {f arg info} : IotaArgNonLambda (.app f arg info) + | all {name bi ty body info} : IotaArgNonLambda (.all name bi ty body info) + | letE {name ty val body nondep info} : + IotaArgNonLambda (.letE name ty val body nondep info) + | prj {id field val info} : IotaArgNonLambda (.prj id field val info) + | nat {value blob info} : IotaArgNonLambda (.nat value blob info) + | str {value blob info} : IotaArgNonLambda (.str value blob info) + +namespace IotaArgNonLambda + +/-- Exact transient execution equation for every non-lambda shape. -/ +theorem applyIotaArg_true + {result : KExpr .anon} (h : IotaArgNonLambda result) + (arg : KExpr .anon) : + RecM.applyIotaArg result arg true = pure (KExpr.mkApp result arg) := by + cases h <;> rfl + +/-- State-level form of `applyIotaArg_true`: direct rebuilding performs no +monadic effect. -/ +theorem applyIotaArg_true_run + {result : KExpr .anon} (h : IotaArgNonLambda result) + (arg : KExpr .anon) (methods : Methods .anon) (s : TcState .anon) : + (RecM.applyIotaArg result arg true).run methods s = + .ok (KExpr.mkApp result arg) s := by + rw [h.applyIotaArg_true arg] + rfl + +end IotaArgNonLambda + +namespace WhnfMeaning + +/-- Rebuilding an application with smart-constructor metadata preserves its +Theory meaning. Both concrete terms translate to the same typed Theory +application; no address equality is used. -/ +theorem appRebuild + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {result arg : KExpr .anon} + {sourceInfo : ExprInfo .anon} + {resultV argV A B : Lean4Lean.VExpr} + (hresultTy : world.venv.HasType uvars Delta.toCtx resultV + (.forallE A B)) + (hargTy : world.venv.HasType uvars Delta.toCtx argV A) + (hresultTr : TrKExprS world.venv uvars world.nameOf trProj Delta + result resultV) + (hargTr : TrKExprS world.venv uvars world.nameOf trProj Delta arg argV) : + WhnfMeaning trProj world uvars Delta + (.app result arg sourceInfo) (KExpr.mkApp result arg) := by + have hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.app result arg sourceInfo) (.app resultV argV) := + .app hresultTy hargTy hresultTr hargTr + have hrebuilt : TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkApp result arg) (.app resultV argV) := by + rw [KExpr.mkApp_shape] + exact .app hresultTy hargTy hresultTr hargTr + exact ⟨_, _, hsource, hrebuilt, + Lean4Lean.VEnv.IsDefEqU.refl + ⟨_, Lean4Lean.VEnv.HasType.app hresultTy hargTy⟩⟩ + +end WhnfMeaning + +namespace RecM + +/-- Transient non-lambda application combines exact production execution +with the semantic smart-constructor rebuild theorem. -/ +theorem applyIotaArg_true_nonlam_semantic + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {result arg : KExpr .anon} + {sourceInfo : ExprInfo .anon} + (hnonlam : IotaArgNonLambda result) + (methods : Methods .anon) (s : TcState .anon) + {resultV argV A B : Lean4Lean.VExpr} + (hresultTy : world.venv.HasType uvars Delta.toCtx resultV + (.forallE A B)) + (hargTy : world.venv.HasType uvars Delta.toCtx argV A) + (hresultTr : TrKExprS world.venv uvars world.nameOf trProj Delta + result resultV) + (hargTr : TrKExprS world.venv uvars world.nameOf trProj Delta arg argV) : + (RecM.applyIotaArg result arg true).run methods s = + .ok (KExpr.mkApp result arg) s ∧ + WhnfMeaning trProj world uvars Delta + (.app result arg sourceInfo) (KExpr.mkApp result arg) := + ⟨hnonlam.applyIotaArg_true_run arg methods s, + WhnfMeaning.appRebuild hresultTy hargTy hresultTr hargTr⟩ + +/-- Non-transient application is exactly one direct-intern request. The +finite support premise is deliberately about the rebuilt node production +passes to the intern table. -/ +theorem applyIotaArg_false_eval + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {result arg : KExpr .anon} + {s : TcState .anon} + (hcollision : support.CollisionFree) + (hsupport : support (KExpr.mkApp result arg)) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (methods : Methods .anon) : + ∃ s', + (RecM.applyIotaArg result arg false).run methods s = + .ok (KExpr.mkApp result arg) s' ∧ + WhnfStateInv layer semantics trProj world support uvars Delta s' ∧ + InternUpdateFrame s s' := by + obtain ⟨s', hintern, hI', hframe⟩ := + TcM.intern_whnf_eval hcollision hsupport hI + refine ⟨s', ?_, hI', hframe⟩ + rw [Ix.Tc.RecM.applyIotaArg_false] + exact hintern + +/-- Full non-transient per-argument contract: execution is intern-only, the +WHNF invariant is preserved, and the returned smart application has the +expected Theory meaning. -/ +theorem applyIotaArg_false_semantic + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {result arg : KExpr .anon} + {sourceInfo : ExprInfo .anon} {s : TcState .anon} + (hcollision : support.CollisionFree) + (hsupport : support (KExpr.mkApp result arg)) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (methods : Methods .anon) + {resultV argV A B : Lean4Lean.VExpr} + (hresultTy : world.venv.HasType uvars Delta.toCtx resultV + (.forallE A B)) + (hargTy : world.venv.HasType uvars Delta.toCtx argV A) + (hresultTr : TrKExprS world.venv uvars world.nameOf trProj Delta + result resultV) + (hargTr : TrKExprS world.venv uvars world.nameOf trProj Delta arg argV) : + ∃ s', + (RecM.applyIotaArg result arg false).run methods s = + .ok (KExpr.mkApp result arg) s' ∧ + WhnfStateInv layer semantics trProj world support uvars Delta s' ∧ + InternUpdateFrame s s' ∧ + WhnfMeaning trProj world uvars Delta + (.app result arg sourceInfo) (KExpr.mkApp result arg) := by + obtain ⟨s', hrun, hI', hframe⟩ := + applyIotaArg_false_eval hcollision hsupport hI methods + exact ⟨s', hrun, hI', hframe, + WhnfMeaning.appRebuild hresultTy hargTy hresultTr hargTr⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/ArgumentExecution.lean b/Ix/Tc/Verify/Whnf/Iota/ArgumentExecution.lean new file mode 100644 index 000000000..bdfc4f840 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/ArgumentExecution.lean @@ -0,0 +1,616 @@ +import Ix.Tc.Verify.Whnf.Iota.ArgumentBranches + +/-! +# Semantic execution of iota argument lists + +Ordinary iota applies three consecutive argument segments to an instantiated +rule RHS: parameters/motives/minors from the source spine, constructor fields, +and the source's trailing over-application. Nat-literal iota uses the same +segments, but beta-reduces transient lambda intermediates without interning. + +The one-argument branches proved in Substitution/ArgumentBranches therefore cannot be composed by +tracking structural syntax alone: a transient beta result generally is not a +structural translation of the Theory application that preceded it. This +slice tracks the result in the quotient relation `TrKExpr` instead. Each +successful step records its exact production run, invariant/frame facts, +finite support, and `WhnfMeaning`; induction then transports the quotient +translation through every intermediate. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace KExpr + +/-- The transient substitution fast path is syntax-independent: once the +stored loose-bvar bound is below the current depth, no constructor inspection +or rebuilding occurs. -/ +theorem substNoIntern_of_lbr_le {body arg : KExpr m} {depth : UInt64} + (h : body.lbr ≤ depth) : substNoIntern body arg depth = body := by + cases body <;> simp_all [substNoIntern] + +/-- Closed-at-cutoff terms are unchanged by the local lift used at a +transient substitution hit. -/ +theorem liftNoIntern_of_lbr_le {e : KExpr m} {shift cutoff : UInt64} + (h : e.lbr ≤ cutoff) : + substNoIntern.liftNoIntern e shift cutoff = e := by + cases e <;> simp_all [substNoIntern.liftNoIntern] + +end KExpr + +namespace WhnfMeaning + +/-- If a source has a quotient translation and reduces with `WhnfMeaning`, +the concrete result has the same quotient translation. Structural +translation uniqueness reconciles the source representative stored in the +meaning proof with the representative stored in the quotient. -/ +theorem resultQuot + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (theory : WhnfTheory trProj world uvars) + {Delta : KVLCtx} (hDelta : KVLCtx.WF world.venv uvars Delta) + {source result : KExpr .anon} {target : VExpr} + (hsource : TrKExpr world.venv uvars world.nameOf trProj Delta + source target) + (hmeaning : WhnfMeaning trProj world uvars Delta source result) : + TrKExpr world.venv uvars world.nameOf trProj Delta result target := by + obtain ⟨sourceV, resultV, hsourceS, hresultS, hdefeq⟩ := hmeaning + have hsourceQ := hsourceS.trKExpr world.venvWF.ordered + theory.literalWF theory.projections.wf hDelta + have hctx := KVLCtx.IsDefEq.refl world.venvWF hDelta + have hsourceEq := hsourceQ.uniq world.venvWF theory.literalWF + theory.projections hctx hsource + have hresultEq := hdefeq.symm.trans world.venvWF hDelta hsourceEq + exact (hresultS.trKExpr world.venvWF.ordered theory.literalWF + theory.projections.wf hDelta).defeq world.venvWF hDelta hresultEq + +/-- A structural source and a quotient-translated result at the same Theory +expression form a `WhnfMeaning` proof. The quotient's representative may +differ syntactically; its stored equality supplies the semantic bridge. -/ +theorem ofStructuralQuot + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {source result : KExpr .anon} {target : VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + source target) + (hresult : TrKExpr world.venv uvars world.nameOf trProj Delta + result target) : + WhnfMeaning trProj world uvars Delta source result := by + obtain ⟨resultV, hresultS, hresultEq⟩ := hresult + exact ⟨target, resultV, hsource, hresultS, hresultEq.symm⟩ + +end WhnfMeaning + +namespace RecM + +/-- The extracted production loop is exactly a left-to-right monadic fold. +This equation fixes argument order independently of the three array slices +selected by ordinary iota. -/ +theorem applyIotaArgs_eq_foldlM (result : KExpr m) + (args : Array (KExpr m)) (transient : Bool) : + applyIotaArgs result args transient = + args.foldlM (m := RecM m) + (fun result arg => applyIotaArg result arg transient) result := by + unfold applyIotaArgs + simp [Array.forIn_yield_eq_foldlM] + +/-- A successful, semantically justified execution of `applyIotaArg` over a +list in production order. The Theory index is the unreduced left-associated +application. Concrete intermediates may instead be beta-reduced terms; the +step meaning is what relates the two views. -/ +inductive ApplyIotaArgsTrace + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (methods : Methods .anon) + (transient : Bool) : + KExpr .anon → VExpr → TcState .anon → + List (KExpr .anon) → KExpr .anon → VExpr → + TcState .anon → Prop + | nil (result resultV s) : + ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient result resultV s [] result resultV s + | cons {result resultV s arg argV A B next s1 rest final finalV sf} + (hfun : world.venv.HasType uvars Delta.toCtx resultV + (.forallE A B)) + (harg : world.venv.HasType uvars Delta.toCtx argV A) + (hargTr : TrKExprS world.venv uvars world.nameOf trProj Delta arg argV) + (hrun : (applyIotaArg result arg transient).run methods s = + .ok next s1) + (hpost : WhnfStateInv layer semantics trProj world support uvars Delta + s1) + (hframe : InternUpdateFrame s s1) + (hnextSupport : support next) + (hmeaning : WhnfMeaning trProj world uvars Delta + (KExpr.mkApp result arg) next) + (tail : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient next (.app resultV argV) s1 rest final + finalV sf) : + ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient result resultV s (arg :: rest) final finalV sf + +namespace ApplyIotaArgsTrace + +/-- One justified argument step is a singleton trace. -/ +theorem singleton + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {result next : KExpr .anon} + {resultV argV A B : VExpr} {arg : KExpr .anon} + {s s1 : TcState .anon} + (hfun : world.venv.HasType uvars Delta.toCtx resultV (.forallE A B)) + (harg : world.venv.HasType uvars Delta.toCtx argV A) + (hargTr : TrKExprS world.venv uvars world.nameOf trProj Delta arg argV) + (hrun : (applyIotaArg result arg transient).run methods s = .ok next s1) + (hpost : WhnfStateInv layer semantics trProj world support uvars Delta s1) + (hframe : InternUpdateFrame s s1) + (hnextSupport : support next) + (hmeaning : WhnfMeaning trProj world uvars Delta + (KExpr.mkApp result arg) next) : + ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient result resultV s [arg] next (.app resultV argV) s1 := + .cons hfun harg hargTr hrun hpost hframe hnextSupport hmeaning + (.nil next (.app resultV argV) s1) + +/-- Sequential traces concatenate without losing their intermediate state or +quotient Theory index. -/ +theorem append + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start middle final : KExpr .anon} + {startV middleV finalV : VExpr} {s sm sf : TcState .anon} + {first second : List (KExpr .anon)} + (hfirst : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient start startV s first middle middleV sm) + (hsecond : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient middle middleV sm second final finalV sf) : + ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient start startV s (first ++ second) final finalV sf := by + induction hfirst with + | nil => exact hsecond + | cons hfun harg hargTr hrun hpost hframe hnextSupport hmeaning tail ih => + exact .cons hfun harg hargTr hrun hpost hframe hnextSupport hmeaning + (ih hsecond) + +/-- Three-way specialization matching ordinary iota's prefix, constructor +field, and trailing-spine segments. -/ +theorem three + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start middle1 middle2 final : KExpr .anon} + {startV middleV1 middleV2 finalV : VExpr} + {s s1 s2 sf : TcState .anon} + {first second third : List (KExpr .anon)} + (hfirst : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient start startV s first middle1 middleV1 s1) + (hsecond : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient middle1 middleV1 s1 second middle2 middleV2 s2) + (hthird : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient middle2 middleV2 s2 third final finalV sf) : + ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient start startV s ((first ++ second) ++ third) final + finalV sf := + (hfirst.append hsecond).append hthird + +/-- Quotient-aware package for ArgumentBranches's transient non-lambda branch. The +`expectedV` head may differ from the structural translation `resultV` of the +concrete intermediate; this is exactly what happens after an earlier +transient beta step. -/ +theorem transientNonLambdaSingletonQuot + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {result arg : KExpr .anon} + {expectedV resultV argV expectedA expectedB A B : VExpr} + {s : TcState .anon} + (hnonlam : IotaArgNonLambda result) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hresultSupport : support (KExpr.mkApp result arg)) + (hexpectedTy : world.venv.HasType uvars Delta.toCtx expectedV + (.forallE expectedA expectedB)) + (hexpectedArgTy : world.venv.HasType uvars Delta.toCtx argV expectedA) + (hresultTy : world.venv.HasType uvars Delta.toCtx resultV + (.forallE A B)) + (hargTy : world.venv.HasType uvars Delta.toCtx argV A) + (hresultTr : TrKExprS world.venv uvars world.nameOf trProj Delta + result resultV) + (hargTr : TrKExprS world.venv uvars world.nameOf trProj Delta arg argV) : + ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods true result expectedV s [arg] (KExpr.mkApp result arg) + (.app expectedV argV) s := by + obtain ⟨hrun, hmeaning⟩ := applyIotaArg_true_nonlam_semantic + (sourceInfo := (KExpr.mkApp result arg).info) + hnonlam methods s hresultTy hargTy hresultTr hargTr + apply singleton hexpectedTy hexpectedArgTy hargTr hrun hI + (InternUpdateFrame.refl s) hresultSupport + rw [KExpr.mkApp_shape] + exact hmeaning + +/-- Structural specialization of `transientNonLambdaSingletonQuot`. -/ +theorem transientNonLambdaSingleton + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {result arg : KExpr .anon} {resultV argV A B : VExpr} + {s : TcState .anon} + (hnonlam : IotaArgNonLambda result) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hresultSupport : support (KExpr.mkApp result arg)) + (hresultTy : world.venv.HasType uvars Delta.toCtx resultV + (.forallE A B)) + (hargTy : world.venv.HasType uvars Delta.toCtx argV A) + (hresultTr : TrKExprS world.venv uvars world.nameOf trProj Delta + result resultV) + (hargTr : TrKExprS world.venv uvars world.nameOf trProj Delta arg argV) : + ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods true result resultV s [arg] (KExpr.mkApp result arg) + (.app resultV argV) s := + transientNonLambdaSingletonQuot hnonlam hI hresultSupport + hresultTy hargTy hresultTy hargTy hresultTr hargTr + +/-- Package ArgumentBranches's ordinary interned branch as a singleton executor trace. +The returned state is existential because the intern table may grow. -/ +theorem internedSingleton + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {result arg : KExpr .anon} {resultV argV A B : VExpr} + {s : TcState .anon} + (hcollision : support.CollisionFree) + (hresultSupport : support (KExpr.mkApp result arg)) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hresultTy : world.venv.HasType uvars Delta.toCtx resultV + (.forallE A B)) + (hargTy : world.venv.HasType uvars Delta.toCtx argV A) + (hresultTr : TrKExprS world.venv uvars world.nameOf trProj Delta + result resultV) + (hargTr : TrKExprS world.venv uvars world.nameOf trProj Delta arg argV) : + ∃ s1, + ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods false result resultV s [arg] (KExpr.mkApp result arg) + (.app resultV argV) s1 := by + obtain ⟨s1, hrun, hpost, hframe, hmeaning⟩ := + applyIotaArg_false_semantic + (sourceInfo := (KExpr.mkApp result arg).info) + hcollision hresultSupport hI methods hresultTy hargTy hresultTr hargTr + refine ⟨s1, singleton hresultTy hargTy hargTr hrun hpost hframe + hresultSupport ?_⟩ + rw [KExpr.mkApp_shape] + exact hmeaning + +/-- Quotient-aware package for Substitution's transient beta branch. The concrete +lambda is translated structurally for the beta proof, while `expectedV` is +the quotient-level head inherited from all preceding argument steps. -/ +theorem transientLambdaSingletonQuot + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body arg : KExpr .anon} {info : ExprInfo .anon} + {expectedV expectedA expectedB A bodyV argV B : VExpr} + {univ : Lean4Lean.VLevel} + {s : TcState .anon} + (hexpectedTy : world.venv.HasType uvars Delta.toCtx expectedV + (.forallE expectedA expectedB)) + (hexpectedArgTy : world.venv.HasType uvars Delta.toCtx argV expectedA) + (projections : TrProjOK world.venv uvars trProj) + (hty : TrKExprS world.venv uvars world.nameOf trProj Delta ty A) + (hbody : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam A) :: Delta) body bodyV) + (harg : TrKExprS world.venv uvars world.nameOf trProj Delta arg argV) + (hA : world.venv.HasType uvars Delta.toCtx A (.sort univ)) + (hbodyTy : world.venv.HasType uvars (A :: Delta.toCtx) bodyV B) + (hargTy : world.venv.HasType uvars Delta.toCtx argV A) + (hbodyCon : KExpr.Constructed body) + (hargCon : KExpr.Constructed arg) + (hbig : Delta.bvars + body.size + arg.size < UInt64.size) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hresultSupport : support (substNoIntern body arg 0)) : + ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods true (.lam name bi ty body info) expectedV s [arg] + (substNoIntern body arg 0) (.app expectedV argV) s := by + have hrun : + (applyIotaArg (.lam name bi ty body info) arg true).run methods s = + .ok (substNoIntern body arg 0) s := by + rw [Ix.Tc.RecM.applyIotaArg_true_lam] + rfl + have hmeaning := WhnfMeaning.betaNoIntern (trProj := trProj) + (world := world) (uvars := uvars) (Delta := Delta) + (projections := projections) + (nm := name) (bi := bi) + (lamMd := info) (appMd := + (KExpr.mkApp (.lam name bi ty body info) arg).info) + (bodyV := bodyV) (B := B) + hty hbody harg hA hbodyTy hargTy hbodyCon hargCon hbig + apply singleton hexpectedTy hexpectedArgTy harg hrun hI + (InternUpdateFrame.refl s) hresultSupport + rw [KExpr.mkApp_shape] + exact hmeaning + +/-- Structural-head specialization of `transientLambdaSingletonQuot`. Its +Theory index is the unreduced application, whereas its concrete result is the +exact non-interning substitution returned by production. -/ +theorem transientLambdaSingleton + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body arg : KExpr .anon} {info : ExprInfo .anon} + {A bodyV argV B : VExpr} {univ : Lean4Lean.VLevel} + {s : TcState .anon} + (projections : TrProjOK world.venv uvars trProj) + (hty : TrKExprS world.venv uvars world.nameOf trProj Delta ty A) + (hbody : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam A) :: Delta) body bodyV) + (harg : TrKExprS world.venv uvars world.nameOf trProj Delta arg argV) + (hA : world.venv.HasType uvars Delta.toCtx A (.sort univ)) + (hbodyTy : world.venv.HasType uvars (A :: Delta.toCtx) bodyV B) + (hargTy : world.venv.HasType uvars Delta.toCtx argV A) + (hbodyCon : KExpr.Constructed body) + (hargCon : KExpr.Constructed arg) + (hbig : Delta.bvars + body.size + arg.size < UInt64.size) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hresultSupport : support (substNoIntern body arg 0)) : + ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods true (.lam name bi ty body info) (.lam A bodyV) s [arg] + (substNoIntern body arg 0) (.app (.lam A bodyV) argV) s := + transientLambdaSingletonQuot + (Lean4Lean.VEnv.HasType.lam hA hbodyTy) hargTy projections + hty hbody harg hA hbodyTy hargTy hbodyCon hargCon hbig hI + hresultSupport + +/-- Erase a trace to the exact list-fold execution. -/ +theorem evalList + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start final : KExpr .anon} + {startV finalV : VExpr} {s sf : TcState .anon} + {args : List (KExpr .anon)} + (h : ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient start startV s args final finalV sf) : + (args.foldlM (m := RecM .anon) + (fun result arg => applyIotaArg result arg transient) start).run + methods s = .ok final sf := by + induction h with + | nil => rfl + | cons hfun harg hargTr hrun hpost hframe hnextSupport hmeaning tail ih => + rw [List.foldlM_cons, ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (applyIotaArg _ _ _) methods) _ _ = _ + unfold EStateM.bind + rw [hrun] + exact ih + +/-- Array form matching the actual production helper. -/ +theorem evalArray + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start final : KExpr .anon} + {startV finalV : VExpr} {s sf : TcState .anon} + {args : Array (KExpr .anon)} + (h : ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient start startV s args.toList final finalV sf) : + (applyIotaArgs start args transient).run methods s = .ok final sf := by + rw [applyIotaArgs_eq_foldlM] + simpa only [← Array.foldlM_toList] using h.evalList + +/-- The concrete unreduced application fold structurally translates to the +Theory application index carried by the trace. -/ +theorem sourceTr + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start final : KExpr .anon} + {startV finalV : VExpr} {s sf : TcState .anon} + {args : List (KExpr .anon)} + (h : ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient start startV s args final finalV sf) + {replacement : KExpr .anon} + (hstart : TrKExprS world.venv uvars world.nameOf trProj Delta replacement + startV) : + TrKExprS world.venv uvars world.nameOf trProj Delta + (args.foldl KExpr.mkApp replacement) finalV := by + induction h generalizing replacement with + | nil => exact hstart + | cons hfun harg hargTr hrun hpost hframe hnextSupport hmeaning tail ih => + rw [List.foldl_cons] + apply ih + rw [KExpr.mkApp_shape] + exact .app hfun harg hstart hargTr + +/-- The actual concrete result quotient-translates to the unreduced Theory +application index. This is the central invariant: transient beta and direct +application rebuilding are both admitted by the same induction. -/ +theorem finalQuot + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start final : KExpr .anon} + {startV finalV : VExpr} {s sf : TcState .anon} + {args : List (KExpr .anon)} + (h : ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient start startV s args final finalV sf) + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hstart : TrKExpr world.venv uvars world.nameOf trProj Delta start + startV) : + TrKExpr world.venv uvars world.nameOf trProj Delta final finalV := by + induction h with + | nil => exact hstart + | @cons result resultV s arg argV A B next s1 rest final finalV sf + hfun harg hargTr hrun hpost hframe hnextSupport hmeaning tail ih => + have hargQ := hargTr.trKExpr world.venvWF.ordered + theory.literalWF theory.projections.wf hDelta + have happQ : TrKExpr world.venv uvars world.nameOf trProj Delta + (KExpr.mkApp result arg) (.app resultV argV) := by + rw [KExpr.mkApp_shape] + exact TrKExpr.app world.venvWF hDelta hfun harg hstart hargQ + have hnextQ := hmeaning.resultQuot theory hDelta happQ + exact ih hnextQ + +/-- Every successful step preserves the complete fixed-layer invariant. -/ +theorem finalInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start final : KExpr .anon} + {startV finalV : VExpr} {s sf : TcState .anon} + {args : List (KExpr .anon)} + (h : ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient start startV s args final finalV sf) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) : + WhnfStateInv layer semantics trProj world support uvars Delta sf := by + induction h with + | nil => exact hI + | cons hfun harg hargTr hrun hpost hframe hnextSupport hmeaning tail ih => + exact ih hpost + +/-- All per-argument intern-only frames compose. Transient steps contribute +the reflexive frame, while ordinary steps may grow the intern table. -/ +theorem frame + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start final : KExpr .anon} + {startV finalV : VExpr} {s sf : TcState .anon} + {args : List (KExpr .anon)} + (h : ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient start startV s args final finalV sf) : + InternUpdateFrame s sf := by + induction h with + | nil => exact InternUpdateFrame.refl _ + | cons hfun harg hargTr hrun hpost hframe hnextSupport hmeaning tail ih => + exact hframe.trans ih + +/-- Finite support is threaded through beta results and rebuilt +applications, so the final reducer output is admissible as a WHNF step. -/ +theorem finalSupport + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start final : KExpr .anon} + {startV finalV : VExpr} {s sf : TcState .anon} + {args : List (KExpr .anon)} + (h : ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient start startV s args final finalV sf) + (hstart : support start) : support final := by + induction h with + | nil => exact hstart + | cons hfun harg hargTr hrun hpost hframe hnextSupport hmeaning tail ih => + exact ih hnextSupport + +/-- Complete semantic postcondition of a certified list execution. -/ +theorem acceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start final : KExpr .anon} + {startV finalV : VExpr} {s sf : TcState .anon} + {args : List (KExpr .anon)} + (h : ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient start startV s args final finalV sf) + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hstartSupport : support start) + (hstartTr : TrKExprS world.venv uvars world.nameOf trProj Delta start + startV) : + (args.foldlM (m := RecM .anon) + (fun result arg => applyIotaArg result arg transient) start).run + methods s = .ok final sf ∧ + WhnfStateInv layer semantics trProj world support uvars Delta sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + WhnfMeaning trProj world uvars Delta + (args.foldl KExpr.mkApp start) final := by + have hstartQ := hstartTr.trKExpr world.venvWF.ordered + theory.literalWF theory.projections.wf hDelta + exact ⟨h.evalList, h.finalInv hI, h.frame, h.finalSupport hstartSupport, + WhnfMeaning.ofStructuralQuot (h.sourceTr hstartTr) + (h.finalQuot theory hDelta hstartQ)⟩ + +/-- Execute three certified arrays through the same sequence of helper calls +used by ordinary iota. This is stronger than merely executing their +concatenated list: it exposes both intermediate production states. -/ +theorem evalThreeArrays + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start middle1 middle2 final : KExpr .anon} + {startV middleV1 middleV2 finalV : VExpr} + {s s1 s2 sf : TcState .anon} + {first second third : Array (KExpr .anon)} + (hfirst : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient start startV s first.toList middle1 middleV1 s1) + (hsecond : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient middle1 middleV1 s1 second.toList middle2 + middleV2 s2) + (hthird : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient middle2 middleV2 s2 third.toList final finalV + sf) : + (do + let result ← applyIotaArgs start first transient + let result ← applyIotaArgs result second transient + applyIotaArgs result third transient).run methods s = .ok final sf := by + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (applyIotaArgs start first transient) methods) _ s = _ + unfold EStateM.bind + rw [hfirst.evalArray] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (applyIotaArgs middle1 second transient) methods) _ s1 = _ + unfold EStateM.bind + rw [hsecond.evalArray] + simp only + exact hthird.evalArray + +/-- Complete ArgumentExecution contract for production's three iota argument segments. +The operational conclusion uses three actual `applyIotaArgs` calls; the +semantic conclusion uses their single left-associated Theory application +sequence and retains trailing over-application. -/ +theorem threeArrayAcceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start middle1 middle2 final : KExpr .anon} + {startV middleV1 middleV2 finalV : VExpr} + {s s1 s2 sf : TcState .anon} + {first second third : Array (KExpr .anon)} + (hfirst : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient start startV s first.toList middle1 middleV1 s1) + (hsecond : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient middle1 middleV1 s1 second.toList middle2 + middleV2 s2) + (hthird : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient middle2 middleV2 s2 third.toList final finalV + sf) + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hstartSupport : support start) + (hstartTr : TrKExprS world.venv uvars world.nameOf trProj Delta start + startV) : + (do + let result ← applyIotaArgs start first transient + let result ← applyIotaArgs result second transient + applyIotaArgs result third transient).run methods s = .ok final sf ∧ + WhnfStateInv layer semantics trProj world support uvars Delta sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + WhnfMeaning trProj world uvars Delta + (((first.toList ++ second.toList) ++ third.toList).foldl + KExpr.mkApp start) final := by + have htrace := hfirst.three hsecond hthird + have hsemantic := htrace.acceptance theory hDelta hI hstartSupport hstartTr + exact ⟨evalThreeArrays hfirst hsecond hthird, hsemantic.2⟩ + +end ApplyIotaArgsTrace + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/ConstructorDispatch.lean b/Ix/Tc/Verify/Whnf/Iota/ConstructorDispatch.lean new file mode 100644 index 000000000..0f4d1284b --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/ConstructorDispatch.lean @@ -0,0 +1,608 @@ +import Ix.Tc.Verify.Whnf.Iota.SelectedRule + +/-! +# Ordinary-constructor iota dispatch + +SelectedRule verifies execution after one concrete recursor rule has already been +selected. This slice moves the boundary outward through production's rule +array lookup, universe-arity guard, and constructor-field guard. It also +records the exact regular-constructor path through `tryIotaWithFlags`: +recursor lookup, major cleanup/WHNF, constructor lookup, and dispatch. + +The trace deliberately excludes the three preprocessing variants that alter +the major before constructor dispatch: K synthesis, Nat-literal expansion, +and String-literal expansion. Those remain separate exhaustive branches; +the regular theorem cannot silently justify any of them. +-/ + +namespace Ix.Tc + +open Lean4Lean (VDefEq VExpr) + +namespace KConst + +/-- The pure iota snapshot retains production's exact wrapping major index. -/ +theorem recursorMajorIdx_of_iotaInfo + {c : KConst .anon} {recr : IotaInfo .anon} + (hinfo : c.iotaInfo? = some recr) : + c.RecursorMajorIdx = some recr.majorIdx := by + cases c <;> simp [KConst.iotaInfo?] at hinfo + case recr => + cases hinfo + simp [KConst.RecursorMajorIdx] + +/-- A rule selected from the decoded snapshot is at the same position in the +loaded recursor declaration. This prevents a semantic certificate for one +array slot from being reused for another. -/ +theorem recursorRuleAt_of_iotaInfo + {c : KConst .anon} {recr : IotaInfo .anon} + (hinfo : c.iotaInfo? = some recr) + {index : Nat} {rule : RecRule .anon} + (hrule : recr.rules[index]? = some rule) : + c.RecursorRuleAt index rule := by + cases c <;> simp [KConst.iotaInfo?] at hinfo + case recr => + cases hinfo + exact hrule + +end KConst + +namespace RecM + +/-- Exact successful execution data for the constructor-dispatch helper. +The selected rule is an index, rather than existential data hidden inside the +record, so this remains a proof-irrelevant operational certificate. -/ +structure TryApplyIotaCtorSuccessTrace + (methods : Methods .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) + (spine ctorArgs : Array (KExpr .anon)) (cidx ctorFields : Nat) + (transient : Bool) (rule : RecRule .anon) + (s : TcState .anon) (final : KExpr .anon) (sf : TcState .anon) : Prop where + selected : recr.rules[cidx]? = some rule + levelArity : recUs.size.toUInt64 = recr.lvls + fieldBound : ctorFields ≤ ctorArgs.size + apply : (applyIotaRule rule recUs recr spine ctorArgs ctorFields + transient).run methods s = .ok final sf + +namespace TryApplyIotaCtorSuccessTrace + +/-- Erase the dispatch certificate to the exact extracted production run. -/ +theorem eval + {methods : Methods .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} + {spine ctorArgs : Array (KExpr .anon)} {cidx ctorFields : Nat} + {transient : Bool} {rule : RecRule .anon} + {s : TcState .anon} {final : KExpr .anon} {sf : TcState .anon} + (h : TryApplyIotaCtorSuccessTrace methods recr recUs spine ctorArgs + cidx ctorFields transient rule s final sf) : + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields transient).run + methods s = .ok (some final) sf := by + unfold tryApplyIotaCtor + rw [h.selected] + simp only + have hlevels : (recUs.size.toUInt64 != recr.lvls) = false := by + simp [h.levelArity] + rw [hlevels] + simp only [Bool.false_eq_true, ↓reduceIte] + rw [if_neg (Nat.not_lt.mpr h.fieldBound)] + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (applyIotaRule rule recUs recr spine ctorArgs ctorFields transient) + methods) _ s = _ + unfold EStateM.bind + rw [h.apply] + rfl + +end TryApplyIotaCtorSuccessTrace + +/-- Semantic dispatch certificate: the guard facts are tied to SelectedRule's exact +selected-rule trace, so the operational rule and the semantically interpreted +rule cannot drift apart. -/ +structure ApplyIotaCtorTrace + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (methods : Methods .anon) + (recr : IotaInfo .anon) (recUs : Array (KUniv .anon)) + (spine ctorArgs : Array (KExpr .anon)) (cidx ctorFields : Nat) + (transient : Bool) (rule : RecRule .anon) (startV : VExpr) + (s : TcState .anon) (final : KExpr .anon) (finalV : VExpr) + (sf : TcState .anon) : Type where + selected : recr.rules[cidx]? = some rule + levelArity : recUs.size.toUInt64 = recr.lvls + fieldBound : ctorFields ≤ ctorArgs.size + ruleTrace : ApplyIotaRuleTrace layer semantics trProj world support uvars + Delta methods rule recUs recr spine ctorArgs ctorFields transient startV + s final finalV sf + +namespace ApplyIotaCtorTrace + +theorem operational + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {spine ctorArgs : Array (KExpr .anon)} {cidx ctorFields : Nat} + {transient : Bool} {rule : RecRule .anon} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaCtorTrace layer semantics trProj world support uvars Delta + methods recr recUs spine ctorArgs cidx ctorFields transient rule startV + s final finalV sf) : + TryApplyIotaCtorSuccessTrace methods recr recUs spine ctorArgs cidx + ctorFields transient rule s final sf := + ⟨h.selected, h.levelArity, h.fieldBound, h.ruleTrace.eval⟩ + +/-- Exact execution of the constructor dispatch seam. -/ +theorem eval + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {spine ctorArgs : Array (KExpr .anon)} {cidx ctorFields : Nat} + {transient : Bool} {rule : RecRule .anon} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaCtorTrace layer semantics trProj world support uvars Delta + methods recr recUs spine ctorArgs cidx ctorFields transient rule startV + s final finalV sf) : + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields transient).run + methods s = .ok (some final) sf := + h.operational.eval + +/-- The exact decoded rule position is also a position in the loaded +recursor that produced the snapshot. -/ +theorem recursorRuleAt + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {spine ctorArgs : Array (KExpr .anon)} {cidx ctorFields : Nat} + {transient : Bool} {rule : RecRule .anon} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaCtorTrace layer semantics trProj world support uvars Delta + methods recr recUs spine ctorArgs cidx ctorFields transient rule startV + s final finalV sf) + {recursor : KConst .anon} + (hinfo : recursor.iotaInfo? = some recr) : + recursor.RecursorRuleAt cidx rule := + KConst.recursorRuleAt_of_iotaInfo hinfo h.selected + +/-- Parameter-free semantic acceptance before relating the registered rule +back to an original recursor application. -/ +theorem acceptance_empty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {spine ctorArgs : Array (KExpr .anon)} {cidx ctorFields : Nat} + {transient : Bool} {rule : RecRule .anon} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaCtorTrace layer semantics trProj world support uvars Delta + methods recr recUs spine ctorArgs cidx ctorFields transient rule startV + s final finalV sf) + (hempty : recUs.isEmpty = true) + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hruleSupport : support rule.rhs) + (hruleTr : TrKExpr world.venv uvars world.nameOf trProj Delta rule.rhs + startV) : + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields transient).run + methods s = .ok (some final) sf ∧ + WhnfStateInv layer semantics trProj world support uvars Delta sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + TrKExpr world.venv uvars world.nameOf trProj Delta final finalV ∧ + WhnfMeaning trProj world uvars Delta + ((((iotaPrefixArgs recr spine).toList ++ + (iotaFieldArgs ctorArgs ctorFields).toList) ++ + (iotaTrailingArgs recr spine).toList).foldl + KExpr.mkApp h.ruleTrace.rhs) final := by + have hacc := h.ruleTrace.acceptance_empty hempty theory hDelta hI + hruleSupport hruleTr + exact ⟨h.eval, hacc.2⟩ + +/-- Parameter-free checked acceptance lifted through the exact rule-selection +and guard helper. Runtime/pattern alignment is added by the outer regular +branch theorem below, where the constructor lookup is still visible. -/ +theorem checkedAcceptance_empty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {methods : Methods .anon} + {id : KId .anon} {recursor : KConst .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {spine ctorArgs : Array (KExpr .anon)} {cidx ctorFields : Nat} + {transient : Bool} {rule : RecRule .anon} {defeq : VDefEq} + {startV : VExpr} {s : TcState .anon} + {final : KExpr .anon} {finalV : VExpr} {sf : TcState .anon} + (h : ApplyIotaCtorTrace layer semantics trProj world support 0 [] + methods recr recUs spine ctorArgs cidx ctorFields transient rule startV + s final finalV sf) + (hregistered : RegisteredRecursorRuleRhsRel world.venv world.nameOf + trProj id recursor rule defeq) + (theory : WhnfTheory trProj world 0) + (hempty : recUs.isEmpty = true) + (harity : defeq.uvars = 0) + (hI : WhnfStateInv layer semantics trProj world support 0 [] s) + (hruleSupport : support rule.rhs) + (hstartV : startV = defeq.rhs) + {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel world.venv world.catalog + world.nameOf id recursor rule pattern) + {source : KExpr .anon} {sourceV sourceType : VExpr} + (hsourceTr : TrKExprS world.venv 0 world.nameOf trProj [] source + sourceV) + (hsourceType : world.venv.HasType 0 [] sourceV sourceType) + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + sourceV levels captures) + (hchecks : pattern.checks.OK + (world.venv.IsDefEqU 0 []) levels captures) + (haligned : IotaRhsApplicationAligned pattern levels captures finalV) : + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields transient).run + methods s = .ok (some final) sf ∧ + WhnfStateInv layer semantics trProj world support 0 [] sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + WhnfMeaning trProj world 0 [] source final := by + have hacc := h.ruleTrace.checkedAcceptance_empty hregistered theory hempty + harity hI hruleSupport hstartV hpattern hsourceTr hsourceType hmatch + hchecks haligned + exact ⟨h.eval, hacc.2⟩ + +/-- Universe-instantiated checked acceptance lifted through the same exact +constructor dispatch. -/ +theorem checkedAcceptance_nonempty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + {id : KId .anon} {recursor : KConst .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {spine ctorArgs : Array (KExpr .anon)} {cidx ctorFields : Nat} + {transient : Bool} {rule : RecRule .anon} {defeq : VDefEq} + {startV : VExpr} {s : TcState .anon} + {final : KExpr .anon} {finalV : VExpr} {sf : TcState .anon} + (h : ApplyIotaCtorTrace layer semantics trProj world support uvars [] + methods recr recUs spine ctorArgs cidx ctorFields transient rule startV + s final finalV sf) + (hregistered : RegisteredRecursorRuleRhsRel world.venv world.nameOf + trProj id recursor rule defeq) + (theory : WhnfTheory trProj world uvars) + (hnonempty : recUs.isEmpty = false) + (hus : ∀ level ∈ recUs, (KUniv.toVLevel level).WF uvars) + (harity : defeq.uvars = recUs.size) + (hcollision : support.CollisionFree) + (hreach : ∀ x, KExpr.InstUnivReach recUs rule.rhs x → support x) + (hI : WhnfStateInv layer semantics trProj world support uvars [] s) + (hfaithful : ∀ left right, + KExpr.LevelReach recUs rule.rhs left → + KExpr.LevelReach recUs rule.rhs right → left.AddrFaithful right) + (hsize : ∀ level, KExpr.LevelReach recUs rule.rhs level → + level.size < UInt64.size) + (hstartV : startV = + defeq.rhs.instL (recUs.toList.map KUniv.toVLevel)) + {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel world.venv world.catalog + world.nameOf id recursor rule pattern) + {source : KExpr .anon} {sourceV sourceType : VExpr} + (hsourceTr : TrKExprS world.venv uvars world.nameOf trProj [] source + sourceV) + (hsourceType : world.venv.HasType uvars [] sourceV sourceType) + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + sourceV levels captures) + (hchecks : pattern.checks.OK + (world.venv.IsDefEqU uvars []) levels captures) + (haligned : IotaRhsApplicationAligned pattern levels captures finalV) : + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields transient).run + methods s = .ok (some final) sf ∧ + WhnfStateInv layer semantics trProj world support uvars [] sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + WhnfMeaning trProj world uvars [] source final := by + have hacc := h.ruleTrace.checkedAcceptance_nonempty hregistered theory + hnonempty hus harity hcollision hreach hI hfaithful hsize hstartV + hpattern hsourceTr hsourceType hmatch hchecks haligned + exact ⟨h.eval, hacc.2⟩ + +end ApplyIotaCtorTrace + +/-- Explicit bridge between the constructor metadata selected by execution +and the pattern metadata supplied by inductive admission. Duplicate rule +bodies make the index equality non-derivable from rule equality alone. -/ +structure IotaCtorDispatchAligned (cidx ctorFields : Nat) + (pattern : RecursorRulePattern) : Prop where + ruleIndex : pattern.ruleIndex = cidx + fields : pattern.constructorFields.toNat = ctorFields + +/-- Shapes that can enter the regular constructor-spine path without Nat or +String literal conversion. A constant is the nullary case; an application +retains an arbitrary nonempty constructor spine. -/ +inductive IotaCtorMajor : KExpr .anon → Prop + | const {id us info} : IotaCtorMajor (.const id us info) + | app {fn arg info} : IotaCtorMajor (.app fn arg info) + +/-- Exact constructor-hit branch of the final dispatch seam. -/ +theorem tryIotaCtorOrStructEta_regular + {methods : Methods .anon} + {s sCtor sf : TcState .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {majorWhnf : KExpr .anon} {transient : Bool} + {ctorId : KId .anon} {ctorUs : Array (KUniv .anon)} + {ctorHeadInfo : ExprInfo .anon} {ctorArgs : Array (KExpr .anon)} + {ctor : KConst .anon} {cidx ctorFields : Nat} + {result : KExpr .anon} + (hctorSpine : majorWhnf.collectSpine = + (.const ctorId ctorUs ctorHeadInfo, ctorArgs)) + (hctorLookup : TcM.tryGetConst ctorId s = .ok (some ctor) sCtor) + (hctorInfo : ctor.iotaCtorInfo? = some (cidx, ctorFields)) + (hdispatch : + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields transient).run + methods sCtor = .ok (some result) sf) : + (tryIotaCtorOrStructEta recId recr recUs spine majorWhnf transient).run + methods s = .ok (some result) sf := by + unfold tryIotaCtorOrStructEta + rw [hctorSpine, ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst ctorId) _ s = _ + unfold EStateM.bind + rw [hctorLookup] + simp only [hctorInfo, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields transient) + methods) _ sCtor = _ + unfold EStateM.bind + rw [hdispatch] + rfl + +/-- Exact regular, non-literal path through post-WHNF preprocessing. -/ +theorem tryIotaAfterMajorWhnf_regular + {methods : Methods .anon} {flags : WhnfFlags} + {s sCleanup sf : TcState .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {majorWhnf : KExpr .anon} {result : KExpr .anon} + (hmajorShape : IotaCtorMajor majorWhnf) + (hcleanup : (cleanupNatOffsetMajor majorWhnf).run methods s = + .ok none sCleanup) + (hdispatch : + (tryIotaCtorOrStructEta recId recr recUs spine majorWhnf false).run + methods sCleanup = .ok (some result) sf) : + (tryIotaAfterMajorWhnf flags recId recr recUs spine majorWhnf).run + methods s = .ok (some result) sf := by + unfold tryIotaAfterMajorWhnf + cases hmajorShape <;> + simp only [pure_bind] + all_goals + rw [ReaderT.run_bind] + change EStateM.bind _ _ s = _ + unfold EStateM.bind + rw [hcleanup] + exact hdispatch + +/-- Exact non-K prefix through recursor lookup, initial cleanup, and the +major callback. Post-WHNF variants remain indexed by `hafter`. -/ +theorem tryIotaWithFlags_nonKPrefix + {methods : Methods .anon} {source : KExpr .anon} {flags : WhnfFlags} + {s sLookup sCleanup sWhnf sf : TcState .anon} + {recId : KId .anon} {recUs : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {spine : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {major majorWhnf result : KExpr .anon} + (hsource : source.collectSpine = (.const recId recUs headInfo, spine)) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sLookup) + (hinfo : recursor.iotaInfo? = some recr) + (hmajorBound : recr.majorIdx < spine.size) + (hmajor : spine[recr.majorIdx]! = major) + (hk : recr.k = false) + (hcleanup : (cleanupNatOffsetMajor major).run methods sLookup = + .ok none sCleanup) + (hwhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec major flags).run methods sCleanup + else (whnfRec major).run methods sCleanup) = + .ok majorWhnf sWhnf) + (hafter : + (tryIotaAfterMajorWhnf flags recId recr recUs spine majorWhnf).run + methods sWhnf = .ok (some result) sf) : + (tryIotaWithFlags source flags).run methods s = .ok (some result) sf := by + unfold tryIotaWithFlags + rw [hsource, ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst recId) _ s = _ + unfold EStateM.bind + rw [hlookup] + simp only + rw [hinfo] + simp only + rw [if_neg (Nat.not_le.mpr hmajorBound)] + rw [hmajor, hk] + simp only [Bool.false_eq_true, ↓reduceIte] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (cleanupNatOffsetMajor major) methods) _ sLookup = _ + unfold EStateM.bind + rw [hcleanup] + simp only [Option.getD] + cases hcheap : flags.cheapRec + · simp only [hcheap, Bool.false_eq_true, ↓reduceIte] at hwhnf ⊢ + change EStateM.bind _ _ sCleanup = _ + unfold EStateM.bind + change whnfRec major methods sCleanup = .ok majorWhnf sWhnf at hwhnf + rw [hwhnf] + exact hafter + · simp only [hcheap, ↓reduceIte] at hwhnf ⊢ + change EStateM.bind _ _ sCleanup = _ + unfold EStateM.bind + change whnfCoreFlagsRec major flags methods sCleanup = + .ok majorWhnf sWhnf at hwhnf + rw [hwhnf] + exact hafter + +/-- Complete regular-constructor branch of `tryIotaWithFlags`. Every +mutable prefix state is explicit, and the three extracted production seams +are composed without unfolding into another preprocessing variant. -/ +theorem tryIotaWithFlags_regularCtor + {methods : Methods .anon} {source : KExpr .anon} {flags : WhnfFlags} + {s sLookup sCleanup sWhnf sCleanupWhnf sCtor sf : TcState .anon} + {recId : KId .anon} {recUs : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {spine : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {major majorWhnf : KExpr .anon} + {ctorId : KId .anon} {ctorUs : Array (KUniv .anon)} + {ctorHeadInfo : ExprInfo .anon} {ctorArgs : Array (KExpr .anon)} + {ctor : KConst .anon} {cidx ctorFields : Nat} + {result : KExpr .anon} + (hsource : source.collectSpine = (.const recId recUs headInfo, spine)) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sLookup) + (hinfo : recursor.iotaInfo? = some recr) + (hmajorBound : recr.majorIdx < spine.size) + (hmajor : spine[recr.majorIdx]! = major) + (hk : recr.k = false) + (hcleanup : (cleanupNatOffsetMajor major).run methods sLookup = + .ok none sCleanup) + (hwhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec major flags).run methods sCleanup + else (whnfRec major).run methods sCleanup) = + .ok majorWhnf sWhnf) + (hmajorShape : IotaCtorMajor majorWhnf) + (hcleanupWhnf : (cleanupNatOffsetMajor majorWhnf).run methods sWhnf = + .ok none sCleanupWhnf) + (hctorSpine : majorWhnf.collectSpine = + (.const ctorId ctorUs ctorHeadInfo, ctorArgs)) + (hctorLookup : TcM.tryGetConst ctorId sCleanupWhnf = + .ok (some ctor) sCtor) + (hctorInfo : ctor.iotaCtorInfo? = some (cidx, ctorFields)) + (hdispatch : + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields false).run + methods sCtor = .ok (some result) sf) : + (tryIotaWithFlags source flags).run methods s = .ok (some result) sf := by + have hctor := tryIotaCtorOrStructEta_regular (recId := recId) + hctorSpine hctorLookup hctorInfo hdispatch + have hafter := tryIotaAfterMajorWhnf_regular (flags := flags) + hmajorShape hcleanupWhnf hctor + exact tryIotaWithFlags_nonKPrefix hsource hlookup hinfo hmajorBound hmajor + hk hcleanup hwhnf hafter + +/-- Headline ConstructorDispatch contract: the actual parameter-free regular-constructor +branch executes the checked rule selected at the runtime constructor index. +The mutable preprocessing prefix must supply its intern-only frame and the +invariant at dispatch ingress; later K1 slices discharge those facts for the +cleanup, callback, and lazy-lookup helpers themselves. -/ +theorem tryIotaWithFlags_regularCtor_checkedAcceptance_empty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {methods : Methods .anon} {source : KExpr .anon} {flags : WhnfFlags} + {s sLookup sCleanup sWhnf sCleanupWhnf sCtor sf : TcState .anon} + {recId : KId .anon} {recUs : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {spine : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {major majorWhnf : KExpr .anon} + {ctorId : KId .anon} {ctorUs : Array (KUniv .anon)} + {ctorHeadInfo : ExprInfo .anon} {ctorArgs : Array (KExpr .anon)} + {ctor : KConst .anon} {cidx ctorFields : Nat} + {rule : RecRule .anon} {defeq : VDefEq} {startV : VExpr} + {final : KExpr .anon} {finalV : VExpr} + (h : ApplyIotaCtorTrace layer semantics trProj world support 0 [] + methods recr recUs spine ctorArgs cidx ctorFields false rule startV + sCtor final finalV sf) + (hcollect : source.collectSpine = (.const recId recUs headInfo, spine)) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sLookup) + (hinfo : recursor.iotaInfo? = some recr) + (hmajorBound : recr.majorIdx < spine.size) + (hmajor : spine[recr.majorIdx]! = major) + (hk : recr.k = false) + (hcleanup : (cleanupNatOffsetMajor major).run methods sLookup = + .ok none sCleanup) + (hwhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec major flags).run methods sCleanup + else (whnfRec major).run methods sCleanup) = + .ok majorWhnf sWhnf) + (hmajorShape : IotaCtorMajor majorWhnf) + (hcleanupWhnf : (cleanupNatOffsetMajor majorWhnf).run methods sWhnf = + .ok none sCleanupWhnf) + (hctorSpine : majorWhnf.collectSpine = + (.const ctorId ctorUs ctorHeadInfo, ctorArgs)) + (hctorLookup : TcM.tryGetConst ctorId sCleanupWhnf = + .ok (some ctor) sCtor) + (hctorInfo : ctor.iotaCtorInfo? = some (cidx, ctorFields)) + (hprefixFrame : InternUpdateFrame s sCtor) + (hdispatchI : WhnfStateInv layer semantics trProj world support 0 [] + sCtor) + (hregistered : RegisteredRecursorRuleRhsRel world.venv world.nameOf + trProj recId recursor rule defeq) + (theory : WhnfTheory trProj world 0) + (hempty : recUs.isEmpty = true) + (harity : defeq.uvars = 0) + (hruleSupport : support rule.rhs) + (hstartV : startV = defeq.rhs) + {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel world.venv world.catalog + world.nameOf recId recursor rule pattern) + (hdispatchAligned : IotaCtorDispatchAligned cidx ctorFields pattern) + {sourceV sourceType : VExpr} + (hsourceTr : TrKExprS world.venv 0 world.nameOf trProj [] source + sourceV) + (hsourceType : world.venv.HasType 0 [] sourceV sourceType) + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + sourceV levels captures) + (hchecks : pattern.checks.OK + (world.venv.IsDefEqU 0 []) levels captures) + (hrhsAligned : IotaRhsApplicationAligned pattern levels captures + finalV) : + (tryIotaWithFlags source flags).run methods s = .ok (some final) sf ∧ + WhnfStateInv layer semantics trProj world support 0 [] sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + WhnfMeaning trProj world 0 [] source final := by + have hpatternDispatch : + ApplyIotaCtorTrace layer semantics trProj world support 0 [] methods + recr recUs spine ctorArgs pattern.ruleIndex + pattern.constructorFields.toNat false rule startV sCtor final finalV + sf := by + simpa only [hdispatchAligned.ruleIndex, hdispatchAligned.fields] using h + have hchecked := hpatternDispatch.checkedAcceptance_empty hregistered + theory hempty harity hdispatchI hruleSupport hstartV hpattern hsourceTr + hsourceType hmatch hchecks hrhsAligned + obtain ⟨_, hfinalI, hdispatchFrame, hfinalSupport, hmeaning⟩ := hchecked + have hrun := tryIotaWithFlags_regularCtor hcollect hlookup hinfo + hmajorBound hmajor hk hcleanup hwhnf hmajorShape hcleanupWhnf + hctorSpine hctorLookup hctorInfo h.eval + exact ⟨hrun, hfinalI, hprefixFrame.trans hdispatchFrame, + hfinalSupport, hmeaning⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/ConstructorSynthesis.lean b/Ix/Tc/Verify/Whnf/Iota/ConstructorSynthesis.lean new file mode 100644 index 000000000..cf6f8fb6d --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/ConstructorSynthesis.lean @@ -0,0 +1,585 @@ +import Ix.Tc.Verify.Whnf.Iota.StringLiteral + +/-! +# Successful K-like constructor synthesis + +ConstructorDispatch--StringLiteral cover iota once the major reaches ordinary constructor dispatch, +but their outer prefixes deliberately assume `recr.k = false`. This slice +opens the positive K branch. It records every fallible production action in +`synthCtorWhenK`, including the caught inference/WHNF/type-scan stages, the +constructor rebuild, statistics boundary, and final def-equality gate, then +lifts a successful synthesis through the actual iota prefix. + +The trace is execution-indexed. It does not infer success merely from the K +flag: malformed or untrusted catalog entries may legitimately make any of the +caught stages return `none`, and callback errors may retain partial state. +-/ + +namespace Ix.Tc + +open Lean4Lean (VDefEq VExpr) + +namespace RecM + +/-- A successful optional probe preserves its exact value and post-state. -/ +theorem tryOptional_success + {methods : Methods .anon} {x : RecM .anon α} + {s sf : TcState .anon} {a : α} + (h : x.run methods s = .ok a sf) : + (tryOptional x).run methods s = .ok (some a) sf := by + unfold tryOptional try? + rw [ReaderT.run_bind] + change EStateM.bind + (EStateM.tryCatch + (EStateM.bind (x.run methods) (fun a s => .ok (some a) s)) _) + _ s = _ + unfold EStateM.bind EStateM.tryCatch + simp only [h] + rfl + +/-- A caught optional-probe error becomes absence while retaining the +error-side state, as required by the Rust `&mut` execution model. -/ +theorem tryOptional_error + {methods : Methods .anon} {x : RecM .anon α} + {s sf : TcState .anon} {err : TcError .anon} + (h : x.run methods s = .error err sf) : + (tryOptional x).run methods s = .ok none sf := by + unfold tryOptional try? + rw [ReaderT.run_bind] + change EStateM.bind + (EStateM.tryCatch + (EStateM.bind (x.run methods) (fun a s => .ok (some a) s)) _) + _ s = _ + unfold EStateM.bind EStateM.tryCatch + simp only [h] + rfl + +/-- Exact successful execution of the candidate-build transaction after +catalog selection has identified the first constructor. -/ +structure VerifyKSynthCandidateSuccessTrace + (methods : Methods .anon) (majorTyW : KExpr .anon) + (ctorId : KId .anon) (tyUs : Array (KUniv .anon)) + (tyArgs : Array (KExpr .anon)) (params : Nat) + (s : TcState .anon) (ctorApp : KExpr .anon) (sf : TcState .anon) : Type where + ctorHead : KExpr .anon + ctorTy : KExpr .anon + sCtorHead : TcState .anon + sCtorApp : TcState .anon + sCtorTy : TcState .anon + sAttempt : TcState .anon + ctorHeadIntern : + TcM.intern (KExpr.mkConst ctorId tyUs) s = .ok ctorHead sCtorHead + ctorApps : + (finishAppResult ctorHead + (tyArgs.extract 0 (min params tyArgs.size)) 0).run methods sCtorHead = + .ok ctorApp sCtorApp + ctorInfer : + (tryOptional (inferOnlyRec ctorApp)).run methods sCtorApp = + .ok (some ctorTy) sCtorTy + attemptStats : + TcM.bumpStats + (fun st => { st with kSynthAttempts := st.kSynthAttempts + 1 }) + sCtorTy = .ok () sAttempt + typeDefEq : + (callIsDefEq majorTyW ctorTy).run methods sAttempt = .ok true sf + +namespace VerifyKSynthCandidateSuccessTrace + +theorem eval + (h : VerifyKSynthCandidateSuccessTrace methods majorTyW ctorId tyUs + tyArgs params s ctorApp sf) : + (verifyKSynthCandidate majorTyW ctorId tyUs tyArgs params).run methods s = + .ok (some ctorApp) sf := by + unfold verifyKSynthCandidate + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkConst ctorId tyUs)) _ s = _ + unfold EStateM.bind + rw [h.ctorHeadIntern] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (finishAppResult h.ctorHead + (tyArgs.extract 0 (min params tyArgs.size)) 0) methods) _ + h.sCtorHead = _ + unfold EStateM.bind + rw [h.ctorApps] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec ctorApp)) methods) _ h.sCtorApp = _ + unfold EStateM.bind + rw [h.ctorInfer] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind + (TcM.bumpStats + (fun st => { st with kSynthAttempts := st.kSynthAttempts + 1 })) _ + h.sCtorTy = _ + unfold EStateM.bind + rw [h.attemptStats] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (callIsDefEq majorTyW h.ctorTy) methods) _ h.sAttempt = _ + unfold EStateM.bind + rw [h.typeDefEq] + rfl + +end VerifyKSynthCandidateSuccessTrace + +/-- The final DefEq rejection is a successful `none`, not an exception, and +the rejection counter is sequenced after the attempt counter. -/ +structure VerifyKSynthCandidateRejectTrace + (methods : Methods .anon) (majorTyW : KExpr .anon) + (ctorId : KId .anon) (tyUs : Array (KUniv .anon)) + (tyArgs : Array (KExpr .anon)) (params : Nat) + (s sf : TcState .anon) : Type where + ctorHead : KExpr .anon + ctorApp : KExpr .anon + ctorTy : KExpr .anon + sCtorHead : TcState .anon + sCtorApp : TcState .anon + sCtorTy : TcState .anon + sAttempt : TcState .anon + sDefEq : TcState .anon + ctorHeadIntern : + TcM.intern (KExpr.mkConst ctorId tyUs) s = .ok ctorHead sCtorHead + ctorApps : + (finishAppResult ctorHead + (tyArgs.extract 0 (min params tyArgs.size)) 0).run methods sCtorHead = + .ok ctorApp sCtorApp + ctorInfer : + (tryOptional (inferOnlyRec ctorApp)).run methods sCtorApp = + .ok (some ctorTy) sCtorTy + attemptStats : + TcM.bumpStats + (fun st => { st with kSynthAttempts := st.kSynthAttempts + 1 }) + sCtorTy = .ok () sAttempt + typeDefEq : + (callIsDefEq majorTyW ctorTy).run methods sAttempt = .ok false sDefEq + rejectStats : + TcM.bumpStats + (fun st => { st with kSynthRejects := st.kSynthRejects + 1 }) + sDefEq = .ok () sf + +namespace VerifyKSynthCandidateRejectTrace + +theorem eval + (h : VerifyKSynthCandidateRejectTrace methods majorTyW ctorId tyUs + tyArgs params s sf) : + (verifyKSynthCandidate majorTyW ctorId tyUs tyArgs params).run methods s = + .ok none sf := by + unfold verifyKSynthCandidate + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkConst ctorId tyUs)) _ s = _ + unfold EStateM.bind + rw [h.ctorHeadIntern] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (finishAppResult h.ctorHead + (tyArgs.extract 0 (min params tyArgs.size)) 0) methods) _ + h.sCtorHead = _ + unfold EStateM.bind + rw [h.ctorApps] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec h.ctorApp)) methods) _ + h.sCtorApp = _ + unfold EStateM.bind + rw [h.ctorInfer] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind + (TcM.bumpStats + (fun st => { st with kSynthAttempts := st.kSynthAttempts + 1 })) _ + h.sCtorTy = _ + unfold EStateM.bind + rw [h.attemptStats] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (callIsDefEq majorTyW h.ctorTy) methods) _ h.sAttempt = _ + unfold EStateM.bind + rw [h.typeDefEq] + simp only [Bool.not_false, if_true] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind + (TcM.bumpStats + (fun st => { st with kSynthRejects := st.kSynthRejects + 1 })) _ + h.sDefEq = _ + unfold EStateM.bind + rw [h.rejectStats] + rfl + +end VerifyKSynthCandidateRejectTrace + +/-- Exact successful execution of `synthCtorWhenK`. Keeping the states +between callbacks explicit prevents swallowed errors or diagnostic-state +changes from being mistaken for pure lookups. -/ +structure SynthCtorWhenKSuccessTrace + (methods : Methods .anon) (major : KExpr .anon) (recId : KId .anon) + (recr : IotaInfo .anon) (recUs : Array (KUniv .anon)) + (s : TcState .anon) + (ctorApp : KExpr .anon) (sf : TcState .anon) : Type where + majorTy : KExpr .anon + majorTyW : KExpr .anon + tyHeadId : KId .anon + tyUs : Array (KUniv .anon) + tyHeadInfo : ExprInfo .anon + tyArgs : Array (KExpr .anon) + recursor : KConst .anon + recursorTy : KExpr .anon + indId : KId .anon + ctorId : KId .anon + indLvls : UInt64 + indParams : UInt64 + indIndices : UInt64 + indUnsafe : Bool + indBlock : KId .anon + indMemberIdx : UInt64 + indTy : KExpr .anon + ctors : Array (KId .anon) + sMajorTy : TcState .anon + sMajorTyW : TcState .anon + sRecursor : TcState .anon + sInductive : TcState .anon + sIndLookup : TcState .anon + levelArity : recUs.size.toUInt64 = recr.lvls + majorInfer : + (tryOptional (inferOnlyRec major)).run methods s = + .ok (some majorTy) sMajorTy + majorWhnf : + (tryOptional (whnfRec majorTy)).run methods sMajorTy = + .ok (some majorTyW) sMajorTyW + majorSpine : + majorTyW.collectSpine = (.const tyHeadId tyUs tyHeadInfo, tyArgs) + recursorLookup : + TcM.tryGetConst recId sMajorTyW = .ok (some recursor) sRecursor + recursorType : recursor.ty = recursorTy + majorInductive : + (tryOptional (do + let recursorTy ← liftM (TcM.instantiateUnivParams recursorTy recUs) + getMajorInductiveId recursorTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64)).run methods sRecursor = + .ok (some indId) sInductive + sameInductive : tyHeadId.addr = indId.addr + inductiveLookup : + TcM.tryGetConst indId sInductive = + .ok (some (.indc () () indLvls indParams indIndices indUnsafe + indBlock indMemberIdx indTy ctors ())) sIndLookup + firstCtor : ctors[0]? = some ctorId + candidate : + (verifyKSynthCandidate majorTyW ctorId tyUs tyArgs recr.params).run + methods sIndLookup = .ok (some ctorApp) sf + +namespace SynthCtorWhenKSuccessTrace + +/-- A successful trace evaluates the production helper exactly. -/ +theorem eval + (h : SynthCtorWhenKSuccessTrace methods major recId recr recUs s ctorApp + sf) : + (synthCtorWhenK major recId recr recUs).run methods s = + .ok (some ctorApp) sf := by + unfold synthCtorWhenK + have hlevels : (recUs.size.toUInt64 != recr.lvls) = false := by + simp [h.levelArity] + rw [hlevels] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec major)) methods) _ s = _ + unfold EStateM.bind + rw [h.majorInfer] + simp only + change EStateM.bind + (ReaderT.run (tryOptional (whnfRec h.majorTy)) methods) _ h.sMajorTy = _ + unfold EStateM.bind + rw [h.majorWhnf] + simp only + rw [h.majorSpine] + simp only + change EStateM.bind (TcM.tryGetConst recId) _ h.sMajorTyW = _ + unfold EStateM.bind + rw [h.recursorLookup] + simp only + rw [h.recursorType] + simp only [pure_bind] + change EStateM.bind + (ReaderT.run + (tryOptional (do + let recursorTy ← + liftM (TcM.instantiateUnivParams h.recursorTy recUs) + getMajorInductiveId recursorTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64)) + methods) _ h.sRecursor = _ + unfold EStateM.bind + rw [h.majorInductive] + simp only + unfold selectKSynthCandidate + rw [h.sameInductive] + have haddrNe : (h.indId.addr != h.indId.addr) = false := by simp + rw [haddrNe] + simp only [Bool.false_eq_true, if_false, pure_bind] + change EStateM.bind (TcM.tryGetConst h.indId) _ h.sInductive = _ + unfold EStateM.bind + rw [h.inductiveLookup] + simp only [h.firstCtor] + exact h.candidate + +end SynthCtorWhenKSuccessTrace + +/-- Exact K-enabled prefix through synthesis (successful or fallback), initial +cleanup, the policy-selected major callback, and post-WHNF processing. The +explicit `selected` equation makes `.getD major` observable when synthesis +returns `none`. -/ +theorem tryIotaWithFlags_kPrefix + {methods : Methods .anon} {source : KExpr .anon} {flags : WhnfFlags} + {s sLookup sSynth sCleanup sWhnf sf : TcState .anon} + {recId : KId .anon} {recUs : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {spine : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {major selected majorWhnf result : KExpr .anon} + {synthResult : Option (KExpr .anon)} + (hsource : source.collectSpine = (.const recId recUs headInfo, spine)) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sLookup) + (hinfo : recursor.iotaInfo? = some recr) + (hmajorBound : recr.majorIdx < spine.size) + (hmajor : spine[recr.majorIdx]! = major) + (hk : recr.k = true) + (hsynth : (synthCtorWhenK major recId recr recUs).run methods sLookup = + .ok synthResult sSynth) + (hselected : synthResult.getD major = selected) + (hcleanup : (cleanupNatOffsetMajor selected).run methods sSynth = + .ok none sCleanup) + (hwhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec selected flags).run methods sCleanup + else (whnfRec selected).run methods sCleanup) = + .ok majorWhnf sWhnf) + (hafter : + (tryIotaAfterMajorWhnf flags recId recr recUs spine majorWhnf).run + methods sWhnf = .ok (some result) sf) : + (tryIotaWithFlags source flags).run methods s = .ok (some result) sf := by + unfold tryIotaWithFlags + rw [hsource, ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst recId) _ s = _ + unfold EStateM.bind + rw [hlookup] + simp only + rw [hinfo] + simp only + rw [if_neg (Nat.not_le.mpr hmajorBound)] + rw [hmajor, hk] + simp only [↓reduceIte] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (synthCtorWhenK major recId recr recUs) methods) _ sLookup = _ + unfold EStateM.bind + rw [hsynth] + simp only + rw [hselected] + simp only [pure_bind] + change EStateM.bind + (ReaderT.run (cleanupNatOffsetMajor selected) methods) _ sSynth = _ + unfold EStateM.bind + rw [hcleanup] + simp only [Option.getD] + cases hcheap : flags.cheapRec + · simp only [hcheap, Bool.false_eq_true, ↓reduceIte] at hwhnf ⊢ + change EStateM.bind _ _ sCleanup = _ + unfold EStateM.bind + change whnfRec selected methods sCleanup = .ok majorWhnf sWhnf at hwhnf + rw [hwhnf] + exact hafter + · simp only [hcheap, ↓reduceIte] at hwhnf ⊢ + change EStateM.bind _ _ sCleanup = _ + unfold EStateM.bind + change whnfCoreFlagsRec selected flags methods sCleanup = + .ok majorWhnf sWhnf at hwhnf + rw [hwhnf] + exact hafter + +/-- A caught K-synthesis miss keeps the original major and continues through +the same cleanup/WHNF/postprocessing path. Partial state retained by the +caught probe is represented by `sSynth`. -/ +theorem tryIotaWithFlags_kFallback + {methods : Methods .anon} {source : KExpr .anon} {flags : WhnfFlags} + {s sLookup sSynth sCleanup sWhnf sf : TcState .anon} + {recId : KId .anon} {recUs : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {spine : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {major majorWhnf result : KExpr .anon} + (hsource : source.collectSpine = (.const recId recUs headInfo, spine)) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sLookup) + (hinfo : recursor.iotaInfo? = some recr) + (hmajorBound : recr.majorIdx < spine.size) + (hmajor : spine[recr.majorIdx]! = major) + (hk : recr.k = true) + (hsynth : (synthCtorWhenK major recId recr recUs).run methods sLookup = + .ok none sSynth) + (hcleanup : (cleanupNatOffsetMajor major).run methods sSynth = + .ok none sCleanup) + (hwhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec major flags).run methods sCleanup + else (whnfRec major).run methods sCleanup) = + .ok majorWhnf sWhnf) + (hafter : + (tryIotaAfterMajorWhnf flags recId recr recUs spine majorWhnf).run + methods sWhnf = .ok (some result) sf) : + (tryIotaWithFlags source flags).run methods s = .ok (some result) sf := + tryIotaWithFlags_kPrefix hsource hlookup hinfo hmajorBound hmajor hk + hsynth rfl hcleanup hwhnf hafter + +/-- Complete successful K-synthesis branch ending in ordinary constructor +dispatch. -/ +theorem tryIotaWithFlags_kCtor + {methods : Methods .anon} {source : KExpr .anon} {flags : WhnfFlags} + {s sLookup sSynth sCleanup sWhnf sCleanupWhnf sCtor sf : TcState .anon} + {recId : KId .anon} {recUs : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {spine : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {major synthesized majorWhnf : KExpr .anon} + {ctorId : KId .anon} {ctorUs : Array (KUniv .anon)} + {ctorHeadInfo : ExprInfo .anon} {ctorArgs : Array (KExpr .anon)} + {ctor : KConst .anon} {cidx ctorFields : Nat} + {result : KExpr .anon} + (hsource : source.collectSpine = (.const recId recUs headInfo, spine)) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sLookup) + (hinfo : recursor.iotaInfo? = some recr) + (hmajorBound : recr.majorIdx < spine.size) + (hmajor : spine[recr.majorIdx]! = major) + (hk : recr.k = true) + (hsynth : (synthCtorWhenK major recId recr recUs).run methods sLookup = + .ok (some synthesized) sSynth) + (hcleanup : (cleanupNatOffsetMajor synthesized).run methods sSynth = + .ok none sCleanup) + (hwhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec synthesized flags).run methods sCleanup + else (whnfRec synthesized).run methods sCleanup) = + .ok majorWhnf sWhnf) + (hmajorShape : IotaCtorMajor majorWhnf) + (hcleanupWhnf : (cleanupNatOffsetMajor majorWhnf).run methods sWhnf = + .ok none sCleanupWhnf) + (hctorSpine : majorWhnf.collectSpine = + (.const ctorId ctorUs ctorHeadInfo, ctorArgs)) + (hctorLookup : TcM.tryGetConst ctorId sCleanupWhnf = + .ok (some ctor) sCtor) + (hctorInfo : ctor.iotaCtorInfo? = some (cidx, ctorFields)) + (hdispatch : + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields false).run + methods sCtor = .ok (some result) sf) : + (tryIotaWithFlags source flags).run methods s = .ok (some result) sf := by + have hctor := tryIotaCtorOrStructEta_regular (recId := recId) + hctorSpine hctorLookup hctorInfo hdispatch + have hafter := tryIotaAfterMajorWhnf_regular (flags := flags) + hmajorShape hcleanupWhnf hctor + exact tryIotaWithFlags_kPrefix hsource hlookup hinfo hmajorBound hmajor hk + hsynth rfl hcleanup hwhnf hafter + +/-- Headline ConstructorSynthesis contract: successful K synthesis enters the same checked +ordinary-constructor rule semantics as a syntactic constructor major. The +mutable callback prefix exposes its invariant and intern-only frame, exactly +as in ConstructorDispatch's non-K branch. -/ +theorem tryIotaWithFlags_kCtor_checkedAcceptance_empty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {methods : Methods .anon} {source : KExpr .anon} {flags : WhnfFlags} + {s sLookup sSynth sCleanup sWhnf sCleanupWhnf sCtor sf : TcState .anon} + {recId : KId .anon} {recUs : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {spine : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {major synthesized majorWhnf : KExpr .anon} + {ctorId : KId .anon} {ctorUs : Array (KUniv .anon)} + {ctorHeadInfo : ExprInfo .anon} {ctorArgs : Array (KExpr .anon)} + {ctor : KConst .anon} {cidx ctorFields : Nat} + {rule : RecRule .anon} {defeq : VDefEq} {startV : VExpr} + {final : KExpr .anon} {finalV : VExpr} + (h : ApplyIotaCtorTrace layer semantics trProj world support 0 [] + methods recr recUs spine ctorArgs cidx ctorFields false rule startV + sCtor final finalV sf) + (hcollect : source.collectSpine = (.const recId recUs headInfo, spine)) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sLookup) + (hinfo : recursor.iotaInfo? = some recr) + (hmajorBound : recr.majorIdx < spine.size) + (hmajor : spine[recr.majorIdx]! = major) + (hk : recr.k = true) + (hsynth : (synthCtorWhenK major recId recr recUs).run methods sLookup = + .ok (some synthesized) sSynth) + (hcleanup : (cleanupNatOffsetMajor synthesized).run methods sSynth = + .ok none sCleanup) + (hwhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec synthesized flags).run methods sCleanup + else (whnfRec synthesized).run methods sCleanup) = + .ok majorWhnf sWhnf) + (hmajorShape : IotaCtorMajor majorWhnf) + (hcleanupWhnf : (cleanupNatOffsetMajor majorWhnf).run methods sWhnf = + .ok none sCleanupWhnf) + (hctorSpine : majorWhnf.collectSpine = + (.const ctorId ctorUs ctorHeadInfo, ctorArgs)) + (hctorLookup : TcM.tryGetConst ctorId sCleanupWhnf = + .ok (some ctor) sCtor) + (hctorInfo : ctor.iotaCtorInfo? = some (cidx, ctorFields)) + (hprefixFrame : InternUpdateFrame s sCtor) + (hdispatchI : WhnfStateInv layer semantics trProj world support 0 [] + sCtor) + (hregistered : RegisteredRecursorRuleRhsRel world.venv world.nameOf + trProj recId recursor rule defeq) + (theory : WhnfTheory trProj world 0) + (hempty : recUs.isEmpty = true) + (harity : defeq.uvars = 0) + (hruleSupport : support rule.rhs) + (hstartV : startV = defeq.rhs) + {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel world.venv world.catalog + world.nameOf recId recursor rule pattern) + (hdispatchAligned : IotaCtorDispatchAligned cidx ctorFields pattern) + {sourceV sourceType : VExpr} + (hsourceTr : TrKExprS world.venv 0 world.nameOf trProj [] source sourceV) + (hsourceType : world.venv.HasType 0 [] sourceV sourceType) + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + sourceV levels captures) + (hchecks : pattern.checks.OK + (world.venv.IsDefEqU 0 []) levels captures) + (hrhsAligned : IotaRhsApplicationAligned pattern levels captures finalV) : + (tryIotaWithFlags source flags).run methods s = .ok (some final) sf ∧ + WhnfStateInv layer semantics trProj world support 0 [] sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + WhnfMeaning trProj world 0 [] source final := by + have hpatternDispatch : + ApplyIotaCtorTrace layer semantics trProj world support 0 [] methods + recr recUs spine ctorArgs pattern.ruleIndex + pattern.constructorFields.toNat false rule startV sCtor final finalV + sf := by + simpa only [hdispatchAligned.ruleIndex, hdispatchAligned.fields] using h + have hchecked := hpatternDispatch.checkedAcceptance_empty hregistered + theory hempty harity hdispatchI hruleSupport hstartV hpattern hsourceTr + hsourceType hmatch hchecks hrhsAligned + obtain ⟨_, hfinalI, hdispatchFrame, hfinalSupport, hmeaning⟩ := hchecked + have hrun := tryIotaWithFlags_kCtor hcollect hlookup hinfo hmajorBound + hmajor hk hsynth hcleanup hwhnf hmajorShape hcleanupWhnf hctorSpine + hctorLookup hctorInfo h.eval + exact ⟨hrun, hfinalI, hprefixFrame.trans hdispatchFrame, + hfinalSupport, hmeaning⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/ConstructorSynthesisFallback.lean b/Ix/Tc/Verify/Whnf/Iota/ConstructorSynthesisFallback.lean new file mode 100644 index 000000000..dc1aa8ed8 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/ConstructorSynthesisFallback.lean @@ -0,0 +1,674 @@ +import Ix.Tc.Verify.Whnf.Iota.ConstructorSynthesis + +/-! +# Exhaustive K-synthesis fallback branches + +ConstructorSynthesis proves successful constructor synthesis and counted DefEq rejection. +This slice closes the complementary control-flow surface: every silent +fallback before candidate verification, the caught candidate-inference +error, and propagation of the final DefEq callback error. Intermediate +states remain explicit because all three caught probes deliberately retain +their error-side mutations. + +The post-scan catalog branches are stated against the named +`selectKSynthCandidate` production seam. This separates genuinely reachable +malformed-inductive cases (for example an empty constructor array) from the +defensive repeated-lookup cases without assuming catalog immutability. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- The structural side condition used by the non-constant type-head exit. -/ +def KSynthNonConstHead : KExpr .anon → Prop + | .const .. => False + | _ => True + +/-- The structural side condition used by the defensive non-inductive +catalog exit. -/ +def KSynthNonInductive : KConst .anon → Prop + | .indc .. => False + | _ => True + +/-- Candidate construction silently rejects a caught inference miss before +either statistics counter or DefEq is touched. -/ +theorem verifyKSynthCandidate_inferMiss + {methods : Methods .anon} {majorTyW : KExpr .anon} + {ctorId : KId .anon} {tyUs : Array (KUniv .anon)} + {tyArgs : Array (KExpr .anon)} {params : Nat} + {s sCtorHead sCtorApp sf : TcState .anon} + {ctorHead ctorApp : KExpr .anon} + (hhead : TcM.intern (KExpr.mkConst ctorId tyUs) s = + .ok ctorHead sCtorHead) + (happs : + (finishAppResult ctorHead + (tyArgs.extract 0 (min params tyArgs.size)) 0).run methods sCtorHead = + .ok ctorApp sCtorApp) + (hinfer : (tryOptional (inferOnlyRec ctorApp)).run methods sCtorApp = + .ok none sf) : + (verifyKSynthCandidate majorTyW ctorId tyUs tyArgs params).run methods s = + .ok none sf := by + unfold verifyKSynthCandidate + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkConst ctorId tyUs)) _ s = _ + unfold EStateM.bind + rw [hhead] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (finishAppResult ctorHead + (tyArgs.extract 0 (min params tyArgs.size)) 0) methods) _ + sCtorHead = _ + unfold EStateM.bind + rw [happs] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec ctorApp)) methods) _ sCtorApp = _ + unfold EStateM.bind + rw [hinfer] + rfl + +/-- Raw candidate-inference errors are caught as absence while preserving +the exact error-side state. -/ +theorem verifyKSynthCandidate_inferError + {methods : Methods .anon} {majorTyW : KExpr .anon} + {ctorId : KId .anon} {tyUs : Array (KUniv .anon)} + {tyArgs : Array (KExpr .anon)} {params : Nat} + {s sCtorHead sCtorApp sf : TcState .anon} + {ctorHead ctorApp : KExpr .anon} {err : TcError .anon} + (hhead : TcM.intern (KExpr.mkConst ctorId tyUs) s = + .ok ctorHead sCtorHead) + (happs : + (finishAppResult ctorHead + (tyArgs.extract 0 (min params tyArgs.size)) 0).run methods sCtorHead = + .ok ctorApp sCtorApp) + (hinfer : (inferOnlyRec ctorApp).run methods sCtorApp = .error err sf) : + (verifyKSynthCandidate majorTyW ctorId tyUs tyArgs params).run methods s = + .ok none sf := + verifyKSynthCandidate_inferMiss hhead happs (tryOptional_error hinfer) + +/-- Unlike the three optional probes, the final DefEq callback is not caught: +its error and post-error state propagate exactly. -/ +theorem verifyKSynthCandidate_defEqError + {methods : Methods .anon} {majorTyW : KExpr .anon} + {ctorId : KId .anon} {tyUs : Array (KUniv .anon)} + {tyArgs : Array (KExpr .anon)} {params : Nat} + {s sCtorHead sCtorApp sCtorTy sAttempt sf : TcState .anon} + {ctorHead ctorApp ctorTy : KExpr .anon} {err : TcError .anon} + (hhead : TcM.intern (KExpr.mkConst ctorId tyUs) s = + .ok ctorHead sCtorHead) + (happs : + (finishAppResult ctorHead + (tyArgs.extract 0 (min params tyArgs.size)) 0).run methods sCtorHead = + .ok ctorApp sCtorApp) + (hinfer : (tryOptional (inferOnlyRec ctorApp)).run methods sCtorApp = + .ok (some ctorTy) sCtorTy) + (hattempt : TcM.bumpStats + (fun st => { st with kSynthAttempts := st.kSynthAttempts + 1 }) + sCtorTy = .ok () sAttempt) + (hdefeq : (callIsDefEq majorTyW ctorTy).run methods sAttempt = + .error err sf) : + (verifyKSynthCandidate majorTyW ctorId tyUs tyArgs params).run methods s = + .error err sf := by + unfold verifyKSynthCandidate + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkConst ctorId tyUs)) _ s = _ + unfold EStateM.bind + rw [hhead] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (finishAppResult ctorHead + (tyArgs.extract 0 (min params tyArgs.size)) 0) methods) _ + sCtorHead = _ + unfold EStateM.bind + rw [happs] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec ctorApp)) methods) _ sCtorApp = _ + unfold EStateM.bind + rw [hinfer] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind + (TcM.bumpStats + (fun st => { st with kSynthAttempts := st.kSynthAttempts + 1 })) _ + sCtorTy = _ + unfold EStateM.bind + rw [hattempt] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (callIsDefEq majorTyW ctorTy) methods) _ sAttempt = _ + unfold EStateM.bind + rw [hdefeq] + +/-- The normalized major type names a different inductive. -/ +theorem selectKSynthCandidate_mismatch + {methods : Methods .anon} {majorTyW : KExpr .anon} + {tyHeadId indId : KId .anon} {tyUs : Array (KUniv .anon)} + {tyArgs : Array (KExpr .anon)} {params : Nat} {s : TcState .anon} + (hmismatch : (tyHeadId.addr != indId.addr) = true) : + (selectKSynthCandidate majorTyW tyHeadId tyUs tyArgs indId params).run + methods s = .ok none s := by + unfold selectKSynthCandidate + rw [hmismatch] + rfl + +/-- The repeated defensive inductive lookup is absent. -/ +theorem selectKSynthCandidate_missing + {methods : Methods .anon} {majorTyW : KExpr .anon} + {tyHeadId indId : KId .anon} {tyUs : Array (KUniv .anon)} + {tyArgs : Array (KExpr .anon)} {params : Nat} {s sf : TcState .anon} + (hsame : (tyHeadId.addr != indId.addr) = false) + (hlookup : TcM.tryGetConst indId s = .ok none sf) : + (selectKSynthCandidate majorTyW tyHeadId tyUs tyArgs indId params).run + methods s = .ok none sf := by + unfold selectKSynthCandidate + rw [hsame] + simp only [Bool.false_eq_true, if_false, pure_bind] + change EStateM.bind (TcM.tryGetConst indId) _ s = _ + unfold EStateM.bind + rw [hlookup] + rfl + +/-- The repeated lookup returns a loaded constant of a non-inductive shape. -/ +theorem selectKSynthCandidate_nonInductive + {methods : Methods .anon} {majorTyW : KExpr .anon} + {tyHeadId indId : KId .anon} {tyUs : Array (KUniv .anon)} + {tyArgs : Array (KExpr .anon)} {params : Nat} {s sf : TcState .anon} + {entry : KConst .anon} + (hsame : (tyHeadId.addr != indId.addr) = false) + (hlookup : TcM.tryGetConst indId s = .ok (some entry) sf) + (hshape : KSynthNonInductive entry) : + (selectKSynthCandidate majorTyW tyHeadId tyUs tyArgs indId params).run + methods s = .ok none sf := by + unfold selectKSynthCandidate + rw [hsame] + simp only [Bool.false_eq_true, if_false, pure_bind] + change EStateM.bind (TcM.tryGetConst indId) _ s = _ + unfold EStateM.bind + rw [hlookup] + cases entry <;> simp [KSynthNonInductive] at hshape + all_goals rfl + +/-- An inductive with no first constructor is a successful silent miss. -/ +theorem selectKSynthCandidate_empty + {methods : Methods .anon} {majorTyW : KExpr .anon} + {tyHeadId indId block : KId .anon} {tyUs : Array (KUniv .anon)} + {tyArgs : Array (KExpr .anon)} {params : Nat} {s sf : TcState .anon} + {lvls indParams indices : UInt64} {isUnsafe : Bool} + {memberIdx : UInt64} {indTy : KExpr .anon} + (hsame : (tyHeadId.addr != indId.addr) = false) + (hlookup : TcM.tryGetConst indId s = + .ok (some (.indc () () lvls indParams indices isUnsafe block memberIdx + indTy #[] ())) sf) : + (selectKSynthCandidate majorTyW tyHeadId tyUs tyArgs indId params).run + methods s = .ok none sf := by + unfold selectKSynthCandidate + rw [hsame] + simp only [Bool.false_eq_true, if_false, pure_bind] + change EStateM.bind (TcM.tryGetConst indId) _ s = _ + unfold EStateM.bind + rw [hlookup] + rfl + +/-- A selected first constructor forwards any successful candidate result. -/ +theorem selectKSynthCandidate_selected + {methods : Methods .anon} {majorTyW : KExpr .anon} + {tyHeadId indId block ctorId : KId .anon} + {tyUs : Array (KUniv .anon)} {tyArgs : Array (KExpr .anon)} + {params : Nat} {s sLookup sf : TcState .anon} + {lvls indParams indices : UInt64} {isUnsafe : Bool} + {memberIdx : UInt64} {indTy : KExpr .anon} + {ctors : Array (KId .anon)} {result : Option (KExpr .anon)} + (hsame : (tyHeadId.addr != indId.addr) = false) + (hlookup : TcM.tryGetConst indId s = + .ok (some (.indc () () lvls indParams indices isUnsafe block memberIdx + indTy ctors ())) sLookup) + (hfirst : ctors[0]? = some ctorId) + (hcandidate : + (verifyKSynthCandidate majorTyW ctorId tyUs tyArgs params).run methods + sLookup = .ok result sf) : + (selectKSynthCandidate majorTyW tyHeadId tyUs tyArgs indId params).run + methods s = .ok result sf := by + unfold selectKSynthCandidate + rw [hsame] + simp only [Bool.false_eq_true, if_false, pure_bind] + change EStateM.bind (TcM.tryGetConst indId) _ s = _ + unfold EStateM.bind + rw [hlookup] + simp only [hfirst] + exact hcandidate + +/-- A selected candidate's uncaught error propagates through the selector. -/ +theorem selectKSynthCandidate_selectedError + {methods : Methods .anon} {majorTyW : KExpr .anon} + {tyHeadId indId block ctorId : KId .anon} + {tyUs : Array (KUniv .anon)} {tyArgs : Array (KExpr .anon)} + {params : Nat} {s sLookup sf : TcState .anon} + {lvls indParams indices : UInt64} {isUnsafe : Bool} + {memberIdx : UInt64} {indTy : KExpr .anon} + {ctors : Array (KId .anon)} {err : TcError .anon} + (hsame : (tyHeadId.addr != indId.addr) = false) + (hlookup : TcM.tryGetConst indId s = + .ok (some (.indc () () lvls indParams indices isUnsafe block memberIdx + indTy ctors ())) sLookup) + (hfirst : ctors[0]? = some ctorId) + (hcandidate : + (verifyKSynthCandidate majorTyW ctorId tyUs tyArgs params).run methods + sLookup = .error err sf) : + (selectKSynthCandidate majorTyW tyHeadId tyUs tyArgs indId params).run + methods s = .error err sf := by + unfold selectKSynthCandidate + rw [hsame] + simp only [Bool.false_eq_true, if_false, pure_bind] + change EStateM.bind (TcM.tryGetConst indId) _ s = _ + unfold EStateM.bind + rw [hlookup] + simp only [hfirst] + exact hcandidate + +/-- The first caught probe can fail before any other K-synthesis action. -/ +theorem synthCtorWhenK_levelMismatch + {methods : Methods .anon} {major : KExpr .anon} {recId : KId .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {s : TcState .anon} + (hlevels : (recUs.size.toUInt64 != recr.lvls) = true) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok none s := by + unfold synthCtorWhenK + rw [hlevels] + rfl + +/-- Once universe arity is valid, the first caught probe can fail before any +other K-synthesis action. -/ +theorem synthCtorWhenK_majorInferMiss + {methods : Methods .anon} {major : KExpr .anon} {recId : KId .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {s sf : TcState .anon} + (hlevels : recUs.size.toUInt64 = recr.lvls) + (hinfer : (tryOptional (inferOnlyRec major)).run methods s = .ok none sf) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok none sf := by + unfold synthCtorWhenK + have hlevelsNe : (recUs.size.toUInt64 != recr.lvls) = false := by + simp [hlevels] + rw [hlevelsNe] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec major)) methods) _ s = _ + unfold EStateM.bind + rw [hinfer] + rfl + +theorem synthCtorWhenK_majorInferError + {methods : Methods .anon} {major : KExpr .anon} {recId : KId .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {s sf : TcState .anon} {err : TcError .anon} + (hlevels : recUs.size.toUInt64 = recr.lvls) + (hinfer : (inferOnlyRec major).run methods s = .error err sf) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok none sf := + synthCtorWhenK_majorInferMiss hlevels (tryOptional_error hinfer) + +/-- Major-type WHNF failure is caught after retaining the inference state. -/ +theorem synthCtorWhenK_majorWhnfMiss + {methods : Methods .anon} {major majorTy : KExpr .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} + {s sInfer sf : TcState .anon} + (hlevels : recUs.size.toUInt64 = recr.lvls) + (hinfer : (tryOptional (inferOnlyRec major)).run methods s = + .ok (some majorTy) sInfer) + (hwhnf : (tryOptional (whnfRec majorTy)).run methods sInfer = + .ok none sf) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok none sf := by + unfold synthCtorWhenK + have hlevelsNe : (recUs.size.toUInt64 != recr.lvls) = false := by + simp [hlevels] + rw [hlevelsNe] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec major)) methods) _ s = _ + unfold EStateM.bind + rw [hinfer] + simp only + change EStateM.bind + (ReaderT.run (tryOptional (whnfRec majorTy)) methods) _ sInfer = _ + unfold EStateM.bind + rw [hwhnf] + rfl + +theorem synthCtorWhenK_majorWhnfError + {methods : Methods .anon} {major majorTy : KExpr .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} + {s sInfer sf : TcState .anon} {err : TcError .anon} + (hlevels : recUs.size.toUInt64 = recr.lvls) + (hinfer : (tryOptional (inferOnlyRec major)).run methods s = + .ok (some majorTy) sInfer) + (hwhnf : (whnfRec majorTy).run methods sInfer = .error err sf) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok none sf := + synthCtorWhenK_majorWhnfMiss hlevels hinfer (tryOptional_error hwhnf) + +/-- A normalized major type whose spine head is not a constant stops before +the recursor catalog is consulted. -/ +theorem synthCtorWhenK_nonConstHead + {methods : Methods .anon} {major majorTy majorTyW tyHead : KExpr .anon} + {tyArgs : Array (KExpr .anon)} {recId : KId .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {s sInfer sf : TcState .anon} + (hlevels : recUs.size.toUInt64 = recr.lvls) + (hinfer : (tryOptional (inferOnlyRec major)).run methods s = + .ok (some majorTy) sInfer) + (hwhnf : (tryOptional (whnfRec majorTy)).run methods sInfer = + .ok (some majorTyW) sf) + (hspine : majorTyW.collectSpine = (tyHead, tyArgs)) + (hshape : KSynthNonConstHead tyHead) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok none sf := by + unfold synthCtorWhenK + have hlevelsNe : (recUs.size.toUInt64 != recr.lvls) = false := by + simp [hlevels] + rw [hlevelsNe] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec major)) methods) _ s = _ + unfold EStateM.bind + rw [hinfer] + simp only + change EStateM.bind + (ReaderT.run (tryOptional (whnfRec majorTy)) methods) _ sInfer = _ + unfold EStateM.bind + rw [hwhnf] + simp only + rw [hspine] + cases tyHead <;> simp [KSynthNonConstHead] at hshape ⊢ <;> rfl + +/-- A constant-headed major type with an absent recursor catalog entry. -/ +theorem synthCtorWhenK_recursorMissing + {methods : Methods .anon} {major majorTy majorTyW : KExpr .anon} + {tyHeadId recId : KId .anon} {tyUs : Array (KUniv .anon)} + {tyHeadInfo : ExprInfo .anon} {tyArgs : Array (KExpr .anon)} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {s sInfer sWhnf sf : TcState .anon} + (hlevels : recUs.size.toUInt64 = recr.lvls) + (hinfer : (tryOptional (inferOnlyRec major)).run methods s = + .ok (some majorTy) sInfer) + (hwhnf : (tryOptional (whnfRec majorTy)).run methods sInfer = + .ok (some majorTyW) sWhnf) + (hspine : majorTyW.collectSpine = + (.const tyHeadId tyUs tyHeadInfo, tyArgs)) + (hlookup : TcM.tryGetConst recId sWhnf = .ok none sf) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok none sf := by + unfold synthCtorWhenK + have hlevelsNe : (recUs.size.toUInt64 != recr.lvls) = false := by + simp [hlevels] + rw [hlevelsNe] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec major)) methods) _ s = _ + unfold EStateM.bind + rw [hinfer] + simp only + change EStateM.bind + (ReaderT.run (tryOptional (whnfRec majorTy)) methods) _ sInfer = _ + unfold EStateM.bind + rw [hwhnf] + simp only + rw [hspine] + simp only + change EStateM.bind (TcM.tryGetConst recId) _ sWhnf = _ + unfold EStateM.bind + rw [hlookup] + rfl + +/-- A failed bounded major-inductive scan is caught after recursor lookup. -/ +theorem synthCtorWhenK_majorInductiveMiss + {methods : Methods .anon} {major majorTy majorTyW recTy : KExpr .anon} + {tyHeadId recId : KId .anon} {tyUs : Array (KUniv .anon)} + {tyHeadInfo : ExprInfo .anon} {tyArgs : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} + {s sInfer sWhnf sRec sf : TcState .anon} + (hlevels : recUs.size.toUInt64 = recr.lvls) + (hinfer : (tryOptional (inferOnlyRec major)).run methods s = + .ok (some majorTy) sInfer) + (hwhnf : (tryOptional (whnfRec majorTy)).run methods sInfer = + .ok (some majorTyW) sWhnf) + (hspine : majorTyW.collectSpine = + (.const tyHeadId tyUs tyHeadInfo, tyArgs)) + (hlookup : TcM.tryGetConst recId sWhnf = .ok (some recursor) sRec) + (hrecTy : recursor.ty = recTy) + (hscan : + (tryOptional (do + let recTy ← liftM (TcM.instantiateUnivParams recTy recUs) + getMajorInductiveId recTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64)).run methods sRec = .ok none sf) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok none sf := by + unfold synthCtorWhenK + have hlevelsNe : (recUs.size.toUInt64 != recr.lvls) = false := by + simp [hlevels] + rw [hlevelsNe] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec major)) methods) _ s = _ + unfold EStateM.bind + rw [hinfer] + simp only + change EStateM.bind + (ReaderT.run (tryOptional (whnfRec majorTy)) methods) _ sInfer = _ + unfold EStateM.bind + rw [hwhnf] + simp only + rw [hspine] + simp only + change EStateM.bind (TcM.tryGetConst recId) _ sWhnf = _ + unfold EStateM.bind + rw [hlookup] + simp only + rw [hrecTy] + simp only [pure_bind] + change EStateM.bind + (ReaderT.run + (tryOptional (do + let recTy ← liftM (TcM.instantiateUnivParams recTy recUs) + getMajorInductiveId recTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64)) + methods) _ sRec = _ + unfold EStateM.bind + rw [hscan] + rfl + +theorem synthCtorWhenK_majorInductiveError + {methods : Methods .anon} {major majorTy majorTyW recTy : KExpr .anon} + {tyHeadId recId : KId .anon} {tyUs : Array (KUniv .anon)} + {tyHeadInfo : ExprInfo .anon} {tyArgs : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} + {s sInfer sWhnf sRec sf : TcState .anon} {err : TcError .anon} + (hlevels : recUs.size.toUInt64 = recr.lvls) + (hinfer : (tryOptional (inferOnlyRec major)).run methods s = + .ok (some majorTy) sInfer) + (hwhnf : (tryOptional (whnfRec majorTy)).run methods sInfer = + .ok (some majorTyW) sWhnf) + (hspine : majorTyW.collectSpine = + (.const tyHeadId tyUs tyHeadInfo, tyArgs)) + (hlookup : TcM.tryGetConst recId sWhnf = .ok (some recursor) sRec) + (hrecTy : recursor.ty = recTy) + (hscan : + (do + let recTy ← liftM (TcM.instantiateUnivParams recTy recUs) + getMajorInductiveId recTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64).run methods sRec = .error err sf) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok none sf := + synthCtorWhenK_majorInductiveMiss hlevels hinfer hwhnf hspine hlookup hrecTy + (tryOptional_error hscan) + +/-- Exact successful prefix through the bounded recursor scan. The selector +result remains abstract so each post-scan branch can be lifted without +replaying the prefix proof. -/ +structure SynthCtorWhenKSelectionTrace + (methods : Methods .anon) (major : KExpr .anon) (recId : KId .anon) + (recr : IotaInfo .anon) (recUs : Array (KUniv .anon)) + (s : TcState .anon) : Type where + majorTy : KExpr .anon + majorTyW : KExpr .anon + tyHeadId : KId .anon + tyUs : Array (KUniv .anon) + tyHeadInfo : ExprInfo .anon + tyArgs : Array (KExpr .anon) + recursor : KConst .anon + recTy : KExpr .anon + indId : KId .anon + sInfer : TcState .anon + sWhnf : TcState .anon + sRec : TcState .anon + sScan : TcState .anon + levelArity : recUs.size.toUInt64 = recr.lvls + majorInfer : (tryOptional (inferOnlyRec major)).run methods s = + .ok (some majorTy) sInfer + majorWhnf : (tryOptional (whnfRec majorTy)).run methods sInfer = + .ok (some majorTyW) sWhnf + majorSpine : majorTyW.collectSpine = + (.const tyHeadId tyUs tyHeadInfo, tyArgs) + recursorLookup : TcM.tryGetConst recId sWhnf = .ok (some recursor) sRec + recursorType : recursor.ty = recTy + majorInductive : + (tryOptional (do + let recTy ← liftM (TcM.instantiateUnivParams recTy recUs) + getMajorInductiveId recTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64)).run methods sRec = .ok (some indId) sScan + +namespace SynthCtorWhenKSelectionTrace + +theorem eval + (h : SynthCtorWhenKSelectionTrace methods major recId recr recUs s) + {outcome : EStateM.Result (TcError .anon) (TcState .anon) + (Option (KExpr .anon))} + (hselect : + (selectKSynthCandidate h.majorTyW h.tyHeadId h.tyUs h.tyArgs h.indId + recr.params).run methods h.sScan = outcome) : + (synthCtorWhenK major recId recr recUs).run methods s = outcome := by + unfold synthCtorWhenK + have hlevelsNe : (recUs.size.toUInt64 != recr.lvls) = false := by + simp [h.levelArity] + rw [hlevelsNe] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec major)) methods) _ s = _ + unfold EStateM.bind + rw [h.majorInfer] + simp only + change EStateM.bind + (ReaderT.run (tryOptional (whnfRec h.majorTy)) methods) _ h.sInfer = _ + unfold EStateM.bind + rw [h.majorWhnf] + simp only + rw [h.majorSpine] + simp only + change EStateM.bind (TcM.tryGetConst recId) _ h.sWhnf = _ + unfold EStateM.bind + rw [h.recursorLookup] + simp only + rw [h.recursorType] + simp only [pure_bind] + change EStateM.bind + (ReaderT.run + (tryOptional (do + let recTy ← liftM (TcM.instantiateUnivParams h.recTy recUs) + getMajorInductiveId recTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64)) + methods) _ h.sRec = _ + unfold EStateM.bind + rw [h.majorInductive] + exact hselect + +theorem mismatch + (h : SynthCtorWhenKSelectionTrace methods major recId recr recUs s) + (hmismatch : (h.tyHeadId.addr != h.indId.addr) = true) : + (synthCtorWhenK major recId recr recUs).run methods s = + .ok none h.sScan := + h.eval (selectKSynthCandidate_mismatch hmismatch) + +theorem missing + (h : SynthCtorWhenKSelectionTrace methods major recId recr recUs s) + {sf : TcState .anon} + (hsame : (h.tyHeadId.addr != h.indId.addr) = false) + (hlookup : TcM.tryGetConst h.indId h.sScan = .ok none sf) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok none sf := + h.eval (selectKSynthCandidate_missing hsame hlookup) + +theorem nonInductive + (h : SynthCtorWhenKSelectionTrace methods major recId recr recUs s) + {sf : TcState .anon} {entry : KConst .anon} + (hsame : (h.tyHeadId.addr != h.indId.addr) = false) + (hlookup : TcM.tryGetConst h.indId h.sScan = .ok (some entry) sf) + (hshape : KSynthNonInductive entry) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok none sf := + h.eval (selectKSynthCandidate_nonInductive hsame hlookup hshape) + +theorem empty + (h : SynthCtorWhenKSelectionTrace methods major recId recr recUs s) + {sf : TcState .anon} {block : KId .anon} + {lvls indParams indices : UInt64} {isUnsafe : Bool} + {memberIdx : UInt64} {indTy : KExpr .anon} + (hsame : (h.tyHeadId.addr != h.indId.addr) = false) + (hlookup : TcM.tryGetConst h.indId h.sScan = + .ok (some (.indc () () lvls indParams indices isUnsafe block memberIdx + indTy #[] ())) sf) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok none sf := + h.eval (selectKSynthCandidate_empty hsame hlookup) + +theorem selected + (h : SynthCtorWhenKSelectionTrace methods major recId recr recUs s) + {sLookup sf : TcState .anon} {block ctorId : KId .anon} + {lvls indParams indices : UInt64} {isUnsafe : Bool} + {memberIdx : UInt64} {indTy : KExpr .anon} + {ctors : Array (KId .anon)} {result : Option (KExpr .anon)} + (hsame : (h.tyHeadId.addr != h.indId.addr) = false) + (hlookup : TcM.tryGetConst h.indId h.sScan = + .ok (some (.indc () () lvls indParams indices isUnsafe block memberIdx + indTy ctors ())) sLookup) + (hfirst : ctors[0]? = some ctorId) + (hcandidate : + (verifyKSynthCandidate h.majorTyW ctorId h.tyUs h.tyArgs recr.params).run + methods sLookup = .ok result sf) : + (synthCtorWhenK major recId recr recUs).run methods s = .ok result sf := + h.eval (selectKSynthCandidate_selected hsame hlookup hfirst hcandidate) + +theorem selectedError + (h : SynthCtorWhenKSelectionTrace methods major recId recr recUs s) + {sLookup sf : TcState .anon} {block ctorId : KId .anon} + {lvls indParams indices : UInt64} {isUnsafe : Bool} + {memberIdx : UInt64} {indTy : KExpr .anon} + {ctors : Array (KId .anon)} {err : TcError .anon} + (hsame : (h.tyHeadId.addr != h.indId.addr) = false) + (hlookup : TcM.tryGetConst h.indId h.sScan = + .ok (some (.indc () () lvls indParams indices isUnsafe block memberIdx + indTy ctors ())) sLookup) + (hfirst : ctors[0]? = some ctorId) + (hcandidate : + (verifyKSynthCandidate h.majorTyW ctorId h.tyUs h.tyArgs recr.params).run + methods sLookup = .error err sf) : + (synthCtorWhenK major recId recr recUs).run methods s = .error err sf := + h.eval (selectKSynthCandidate_selectedError hsame hlookup hfirst hcandidate) + +end SynthCtorWhenKSelectionTrace + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/Ingress.lean b/Ix/Tc/Verify/Whnf/Iota/Ingress.lean new file mode 100644 index 000000000..651281181 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/Ingress.lean @@ -0,0 +1,186 @@ +import Ix.Tc.Verify.Whnf.Iota.SynthesisRequests + +/-! +# Actual iota ingress state closure + +RebuildRequests closes every post-major branch and SynthesisRequests closes the positive K-synthesis +prefix. This slice composes those results through production's real +`tryIotaWithFlags` dispatcher: spine classification, lazy recursor lookup, +iota-info and major-index guards, optional K synthesis, the first Nat-offset +cleanup, and the policy-selected major callback. + +The struct-eta inference probes and both major-normalization callbacks are +instantiated at their exact translated inputs. Generated expressions, +catalog reads, and both ordinary and struct-eta iota tails are discharged +from finite run censuses; the remaining callback premises are confined to +bounded helper scans over open declaration telescopes. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Exhaustive state closure of the actual iota reducer. -/ +theorem tryIotaWithFlags_state_wf_of_contexts + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (kCensus : KSynthCandidateRequestCensus requests) + (iotaCensus : IotaRuleRequestCensus requests) + (finishCensus : StructEtaFinishRequestCensus requests) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} + (strings : ProjectionStringPlanContext trProj world support) + (inputs : WhnfCoreInputSupport support) + (telescopeInputs : ConstructorTelescopeInputSupport support) + (constructorInputs : + ConstructorTelescopeInputOracle trProj world support) + (recursorInputs : StructEtaRecursorInputOracle trProj world support) + (candidateInputs : KSynthCandidateInputOracle trProj world support) + (cleanupInputs : NatOffsetCleanupInputOracle trProj world support) + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + (hmethods : + Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hfault : ∀ {current : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars current)) + (hreferences : TrustedReferences world support) + (hwrites : ∀ id, world.trusted id → + IsRecCacheWriteOracle semantics world support methods id) + (e : KExpr .anon) {sourceV : Lean4Lean.VExpr} + (hsourceSupport : support e) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV) + (flags : WhnfFlags) (s : TcState .anon) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((tryIotaWithFlags e flags).run methods) + (fun _ _ => True) := by + let I := + WhnfStateInv .noAccel semantics trProj world support uvars Delta + have hpost : ∀ (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) + (major : KExpr .anon) {majorV : Lean4Lean.VExpr} + (after : TcState .anon), + support major → + TrKExprS world.venv uvars world.nameOf trProj Delta major majorV → + support spine[recr.majorIdx]! → + ∀ {spineMajorV : Lean4Lean.VExpr}, + TrKExprS world.venv uvars world.nameOf trProj Delta + spine[recr.majorIdx]! spineMajorV → + TcM.WF I after + ((do + let major := (← cleanupNatOffsetMajor major).getD major + let majorWhnf0 ← + if flags.cheapRec then whnfCoreFlagsRec major flags + else whnfRec major + tryIotaAfterMajorWhnf flags recId recr recUs spine majorWhnf0).run + methods) + (fun _ _ => True) := by + intro recId recr recUs spine major majorV after hmajorSupport hmajorTr + hspineMajorSupport spineMajorV hspineMajorTr + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cleanupNatOffsetMajor_input_wf cleanupInputs hmajorSupport hmajorTr after) + intro cleaned afterCleanup hcleaned + let cleanedMajor := cleaned.getD major + obtain ⟨cleanedMajorV, hcleanedSupport, hcleanedTr⟩ : + ∃ cleanedMajorV, + support cleanedMajor ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta + cleanedMajor cleanedMajorV := by + cases cleaned with + | none => + exact ⟨majorV, hmajorSupport, hmajorTr⟩ + | some result => + simpa only [cleanedMajor, Option.getD_some] using hcleaned + cases hcheap : flags.cheapRec with + | false => + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + apply TcM.WF.bind + ((whnfRec_wf (s := afterCleanup) hcleanedSupport hcleanedTr) + methods hmethods) + intro majorWhnf0 afterWhnf _ + exact tryIotaAfterMajorWhnf_state_wf_of_contexts + hrun iotaCensus finishCensus strings hmethods telescopeInputs + constructorInputs recursorInputs hfault hreferences hwrites + hspineMajorSupport hspineMajorTr + | true => + simp only [if_true] + rw [ReaderT.run_bind] + apply TcM.WF.bind + ((whnfCoreFlagsRec_wf (s := afterCleanup) + hcleanedSupport hcleanedTr) methods hmethods) + intro majorWhnf0 afterWhnf _ + exact tryIotaAfterMajorWhnf_state_wf_of_contexts + hrun iotaCensus finishCensus strings hmethods telescopeInputs + constructorInputs recursorInputs hfault hreferences hwrites + hspineMajorSupport hspineMajorTr + unfold tryIotaWithFlags + rcases hspine : e.collectSpine with ⟨head, spine⟩ + cases head with + | const recId recUs info => + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (TcM.tryGetConst_wf (hfault (current := Delta)) recId s) + intro foundRecursor afterLookup _ + cases foundRecursor with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some recursor => + cases hinfo : recursor.iotaInfo? with + | none => + simp only [hinfo] + exact TcM.WF.pure (fun _ => trivial) + | some recr => + simp only [hinfo, pure_bind] + by_cases hmajor : spine.size ≤ recr.majorIdx + · simp only [hmajor, if_pos] + exact TcM.WF.pure (fun _ => trivial) + · simp only [hmajor] + let major := spine[recr.majorIdx]! + have hmajorLt : recr.majorIdx < spine.size := by + omega + have hmajorGet : + spine[recr.majorIdx]? = + some spine[recr.majorIdx]! := by + rw [getElem?_pos spine recr.majorIdx hmajorLt, + getElem!_pos spine recr.majorIdx hmajorLt] + have hmajorMem : + spine[recr.majorIdx]! ∈ spine.toList := + Array.mem_toList_iff.mpr + (Array.mem_of_getElem? hmajorGet) + have hmajorSupport : support major := + inputs.spineArg hsourceSupport hspine hmajorMem + have hspineTr := + trAppSpine_of_collectSpine hsource hspine + obtain ⟨majorV, _, _, hmajorTr⟩ := + hspineTr.argument hmajorMem + cases hk : recr.k with + | false => + simp only [Bool.false_eq_true, if_false] + exact hpost recId recr recUs spine major afterLookup + hmajorSupport hmajorTr hmajorSupport hmajorTr + | true => + simp only [if_true, if_false] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (synthCtorWhenK_state_wf_of_inputs hrun kCensus + hmethods telescopeInputs recursorInputs hfault + hreferences candidateInputs hmajorSupport hmajorTr + recId recr recUs afterLookup) + intro synthesized afterKSynth hsynthesized + cases synthesized with + | none => + exact hpost recId recr recUs spine major afterKSynth + hmajorSupport hmajorTr hmajorSupport hmajorTr + | some synthesized => + obtain ⟨synthesizedV, hsynthesizedSupport, + hsynthesizedTr⟩ := hsynthesized + exact hpost recId recr recUs spine synthesized + afterKSynth hsynthesizedSupport hsynthesizedTr + hmajorSupport hmajorTr + | _ => + exact TcM.WF.pure (fun _ => trivial) + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/NatLiteral.lean b/Ix/Tc/Verify/Whnf/Iota/NatLiteral.lean new file mode 100644 index 000000000..0dba7dc2c --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/NatLiteral.lean @@ -0,0 +1,234 @@ +import Ix.Tc.Verify.Whnf.Iota.ConstructorDispatch + +/-! +# Nat-literal iota preprocessing + +ConstructorDispatch verifies the ordinary-constructor path once the normalized major is +already a constructor spine. This slice closes the adjacent Nat-literal +branch: production expands exactly one constructor layer, marks the ensuing +iota application transient, performs the second Nat-offset cleanup, and then +uses the same constructor-indexed dispatcher. + +String-literal expansion remains separate because it invokes a recursive +WHNF callback after constructing the String spine. K synthesis and struct +eta likewise retain their own inference and recursive-WHNF obligations. +-/ + +namespace Ix.Tc + +open Lean4Lean (VDefEq VExpr) + +namespace RecM + +/-- Production's zero-literal expansion reads the active primitive table and +does not mutate checker state. -/ +theorem natToConstructor_zero + (methods : Methods .anon) (s : TcState .anon) : + (natToConstructor 0).run methods s = + .ok (KExpr.mkConst s.prims.natZero #[]) s := by + unfold natToConstructor + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run prims methods) _ s = _ + unfold EStateM.bind + rw [show ReaderT.run prims methods s = .ok s.prims s from rfl] + rfl + +/-- Production exposes exactly one successor layer and retains the +predecessor as a literal. In particular, this is not recursive unary +expansion. -/ +theorem natToConstructor_succ + (methods : Methods .anon) (s : TcState .anon) (predecessor : Nat) : + (natToConstructor (predecessor + 1)).run methods s = + .ok (KExpr.mkApp (KExpr.mkConst s.prims.natSucc #[]) + (natExprFromValue predecessor)) s := by + unfold natToConstructor + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run prims methods) _ s = _ + unfold EStateM.bind + rw [show ReaderT.run prims methods s = .ok s.prims s from rfl] + rfl + +/-- Exact Nat-literal path through post-WHNF preprocessing. The dispatch +receives `transient = true`, matching production's protection against +interning work proportional to a literal's value. -/ +theorem tryIotaAfterMajorWhnf_nat + {methods : Methods .anon} {flags : WhnfFlags} + {s sNat sCleanup sf : TcState .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {value : Nat} {blob : Address} {info : ExprInfo .anon} + {ctorMajor result : KExpr .anon} + (hnat : (natToConstructor value).run methods s = .ok ctorMajor sNat) + (hctorShape : IotaCtorMajor ctorMajor) + (hcleanup : (cleanupNatOffsetMajor ctorMajor).run methods sNat = + .ok none sCleanup) + (hdispatch : + (tryIotaCtorOrStructEta recId recr recUs spine ctorMajor true).run + methods sCleanup = .ok (some result) sf) : + (tryIotaAfterMajorWhnf flags recId recr recUs spine + (.nat value blob info)).run methods s = .ok (some result) sf := by + unfold tryIotaAfterMajorWhnf + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (natToConstructor value) methods) _ s = _ + unfold EStateM.bind + rw [hnat] + cases hctorShape <;> simp only [pure_bind] + all_goals + rw [ReaderT.run_bind] + change EStateM.bind _ _ sNat = _ + unfold EStateM.bind + rw [hcleanup] + exact hdispatch + +/-- Complete non-K Nat-literal branch of `tryIotaWithFlags`. Constructor +lookup and rule selection are the same production operations as ConstructorDispatch, but +the selected rule now runs transiently after one-layer literal expansion. -/ +theorem tryIotaWithFlags_natCtor + {methods : Methods .anon} {source : KExpr .anon} {flags : WhnfFlags} + {s sLookup sCleanup sWhnf sNat sCleanupWhnf sCtor sf : TcState .anon} + {recId : KId .anon} {recUs : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {spine : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {major : KExpr .anon} {value : Nat} {blob : Address} + {natInfo : ExprInfo .anon} {ctorMajor : KExpr .anon} + {ctorId : KId .anon} {ctorUs : Array (KUniv .anon)} + {ctorHeadInfo : ExprInfo .anon} {ctorArgs : Array (KExpr .anon)} + {ctor : KConst .anon} {cidx ctorFields : Nat} + {result : KExpr .anon} + (hsource : source.collectSpine = (.const recId recUs headInfo, spine)) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sLookup) + (hinfo : recursor.iotaInfo? = some recr) + (hmajorBound : recr.majorIdx < spine.size) + (hmajor : spine[recr.majorIdx]! = major) + (hk : recr.k = false) + (hcleanup : (cleanupNatOffsetMajor major).run methods sLookup = + .ok none sCleanup) + (hwhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec major flags).run methods sCleanup + else (whnfRec major).run methods sCleanup) = + .ok (.nat value blob natInfo) sWhnf) + (hnat : (natToConstructor value).run methods sWhnf = + .ok ctorMajor sNat) + (hctorShape : IotaCtorMajor ctorMajor) + (hcleanupWhnf : (cleanupNatOffsetMajor ctorMajor).run methods sNat = + .ok none sCleanupWhnf) + (hctorSpine : ctorMajor.collectSpine = + (.const ctorId ctorUs ctorHeadInfo, ctorArgs)) + (hctorLookup : TcM.tryGetConst ctorId sCleanupWhnf = + .ok (some ctor) sCtor) + (hctorInfo : ctor.iotaCtorInfo? = some (cidx, ctorFields)) + (hdispatch : + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields true).run + methods sCtor = .ok (some result) sf) : + (tryIotaWithFlags source flags).run methods s = .ok (some result) sf := by + have hctor := tryIotaCtorOrStructEta_regular (recId := recId) + (transient := true) hctorSpine hctorLookup hctorInfo hdispatch + have hafter := tryIotaAfterMajorWhnf_nat (flags := flags) + (blob := blob) (info := natInfo) hnat hctorShape hcleanupWhnf hctor + exact tryIotaWithFlags_nonKPrefix hsource hlookup hinfo hmajorBound hmajor + hk hcleanup hwhnf hafter + +/-- Headline NatLiteral contract: an actual Nat-literal recursor run executes the +checked constructor rule selected after literal expansion. As in ConstructorDispatch, the +mutable prefix frame and dispatch-ingress invariant remain explicit until +the cleanup, callback, and lazy lookup helpers receive their own semantic +preservation theorems. -/ +theorem tryIotaWithFlags_natCtor_checkedAcceptance_empty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {methods : Methods .anon} {source : KExpr .anon} {flags : WhnfFlags} + {s sLookup sCleanup sWhnf sNat sCleanupWhnf sCtor sf : TcState .anon} + {recId : KId .anon} {recUs : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {spine : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {major : KExpr .anon} {value : Nat} {blob : Address} + {natInfo : ExprInfo .anon} {ctorMajor : KExpr .anon} + {ctorId : KId .anon} {ctorUs : Array (KUniv .anon)} + {ctorHeadInfo : ExprInfo .anon} {ctorArgs : Array (KExpr .anon)} + {ctor : KConst .anon} {cidx ctorFields : Nat} + {rule : RecRule .anon} {defeq : VDefEq} {startV : VExpr} + {final : KExpr .anon} {finalV : VExpr} + (h : ApplyIotaCtorTrace layer semantics trProj world support 0 [] + methods recr recUs spine ctorArgs cidx ctorFields true rule startV + sCtor final finalV sf) + (hcollect : source.collectSpine = (.const recId recUs headInfo, spine)) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sLookup) + (hinfo : recursor.iotaInfo? = some recr) + (hmajorBound : recr.majorIdx < spine.size) + (hmajor : spine[recr.majorIdx]! = major) + (hk : recr.k = false) + (hcleanup : (cleanupNatOffsetMajor major).run methods sLookup = + .ok none sCleanup) + (hwhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec major flags).run methods sCleanup + else (whnfRec major).run methods sCleanup) = + .ok (.nat value blob natInfo) sWhnf) + (hnat : (natToConstructor value).run methods sWhnf = + .ok ctorMajor sNat) + (hctorShape : IotaCtorMajor ctorMajor) + (hcleanupWhnf : (cleanupNatOffsetMajor ctorMajor).run methods sNat = + .ok none sCleanupWhnf) + (hctorSpine : ctorMajor.collectSpine = + (.const ctorId ctorUs ctorHeadInfo, ctorArgs)) + (hctorLookup : TcM.tryGetConst ctorId sCleanupWhnf = + .ok (some ctor) sCtor) + (hctorInfo : ctor.iotaCtorInfo? = some (cidx, ctorFields)) + (hprefixFrame : InternUpdateFrame s sCtor) + (hdispatchI : WhnfStateInv layer semantics trProj world support 0 [] + sCtor) + (hregistered : RegisteredRecursorRuleRhsRel world.venv world.nameOf + trProj recId recursor rule defeq) + (theory : WhnfTheory trProj world 0) + (hempty : recUs.isEmpty = true) + (harity : defeq.uvars = 0) + (hruleSupport : support rule.rhs) + (hstartV : startV = defeq.rhs) + {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel world.venv world.catalog + world.nameOf recId recursor rule pattern) + (hdispatchAligned : IotaCtorDispatchAligned cidx ctorFields pattern) + {sourceV sourceType : VExpr} + (hsourceTr : TrKExprS world.venv 0 world.nameOf trProj [] source + sourceV) + (hsourceType : world.venv.HasType 0 [] sourceV sourceType) + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + sourceV levels captures) + (hchecks : pattern.checks.OK + (world.venv.IsDefEqU 0 []) levels captures) + (hrhsAligned : IotaRhsApplicationAligned pattern levels captures + finalV) : + (tryIotaWithFlags source flags).run methods s = .ok (some final) sf ∧ + WhnfStateInv layer semantics trProj world support 0 [] sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + WhnfMeaning trProj world 0 [] source final := by + have hpatternDispatch : + ApplyIotaCtorTrace layer semantics trProj world support 0 [] methods + recr recUs spine ctorArgs pattern.ruleIndex + pattern.constructorFields.toNat true rule startV sCtor final finalV + sf := by + simpa only [hdispatchAligned.ruleIndex, hdispatchAligned.fields] using h + have hchecked := hpatternDispatch.checkedAcceptance_empty hregistered + theory hempty harity hdispatchI hruleSupport hstartV hpattern hsourceTr + hsourceType hmatch hchecks hrhsAligned + obtain ⟨_, hfinalI, hdispatchFrame, hfinalSupport, hmeaning⟩ := hchecked + have hrun := tryIotaWithFlags_natCtor hcollect hlookup hinfo + hmajorBound hmajor hk hcleanup hwhnf hnat hctorShape hcleanupWhnf + hctorSpine hctorLookup hctorInfo h.eval + exact ⟨hrun, hfinalI, hprefixFrame.trans hdispatchFrame, + hfinalSupport, hmeaning⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/NatOffset.lean b/Ix/Tc/Verify/Whnf/Iota/NatOffset.lean new file mode 100644 index 000000000..99911808e --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/NatOffset.lean @@ -0,0 +1,645 @@ +import Ix.Tc.Verify.Whnf.Runtime.LazyIngress + +/-! +# State closure for iota's Nat-offset preprocessing + +`tryIotaWithFlags` invokes `cleanupNatOffsetMajor` before the recursive major +callback, and `tryIotaAfterMajorWhnf` invokes it again afterward. Earlier +operational slices proved the String-literal miss, but the production helper +accepts an arbitrary expression. + +Both bounded parsers used by the cleanup are read-only. This slice proves +that fact for every input and every invariant, then closes the complete +cleanup helper without leaving it as an iota runtime premise. +-/ + +namespace Ix.Tc +namespace RecM + +set_option maxHeartbeats 800000 + +attribute [local irreducible] strLitToConstructor + tryIotaAfterCleanup tryIotaAfterMajorWhnf + +/-- A successful optional expression result is a certified input for the +next predecessor-table callback. Misses generate no new input obligation. + +This postcondition is shared by K-synthesis and Nat-offset cleanup: both may +replace the original iota major with freshly constructed syntax, and +`Methods.WF` may be invoked on that replacement only after finite support and +a structural translation have been recovered. -/ +def OptionalGeneratedInput (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) (Delta : KVLCtx) : + Option (KExpr .anon) → Prop + | none => True + | some result => + ∃ resultV, support result ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta result resultV + +/-- Reading the primitive table through `RecM.prims` changes no state. -/ +theorem prims_state_wf {I : TcState .anon → Prop} + (methods : Methods .anon) (s : TcState .anon) : + TcM.WF I s (prims.run methods) (fun _ _ => True) := + fun hI => ⟨hI, trivial⟩ + +/-- Primitive-address classification for binary Nat arithmetic is a +read-only primitive-table query. -/ +theorem isNatBinArithAddr_state_wf {I : TcState .anon → Prop} + (methods : Methods .anon) (addr : Address) (s : TcState .anon) : + TcM.WF I s ((isNatBinArithAddr addr).run methods) (fun _ _ => True) := by + unfold isNatBinArithAddr + rw [ReaderT.run_bind] + apply TcM.WF.bind (prims_state_wf methods s) + intro _ _ _ + exact TcM.WF.pure (fun _ => trivial) + +/-- The two mutually recursive Nat-offset readers preserve an arbitrary +state invariant. The conjunction follows the production mutual recursion: +`natOffsetFuel` calls the literal reader for an additive RHS, while the +literal reader calls itself on predecessor and binary-arithmetic operands. -/ +theorem natOffsetReaders_state_wf (fuel : Nat) : + (∀ (I : TcState .anon → Prop) (methods : Methods .anon) + (e : KExpr .anon) (s : TcState .anon), + TcM.WF I s ((natOffsetFuel fuel e).run methods) (fun _ _ => True)) ∧ + (∀ (I : TcState .anon → Prop) (methods : Methods .anon) + (e : KExpr .anon) (s : TcState .anon), + TcM.WF I s ((evalNatOffsetLiteralFuel fuel e).run methods) + (fun _ _ => True)) := by + induction fuel with + | zero => + constructor <;> intro I methods e s <;> + exact TcM.WF.pure (fun _ => trivial) + | succ fuel ih => + constructor + · intro I methods e s + unfold natOffsetFuel + rcases hspine : e.collectSpine with ⟨head, args⟩ + cases head with + | const id us info => + rw [ReaderT.run_bind] + apply TcM.WF.bind (prims_state_wf methods s) + intro p after _ + by_cases hsucc : + (id.addr == p.natSucc.addr && args.size == 1) = true + · simp only [hsucc, if_true] + rw [ReaderT.run_bind] + apply TcM.WF.bind (ih.1 I methods args[0]! after) + intro found afterOffset _ + cases found with + | none => + exact TcM.WF.pure (Q := fun _ _ => True) + (fun _ => trivial) + | some pair => + rcases pair with ⟨base, offset⟩ + exact TcM.WF.pure (Q := fun _ _ => True) + (fun _ => trivial) + · simp only [hsucc, pure_bind] + by_cases hadd : + (id.addr == p.natAdd.addr && args.size == 2) = true + · simp only [hadd, if_true] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + apply TcM.WF.bind (ih.2 I methods args[1]! after) + intro rhs afterRhs _ + cases rhs with + | none => + exact TcM.WF.pure (Q := fun _ _ => True) + (fun _ => trivial) + | some rhs => + rw [ReaderT.run_bind] + apply TcM.WF.bind + (ih.1 I methods args[0]! afterRhs) + intro found afterOffset _ + cases found with + | none => + exact TcM.WF.pure (Q := fun _ _ => True) + (fun _ => trivial) + | some pair => + rcases pair with ⟨base, offset⟩ + exact TcM.WF.pure (Q := fun _ _ => True) + (fun _ => trivial) + · simp only [hadd] + exact TcM.WF.pure (Q := fun _ _ => True) + (fun _ => trivial) + | _ => exact TcM.WF.pure (fun _ => trivial) + · intro I methods e s + unfold evalNatOffsetLiteralFuel + rw [ReaderT.run_bind] + apply TcM.WF.bind (prims_state_wf methods s) + intro p after _ + cases hextract : extractNatValue e p with + | some value => + exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + | none => + simp only [pure_bind] + rcases hspine : e.collectSpine with ⟨head, args⟩ + cases head with + | const id us info => + by_cases hpred : + (id.addr == p.natPred.addr && args.size == 1) = true + · simp only [hpred, if_true] + rw [ReaderT.run_bind] + apply TcM.WF.bind (ih.2 I methods args[0]! after) + intro value afterValue _ + cases value <;> + exact TcM.WF.pure (Q := fun _ _ => True) + (fun _ => trivial) + · simp only [hpred] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (isNatBinArithAddr_state_wf methods id.addr after) + intro answer afterAddr _ + by_cases hbinary : + (answer && args.size == 2) = true + · simp only [hbinary, if_true] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (ih.2 I methods args[0]! afterAddr) + intro left afterLeft _ + cases left with + | none => + exact TcM.WF.pure (Q := fun _ _ => True) + (fun _ => trivial) + | some left => + rw [ReaderT.run_bind] + apply TcM.WF.bind + (ih.2 I methods args[1]! afterLeft) + intro right afterRight _ + cases right <;> + exact TcM.WF.pure (Q := fun _ _ => True) + (fun _ => trivial) + · simp only [hbinary] + exact TcM.WF.pure (Q := fun _ _ => True) + (fun _ => trivial) + | _ => exact TcM.WF.pure (fun _ => trivial) + +/-- The public bounded Nat-offset parser preserves any invariant. -/ +theorem natOffset_state_wf {I : TcState .anon → Prop} + (methods : Methods .anon) (e : KExpr .anon) (depth : Nat) + (s : TcState .anon) : + TcM.WF I s ((natOffset e depth).run methods) (fun _ _ => True) := by + unfold natOffset + exact (natOffsetReaders_state_wf (256 - depth)).1 I methods e s + +/-- The public bounded literal evaluator preserves any invariant. -/ +theorem evalNatOffsetLiteral_state_wf {I : TcState .anon → Prop} + (methods : Methods .anon) (e : KExpr .anon) (depth : Nat) + (s : TcState .anon) : + TcM.WF I s ((evalNatOffsetLiteral e depth).run methods) + (fun _ _ => True) := by + unfold evalNatOffsetLiteral + exact (natOffsetReaders_state_wf (256 - depth)).2 I methods e s + +/-- One-layer Nat-literal constructor expansion reads only the primitive +table and leaves the state unchanged. -/ +theorem natToConstructor_state_wf {I : TcState .anon → Prop} + (methods : Methods .anon) (value : Nat) (s : TcState .anon) : + TcM.WF I s ((natToConstructor value).run methods) (fun _ _ => True) := by + unfold natToConstructor + rw [ReaderT.run_bind] + apply TcM.WF.bind (prims_state_wf methods s) + intro _ _ _ + split <;> exact TcM.WF.pure (fun _ => trivial) + +/-- Building the non-interned `Nat.succ` syntax reads only the primitive +table and therefore preserves every state invariant. -/ +theorem mkNatSucc_state_wf {I : TcState .anon → Prop} + (methods : Methods .anon) (e : KExpr .anon) (s : TcState .anon) : + TcM.WF I s ((mkNatSucc e).run methods) (fun _ _ => True) := by + unfold mkNatSucc + rw [ReaderT.run_bind] + apply TcM.WF.bind (prims_state_wf methods s) + intro _ _ _ + exact TcM.WF.pure (fun _ => trivial) + +/-- Building the non-interned `Nat.add` syntax has the same read-only +primitive-table effect. -/ +theorem mkNatAdd_state_wf {I : TcState .anon → Prop} + (methods : Methods .anon) (a b : KExpr .anon) (s : TcState .anon) : + TcM.WF I s ((mkNatAdd a b).run methods) (fun _ _ => True) := by + unfold mkNatAdd + rw [ReaderT.run_bind] + apply TcM.WF.bind (prims_state_wf methods s) + intro _ _ _ + exact TcM.WF.pure (fun _ => trivial) + +/-- Finite semantic input authority for the expression generated by one +successful Nat-offset cleanup. + +The oracle is indexed by the actual production execution and assumes neither +state preservation nor callback behavior. A later primitive/parser trace +construction supplies this field; K1 uses it only to recover the support and +structural translation required by `Methods.WF` for the selected major. -/ +structure NatOffsetCleanupInputOracle (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Prop where + generated : + ∀ {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + {before after : TcState .anon} {result : KExpr .anon}, + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + (cleanupNatOffsetMajor source).run methods before = + .ok (some result) after → + OptionalGeneratedInput trProj world support uvars Delta (some result) + +/-- The complete production Nat-offset cleanup is state-safe on hits, +misses, and every bounded-parser branch. -/ +theorem cleanupNatOffsetMajor_state_wf {I : TcState .anon → Prop} + (methods : Methods .anon) (e : KExpr .anon) (s : TcState .anon) : + TcM.WF I s ((cleanupNatOffsetMajor e).run methods) (fun _ _ => True) := by + unfold cleanupNatOffsetMajor + rw [ReaderT.run_bind] + apply TcM.WF.bind (evalNatOffsetLiteral_state_wf methods e 0 s) + intro literal afterLiteral _ + cases hsome : literal.isSome with + | true => exact TcM.WF.pure (fun _ => trivial) + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind (natOffset_state_wf methods e 0 afterLiteral) + intro offsetResult afterOffset _ + cases hoffset : offsetResult with + | none => + exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + | some pair => + rcases pair with ⟨base, offset⟩ + by_cases hzero : (offset == 0) = true + · simp only [hzero, if_true] + exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + · simp only [hzero] + by_cases hpredZero : (offset - 1 == 0) = true + · simp only [hpredZero, if_true] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (mkNatSucc_state_wf methods base afterOffset) + intro result afterResult _ + exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + · simp only [hpredZero] + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (mkNatAdd_state_wf methods base + (natExprFromValue (offset - 1)) afterOffset) + intro pred afterPred _ + rw [ReaderT.run_bind] + apply TcM.WF.bind + (mkNatSucc_state_wf methods pred afterPred) + intro result afterResult _ + exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + +/-- Combine the unconditional state proof with the execution-indexed cleanup +input authority. On a miss the optional postcondition is vacuous; on a hit +the oracle is tied to the exact value and post-state returned by production. -/ +theorem cleanupNatOffsetMajor_input_wf + {I : TcState .anon → Prop} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + (inputs : NatOffsetCleanupInputOracle trProj world support) + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (s : TcState .anon) : + TcM.WF I s ((cleanupNatOffsetMajor source).run methods) + (fun result _ => + OptionalGeneratedInput trProj world support uvars Delta result) := by + apply TcM.WF.mono + (TcM.WF.with_run_eq + (cleanupNatOffsetMajor_state_wf methods source s)) + · intro result after hpost + cases result with + | none => trivial + | some result => + exact inputs.generated hsourceSupport hsource hpost.2 + · intro _ _ _ + trivial + +/-! ## Exhaustive post-major state assembly -/ + +/-- State boundary for the actual ordinary-constructor rule application. +Unlike a whole-iota premise, this owns only universe instantiation and the +three finite argument folds after production has selected a constructor. -/ +def TryApplyIotaCtorPreserves (I : TcState .anon → Prop) + (methods : Methods .anon) : Prop := + ∀ recr recUs spine ctorArgs cidx ctorFields transient s, + TcM.WF I s + ((tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields transient).run + methods) + (fun _ _ => True) + +/-- State boundary for the struct-eta fallback. Classifier/RebuildTail construct this +from lazy ingress, callbacks, recursion-cache writes, and finite rebuild +requests. -/ +def StructEtaIotaPreserves (I : TcState .anon → Prop) + (methods : Methods .anon) : Prop := + ∀ recId recr recUs spine s, + TcM.WF I s ((tryStructEtaIota recId recr recUs spine).run methods) + (fun _ _ => True) + +/-- Input-indexed state boundary for the one struct-eta fallback selected by +the surrounding iota dispatcher. Unlike `StructEtaIotaPreserves`, this does +not grant authority over unrelated recursors or argument spines. -/ +def SelectedStructEtaIotaPreserves (I : TcState .anon → Prop) + (methods : Methods .anon) (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) : Prop := + ∀ s, TcM.WF I s + ((tryStructEtaIota recId recr recUs spine).run methods) + (fun _ _ => True) + +/-- Exhaust the actual constructor lookup and dispatch. Lazy lookup is +proved directly; only the two genuine successful tails remain as inputs. -/ +theorem tryIotaCtorOrStructEta_state_wf + {I : TcState .anon → Prop} {methods : Methods .anon} + (hfault : TcM.LazyFaultPreserves I) + (happly : TryApplyIotaCtorPreserves I methods) + (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) + (hstruct : SelectedStructEtaIotaPreserves I methods recId recr recUs + spine) + (majorWhnf : KExpr .anon) (transient : Bool) (s : TcState .anon) : + TcM.WF I s + ((tryIotaCtorOrStructEta recId recr recUs spine majorWhnf transient).run + methods) + (fun _ _ => True) := by + unfold tryIotaCtorOrStructEta + rcases hspine : majorWhnf.collectSpine with ⟨ctorHead, ctorArgs⟩ + cases ctorHead with + | const ctorId ctorUs ctorInfo => + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind (TcM.tryGetConst_wf hfault ctorId s) + intro found afterLookup _ + cases found with + | none => + simp only + exact hstruct afterLookup + | some declaration => + cases hinfo : declaration.iotaCtorInfo? with + | none => + simp only [hinfo] + exact hstruct afterLookup + | some pair => + rcases pair with ⟨cidx, ctorFields⟩ + simp only [hinfo, pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (happly recr recUs spine ctorArgs cidx ctorFields transient + afterLookup) + intro result afterApply _ + exact TcM.WF.pure (fun _ => trivial) + | _ => exact hstruct s + +/-- A StringExpansion finite String plan can be selected at the state where expansion +actually runs. This avoids assuming that cleanup left the primitive table +equal to an earlier snapshot; its invariant supplies the canonical table +fact at the exact callback state. -/ +theorem strLitToConstructor_context_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (strings : ProjectionStringPlanContext trProj world support) + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + (hmethods : + Methods.WFAt .noAccel semantics trProj world support uvars methods) + (value : String) (s : TcState .anon) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((strLitToConstructor value).run methods) + (fun expanded _ => + support expanded ∧ + ∃ expandedV, + TrKExprS world.venv uvars world.nameOf trProj Delta expanded + expandedV) := by + intro hI + have plan := strings.plan s.prims hI.noAccel_primitives value + have hrun : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (strLitToConstructor value) + (fun expanded _ => + support expanded ∧ + ∃ expandedV, + TrKExprS world.venv uvars world.nameOf trProj Delta expanded + expandedV) := + strLitToConstructor_plan_wf + (semantics := semantics) (trProj := trProj) (world := world) + (support := support) strings.collisionFree plan + exact hrun methods hmethods hI + +/-- Exhaust the named post-cleanup seam: String expansion and its recursive +callback are concrete; every resulting shape enters the already exhausted +constructor/struct-eta dispatcher. -/ +theorem tryIotaAfterCleanup_state_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (strings : ProjectionStringPlanContext trProj world support) + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + (hmethods : + Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (happly : TryApplyIotaCtorPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) + methods) + {flags : WhnfFlags} {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + (hstruct : SelectedStructEtaIotaPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) + methods recId recr recUs spine) + (majorWhnf : KExpr .anon) (majorWasNatLit : Bool) + (s : TcState .anon) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((tryIotaAfterCleanup flags recId recr recUs spine majorWhnf + majorWasNatLit).run methods) + (fun _ _ => True) := by + let I := WhnfStateInv .noAccel semantics trProj world support uvars Delta + have hdispatch : ∀ major after, + TcM.WF I after + ((tryIotaCtorOrStructEta recId recr recUs spine major + majorWasNatLit).run methods) + (fun _ _ => True) := + fun major after => + tryIotaCtorOrStructEta_state_wf hfault happly + recId recr recUs spine hstruct major majorWasNatLit after + unfold tryIotaAfterCleanup + cases majorWhnf with + | str value blob info => + rw [ReaderT.run_bind] + apply TcM.WF.bind + (strLitToConstructor_context_wf strings hmethods value s) + intro expanded afterExpansion hexpanded + rcases hexpanded with ⟨hexpandedSupport, expandedV, hexpandedTr⟩ + cases hcheap : flags.cheapRec with + | false => + simp only [Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (hmethods.whnf hexpandedSupport hexpandedTr) + intro reduced afterWhnf _ + exact hdispatch reduced afterWhnf + | true => + simp only [if_true] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (hmethods.whnfCoreFlags hexpandedSupport hexpandedTr) + intro reduced afterWhnf _ + exact hdispatch reduced afterWhnf + | var idx name info => exact hdispatch (.var idx name info) s + | fvar id name info => exact hdispatch (.fvar id name info) s + | sort level info => exact hdispatch (.sort level info) s + | const id us info => exact hdispatch (.const id us info) s + | app fn arg info => exact hdispatch (.app fn arg info) s + | lam name bi ty body info => exact hdispatch (.lam name bi ty body info) s + | all name bi ty body info => exact hdispatch (.all name bi ty body info) s + | letE name ty value body nondep info => + exact hdispatch (.letE name ty value body nondep info) s + | prj id field value info => exact hdispatch (.prj id field value info) s + | nat value blob info => exact hdispatch (.nat value blob info) s + +/-- The complete post-major preprocessing stage preserves the fixed K1 +invariant. Nat conversion and both cleanup passes are now concrete. String +conversion uses the finite StringExpansion plan and the predecessor method-table +contract for its one policy-selected callback. -/ +theorem tryIotaAfterMajorWhnf_state_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (strings : ProjectionStringPlanContext trProj world support) + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + (hmethods : + Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (happly : TryApplyIotaCtorPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) + methods) + {flags : WhnfFlags} {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + (hstruct : SelectedStructEtaIotaPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) + methods recId recr recUs spine) + {majorWhnf0 : KExpr .anon} {s : TcState .anon} : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((tryIotaAfterMajorWhnf flags recId recr recUs spine majorWhnf0).run + methods) + (fun _ _ => True) := by + let I := WhnfStateInv .noAccel semantics trProj world support uvars Delta + have hfinish : ∀ major transient after, + TcM.WF I after + ((tryIotaAfterCleanup flags recId recr recUs spine major transient).run + methods) + (fun _ _ => True) := + fun major transient after => + tryIotaAfterCleanup_state_wf strings hmethods hfault happly hstruct + major transient after + unfold tryIotaAfterMajorWhnf + cases majorWhnf0 with + | nat value blob info => + rw [ReaderT.run_bind] + apply TcM.WF.bind (natToConstructor_state_wf methods value s) + intro major afterNat _ + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cleanupNatOffsetMajor_state_wf methods major afterNat) + intro cleaned afterCleanup _ + cases cleaned with + | none => exact hfinish major true afterCleanup + | some cleanedMajor => exact hfinish cleanedMajor true afterCleanup + | str value blob info => + simp only [pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cleanupNatOffsetMajor_state_wf methods (.str value blob info) s) + intro cleaned afterCleanup _ + cases cleaned with + | none => exact hfinish (.str value blob info) false afterCleanup + | some cleanedMajor => exact hfinish cleanedMajor false afterCleanup + | var idx name info => + simp only [pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cleanupNatOffsetMajor_state_wf methods (.var idx name info) s) + intro cleaned afterCleanup _ + cases cleaned with + | none => exact hfinish (.var idx name info) false afterCleanup + | some cleanedMajor => exact hfinish cleanedMajor false afterCleanup + | fvar id name info => + simp only [pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cleanupNatOffsetMajor_state_wf methods (.fvar id name info) s) + intro cleaned afterCleanup _ + cases cleaned with + | none => exact hfinish (.fvar id name info) false afterCleanup + | some cleanedMajor => exact hfinish cleanedMajor false afterCleanup + | sort level info => + simp only [pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cleanupNatOffsetMajor_state_wf methods (.sort level info) s) + intro cleaned afterCleanup _ + cases cleaned with + | none => exact hfinish (.sort level info) false afterCleanup + | some cleanedMajor => exact hfinish cleanedMajor false afterCleanup + | const id us info => + simp only [pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cleanupNatOffsetMajor_state_wf methods (.const id us info) s) + intro cleaned afterCleanup _ + cases cleaned with + | none => exact hfinish (.const id us info) false afterCleanup + | some cleanedMajor => exact hfinish cleanedMajor false afterCleanup + | app fn arg info => + simp only [pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cleanupNatOffsetMajor_state_wf methods (.app fn arg info) s) + intro cleaned afterCleanup _ + cases cleaned with + | none => exact hfinish (.app fn arg info) false afterCleanup + | some cleanedMajor => exact hfinish cleanedMajor false afterCleanup + | lam name bi ty body info => + simp only [pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cleanupNatOffsetMajor_state_wf methods + (.lam name bi ty body info) s) + intro cleaned afterCleanup _ + cases cleaned with + | none => exact hfinish (.lam name bi ty body info) false afterCleanup + | some cleanedMajor => exact hfinish cleanedMajor false afterCleanup + | all name bi ty body info => + simp only [pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cleanupNatOffsetMajor_state_wf methods + (.all name bi ty body info) s) + intro cleaned afterCleanup _ + cases cleaned with + | none => exact hfinish (.all name bi ty body info) false afterCleanup + | some cleanedMajor => exact hfinish cleanedMajor false afterCleanup + | letE name ty value body nondep info => + simp only [pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cleanupNatOffsetMajor_state_wf methods + (.letE name ty value body nondep info) s) + intro cleaned afterCleanup _ + cases cleaned with + | none => + exact hfinish (.letE name ty value body nondep info) false + afterCleanup + | some cleanedMajor => exact hfinish cleanedMajor false afterCleanup + | prj id field value info => + simp only [pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cleanupNatOffsetMajor_state_wf methods (.prj id field value info) s) + intro cleaned afterCleanup _ + cases cleaned with + | none => exact hfinish (.prj id field value info) false afterCleanup + | some cleanedMajor => exact hfinish cleanedMajor false afterCleanup + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/NatPatternMatching.lean b/Ix/Tc/Verify/Whnf/Iota/NatPatternMatching.lean new file mode 100644 index 000000000..a083c7404 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/NatPatternMatching.lean @@ -0,0 +1,295 @@ +import Ix.Tc.Verify.Whnf.Iota.NatRecognizer + +/-! +# Constructive Nat-iota pattern matching + +NatRecognizer identifies the exact recursor rule and the literal-major position used +by the linear Nat recognizer. This slice crosses the next semantic boundary: +it constructs Lean4Lean's dependent `Pattern.Matches` capture map from exact +constant-spine shapes. + +The bridge deliberately ends at the application through the major argument. +Any trailing application suffix must be split and typed before these matches +can be used to justify the production fast path; silently matching a prefix +as though it were the whole source would lose over-application semantics. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace HeadConstN + +/-- Every exact constant-headed spine constructively matches the corresponding +`varN` pattern. The existential capture map is produced by Lean4Lean's own +`Pattern.Matches.var` constructor at each application. -/ +theorem matches_varN + {name : Lean.Name} {arity : Nat} {source : VExpr} + (h : HeadConstN name arity source) : + ∃ (levels : List Lean4Lean.VLevel) + (captures : ((Lean4Lean.Pattern.const name).varN arity).Path → VExpr), + Lean4Lean.Pattern.Matches + ((Lean4Lean.Pattern.const name).varN arity) + source levels captures := by + induction h with + | const levels => + exact ⟨levels, nofun, .const⟩ + | @app arity fn arg hprefix ih => + obtain ⟨levels, captures, hmatch⟩ := ih + refine ⟨levels, + (fun path : Option (((Lean4Lean.Pattern.const name).varN arity).Path) => + path.elim arg captures), ?_⟩ + simpa only [Lean4Lean.Pattern.varN, Nat.add_comm] using + (Lean4Lean.Pattern.Matches.var (a' := arg) hmatch) + +/-- The canonical Theory numeral zero is a nullary `Nat.zero` spine. -/ +theorem natLit_zero : + HeadConstN ``Nat.zero 0 (VExpr.natLit 0) := by + exact .const [] + +/-- Every positive canonical Theory numeral is a unary `Nat.succ` spine; +the predecessor remains the single captured constructor argument. -/ +theorem natLit_succ (predecessor : Nat) : + HeadConstN ``Nat.succ 1 (VExpr.natLit (predecessor + 1)) := by + change HeadConstN ``Nat.succ 1 + (.app (.const ``Nat.succ []) (VExpr.natLit predecessor)) + simpa using HeadConstN.app (HeadConstN.const (name := ``Nat.succ) []) + +end HeadConstN + +namespace RecursorIotaPattern + +/-- Exact recursor and constructor spines construct the dependent match for +Lean4Lean's ordinary iota pattern. The recursor levels and both capture maps +are exactly those built by `Pattern.Matches`; no choice principle is needed. -/ +theorem matches_of_shapes + {recursorName constructorName : Lean.Name} + {majorIdx constructorArgs : Nat} + {recursorPrefix major : VExpr} + (hrecursor : HeadConstN recursorName majorIdx recursorPrefix) + (hconstructor : HeadConstN constructorName constructorArgs major) : + ∃ (levels : List Lean4Lean.VLevel) + (captures : (RecursorIotaPattern recursorName majorIdx + constructorName constructorArgs).Path → VExpr), + Lean4Lean.Pattern.Matches + (RecursorIotaPattern recursorName majorIdx constructorName + constructorArgs) + (.app recursorPrefix major) levels captures := by + obtain ⟨recursorLevels, recursorCaptures, hrecursorMatch⟩ := + hrecursor.matches_varN + obtain ⟨_, constructorCaptures, hconstructorMatch⟩ := + hconstructor.matches_varN + refine ⟨recursorLevels, Sum.elim recursorCaptures constructorCaptures, ?_⟩ + simpa only [RecursorIotaPattern, Lean4Lean.SimplePattern.toPattern] using + Lean4Lean.Pattern.Matches.app hrecursorMatch hconstructorMatch + +/-- Constructive matching and the counted-spine view are equivalent. This +packages the registered-rule inversion together with the capture-map +construction and exposes the exact through-major boundary in either +direction. -/ +theorem exists_matches_iff_shapes + {recursorName constructorName : Lean.Name} + {majorIdx constructorArgs : Nat} {source : VExpr} : + (∃ (levels : List Lean4Lean.VLevel) + (captures : (RecursorIotaPattern recursorName majorIdx + constructorName constructorArgs).Path → VExpr), + Lean4Lean.Pattern.Matches + (RecursorIotaPattern recursorName majorIdx constructorName + constructorArgs) + source levels captures) ↔ + ∃ recursorPrefix major, + source = .app recursorPrefix major ∧ + HeadConstN recursorName majorIdx recursorPrefix ∧ + HeadConstN constructorName constructorArgs major := by + constructor + · rintro ⟨_, _, hmatch⟩ + exact matches_shape hmatch + · rintro ⟨recursorPrefix, major, rfl, hrecursor, hconstructor⟩ + exact matches_of_shapes hrecursor hconstructor + +/-- A nullary zero major yields a concrete iota match. -/ +theorem matches_natZero + {recursorName : Lean.Name} {majorIdx : Nat} + {recursorPrefix : VExpr} + (hrecursor : HeadConstN recursorName majorIdx recursorPrefix) : + ∃ (levels : List Lean4Lean.VLevel) + (captures : (RecursorIotaPattern recursorName majorIdx + ``Nat.zero 0).Path → VExpr), + Lean4Lean.Pattern.Matches + (RecursorIotaPattern recursorName majorIdx ``Nat.zero 0) + (.app recursorPrefix (VExpr.natLit 0)) levels captures := + matches_of_shapes hrecursor HeadConstN.natLit_zero + +/-- A unary successor major yields a concrete iota match whose constructor +capture is the canonical predecessor numeral. -/ +theorem matches_natSucc + {recursorName : Lean.Name} {majorIdx predecessor : Nat} + {recursorPrefix : VExpr} + (hrecursor : HeadConstN recursorName majorIdx recursorPrefix) : + ∃ (levels : List Lean4Lean.VLevel) + (captures : (RecursorIotaPattern recursorName majorIdx + ``Nat.succ 1).Path → VExpr), + Lean4Lean.Pattern.Matches + (RecursorIotaPattern recursorName majorIdx ``Nat.succ 1) + (.app recursorPrefix (VExpr.natLit (predecessor + 1))) + levels captures := + matches_of_shapes hrecursor (HeadConstN.natLit_succ predecessor) + +end RecursorIotaPattern + +/-- The two constructor shapes that a trusted linear `Nat.rec` rule may use. +Rule position, constructor identity, constructor parameters, and fields are +all explicit: none is inferred merely from the literal value. -/ +def NatRecIotaCase (pattern : RecursorRulePattern) (major : Nat) : Prop := + (major = 0 ∧ + pattern.ruleIndex = 0 ∧ + pattern.constructorName = ``Nat.zero ∧ + pattern.constructorParams = 0 ∧ + pattern.constructorFields = 0) ∨ + ∃ predecessor, + major = predecessor + 1 ∧ + pattern.ruleIndex = 1 ∧ + pattern.constructorName = ``Nat.succ ∧ + pattern.constructorParams = 0 ∧ + pattern.constructorFields = 1 + +namespace NatRecIotaCase + +/-- A certified Nat rule case gives the exact constructor-headed shape of +the canonical Theory numeral inspected by the fast path. -/ +theorem major_shape + {pattern : RecursorRulePattern} {major : Nat} + (h : NatRecIotaCase pattern major) : + HeadConstN pattern.constructorName + (pattern.constructorParams.toNat + pattern.constructorFields.toNat) + (VExpr.natLit major) := by + rcases h with hzero | hsucc + · rcases hzero with ⟨rfl, _, hname, hparams, hfields⟩ + simpa [hname, hparams, hfields] using HeadConstN.natLit_zero + · obtain ⟨predecessor, rfl, _, hname, hparams, hfields⟩ := hsucc + simpa [hname, hparams, hfields] using + HeadConstN.natLit_succ predecessor + +end NatRecIotaCase + +namespace RecursorRulePattern + +/-- Once the recursor prefix and Nat constructor case are fixed, the exact +trusted rule pattern has a concrete Lean4Lean match and capture map. -/ +theorem matches_natLiteral + {pattern : RecursorRulePattern} {major : Nat} + {recursorPrefix : VExpr} + (hrecursor : HeadConstN pattern.recursorName pattern.majorIdx + recursorPrefix) + (hcase : NatRecIotaCase pattern major) : + ∃ (levels : List Lean4Lean.VLevel) + (captures : (RecursorIotaPattern pattern.recursorName + pattern.majorIdx pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr), + Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + (.app recursorPrefix (VExpr.natLit major)) levels captures := + RecursorIotaPattern.matches_of_shapes hrecursor hcase.major_shape + +end RecursorRulePattern + +namespace RecM +namespace TrAppSpine + +/-- A translated concrete spine whose head is a named constant becomes an +exactly counted Theory constant spine. In particular, this theorem does not +forget how many arguments precede a descriptor-selected major. -/ +theorem headConstN + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {id : KId .anon} + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {args : List (KExpr .anon)} {resultV : VExpr} {name : Lean.Name} + (h : TrAppSpine env uvars nameOf trProj Delta + (.const id us info) args resultV) + (hname : nameOf id.addr = some name) : + HeadConstN name args.length resultV := by + induction h with + | head hhead => + cases hhead with + | const translatedName _ _ _ => + have hnames : _ = name := + Option.some.inj (translatedName.symm.trans hname) + subst name + exact .const _ + | app hprefix _ _ _ ih => + simpa using HeadConstN.app ih + +/-- Translation of precisely the arguments before the major supplies the +recursor half of the selected pattern match. The length equality is an +explicit prefix-boundary obligation. -/ +theorem matches_natRecRulePrefix + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {id : KId .anon} + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {args : List (KExpr .anon)} {recursorPrefix : VExpr} + {pattern : RecursorRulePattern} {major : Nat} + (hspine : TrAppSpine env uvars nameOf trProj Delta + (.const id us info) args recursorPrefix) + (hname : nameOf id.addr = some pattern.recursorName) + (hlength : args.length = pattern.majorIdx) + (hcase : NatRecIotaCase pattern major) : + ∃ (levels : List Lean4Lean.VLevel) + (captures : (RecursorIotaPattern pattern.recursorName + pattern.majorIdx pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr), + Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + (.app recursorPrefix (VExpr.natLit major)) levels captures := by + apply pattern.matches_natLiteral + · simpa only [hlength] using hspine.headConstN hname + · exact hcase + +end TrAppSpine +end RecM + +namespace RawRecursorRulePatternRel + +/-- The translation bridge can take its recursor name directly from trusted +pattern provenance. Constructor shape remains a separate Nat-specific fact, +so a catalogued rule at index zero or one is not silently assumed to be the +corresponding Nat rule. -/ +theorem matches_natLiteralPrefix + {env : Lean4Lean.VEnv} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {id : KId .anon} {recursor : KConst .anon} {rule : RecRule .anon} + {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel env catalog nameOf id recursor + rule pattern) + {uvars : Nat} {Delta : KVLCtx} + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {args : List (KExpr .anon)} {recursorPrefix : VExpr} {major : Nat} + (hspine : RecM.TrAppSpine env uvars nameOf trProj Delta + (.const id us info) args recursorPrefix) + (hlength : args.length = pattern.majorIdx) + (hcase : NatRecIotaCase pattern major) : + ∃ (levels : List Lean4Lean.VLevel) + (captures : (RecursorIotaPattern pattern.recursorName + pattern.majorIdx pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr), + Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + (.app recursorPrefix (VExpr.natLit major)) levels captures := + hspine.matches_natRecRulePrefix hpattern.1 hlength hcase + +end RawRecursorRulePatternRel + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/NatRecognizer.lean b/Ix/Tc/Verify/Whnf/Iota/NatRecognizer.lean new file mode 100644 index 000000000..1ad3dbf2c --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/NatRecognizer.lean @@ -0,0 +1,335 @@ +import Ix.Tc.Verify.Whnf.RuntimeContracts + +/-! +# Linear Nat-recognizer success provenance + +The linear `Nat.rec` optimization used to expose only a whole-computation +semantic oracle. This module first records what a successful production run +actually established: the exact constant-headed spine, primitive-address +test, recursor lookup, count test, and literal-major position. Keeping this +trace separate from its semantic interpretation prevents trusted iota facts +from being applied to a recursor rule or major index that execution never +selected. +-/ + +namespace Ix.Tc + +namespace KId + +/-- In anonymous mode an identifier is completely determined by its content +address; the metadata component is `Unit`. -/ +theorem anon_eq_of_addr_eq {left right : KId .anon} + (h : left.addr = right.addr) : left = right := by + rcases left with ⟨leftAddr, ⟨⟩⟩ + rcases right with ⟨rightAddr, ⟨⟩⟩ + cases h + rfl + +end KId + +namespace TcM + +/-- Any successful `tryGetConst` hit is present in the returned state's +concrete environment. This covers both the initial fast hit and a hit after +the driver-owned lazy-ingress hook. -/ +theorem tryGetConst_success_loaded + {id : KId .anon} {c : KConst .anon} {s after : TcState .anon} + (hrun : TcM.tryGetConst id s = .ok (some c) after) : + after.env.get? id = some c := by + unfold TcM.tryGetConst at hrun + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ at hrun + unfold EStateM.bind at hrun + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] at hrun + simp only at hrun + match hget : s.env.get? id with + | some found => + rw [hget] at hrun + simp only at hrun + rcases hrun with ⟨rfl, rfl⟩ + exact hget + | none => + rw [hget] at hrun + simp only [pure_bind] at hrun + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ at hrun + unfold EStateM.bind at hrun + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + at hrun + simp only at hrun + change EStateM.bind (TcM.lazyIngressAddr id.addr) _ s = _ at hrun + unfold EStateM.bind at hrun + match hfault : TcM.lazyIngressAddr id.addr s with + | .error err faultState => + rw [hfault] at hrun + contradiction + | .ok _ faultState => + rw [hfault] at hrun + simp only at hrun + change EStateM.bind (get : TcM .anon (TcState .anon)) _ + faultState = _ at hrun + unfold EStateM.bind at hrun + rw [show (get : TcM .anon (TcState .anon)) faultState = + .ok faultState faultState from rfl] at hrun + simp only at hrun + match hretry : faultState.env.get? id with + | some found => + rw [hretry] at hrun + simp only at hrun + rcases hrun with ⟨rfl, rfl⟩ + exact hretry + | none => + rw [hretry] at hrun + cases hlazy : s.lazyFault.isSome with + | false => simp [hlazy] at hrun + | true => + simp only [hlazy, ↓reduceIte] at hrun + change EStateM.Result.error + (TcError.unknownConst id.addr) faultState = _ at hrun + cases hrun + +end TcM + +namespace RecM + +/-- Pure structural meaning of a successful descriptor. This relation +retains the recursor fields needed to compare the fast path's mathematical +major index with ordinary iota's wrapping index. -/ +def NatRecLiteralPartsDescriptor (id : KId .anon) (c : KConst .anon) + (source : KExpr .anon) (parts : NatRecLiteralParts .anon) : Prop := + ∃ (us : Array (KUniv .anon)) (headInfo : ExprInfo .anon) + (spine : Array (KExpr .anon)) + (name levelParams : Unit) (k isUnsafe : Bool) + (lvls params indices motives minors : UInt64) + (block : KId .anon) (memberIdx : UInt64) (ty : KExpr .anon) + (rules : Array (RecRule .anon)) (leanAll : Unit) + (major : Nat) (blob : Address) (majorInfo : ExprInfo .anon), + source.collectSpine = (.const id us headInfo, spine) ∧ + c = .recr name levelParams k isUnsafe lvls params indices motives + minors block memberIdx ty rules leanAll ∧ + 2 ≤ minors.toNat ∧ + spine[params.toNat + motives.toNat + minors.toNat + indices.toNat]? = + some (.nat major blob majorInfo) ∧ + parts = + { spine, major, + baseIdx := params.toNat + motives.toNat, + stepIdx := params.toNat + motives.toNat + 1, + majorIdx := params.toNat + motives.toNat + minors.toNat + + indices.toNat } + +/-- Trusted-world certificate extracted from a successful descriptor run. +It identifies the exact catalog recursor selected by execution without yet +claiming that a zero or successor rule exists. The witnesses remain under +the existential because this certificate is proof-irrelevant. -/ +def TrustedNatRecLiteralParts (world : VerifyWorld) + (source : KExpr .anon) (parts : NatRecLiteralParts .anon) : Prop := + ∃ id recursor, + PrimitiveIdAgrees world id ``Nat.rec ∧ + world.catalog id = some recursor ∧ + NatRecLiteralPartsDescriptor id recursor source parts + +/-- Exhaustive operational evidence returned by a successful +`natRecLiteralParts` execution. The indices are definitionally the ones +computed by production, including its per-field `UInt64.toNat` conversion. -/ +inductive NatRecLiteralPartsSuccessTrace + (methods : Methods .anon) (source : KExpr .anon) + (s : TcState .anon) : + NatRecLiteralParts .anon → TcState .anon → Prop + | intro + {id : KId .anon} {us : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {spine : Array (KExpr .anon)} + {name : Unit} {levelParams : Unit} {k isUnsafe : Bool} + {lvls params indices motives minors : UInt64} + {block : KId .anon} {memberIdx : UInt64} {ty : KExpr .anon} + {rules : Array (RecRule .anon)} {leanAll : Unit} + {major : Nat} {blob : Address} {majorInfo : ExprInfo .anon} + {after : TcState .anon} + (hcollect : source.collectSpine = (.const id us headInfo, spine)) + (haddr : id.addr = s.prims.natRec.addr) + (hlookup : TcM.tryGetConst id s = + .ok (some (.recr name levelParams k isUnsafe lvls params indices + motives minors block memberIdx ty rules leanAll)) after) + (hminors : 2 ≤ minors.toNat) + (hmajor : spine[params.toNat + motives.toNat + minors.toNat + + indices.toNat]? = some (.nat major blob majorInfo)) : + NatRecLiteralPartsSuccessTrace methods source s + { spine, major, + baseIdx := params.toNat + motives.toNat, + stepIdx := params.toNat + motives.toNat + 1, + majorIdx := params.toNat + motives.toNat + minors.toNat + + indices.toNat } + after + +namespace NatRecLiteralPartsSuccessTrace + +/-- Erase the success trace back to the exact production descriptor run. -/ +theorem eval + {methods : Methods .anon} {source : KExpr .anon} + {s after : TcState .anon} {parts : NatRecLiteralParts .anon} + (trace : NatRecLiteralPartsSuccessTrace methods source s parts after) : + (natRecLiteralParts source).run methods s = .ok (some parts) after := by + cases trace with + | intro hcollect haddr hlookup hminors hmajor => + unfold natRecLiteralParts + rw [hcollect, ReaderT.run_bind] + change EStateM.bind (RecM.prims.run methods) _ s = _ + unfold EStateM.bind + rw [prims_run] + simp only + simp [haddr] + change EStateM.bind (TcM.tryGetConst _) _ s = _ + unfold EStateM.bind + rw [hlookup] + simp only + rw [if_neg (by omega)] + simp only [hmajor] + rfl + +/-- Every successful production descriptor run has the trace above; misses +and lazy-ingress errors cannot inhabit this result. -/ +theorem complete + {methods : Methods .anon} {source : KExpr .anon} + {s after : TcState .anon} {parts : NatRecLiteralParts .anon} + (hrun : (natRecLiteralParts source).run methods s = + .ok (some parts) after) : + NatRecLiteralPartsSuccessTrace methods source s parts after := by + unfold natRecLiteralParts at hrun + rcases hcollect : source.collectSpine with ⟨head, spine⟩ + rw [hcollect] at hrun + cases head <;> simp only at hrun + all_goals try { simp at hrun } + case const id us headInfo => + rw [ReaderT.run_bind] at hrun + change EStateM.bind (RecM.prims.run methods) _ s = _ at hrun + unfold EStateM.bind at hrun + rw [prims_run] at hrun + simp only at hrun + by_cases haddr : id.addr = s.prims.natRec.addr + · simp [haddr] at hrun + change EStateM.bind (TcM.tryGetConst id) _ s = _ at hrun + unfold EStateM.bind at hrun + match hlookup : TcM.tryGetConst id s with + | .error err lookupState => + rw [hlookup] at hrun + contradiction + | .ok found lookupState => + rw [hlookup] at hrun + cases found with + | none => + simp only at hrun + cases hrun + | some c => + cases c <;> simp only at hrun + all_goals try cases hrun + case recr name levelParams k isUnsafe lvls params indices + motives minors block memberIdx ty rules leanAll => + by_cases hminors : 2 ≤ minors.toNat + · rw [if_neg (by omega : ¬ minors.toNat < 2)] at hrun + match hmajor : spine[params.toNat + motives.toNat + + minors.toNat + indices.toNat]? with + | none => + rw [hmajor] at hrun + cases hrun + | some majorExpr => + rw [hmajor] at hrun + cases majorExpr + case nat major blob majorInfo => + rcases hrun with ⟨rfl, rfl⟩ + exact .intro hcollect haddr hlookup hminors hmajor + all_goals simp at hrun + · have hlt : minors.toNat < 2 := by omega + rw [if_pos hlt] at hrun + cases hrun + · simp [haddr] at hrun + +end NatRecLiteralPartsSuccessTrace + +/-- Interpret only the trusted-lookup portion of an operational success +trace. The initial invariant binds the primitive address to `Nat.rec`; the +post-lookup invariant turns the concrete loaded hit into the immutable +catalog equation. -/ +theorem NatRecLiteralPartsSuccessTrace.trusted + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} {natSuccMode : NatSuccMode} + (context : NoDeltaPrimitiveContext world support flags natSuccMode) + {uvars : Nat} {Delta : KVLCtx} + {methods : Methods .anon} {source : KExpr .anon} + {s after : TcState .anon} {parts : NatRecLiteralParts .anon} + (trace : NatRecLiteralPartsSuccessTrace methods source s parts after) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Delta s) + (hAfter : WhnfStateInv .noAccel semantics trProj world support + uvars Delta after) : + TrustedNatRecLiteralParts world source parts := by + cases trace with + | @intro id us headInfo spine name levelParams k isUnsafe lvls params + indices motives minors block memberIdx ty rules leanAll major blob + majorInfo after hcollect haddr hlookup hminors hmajor => + let recursor : KConst .anon := + .recr name levelParams k isUnsafe lvls params indices motives minors + block memberIdx ty rules leanAll + have hloaded : after.env.get? id = some recursor := + TcM.tryGetConst_success_loaded hlookup + have hcatalog : world.catalog id = some recursor := + hAfter.1.core.loaded hloaded + have hid : id = s.prims.natRec := KId.anon_eq_of_addr_eq haddr + refine ⟨id, recursor, ?_, hcatalog, ?_⟩ + · simpa only [hid] using (context.stateTable hI).natRec + · exact ⟨us, headInfo, spine, name, levelParams, k, isUnsafe, lvls, + params, indices, motives, minors, block, memberIdx, ty, rules, + leanAll, major, blob, majorInfo, hcollect, rfl, hminors, hmajor, + rfl⟩ + +namespace TrustedNatRecLiteralParts + +/-- Resolve an actually selected rule slot to the exact registered-rule +pattern and prove that the pattern's wrapping iota index is the literal +position inspected by the fast descriptor. Rule existence remains an +explicit premise because `natRecLiteralParts` itself never indexes the rule +array. -/ +theorem patternAt + {trProj : RawProjRel} {world : VerifyWorld} + (hcatalogRel : TrustedCatalogRel trProj world) + {id : KId .anon} {recursor : KConst .anon} + (hprimitive : PrimitiveIdAgrees world id ``Nat.rec) + (hcatalog : world.catalog id = some recursor) + {source : KExpr .anon} {parts : NatRecLiteralParts .anon} + (hdescriptor : NatRecLiteralPartsDescriptor id recursor source parts) + {ruleIndex : Nat} {rule : RecRule .anon} + (hrule : recursor.RecursorRuleAt ruleIndex rule) : + ∃ (pattern : RecursorRulePattern) (majorIdx : Nat) + (blob : Address) (majorInfo : ExprInfo .anon), + RawRecursorRuleRel world.venv world.nameOf trProj + id recursor rule ∧ + RawRecursorRulePatternRel world.venv world.catalog world.nameOf + id recursor rule pattern ∧ + pattern.ruleIndex = ruleIndex ∧ + source.collectSpine.2[majorIdx]? = + some (.nat parts.major blob majorInfo) ∧ + pattern.majorIdx = majorIdx := by + obtain ⟨pattern, hpattern, hindex⟩ := + hcatalogRel.recursorPattern hprimitive.1 hcatalog hrule + have hruleSemantics := hcatalogRel.recursorRule hprimitive.1 hcatalog + hrule.hasRecursorRule + rcases hdescriptor with + ⟨us, headInfo, spine, name, levelParams, k, isUnsafe, lvls, params, + indices, motives, minors, block, memberIdx, ty, rules, leanAll, major, + blob, majorInfo, hcollect, hrecursor, hminors, hmajor, hparts⟩ + have hpatternMajor := hpattern.2.1 + have hcoherent := hpattern.2.2.1 + rw [hrecursor] at hpatternMajor hcoherent + simp only [KConst.RecursorMajorIdx, KConst.RecursorMajorIdxCoherent, + Option.some.injEq] at hpatternMajor hcoherent + have hmajorIdx : pattern.majorIdx = + params.toNat + motives.toNat + minors.toNat + indices.toNat := + hpatternMajor.symm.trans hcoherent + have hsourceSpine := congrArg Prod.snd hcollect + subst parts + refine ⟨pattern, + params.toNat + motives.toNat + minors.toNat + indices.toNat, + blob, majorInfo, hruleSemantics, hpattern, hindex, ?_, hmajorIdx⟩ + rw [hsourceSpine] + exact hmajor + +end TrustedNatRecLiteralParts + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/NatReduction.lean b/Ix/Tc/Verify/Whnf/Iota/NatReduction.lean new file mode 100644 index 000000000..3043f811a --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/NatReduction.lean @@ -0,0 +1,177 @@ +import Ix.Tc.Verify.Whnf.Iota.NatRuleLayout + +/-! +# Checked Nat-iota reduction through typed suffixes + +NatRuleLayout retains every application after the literal major instead of silently +discarding an over-application. This slice gives that suffix its semantic +eliminator. A definitionally equal replacement for the through-major prefix +can be retranslated under the same concrete arguments, and application +congruence transports the equality to the complete source. + +The selected iota pattern still needs two explicit inputs: its checks must +hold for the constructed capture map, and a concrete reducer result must +translate to `pattern.rhs.apply`. Those are precisely the remaining +inductive-admission/RHS obligations; neither follows from rule-slot existence +or from a successful pattern match alone. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM +namespace TrAppSuffix + +/-- The start of a typed suffix is itself typed whenever the complete +application is typed. For a nonempty suffix, the first applicable function +type is recovered by walking backward through the snoc derivation. -/ +theorem startHasType + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start : VExpr} + {args : List (KExpr .anon)} {resultV resultType : VExpr} + (h : TrAppSuffix env uvars nameOf trProj Delta start args resultV) + (hresult : env.HasType uvars Delta.toCtx resultV resultType) : + ∃ startType, env.HasType uvars Delta.toCtx start startType := by + induction h generalizing resultType with + | nil => exact ⟨resultType, hresult⟩ + | app hsuffix hfun _ _ ih => exact ih hfun + +/-- Replace the translated start of a suffix by a definitionally equal +concrete expression. Every original argument is reattached in production +order, and the complete old and new applications remain definitionally +equal. In particular, the result expression contains `args`; this theorem +cannot justify dropping a trailing application. -/ +theorem rebase + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start : VExpr} + {args : List (KExpr .anon)} {resultV : VExpr} + (h : TrAppSuffix env uvars nameOf trProj Delta start args resultV) + (henv : env.WF) (hDelta : KVLCtx.WF env uvars Delta) + {replacement : KExpr .anon} {replacementV : VExpr} + (hreplacementTr : + TrKExprS env uvars nameOf trProj Delta replacement replacementV) + (hreplacement : + env.IsDefEqU uvars Delta.toCtx start replacementV) : + ∃ resultV', + TrKExprS env uvars nameOf trProj Delta + (args.foldl KExpr.mkApp replacement) resultV' ∧ + env.IsDefEqU uvars Delta.toCtx resultV resultV' := by + induction h generalizing replacement replacementV with + | nil => exact ⟨replacementV, hreplacementTr, hreplacement⟩ + | @app args current arg argV A B hsuffix hfun harg hargTr ih => + obtain ⟨currentV', hcurrentTr, hcurrentEq⟩ := + ih hreplacementTr hreplacement + have hcurrentType : + env.HasType uvars Delta.toCtx currentV' (.forallE A B) := + hfun.defeqU_l henv hDelta.toCtx hcurrentEq + have hcurrentEqAt : + env.IsDefEq uvars Delta.toCtx current currentV' (.forallE A B) := + hcurrentEq.of_l henv hDelta.toCtx hfun + refine ⟨.app currentV' argV, ?_, ?_⟩ + · rw [List.foldl_append] + simp only [List.foldl_cons, List.foldl_nil] + rw [KExpr.mkApp_shape] + exact .app hcurrentType harg hcurrentTr hargTr + · exact (Lean4Lean.VEnv.IsDefEq.appDF hcurrentEqAt harg).toU + +end TrAppSuffix +end RecM + +namespace RawRecursorRulePatternRel + +/-- Apply the soundness component of an admitted iota pattern in the current +environment. A match is deliberately insufficient: the pattern's explicit +definitional-equality checks must also be discharged. -/ +theorem checkedReduction + {env : Lean4Lean.VEnv} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} + {id : KId .anon} {recursor : KConst .anon} {rule : RecRule .anon} + {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel env catalog nameOf id recursor + rule pattern) + {uvars : Nat} {Gamma : List VExpr} {source A : VExpr} + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + source levels captures) + (htype : env.HasType uvars Gamma source A) + (hchecks : pattern.checks.OK (env.IsDefEqU uvars Gamma) + levels captures) : + env.IsDefEqU uvars Gamma source + (pattern.rhs.apply levels captures) := by + rcases hpattern with + ⟨_, _, _, _, _, _, _, hsound⟩ + exact hsound Lean4Lean.VEnv.LE.rfl hmatch htype hchecks + +end RawRecursorRulePatternRel + +namespace RecM +namespace NatRecLiteralTranslationSplit + +/-- Turn a checked iota match at NatRuleLayout's exact through-major boundary into a +semantic replacement of the complete source. The concrete RHS is rebuilt +under every retained trailing argument, so the conclusion is valid for both +exactly applied and over-applied recursors. + +This theorem isolates the final admission-side obligations as `hchecks` and +`hrhsTr`: the current generic inductive oracle supplies conditional pattern +soundness, but it does not prove that a successful match passes its checks or +identify the concrete rule-body application with `pattern.rhs.apply`. -/ +theorem checkedRhsSuffix + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Delta : KVLCtx} + (hDelta : KVLCtx.WF world.venv uvars Delta) + {id : KId .anon} {source : KExpr .anon} + {parts : NatRecLiteralParts .anon} {majorIdx : Nat} + {sourceV : VExpr} {priorArgs laterArgs : List (KExpr .anon)} + {priorV : VExpr} + (hsplit : NatRecLiteralTranslationSplit world.venv uvars world.nameOf + trProj Delta id source parts majorIdx sourceV priorArgs laterArgs + priorV) + {recursor : KConst .anon} {rule : RecRule .anon} + {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel world.venv world.catalog + world.nameOf id recursor rule pattern) + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + (.app priorV (.natLit parts.major)) levels captures) + {sourceType : VExpr} + (hsourceType : world.venv.HasType uvars Delta.toCtx sourceV sourceType) + (hchecks : pattern.checks.OK + (world.venv.IsDefEqU uvars Delta.toCtx) levels captures) + {rhs : KExpr .anon} + (hrhsTr : TrKExprS world.venv uvars world.nameOf trProj Delta rhs + (pattern.rhs.apply levels captures)) : + ∃ resultV, + TrKExprS world.venv uvars world.nameOf trProj Delta + (laterArgs.foldl KExpr.mkApp rhs) resultV ∧ + world.venv.IsDefEqU uvars Delta.toCtx sourceV resultV := by + rcases hsplit with + ⟨_, _, _, _, _, _, _, _, hthroughTr, hsuffix⟩ + obtain ⟨throughType, hthroughType⟩ := + hsuffix.startHasType hsourceType + have hthroughEq := + hpattern.checkedReduction hmatch hthroughType hchecks + exact hsuffix.rebase world.venvWF hDelta hrhsTr hthroughEq + +end NatRecLiteralTranslationSplit +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/NatRuleLayout.lean b/Ix/Tc/Verify/Whnf/Iota/NatRuleLayout.lean new file mode 100644 index 000000000..cb260928b --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/NatRuleLayout.lean @@ -0,0 +1,366 @@ +import Ix.Tc.Verify.Whnf.Iota.NatPatternMatching + +/-! +# Trusted Nat-rule layout and through-major spine splitting + +The linear descriptor checks that the recursor reports at least two minors, +but it never indexes the rule array. Moreover, constructor indices are local +to an inductive family: an arbitrary constructor at index zero is not thereby +`Nat.zero`. This slice records the missing Nat-specific catalog fact as an +explicit certificate rather than deriving it from either count alone. + +The second half splits a translated production spine at an observed array +hit. It retains the application through the major and a typed trailing +suffix separately, so later RHS reasoning cannot accidentally discard an +over-application. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-! ## Trusted Nat recursor layout -/ + +/-- Exact trusted catalog data needed to interpret the first two rules of a +`Nat.rec` declaration. This is the Nat-specific consequence that a complete +inductive-admission proof must construct. Neither `minors ≥ 2` nor a bare +constructor index can inhabit these fields. -/ +structure TrustedNatRecursorLayout (trProj : RawProjRel) (world : VerifyWorld) + (id : KId .anon) (recursor : KConst .anon) : Prop where + primitive : PrimitiveIdAgrees world id ``Nat.rec + catalog : world.catalog id = some recursor + zero : ∃ rule pattern, + recursor.RecursorRuleAt 0 rule ∧ + RawRecursorRulePatternRel world.venv world.catalog world.nameOf + id recursor rule pattern ∧ + pattern.ruleIndex = 0 ∧ + pattern.constructorName = ``Nat.zero ∧ + pattern.constructorParams = 0 ∧ + pattern.constructorFields = 0 + succ : ∃ rule pattern, + recursor.RecursorRuleAt 1 rule ∧ + RawRecursorRulePatternRel world.venv world.catalog world.nameOf + id recursor rule pattern ∧ + pattern.ruleIndex = 1 ∧ + pattern.constructorName = ``Nat.succ ∧ + pattern.constructorParams = 0 ∧ + pattern.constructorFields = 1 + +/-- World-level provider for whichever concrete declaration is bound to the +trusted `Nat.rec` primitive. Keeping the primitive and catalog equations as +arguments prevents a certificate for an unrelated recursor from being used. -/ +def TrustedNatRecursorLayouts (trProj : RawProjRel) + (world : VerifyWorld) : Prop := + ∀ {id recursor}, + PrimitiveIdAgrees world id ``Nat.rec → + world.catalog id = some recursor → + TrustedNatRecursorLayout trProj world id recursor + +namespace TrustedNatRecursorLayout + +/-- Select the exact trusted zero or successor rule for a canonical Nat +literal and recover both its registered equation and NatPatternMatching case shape. -/ +theorem caseForMajor + {trProj : RawProjRel} {world : VerifyWorld} + {id : KId .anon} {recursor : KConst .anon} + (layout : TrustedNatRecursorLayout trProj world id recursor) + (hcatalogRel : TrustedCatalogRel trProj world) + (major : Nat) : + ∃ rule pattern, + recursor.RecursorRuleAt pattern.ruleIndex rule ∧ + RawRecursorRuleRel world.venv world.nameOf trProj + id recursor rule ∧ + RawRecursorRulePatternRel world.venv world.catalog world.nameOf + id recursor rule pattern ∧ + NatRecIotaCase pattern major := by + cases major with + | zero => + obtain ⟨rule, pattern, hrule, hpattern, hindex, hname, hparams, + hfields⟩ := layout.zero + refine ⟨rule, pattern, ?_, + hcatalogRel.recursorRule layout.primitive.1 layout.catalog + hrule.hasRecursorRule, + hpattern, ?_⟩ + · simpa only [hindex] using hrule + · exact Or.inl ⟨rfl, hindex, hname, hparams, hfields⟩ + | succ predecessor => + obtain ⟨rule, pattern, hrule, hpattern, hindex, hname, hparams, + hfields⟩ := layout.succ + refine ⟨rule, pattern, ?_, + hcatalogRel.recursorRule layout.primitive.1 layout.catalog + hrule.hasRecursorRule, + hpattern, ?_⟩ + · simpa only [hindex] using hrule + · exact Or.inr + ⟨predecessor, rfl, hindex, hname, hparams, hfields⟩ + +end TrustedNatRecursorLayout + +/-! ## Typed application suffixes and positional splitting -/ + +namespace RecM + +/-- Typed translation of a left-associated application suffix starting from +an already translated prefix. The suffix is stored in production order. -/ +inductive TrAppSuffix (env : Lean4Lean.VEnv) (uvars : Nat) + (nameOf : Address → Option Lean.Name) (trProj : RawProjRel) + (Delta : KVLCtx) (start : VExpr) : + List (KExpr .anon) → VExpr → Prop + | nil : TrAppSuffix env uvars nameOf trProj Delta start [] start + | app {args current arg argV A B} : + TrAppSuffix env uvars nameOf trProj Delta start args current → + env.HasType uvars Delta.toCtx current (.forallE A B) → + env.HasType uvars Delta.toCtx argV A → + TrKExprS env uvars nameOf trProj Delta arg argV → + TrAppSuffix env uvars nameOf trProj Delta start (args ++ [arg]) + (.app current argV) + +namespace TrAppSuffix + +/-- Reattach a certified suffix to a translated concrete prefix. -/ +theorem tr + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start : VExpr} + {args : List (KExpr .anon)} {resultV : VExpr} + (h : TrAppSuffix env uvars nameOf trProj Delta start args resultV) + {startExpr : KExpr .anon} + (hstart : TrKExprS env uvars nameOf trProj Delta startExpr start) : + TrKExprS env uvars nameOf trProj Delta + (args.foldl KExpr.mkApp startExpr) resultV := by + induction h with + | nil => exact hstart + | app hsuffix hfun harg hargTr ih => + rw [List.foldl_append] + simp only [List.foldl_cons, List.foldl_nil] + rw [KExpr.mkApp_shape] + exact .app hfun harg ih hargTr + +end TrAppSuffix + +namespace TrAppSpine + +/-- Complete typed decomposition of a translated spine at one observed raw +argument. `throughTr` ends exactly after applying the major; `suffixTr` +accounts for every later argument. -/ +def SplitAt + (env : Lean4Lean.VEnv) (uvars : Nat) + (nameOf : Address → Option Lean.Name) (trProj : RawProjRel) + (Delta : KVLCtx) (head : KExpr .anon) + (args : List (KExpr .anon)) (majorIdx : Nat) + (major : KExpr .anon) (resultV : VExpr) : Prop := + ∃ (priorArgs laterArgs : List (KExpr .anon)) (priorV majorV : VExpr), + args = priorArgs ++ major :: laterArgs ∧ + majorIdx = priorArgs.length ∧ + TrAppSpine env uvars nameOf trProj Delta head priorArgs priorV ∧ + TrKExprS env uvars nameOf trProj Delta major majorV ∧ + TrKExprS env uvars nameOf trProj Delta + (KExpr.mkApp (priorArgs.foldl KExpr.mkApp head) major) + (.app priorV majorV) ∧ + TrAppSuffix env uvars nameOf trProj Delta + (.app priorV majorV) laterArgs resultV + +/-- Split a typed production-order spine at any successful `getElem?` hit. +The proof follows the snoc structure of `TrAppSpine`, distinguishing a hit in +the prior prefix from the newly appended final argument. -/ +theorem splitAt + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {head major : KExpr .anon} + {args : List (KExpr .anon)} {majorIdx : Nat} {resultV : VExpr} + (h : TrAppSpine env uvars nameOf trProj Delta head args resultV) + (hmajor : args[majorIdx]? = some major) : + SplitAt env uvars nameOf trProj Delta head args majorIdx major + resultV := by + induction h generalizing majorIdx major with + | head hhead => + simp at hmajor + | @app args fV arg argV A B hprefix hfun harg hargTr ih => + by_cases hbefore : majorIdx < args.length + · have hprefixMajor := hmajor + rw [List.getElem?_append_left hbefore] at hprefixMajor + obtain ⟨priorArgs, laterArgs, priorV, majorV, hargs, hindex, + hpriorTr, hmajorTr, hthroughTr, hlaterTr⟩ := ih hprefixMajor + refine ⟨priorArgs, laterArgs ++ [arg], priorV, majorV, ?_, hindex, + hpriorTr, hmajorTr, hthroughTr, + TrAppSuffix.app hlaterTr hfun harg hargTr⟩ + calc + args ++ [arg] = + (priorArgs ++ major :: laterArgs) ++ [arg] := + congrArg (· ++ [arg]) hargs + _ = priorArgs ++ major :: (laterArgs ++ [arg]) := by + simp only [List.append_assoc, List.cons_append] + · have hbound : majorIdx < (args ++ [arg]).length := + (List.getElem?_eq_some_iff.mp hmajor).choose + have hindex : majorIdx = args.length := by + simp only [List.length_append, List.length_singleton] at hbound + omega + subst majorIdx + rw [List.getElem?_concat_length] at hmajor + have hargMajor : arg = major := Option.some.inj hmajor + subst major + refine ⟨args, [], fV, argV, by simp, rfl, hprefix, hargTr, ?_, .nil⟩ + rw [KExpr.mkApp_shape] + exact .app hfun harg hprefix.tr hargTr + +end TrAppSpine + +/-! ## Descriptor-indexed translated Nat splits -/ + +/-- Exact translated decomposition induced by the literal position recorded +in a successful Nat-recognizer descriptor. -/ +def NatRecLiteralTranslationSplit + (env : Lean4Lean.VEnv) (uvars : Nat) + (nameOf : Address → Option Lean.Name) (trProj : RawProjRel) + (Delta : KVLCtx) (id : KId .anon) + (source : KExpr .anon) (parts : NatRecLiteralParts .anon) + (majorIdx : Nat) (sourceV : VExpr) + (priorArgs laterArgs : List (KExpr .anon)) (priorV : VExpr) : Prop := + ∃ (us : Array (KUniv .anon)) (headInfo : ExprInfo .anon) + (blob : Address) (majorInfo : ExprInfo .anon), + source.collectSpine = (.const id us headInfo, parts.spine) ∧ + parts.spine.toList = + priorArgs ++ (.nat parts.major blob majorInfo) :: laterArgs ∧ + majorIdx = priorArgs.length ∧ + TrAppSpine env uvars nameOf trProj Delta + (.const id us headInfo) priorArgs priorV ∧ + TrKExprS env uvars nameOf trProj Delta + (KExpr.mkApp (priorArgs.foldl KExpr.mkApp (.const id us headInfo)) + (.nat parts.major blob majorInfo)) + (.app priorV (.natLit parts.major)) ∧ + TrAppSuffix env uvars nameOf trProj Delta + (.app priorV (.natLit parts.major)) laterArgs sourceV + +namespace NatRecLiteralPartsDescriptor + +/-- Any trusted rule pattern for this descriptor uses the same major position +as the literal array hit. This is NatRecognizer's arithmetic-coherence argument, +stated for an already selected pattern so no second oracle choice is made. -/ +theorem patternMajor + {world : VerifyWorld} + {id : KId .anon} {recursor : KConst .anon} + {source : KExpr .anon} {parts : NatRecLiteralParts .anon} + (hdescriptor : NatRecLiteralPartsDescriptor id recursor source parts) + {rule : RecRule .anon} {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel world.venv world.catalog + world.nameOf id recursor rule pattern) : + ∃ blob majorInfo, + source.collectSpine.2[pattern.majorIdx]? = + some (.nat parts.major blob majorInfo) := by + rcases hdescriptor with + ⟨us, headInfo, spine, name, levelParams, k, isUnsafe, lvls, params, + indices, motives, minors, block, memberIdx, ty, rules, leanAll, major, + blob, majorInfo, hcollect, hrecursor, hminors, hmajor, hparts⟩ + have hpatternMajor := hpattern.2.1 + have hcoherent := hpattern.2.2.1 + rw [hrecursor] at hpatternMajor hcoherent + simp only [KConst.RecursorMajorIdx, KConst.RecursorMajorIdxCoherent, + Option.some.injEq] at hpatternMajor hcoherent + have hmajorIdx : pattern.majorIdx = + params.toNat + motives.toNat + minors.toNat + indices.toNat := + hpatternMajor.symm.trans hcoherent + have hsourceSpine := congrArg Prod.snd hcollect + subst parts + refine ⟨blob, majorInfo, ?_⟩ + rw [hsourceSpine, hmajorIdx] + exact hmajor + +/-- Split the actual translated source at a descriptor-aligned literal hit. +The major translation becomes the canonical Theory numeral by inversion of +the owned literal translation rule. -/ +theorem translatedSplit + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {id : KId .anon} {recursor : KConst .anon} + {source : KExpr .anon} {parts : NatRecLiteralParts .anon} + (hdescriptor : NatRecLiteralPartsDescriptor id recursor source parts) + {majorIdx : Nat} {blob : Address} {majorInfo : ExprInfo .anon} + {sourceV : VExpr} + (hsource : TrKExprS env uvars nameOf trProj Delta source sourceV) + (hmajor : source.collectSpine.2[majorIdx]? = + some (.nat parts.major blob majorInfo)) : + ∃ priorArgs laterArgs priorV, + NatRecLiteralTranslationSplit env uvars nameOf trProj Delta id + source parts majorIdx sourceV priorArgs laterArgs priorV := by + rcases hdescriptor with + ⟨us, headInfo, spine, name, levelParams, k, isUnsafe, lvls, params, + indices, motives, minors, block, memberIdx, ty, rules, leanAll, major, + descriptorBlob, descriptorInfo, hcollect, hrecursor, hminors, + hdescriptorMajor, hparts⟩ + subst parts + have hmajorSpine : spine[majorIdx]? = + some (.nat major blob majorInfo) := by + rw [hcollect] at hmajor + exact hmajor + have hmajorList : spine.toList[majorIdx]? = + some (.nat major blob majorInfo) := by + rw [Array.getElem?_toList] + exact hmajorSpine + have hspine := trAppSpine_of_collectSpine hsource hcollect + obtain + ⟨priorArgs, laterArgs, priorV, majorV, hargs, hindex, hpriorTr, + hmajorTr, hthroughTr, hsuffixTr⟩ := hspine.splitAt hmajorList + cases hmajorTr with + | nat hlit => + exact ⟨priorArgs, laterArgs, priorV, us, headInfo, blob, majorInfo, + hcollect, hargs, hindex, hpriorTr, hthroughTr, hsuffixTr⟩ + +end NatRecLiteralPartsDescriptor + +namespace TrustedNatRecLiteralParts + +/-- Assemble NatRecognizer's trusted descriptor, NatRuleLayout's exact Nat layout and source +split, and NatPatternMatching's constructive pattern match. Pattern checks and RHS +identification deliberately remain outside this theorem. -/ +theorem translatedCase + {trProj : RawProjRel} {world : VerifyWorld} + (hcatalogRel : TrustedCatalogRel trProj world) + (layouts : TrustedNatRecursorLayouts trProj world) + {source : KExpr .anon} {parts : NatRecLiteralParts .anon} + (htrusted : TrustedNatRecLiteralParts world source parts) + {uvars : Nat} {Delta : KVLCtx} {sourceV : VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + source sourceV) : + ∃ (id : KId .anon) (recursor : KConst .anon) (rule : RecRule .anon) + (pattern : RecursorRulePattern) + (priorArgs laterArgs : List (KExpr .anon)) (priorV : VExpr) + (levels : List Lean4Lean.VLevel) + (captures : (RecursorIotaPattern pattern.recursorName + pattern.majorIdx pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr), + NatRecLiteralTranslationSplit world.venv uvars world.nameOf trProj + Delta id source parts pattern.majorIdx sourceV + priorArgs laterArgs priorV ∧ + recursor.RecursorRuleAt pattern.ruleIndex rule ∧ + RawRecursorRuleRel world.venv world.nameOf trProj + id recursor rule ∧ + RawRecursorRulePatternRel world.venv world.catalog world.nameOf + id recursor rule pattern ∧ + NatRecIotaCase pattern parts.major ∧ + Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + (.app priorV (.natLit parts.major)) levels captures := by + obtain ⟨id, recursor, hprimitive, hcatalog, hdescriptor⟩ := htrusted + let layout := layouts hprimitive hcatalog + obtain ⟨rule, pattern, hrule, hruleRel, hpattern, hcase⟩ := + layout.caseForMajor hcatalogRel parts.major + obtain ⟨blob, majorInfo, hmajor⟩ := hdescriptor.patternMajor hpattern + obtain ⟨priorArgs, laterArgs, priorV, us, headInfo, splitBlob, + splitMajorInfo, hcollect, hargs, hindex, hpriorTr, hthroughTr, + hlaterTr⟩ := hdescriptor.translatedSplit hsource hmajor + obtain ⟨levels, captures, hmatch⟩ := + hpattern.matches_natLiteralPrefix hpriorTr hindex.symm hcase + refine ⟨id, recursor, rule, pattern, priorArgs, laterArgs, priorV, + levels, captures, ?_, hrule, hruleRel, hpattern, hcase, hmatch⟩ + exact ⟨us, headInfo, splitBlob, splitMajorInfo, hcollect, hargs, hindex, + hpriorTr, hthroughTr, hlaterTr⟩ + +end TrustedNatRecLiteralParts + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/OptionalReduction.lean b/Ix/Tc/Verify/Whnf/Iota/OptionalReduction.lean new file mode 100644 index 000000000..286e3fee1 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/OptionalReduction.lean @@ -0,0 +1,122 @@ +import Ix.Tc.Verify.Whnf.Iota.Ingress + +/-! +# Exhaustive iota optional-reduction contract + +`Ingress` proves that every result or partial error of the production +`tryIotaWithFlags` dispatcher preserves the complete K1 state invariant. This +slice separates the two remaining concerns: + +* `IotaCallbackFrameOracle` retains the trusted-reference and + recursion-cache authorities crossed by the dispatcher; predecessor-table + callback contracts now come directly from `Methods.WF` at their exact + translated inputs; and +* `IotaSuccessOracle` is the admission-owned semantic boundary for an observed + successful reduction. + +The latter deliberately contains no state-preservation field. Successful, +absent, and error states are all discharged by `Ingress`; the inductive boundary +supplies only finite result support and Theory meaning. Lazy declaration +ingress is supplied separately by `AnonLazyIngressContext`, which identifies +the actual installed `ingressAnonAddrShallow` hook. +-/ + +namespace Ix.Tc + +/-- Remaining non-method authority used by `tryIotaWithFlags`. + +The predecessor-table WHNF and inference frames are no longer fields here: +`Ingress` instantiates them directly from `Methods.WF` at the supported, +translated inputs selected by the production trace. What remains is +catalog/reference closure and semantic provenance for recursion-cache +writes. -/ +structure IotaCallbackFrameOracle (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Prop where + trustedReferences : RecM.TrustedReferences world support + isRecValid : ∀ {id : KId .anon}, world.trusted id → + ∀ value, + semantics.Valid (CacheAuthority.stable world) support + (.isRec id.addr value) + +/-- Semantic authority for one observed successful iota reduction. + +This is the direct boundary required by the current application step. Unlike +the historical `InductiveReductionOracle.iota` field, it does not depend on an +unrelated preceding head-WHNF equation. Inductive admission must construct +this field from its registered checked recursor rules, including ordinary +iota, literal preprocessing, K synthesis, and struct eta. -/ +structure IotaSuccessOracle (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Prop where + accept : ∀ {uvars : Nat} {Delta : KVLCtx} + {methods : Methods .anon} {source : KExpr .anon} + {sourceV : Lean4Lean.VExpr} {flags : WhnfFlags} + {s sf : TcState .anon} {result : KExpr .anon}, + Methods.WFAt .noAccel semantics trProj world support uvars methods → + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + WhnfStateInv .noAccel semantics trProj world support uvars Delta s → + (RecM.tryIotaWithFlags source flags).run methods s = + .ok (some result) sf → + support result ∧ + WhnfMeaning trProj world uvars Delta source result + +namespace RecM + +/-- Complete `OptionalReduction.WF` for the production iota dispatcher. + +All state claims, including partial errors, come from the exhaustive Ingress +proof. The success oracle is consulted only after the actual run has returned +`some`; misses require no semantic authority. -/ +theorem tryIotaWithFlags_optional_wf_of_contexts + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (kCensus : KSynthCandidateRequestCensus requests) + (iotaCensus : IotaRuleRequestCensus requests) + (finishCensus : StructEtaFinishRequestCensus requests) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} + (strings : ProjectionStringPlanContext trProj world support) + (inputs : WhnfCoreInputSupport support) + (telescopeInputs : ConstructorTelescopeInputSupport support) + (constructorInputs : + ConstructorTelescopeInputOracle trProj world support) + (recursorInputs : StructEtaRecursorInputOracle trProj world support) + (candidateInputs : KSynthCandidateInputOracle trProj world support) + (cleanupInputs : NatOffsetCleanupInputOracle trProj world support) + (ingress : AnonLazyIngressContext .noAccel semantics trProj world support) + (callbacks : IotaCallbackFrameOracle semantics trProj world support) + (success : IotaSuccessOracle semantics trProj world support) + (flags : WhnfFlags) : + OptionalReduction.WF .noAccel semantics trProj world support + (fun source => tryIotaWithFlags source flags) := by + intro uvars Delta source sourceV s hsourceSupport hsource + intro methods hmethods hI + have hstate := + tryIotaWithFlags_state_wf_of_contexts (uvars := uvars) (Delta := Delta) + hrun kCensus iotaCensus finishCensus strings inputs telescopeInputs + constructorInputs recursorInputs candidateInputs cleanupInputs + hmethods (fun {_} => ingress.preserves) + callbacks.trustedReferences + (fun id htrusted => + IsRecCacheWriteOracle.of_trusted htrusted + (callbacks.isRecValid htrusted)) + source hsourceSupport hsource flags s + have hpost := hstate hI + match hrunIota : + (tryIotaWithFlags source flags).run methods s with + | .error err sf => + rw [hrunIota] at hpost + exact ⟨hpost.1, trivial⟩ + | .ok none sf => + rw [hrunIota] at hpost + exact ⟨hpost.1, trivial⟩ + | .ok (some result) sf => + rw [hrunIota] at hpost + exact ⟨hpost.1, + success.accept hmethods hsourceSupport hsource hI hrunIota⟩ + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/RuleInstantiation.lean b/Ix/Tc/Verify/Whnf/Iota/RuleInstantiation.lean new file mode 100644 index 000000000..2a14d0992 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/RuleInstantiation.lean @@ -0,0 +1,139 @@ +import Ix.Tc.Verify.Whnf.Iota.NatReduction +import Ix.Tc.Verify.InstL + +/-! +# Typed registered recursor RHS instantiation + +`RawRecursorRuleRel` previously ended at `RawExprRel`. That relation is +deliberately syntax-only, so it could not soundly be supplied to +`TrKExprS.instL`, whose proof needs typing at every application and binder. +The admission certificate now retains a `TrKExprS` derivation for the same +closed concrete rule body and registered Theory RHS. + +This slice carries that derivation through both the pure universe-instantiation +specification and a successful production `TcM.instantiateUnivParams` run. +The runtime theorem is stated for the nonempty path used by universe-polymorphic +recursors such as `Nat.rec`; production's parameter-free fast path remains a +separate case. + +The result intentionally stops at `defeq.rhs.instL levels`. It does not claim +that this unapplied registered body is already `pattern.rhs.apply`: ordinary +iota still applies the recursor prefix, constructor fields, and any trailing +arguments. Modeling those applications is the next bridge, and conflating +the two terms here would be unsound. +-/ + +namespace Ix.Tc + +open Lean4Lean (VDefEq VEnv VExpr) + +namespace RegisteredRecursorRuleRhsRel + +/-- Project the syntax-only relation retained for admission diagnostics. -/ +theorem rhsRaw + {env : VEnv} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {id : KId .anon} {c : KConst .anon} + {rule : RecRule .anon} {defeq : VDefEq} + (h : RegisteredRecursorRuleRhsRel env nameOf trProj id c rule defeq) : + RawExprRel env nameOf trProj [] rule.rhs defeq.rhs := by + obtain ⟨_, _, _, _, _, _, _, hrhs, _⟩ := h + exact hrhs + +/-- Project the typed structural relation required by verified walkers. -/ +theorem rhsStructural + {env : VEnv} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {id : KId .anon} {c : KConst .anon} + {rule : RecRule .anon} {defeq : VDefEq} + (h : RegisteredRecursorRuleRhsRel env nameOf trProj id c rule defeq) : + TrKExprS env defeq.uvars nameOf trProj [] rule.rhs defeq.rhs := by + obtain ⟨_, _, _, _, _, _, _, _, hrhs⟩ := h + exact hrhs + +/-- Instantiate a typed registered rule body through the pure walker spec. +The quotient translation is necessary because universe smart constructors +are Theory-equivalent rather than syntactically identical. -/ +theorem instUnivSpec + {env : VEnv} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {id : KId .anon} {c : KConst .anon} + {rule : RecRule .anon} {defeq : VDefEq} + (h : RegisteredRecursorRuleRhsRel env nameOf trProj id c rule defeq) + {U' : Nat} + (henv : env.WF) + (hlit : ∀ literal, env.ContainsLits literal → + VExpr.WF env U' [] (VExpr.trLiteral literal)) + (htp : TrProjOK env U' trProj) + {us : Array (KUniv .anon)} + (hus : ∀ level ∈ us, (KUniv.toVLevel level).WF U') + (harity : defeq.uvars = us.size) + {result : KExpr .anon} + (hspec : KExpr.instUnivSpec rule.rhs us = .ok result) + (hfaithful : ∀ left right, + KExpr.LevelReach us rule.rhs left → + KExpr.LevelReach us rule.rhs right → left.AddrFaithful right) + (hsize : ∀ level, KExpr.LevelReach us rule.rhs level → + level.size < UInt64.size) : + TrKExpr env U' nameOf trProj [] result + (defeq.rhs.instL (us.toList.map KUniv.toVLevel)) := by + have hresult := TrKExprS.instL henv hlit htp hus harity + h.rhsStructural (by trivial) hspec hfaithful hsize + simpa using hresult + +/-- Carry the registered RHS through an observed successful production +universe-instantiation run. The walker Hoare theorem supplies the exact pure +spec equation; `instUnivSpec` above supplies the Theory translation. -/ +theorem instantiateUnivParams_nonempty + {env : VEnv} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {id : KId .anon} {c : KConst .anon} + {rule : RecRule .anon} {defeq : VDefEq} + (h : RegisteredRecursorRuleRhsRel env nameOf trProj id c rule defeq) + {U' : Nat} + (henv : env.WF) + (hlit : ∀ literal, env.ContainsLits literal → + VExpr.WF env U' [] (VExpr.trLiteral literal)) + (htp : TrProjOK env U' trProj) + {us : Array (KUniv .anon)} + (hnonempty : us.isEmpty = false) + (hus : ∀ level ∈ us, (KUniv.toVLevel level).WF U') + (harity : defeq.uvars = us.size) + {S : KExpr .anon → Prop} + (hcollision : KExpr.CollisionFree S) + (hreach : ∀ expr, KExpr.InstUnivReach us rule.rhs expr → S expr) + {s after : TcState .anon} + (hintern : s.env.intern.WF ∧ + ∀ expr, s.env.intern.ExprSupport expr → S expr) + {result : KExpr .anon} + (hrun : TcM.instantiateUnivParams rule.rhs us s = .ok result after) + (hfaithful : ∀ left right, + KExpr.LevelReach us rule.rhs left → + KExpr.LevelReach us rule.rhs right → left.AddrFaithful right) + (hsize : ∀ level, KExpr.LevelReach us rule.rhs level → + level.size < UInt64.size) : + TrKExpr env U' nameOf trProj [] result + (defeq.rhs.instL (us.toList.map KUniv.toVLevel)) := by + have hwalk := TcM.instantiateUnivParams_wf hcollision hreach hintern + rw [hrun] at hwalk + have hspec : KExpr.instUnivSpec rule.rhs us = .ok result := by + simpa [KExpr.instantiateUnivParamsSpec, hnonempty] using hwalk.2.1 + exact h.instUnivSpec henv hlit htp hus harity hspec hfaithful hsize + +end RegisteredRecursorRuleRhsRel + +namespace RawRecursorRuleRel + +/-- The existential rule certificate exposes a particular registered RHS +that is both structurally translated and Theory-typed. -/ +theorem registeredRhsTyped + {env : VEnv} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {id : KId .anon} {c : KConst .anon} + {rule : RecRule .anon} + (h : RawRecursorRuleRel env nameOf trProj id c rule) : + ∃ defeq, + RegisteredRecursorRuleRhsRel env nameOf trProj id c rule defeq ∧ + TrKExprS env defeq.uvars nameOf trProj [] rule.rhs defeq.rhs ∧ + env.HasType defeq.uvars [] defeq.rhs defeq.type := by + obtain ⟨defeq, hrhs⟩ := h.registeredRhs + exact ⟨defeq, hrhs, hrhs.rhsStructural, hrhs.rhsTyped⟩ + +end RawRecursorRuleRel + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/RuleSuffixTransport.lean b/Ix/Tc/Verify/Whnf/Iota/RuleSuffixTransport.lean new file mode 100644 index 000000000..1e7640413 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/RuleSuffixTransport.lean @@ -0,0 +1,117 @@ +import Ix.Tc.Verify.Whnf.Iota.RuleInstantiation + +/-! +# Quotient-aware registered RHS suffix transport + +NatReduction's suffix rebasing theorem required a structural `TrKExprS` witness for +the replacement expression. RuleInstantiation necessarily produces the quotient relation +`TrKExpr`: universe-instantiation smart constructors preserve Theory meaning, +but need not preserve the exact Theory syntax chosen by the admission record. + +This slice removes that impedance mismatch without strengthening either +relation. It selects the structural representative already carried by +`TrKExpr`, transports the through-major equality to that representative, and +then reuses NatReduction's typed application induction. Consequently a checked iota +reduction can now consume a quotient-translated concrete RHS while retaining +every trailing application. + +The theorem still does not identify an instantiated registered body with +`pattern.rhs.apply`. Ordinary iota's prefix and constructor-field application +sequence remains an explicit subsequent obligation. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM +namespace TrAppSuffix + +/-- Rebase a typed application suffix from a quotient-translated concrete +replacement. The quotient contains a structural representative; composing +the caller's equality with the representative equality is enough to invoke +the structural suffix theorem. + +The result is structural again. In particular, all original concrete suffix +arguments remain visible in `args.foldl KExpr.mkApp replacement`. -/ +theorem rebaseQuot + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {start : VExpr} + {args : List (KExpr .anon)} {resultV : VExpr} + (h : TrAppSuffix env uvars nameOf trProj Delta start args resultV) + (henv : env.WF) (hDelta : KVLCtx.WF env uvars Delta) + {replacement : KExpr .anon} {replacementV : VExpr} + (hreplacementTr : + TrKExpr env uvars nameOf trProj Delta replacement replacementV) + (hreplacement : + env.IsDefEqU uvars Delta.toCtx start replacementV) : + ∃ resultV', + TrKExprS env uvars nameOf trProj Delta + (args.foldl KExpr.mkApp replacement) resultV' ∧ + env.IsDefEqU uvars Delta.toCtx resultV resultV' := by + obtain ⟨replacementS, hreplacementS, hreplacementSEq⟩ := hreplacementTr + have hstartS : + env.IsDefEqU uvars Delta.toCtx start replacementS := + hreplacement.trans henv hDelta.toCtx hreplacementSEq.symm + exact h.rebase henv hDelta hreplacementS hstartS + +end TrAppSuffix +end RecM + +namespace RecM +namespace NatRecLiteralTranslationSplit + +/-- Quotient form of `checkedRhsSuffix`. This is the consumer shape needed +by RuleInstantiation's universe-instantiated registered RHS theorem: exact structural +Theory syntax is unnecessary, while typing and every trailing application +remain explicit. -/ +theorem checkedRhsSuffixQuot + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Delta : KVLCtx} + (hDelta : KVLCtx.WF world.venv uvars Delta) + {id : KId .anon} {source : KExpr .anon} + {parts : NatRecLiteralParts .anon} {majorIdx : Nat} + {sourceV : VExpr} {priorArgs laterArgs : List (KExpr .anon)} + {priorV : VExpr} + (hsplit : NatRecLiteralTranslationSplit world.venv uvars world.nameOf + trProj Delta id source parts majorIdx sourceV priorArgs laterArgs + priorV) + {recursor : KConst .anon} {rule : RecRule .anon} + {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel world.venv world.catalog + world.nameOf id recursor rule pattern) + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + (.app priorV (.natLit parts.major)) levels captures) + {sourceType : VExpr} + (hsourceType : world.venv.HasType uvars Delta.toCtx sourceV sourceType) + (hchecks : pattern.checks.OK + (world.venv.IsDefEqU uvars Delta.toCtx) levels captures) + {rhs : KExpr .anon} + (hrhsTr : TrKExpr world.venv uvars world.nameOf trProj Delta rhs + (pattern.rhs.apply levels captures)) : + ∃ resultV, + TrKExprS world.venv uvars world.nameOf trProj Delta + (laterArgs.foldl KExpr.mkApp rhs) resultV ∧ + world.venv.IsDefEqU uvars Delta.toCtx sourceV resultV := by + rcases hsplit with + ⟨_, _, _, _, _, _, _, _, hthroughTr, hsuffix⟩ + obtain ⟨throughType, hthroughType⟩ := + hsuffix.startHasType hsourceType + have hthroughEq := + hpattern.checkedReduction hmatch hthroughType hchecks + exact hsuffix.rebaseQuot world.venvWF hDelta hrhsTr hthroughEq + +end NatRecLiteralTranslationSplit +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/SelectedRule.lean b/Ix/Tc/Verify/Whnf/Iota/SelectedRule.lean new file mode 100644 index 000000000..4c30a228f --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/SelectedRule.lean @@ -0,0 +1,765 @@ +import Ix.Tc.Verify.Whnf.Iota.ArgumentExecution + +/-! +# Checked execution of one selected iota rule + +ArgumentExecution composes the three argument loops after a concrete rule RHS already +exists. This slice includes production's universe-instantiation call and +fixes the loop arrays to the exact prefix/constructor-field/trailing slices +computed by `tryIotaWithFlags`. + +The adversarial boundary is explicit. Ambient admission currently records a +registered `VDefEq` RHS and a `Pattern.RHS` independently. Neither existing +relation says that applying the former to production's three slices yields +the latter under the match captures. `IotaRhsApplicationAligned` names that +missing certificate instead of deriving a false equality. Given the +certificate, the selected-rule trace proves exact production execution, +state/intern framing, finite support, and source-to-result `WhnfMeaning`. +-/ + +namespace Ix.Tc + +open Lean4Lean (VDefEq VExpr) + +namespace WhnfMeaning + +/-- Two concrete expressions quotient-translated to the same Theory target +have a `WhnfMeaning` relation. This is the quotient/quotient counterpart of +ArgumentExecution's `ofStructuralQuot`. -/ +theorem ofQuot + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} (hDelta : KVLCtx.WF world.venv uvars Delta) + {source result : KExpr .anon} {target : VExpr} + (hsource : TrKExpr world.venv uvars world.nameOf trProj Delta + source target) + (hresult : TrKExpr world.venv uvars world.nameOf trProj Delta + result target) : + WhnfMeaning trProj world uvars Delta source result := by + obtain ⟨sourceV, hsourceS, hsourceEq⟩ := hsource + obtain ⟨resultV, hresultS, hresultEq⟩ := hresult + exact ⟨sourceV, resultV, hsourceS, hresultS, + hsourceEq.trans world.venvWF hDelta hresultEq.symm⟩ + +end WhnfMeaning + +namespace RecM +namespace ApplyIotaArgsTrace + +/-- Quotient translation of the unreduced concrete application sequence. +Unlike `sourceTr`, this accepts the universe-instantiated RHS relation +produced by RuleInstantiation, whose structural representative need not use the registered +RHS's exact Theory syntax. -/ +theorem sourceQuot + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start final : KExpr .anon} + {startV finalV : VExpr} {s sf : TcState .anon} + {args : List (KExpr .anon)} + (h : ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient start startV s args final finalV sf) + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + {replacement : KExpr .anon} + (hstart : TrKExpr world.venv uvars world.nameOf trProj Delta replacement + startV) : + TrKExpr world.venv uvars world.nameOf trProj Delta + (args.foldl KExpr.mkApp replacement) finalV := by + induction h generalizing replacement with + | nil => exact hstart + | @cons result resultV s arg argV A B next s1 rest final finalV sf + hfun harg hargTr hrun hpost hframe hnextSupport hmeaning tail ih => + have hargQ := hargTr.trKExpr world.venvWF.ordered + theory.literalWF theory.projections.wf hDelta + have happQ : TrKExpr world.venv uvars world.nameOf trProj Delta + (KExpr.mkApp replacement arg) (.app resultV argV) := by + rw [KExpr.mkApp_shape] + exact TrKExpr.app world.venvWF hDelta hfun harg hstart hargQ + rw [List.foldl_cons] + exact ih happQ + +/-- ArgumentExecution acceptance generalized to a quotient-translated initial RHS. -/ +theorem acceptanceQuot + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start final : KExpr .anon} + {startV finalV : VExpr} {s sf : TcState .anon} + {args : List (KExpr .anon)} + (h : ApplyIotaArgsTrace layer semantics trProj world support uvars Delta + methods transient start startV s args final finalV sf) + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hstartSupport : support start) + (hstartTr : TrKExpr world.venv uvars world.nameOf trProj Delta start + startV) : + (args.foldlM (m := RecM .anon) + (fun result arg => applyIotaArg result arg transient) start).run + methods s = .ok final sf ∧ + WhnfStateInv layer semantics trProj world support uvars Delta sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + TrKExpr world.venv uvars world.nameOf trProj Delta final finalV ∧ + WhnfMeaning trProj world uvars Delta + (args.foldl KExpr.mkApp start) final := by + have hsourceQ := h.sourceQuot theory hDelta hstartTr + have hfinalQ := h.finalQuot theory hDelta hstartTr + exact ⟨h.evalList, h.finalInv hI, h.frame, + h.finalSupport hstartSupport, hfinalQ, + WhnfMeaning.ofQuot hDelta hsourceQ hfinalQ⟩ + +/-- Quotient-aware complete contract for the exact three-array helper +sequence. -/ +theorem threeArrayAcceptanceQuot + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {transient : Bool} {start middle1 middle2 final : KExpr .anon} + {startV middleV1 middleV2 finalV : VExpr} + {s s1 s2 sf : TcState .anon} + {first second third : Array (KExpr .anon)} + (hfirst : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient start startV s first.toList middle1 middleV1 s1) + (hsecond : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient middle1 middleV1 s1 second.toList middle2 + middleV2 s2) + (hthird : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient middle2 middleV2 s2 third.toList final finalV + sf) + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hstartSupport : support start) + (hstartTr : TrKExpr world.venv uvars world.nameOf trProj Delta start + startV) : + (do + let result ← applyIotaArgs start first transient + let result ← applyIotaArgs result second transient + applyIotaArgs result third transient).run methods s = .ok final sf ∧ + WhnfStateInv layer semantics trProj world support uvars Delta sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + TrKExpr world.venv uvars world.nameOf trProj Delta final finalV ∧ + WhnfMeaning trProj world uvars Delta + (((first.toList ++ second.toList) ++ third.toList).foldl + KExpr.mkApp start) final := by + have htrace := hfirst.three hsecond hthird + have hsemantic := + htrace.acceptanceQuot theory hDelta hI hstartSupport hstartTr + exact ⟨evalThreeArrays hfirst hsecond hthird, hsemantic.2⟩ + +end ApplyIotaArgsTrace +end RecM + +namespace TcM + +/-- A successful universe-instantiation run preserves the complete K1 +invariant, changes only the intern table, and returns an expression in the +walk's finite support. RuleInstantiation used the walker equation semantically; this is +the state/resource half needed before the three ArgumentExecution traces can start. -/ +theorem instantiateUnivParams_whnf_of_run + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + {us : Array (KUniv .anon)} {e result : KExpr .anon} + {s after : TcState .anon} + (hcollision : support.CollisionFree) + (hreach : ∀ x, KExpr.InstUnivReach us e x → support x) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hrun : TcM.instantiateUnivParams e us s = .ok result after) : + KExpr.instantiateUnivParamsSpec e us = .ok result ∧ + WhnfStateInv layer semantics trProj world support uvars Delta after ∧ + InternUpdateFrame s after ∧ + support result := by + have hwalk := TcM.instantiateUnivParams_wf hcollision.expr hreach + ⟨hI.1.core.intern, hI.1.internSupport.expr⟩ + rw [hrun] at hwalk + have hspec := hwalk.2.1 + have hframe : InternUpdateFrame s after := hwalk.2.2.1 + have hunivs := hwalk.2.2.2 + have hconsts : after.env.consts = s.env.consts := by + simpa [InternUpdateFrame] using + congrArg (fun state : TcState .anon => state.env.consts) hframe + have henv : after.env = + { s.env with intern := after.env.intern } := by + simpa [InternUpdateFrame] using + congrArg (fun state : TcState .anon => state.env) hframe + have hcover : support.CoversIntern after.env.intern := { + expr := hwalk.1.2 + univ := by + intro u hu + exact hI.1.internSupport.univ u (by + simpa only [InternTable.UnivSupport, hunivs] using hu) + } + have hcaches : CacheInvariant semantics (.stable world) support after.env := by + rw [henv] + exact hI.1.caches.of_intern_update + have hkernel : KernelStateWF semantics trProj world support after := { + core := hI.1.core.of_consts_eq hconsts hwalk.1.1 + internSupport := hcover + caches := hcaches + equivalences := by + have hequiv := congrArg TcState.equivManager hframe + simpa [InternUpdateFrame] using hequiv ▸ hI.1.equivalences + } + have hIafter := hframe.whnfStateInv hkernel hI + have hresultSupport : support result := by + by_cases hempty : us.isEmpty + · have heq : e = result := by + simpa [KExpr.instantiateUnivParamsSpec, hempty] using hspec + rw [← heq] + exact hreach e (KExpr.InstUnivReach.self us e) + · have hspec' : KExpr.instUnivSpec e us = .ok result := by + simpa [KExpr.instantiateUnivParamsSpec, hempty] using hspec + exact hreach result (KExpr.InstUnivReach.spec hspec') + exact ⟨hspec, hIafter, hframe, hresultSupport⟩ + +end TcM + +namespace RecM + +/-- The missing admission-side coherence fact: the Theory application index +obtained by applying the registered equation RHS to production's exact +argument slices is the pattern RHS under the match's levels and captures. +Current `RawRecursorRuleRel` and `RawRecursorRulePatternRel` do not imply this +equation because they record their RHS values independently. -/ +def IotaRhsApplicationAligned + (pattern : RecursorRulePattern) (levels : List Lean4Lean.VLevel) + (captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr) + (applied : VExpr) : Prop := + applied = pattern.rhs.apply levels captures + +/-- Exact successful execution certificate for `applyIotaRule`. Its three +trace indices are definitionally production's prefix, constructor-field, and +trailing slices; callers cannot silently replace one with a convenient list. +The initial Theory index is left abstract so RuleInstantiation can later identify it with +the instantiated registered RHS. -/ +structure ApplyIotaRuleTrace + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (methods : Methods .anon) + (rule : RecRule .anon) (recUs : Array (KUniv .anon)) + (recr : IotaInfo .anon) (spine ctorArgs : Array (KExpr .anon)) + (ctorFields : Nat) (transient : Bool) (startV : VExpr) + (s : TcState .anon) (final : KExpr .anon) (finalV : VExpr) + (sf : TcState .anon) : Type where + rhs : KExpr .anon + after : TcState .anon + middle1 : KExpr .anon + middle2 : KExpr .anon + middleV1 : VExpr + middleV2 : VExpr + s1 : TcState .anon + s2 : TcState .anon + instantiate : TcM.instantiateUnivParams rule.rhs recUs s = .ok rhs after + prefixTrace : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient rhs startV after + (iotaPrefixArgs recr spine).toList middle1 middleV1 s1 + fieldTrace : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient middle1 middleV1 s1 + (iotaFieldArgs ctorArgs ctorFields).toList middle2 middleV2 s2 + trailingTrace : ApplyIotaArgsTrace layer semantics trProj world support uvars + Delta methods transient middle2 middleV2 s2 + (iotaTrailingArgs recr spine).toList final finalV sf + +namespace ApplyIotaRuleTrace + +/-- Erase the certificate to the exact extracted production helper run. -/ +theorem eval + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {rule : RecRule .anon} {recUs : Array (KUniv .anon)} + {recr : IotaInfo .anon} {spine ctorArgs : Array (KExpr .anon)} + {ctorFields : Nat} {transient : Bool} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaRuleTrace layer semantics trProj world support uvars Delta + methods rule recUs recr spine ctorArgs ctorFields transient startV s + final finalV sf) : + (applyIotaRule rule recUs recr spine ctorArgs ctorFields transient).run + methods s = .ok final sf := by + unfold applyIotaRule + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.instantiateUnivParams rule.rhs recUs) _ s = _ + unfold EStateM.bind + rw [h.instantiate] + simp only + exact ApplyIotaArgsTrace.evalThreeArrays h.prefixTrace h.fieldTrace + h.trailingTrace + +/-- Production's parameter-free universe-instantiation path returns the rule +body and leaves state untouched. The equalities are recovered from the +trace's observed run, so later proofs cannot posit a different RHS even on +this fast path. -/ +theorem emptyInstantiation + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {rule : RecRule .anon} {recUs : Array (KUniv .anon)} + {recr : IotaInfo .anon} {spine ctorArgs : Array (KExpr .anon)} + {ctorFields : Nat} {transient : Bool} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaRuleTrace layer semantics trProj world support uvars Delta + methods rule recUs recr spine ctorArgs ctorFields transient startV s + final finalV sf) + (hempty : recUs.isEmpty = true) : + h.rhs = rule.rhs ∧ h.after = s := by + have hrun := h.instantiate + rw [TcM.instantiateUnivParams, if_pos hempty] at hrun + have hinj := EStateM.Result.ok.inj hrun + exact ⟨hinj.1.symm, hinj.2.symm⟩ + +/-- Resource/state facts for the universe-instantiation prefix of the trace. -/ +theorem instantiatePost + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {rule : RecRule .anon} {recUs : Array (KUniv .anon)} + {recr : IotaInfo .anon} {spine ctorArgs : Array (KExpr .anon)} + {ctorFields : Nat} {transient : Bool} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaRuleTrace layer semantics trProj world support uvars Delta + methods rule recUs recr spine ctorArgs ctorFields transient startV s + final finalV sf) + (hcollision : support.CollisionFree) + (hreach : ∀ x, KExpr.InstUnivReach recUs rule.rhs x → support x) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) : + KExpr.instantiateUnivParamsSpec rule.rhs recUs = .ok h.rhs ∧ + WhnfStateInv layer semantics trProj world support uvars Delta h.after ∧ + InternUpdateFrame s h.after ∧ + support h.rhs := + TcM.instantiateUnivParams_whnf_of_run hcollision hreach hI h.instantiate + +/-- Complete selected-rule contract before relating the applied registered +RHS back to the original recursor application. -/ +theorem acceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {rule : RecRule .anon} {recUs : Array (KUniv .anon)} + {recr : IotaInfo .anon} {spine ctorArgs : Array (KExpr .anon)} + {ctorFields : Nat} {transient : Bool} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaRuleTrace layer semantics trProj world support uvars Delta + methods rule recUs recr spine ctorArgs ctorFields transient startV s + final finalV sf) + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hcollision : support.CollisionFree) + (hreach : ∀ x, KExpr.InstUnivReach recUs rule.rhs x → support x) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hrhsTr : TrKExpr world.venv uvars world.nameOf trProj Delta h.rhs + startV) : + (applyIotaRule rule recUs recr spine ctorArgs ctorFields transient).run + methods s = .ok final sf ∧ + WhnfStateInv layer semantics trProj world support uvars Delta sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + TrKExpr world.venv uvars world.nameOf trProj Delta final finalV ∧ + WhnfMeaning trProj world uvars Delta + ((((iotaPrefixArgs recr spine).toList ++ + (iotaFieldArgs ctorArgs ctorFields).toList) ++ + (iotaTrailingArgs recr spine).toList).foldl + KExpr.mkApp h.rhs) final := by + obtain ⟨hspec, hafterI, hinstFrame, hrhsSupport⟩ := + h.instantiatePost hcollision hreach hI + have hargs := ApplyIotaArgsTrace.threeArrayAcceptanceQuot + h.prefixTrace h.fieldTrace h.trailingTrace theory hDelta hafterI + hrhsSupport hrhsTr + obtain ⟨hargsRun, hfinalI, hargsFrame, hfinalSupport, hfinalTr, + hmeaning⟩ := hargs + exact ⟨h.eval, hfinalI, hinstFrame.trans hargsFrame, hfinalSupport, + hfinalTr, hmeaning⟩ + +/-- Parameter-free selected-rule contract. Since production does not invoke +the universe walker, no collision or walker-reach premise is needed; support +of the unchanged registered body is the exact resource assumption. -/ +theorem acceptance_empty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {rule : RecRule .anon} {recUs : Array (KUniv .anon)} + {recr : IotaInfo .anon} {spine ctorArgs : Array (KExpr .anon)} + {ctorFields : Nat} {transient : Bool} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaRuleTrace layer semantics trProj world support uvars Delta + methods rule recUs recr spine ctorArgs ctorFields transient startV s + final finalV sf) + (hempty : recUs.isEmpty = true) + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hruleSupport : support rule.rhs) + (hruleTr : TrKExpr world.venv uvars world.nameOf trProj Delta rule.rhs + startV) : + (applyIotaRule rule recUs recr spine ctorArgs ctorFields transient).run + methods s = .ok final sf ∧ + WhnfStateInv layer semantics trProj world support uvars Delta sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + TrKExpr world.venv uvars world.nameOf trProj Delta final finalV ∧ + WhnfMeaning trProj world uvars Delta + ((((iotaPrefixArgs recr spine).toList ++ + (iotaFieldArgs ctorArgs ctorFields).toList) ++ + (iotaTrailingArgs recr spine).toList).foldl + KExpr.mkApp h.rhs) final := by + obtain ⟨hrhs, hafter⟩ := h.emptyInstantiation hempty + have hafterI : WhnfStateInv layer semantics trProj world support uvars + Delta h.after := by simpa only [hafter] using hI + have hrhsSupport : support h.rhs := by + simpa only [hrhs] using hruleSupport + have hrhsTr : TrKExpr world.venv uvars world.nameOf trProj Delta h.rhs + startV := by simpa only [hrhs] using hruleTr + have hargs := ApplyIotaArgsTrace.threeArrayAcceptanceQuot + h.prefixTrace h.fieldTrace h.trailingTrace theory hDelta hafterI + hrhsSupport hrhsTr + obtain ⟨hargsRun, hfinalI, hargsFrame, hfinalSupport, hfinalTr, + hmeaning⟩ := hargs + have hinstFrame : InternUpdateFrame s h.after := by + simpa only [hafter] using InternUpdateFrame.refl s + exact ⟨h.eval, hfinalI, hinstFrame.trans hargsFrame, hfinalSupport, + hfinalTr, hmeaning⟩ + +/-- A parameter-free admitted rule starts at its registered Theory RHS. +Unlike the nonempty theorem below, this is a direct embedding of the stored +structural translation: production returns the rule body unchanged, and the +registered equation has universe arity zero. -/ +theorem registeredStartQuot_empty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {methods : Methods .anon} + {id : KId .anon} {recursor : KConst .anon} + {rule : RecRule .anon} {defeq : VDefEq} + {recUs : Array (KUniv .anon)} + {recr : IotaInfo .anon} {spine ctorArgs : Array (KExpr .anon)} + {ctorFields : Nat} {transient : Bool} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaRuleTrace layer semantics trProj world support 0 [] + methods rule recUs recr spine ctorArgs ctorFields transient startV s + final finalV sf) + (hregistered : RegisteredRecursorRuleRhsRel world.venv world.nameOf + trProj id recursor rule defeq) + (theory : WhnfTheory trProj world 0) + (hempty : recUs.isEmpty = true) + (harity : defeq.uvars = 0) + (hstartV : startV = defeq.rhs) : + TrKExpr world.venv 0 world.nameOf trProj [] h.rhs startV := by + obtain ⟨hrhs, _⟩ := h.emptyInstantiation hempty + have hstruct := hregistered.rhsStructural + rw [harity] at hstruct + have hquot := hstruct.trKExpr world.venvWF.ordered theory.literalWF + theory.projections.wf (by trivial) + simpa only [hrhs, hstartV] using hquot + +/-- Registered-rule specialization for production's parameter-free path. +The unchanged rule body must be in support, but no universe-instantiation +collision or reachability premise is necessary. -/ +theorem registeredAcceptance_empty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {methods : Methods .anon} + {id : KId .anon} {recursor : KConst .anon} + {rule : RecRule .anon} {defeq : VDefEq} + {recUs : Array (KUniv .anon)} + {recr : IotaInfo .anon} {spine ctorArgs : Array (KExpr .anon)} + {ctorFields : Nat} {transient : Bool} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaRuleTrace layer semantics trProj world support 0 [] + methods rule recUs recr spine ctorArgs ctorFields transient startV s + final finalV sf) + (hregistered : RegisteredRecursorRuleRhsRel world.venv world.nameOf + trProj id recursor rule defeq) + (theory : WhnfTheory trProj world 0) + (hempty : recUs.isEmpty = true) + (harity : defeq.uvars = 0) + (hI : WhnfStateInv layer semantics trProj world support 0 [] s) + (hruleSupport : support rule.rhs) + (hstartV : startV = defeq.rhs) : + (applyIotaRule rule recUs recr spine ctorArgs ctorFields transient).run + methods s = .ok final sf ∧ + WhnfStateInv layer semantics trProj world support 0 [] sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + TrKExpr world.venv 0 world.nameOf trProj [] final finalV ∧ + WhnfMeaning trProj world 0 [] + ((((iotaPrefixArgs recr spine).toList ++ + (iotaFieldArgs ctorArgs ctorFields).toList) ++ + (iotaTrailingArgs recr spine).toList).foldl + KExpr.mkApp h.rhs) final := by + apply h.acceptance_empty hempty theory (by trivial) hI hruleSupport + obtain ⟨hrhs, _⟩ := h.emptyInstantiation hempty + simpa only [hrhs] using + (h.registeredStartQuot_empty hregistered theory hempty harity hstartV) + +/-- RuleInstantiation supplies the trace's initial quotient translation for a nonempty +universe instantiation of an admitted registered rule. This theorem is +closed-context because the registered rule body is admitted closed; the +future open-context theorem must explicitly weaken that witness. -/ +theorem registeredStartQuot_nonempty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + {id : KId .anon} {recursor : KConst .anon} + {rule : RecRule .anon} {defeq : VDefEq} + {recUs : Array (KUniv .anon)} + {recr : IotaInfo .anon} {spine ctorArgs : Array (KExpr .anon)} + {ctorFields : Nat} {transient : Bool} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaRuleTrace layer semantics trProj world support uvars [] + methods rule recUs recr spine ctorArgs ctorFields transient startV s + final finalV sf) + (hregistered : RegisteredRecursorRuleRhsRel world.venv world.nameOf + trProj id recursor rule defeq) + (theory : WhnfTheory trProj world uvars) + (hnonempty : recUs.isEmpty = false) + (hus : ∀ level ∈ recUs, (KUniv.toVLevel level).WF uvars) + (harity : defeq.uvars = recUs.size) + (hcollision : support.CollisionFree) + (hreach : ∀ x, KExpr.InstUnivReach recUs rule.rhs x → support x) + (hI : WhnfStateInv layer semantics trProj world support uvars [] s) + (hfaithful : ∀ left right, + KExpr.LevelReach recUs rule.rhs left → + KExpr.LevelReach recUs rule.rhs right → left.AddrFaithful right) + (hsize : ∀ level, KExpr.LevelReach recUs rule.rhs level → + level.size < UInt64.size) + (hstartV : startV = + defeq.rhs.instL (recUs.toList.map KUniv.toVLevel)) : + TrKExpr world.venv uvars world.nameOf trProj [] h.rhs startV := by + have hresult := hregistered.instantiateUnivParams_nonempty + world.venvWF theory.literalWF theory.projections hnonempty hus harity + hcollision.expr hreach + ⟨hI.1.core.intern, hI.1.internSupport.expr⟩ h.instantiate hfaithful hsize + simpa only [hstartV] using hresult + +/-- Registered-rule specialization of `acceptance`: RuleInstantiation and the successful +production instantiator jointly discharge the initial quotient premise. -/ +theorem registeredAcceptance_nonempty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + {id : KId .anon} {recursor : KConst .anon} + {rule : RecRule .anon} {defeq : VDefEq} + {recUs : Array (KUniv .anon)} + {recr : IotaInfo .anon} {spine ctorArgs : Array (KExpr .anon)} + {ctorFields : Nat} {transient : Bool} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaRuleTrace layer semantics trProj world support uvars [] + methods rule recUs recr spine ctorArgs ctorFields transient startV s + final finalV sf) + (hregistered : RegisteredRecursorRuleRhsRel world.venv world.nameOf + trProj id recursor rule defeq) + (theory : WhnfTheory trProj world uvars) + (hnonempty : recUs.isEmpty = false) + (hus : ∀ level ∈ recUs, (KUniv.toVLevel level).WF uvars) + (harity : defeq.uvars = recUs.size) + (hcollision : support.CollisionFree) + (hreach : ∀ x, KExpr.InstUnivReach recUs rule.rhs x → support x) + (hI : WhnfStateInv layer semantics trProj world support uvars [] s) + (hfaithful : ∀ left right, + KExpr.LevelReach recUs rule.rhs left → + KExpr.LevelReach recUs rule.rhs right → left.AddrFaithful right) + (hsize : ∀ level, KExpr.LevelReach recUs rule.rhs level → + level.size < UInt64.size) + (hstartV : startV = + defeq.rhs.instL (recUs.toList.map KUniv.toVLevel)) : + (applyIotaRule rule recUs recr spine ctorArgs ctorFields transient).run + methods s = .ok final sf ∧ + WhnfStateInv layer semantics trProj world support uvars [] sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + TrKExpr world.venv uvars world.nameOf trProj [] final finalV ∧ + WhnfMeaning trProj world uvars [] + ((((iotaPrefixArgs recr spine).toList ++ + (iotaFieldArgs ctorArgs ctorFields).toList) ++ + (iotaTrailingArgs recr spine).toList).foldl + KExpr.mkApp h.rhs) final := by + apply h.acceptance theory (by trivial) hcollision hreach hI + exact h.registeredStartQuot_nonempty hregistered theory hnonempty hus + harity hcollision hreach hI hfaithful hsize hstartV + +/-- A checked pattern reduction plus the explicit RHS-alignment certificate +relates the original concrete recursor application directly to the trace's +final concrete result. -/ +theorem checkedMeaning + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Delta : KVLCtx} + (hDelta : KVLCtx.WF world.venv uvars Delta) + {id : KId .anon} {recursor : KConst .anon} + {rule : RecRule .anon} {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel world.venv world.catalog + world.nameOf id recursor rule pattern) + {source final : KExpr .anon} {sourceV sourceType finalV : VExpr} + (hsourceTr : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hsourceType : world.venv.HasType uvars Delta.toCtx sourceV sourceType) + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + sourceV levels captures) + (hchecks : pattern.checks.OK + (world.venv.IsDefEqU uvars Delta.toCtx) levels captures) + (haligned : IotaRhsApplicationAligned pattern levels captures finalV) + (hfinalTr : TrKExpr world.venv uvars world.nameOf trProj Delta final + finalV) : + WhnfMeaning trProj world uvars Delta source final := by + have hsourceFinal := hpattern.checkedReduction hmatch hsourceType hchecks + change finalV = pattern.rhs.apply levels captures at haligned + rw [← haligned] at hsourceFinal + obtain ⟨resultV, hresultTr, hresultEq⟩ := hfinalTr + exact ⟨sourceV, resultV, hsourceTr, hresultTr, + hsourceFinal.trans world.venvWF hDelta hresultEq.symm⟩ + +/-- Checked selected-rule execution for a parameter-free registered rule. +This closes the fast path end to end while retaining the admission-side RHS +alignment premise that is also required by the nonempty path. -/ +theorem checkedAcceptance_empty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {methods : Methods .anon} + {id : KId .anon} {recursor : KConst .anon} + {rule : RecRule .anon} {defeq : VDefEq} + {recUs : Array (KUniv .anon)} + {recr : IotaInfo .anon} {spine ctorArgs : Array (KExpr .anon)} + {ctorFields : Nat} {transient : Bool} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaRuleTrace layer semantics trProj world support 0 [] + methods rule recUs recr spine ctorArgs ctorFields transient startV s + final finalV sf) + (hregistered : RegisteredRecursorRuleRhsRel world.venv world.nameOf + trProj id recursor rule defeq) + (theory : WhnfTheory trProj world 0) + (hempty : recUs.isEmpty = true) + (harity : defeq.uvars = 0) + (hI : WhnfStateInv layer semantics trProj world support 0 [] s) + (hruleSupport : support rule.rhs) + (hstartV : startV = defeq.rhs) + {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel world.venv world.catalog + world.nameOf id recursor rule pattern) + {source : KExpr .anon} {sourceV sourceType : VExpr} + (hsourceTr : TrKExprS world.venv 0 world.nameOf trProj [] source + sourceV) + (hsourceType : world.venv.HasType 0 [] sourceV sourceType) + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + sourceV levels captures) + (hchecks : pattern.checks.OK + (world.venv.IsDefEqU 0 []) levels captures) + (haligned : IotaRhsApplicationAligned pattern levels captures finalV) : + (applyIotaRule rule recUs recr spine ctorArgs ctorFields transient).run + methods s = .ok final sf ∧ + WhnfStateInv layer semantics trProj world support 0 [] sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + WhnfMeaning trProj world 0 [] source final := by + have hacc := h.registeredAcceptance_empty hregistered theory hempty + harity hI hruleSupport hstartV + obtain ⟨hrun, hfinalI, hframe, hfinalSupport, hfinalTr, hfoldMeaning⟩ := + hacc + exact ⟨hrun, hfinalI, hframe, hfinalSupport, + checkedMeaning (by trivial) hpattern hsourceTr hsourceType hmatch + hchecks haligned hfinalTr⟩ + +/-- Headline SelectedRule contract. One selected nonempty-universe rule executes +through production's exact slices and is semantically sound for the original +recursor application, conditional only on the explicit admission-side RHS +alignment that the current oracle does not yet store. -/ +theorem checkedAcceptance_nonempty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + {id : KId .anon} {recursor : KConst .anon} + {rule : RecRule .anon} {defeq : VDefEq} + {recUs : Array (KUniv .anon)} + {recr : IotaInfo .anon} {spine ctorArgs : Array (KExpr .anon)} + {ctorFields : Nat} {transient : Bool} {startV : VExpr} + {s : TcState .anon} {final : KExpr .anon} {finalV : VExpr} + {sf : TcState .anon} + (h : ApplyIotaRuleTrace layer semantics trProj world support uvars [] + methods rule recUs recr spine ctorArgs ctorFields transient startV s + final finalV sf) + (hregistered : RegisteredRecursorRuleRhsRel world.venv world.nameOf + trProj id recursor rule defeq) + (theory : WhnfTheory trProj world uvars) + (hnonempty : recUs.isEmpty = false) + (hus : ∀ level ∈ recUs, (KUniv.toVLevel level).WF uvars) + (harity : defeq.uvars = recUs.size) + (hcollision : support.CollisionFree) + (hreach : ∀ x, KExpr.InstUnivReach recUs rule.rhs x → support x) + (hI : WhnfStateInv layer semantics trProj world support uvars [] s) + (hfaithful : ∀ left right, + KExpr.LevelReach recUs rule.rhs left → + KExpr.LevelReach recUs rule.rhs right → left.AddrFaithful right) + (hsize : ∀ level, KExpr.LevelReach recUs rule.rhs level → + level.size < UInt64.size) + (hstartV : startV = + defeq.rhs.instL (recUs.toList.map KUniv.toVLevel)) + {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel world.venv world.catalog + world.nameOf id recursor rule pattern) + {source : KExpr .anon} {sourceV sourceType : VExpr} + (hsourceTr : TrKExprS world.venv uvars world.nameOf trProj [] source + sourceV) + (hsourceType : world.venv.HasType uvars [] sourceV sourceType) + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + sourceV levels captures) + (hchecks : pattern.checks.OK + (world.venv.IsDefEqU uvars []) levels captures) + (haligned : IotaRhsApplicationAligned pattern levels captures finalV) : + (applyIotaRule rule recUs recr spine ctorArgs ctorFields transient).run + methods s = .ok final sf ∧ + WhnfStateInv layer semantics trProj world support uvars [] sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + WhnfMeaning trProj world uvars [] source final := by + have hacc := h.registeredAcceptance_nonempty hregistered theory hnonempty + hus harity hcollision hreach hI hfaithful hsize hstartV + obtain ⟨hrun, hfinalI, hframe, hfinalSupport, hfinalTr, hfoldMeaning⟩ := + hacc + exact ⟨hrun, hfinalI, hframe, hfinalSupport, + checkedMeaning (by trivial) hpattern hsourceTr hsourceType hmatch + hchecks haligned hfinalTr⟩ + +end ApplyIotaRuleTrace + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/StringLiteral.lean b/Ix/Tc/Verify/Whnf/Iota/StringLiteral.lean new file mode 100644 index 000000000..4c752fc94 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/StringLiteral.lean @@ -0,0 +1,433 @@ +import Ix.Tc.Verify.Whnf.Iota.NatLiteral + +/-! +# String-literal iota preprocessing + +NatLiteral closes the Nat-literal variant of production's post-WHNF iota path. +This slice closes the neighboring String variant: the second Nat-offset +cleanup must miss, `strLitToConstructor` builds the constructor spine through +the intern table, the callback selected by `cheapRec` normalizes that spine, +and ordinary constructor dispatch resumes with `transient = false`. + +The callback's invariant and intern-only frame are explicit at the headline +boundary. Proving those facts uniformly for arbitrary generated String +spines is a separate helper-closure obligation; this file does not disguise +it as a consequence of the operational callback equation. +-/ + +namespace Ix.Tc + +open Lean4Lean (VDefEq VExpr) + +namespace RecM + +/-- Direct expression interning is total and changes only the intern table. +This operational fact does not require semantic collision freedom: a hash hit +may return an existing canonical node, but it cannot throw or mutate any +other checker component. -/ +theorem intern_success_frame (e : KExpr .anon) (s : TcState .anon) : + ∃ result s', + TcM.intern e s = .ok result s' ∧ InternUpdateFrame s s' := by + unfold TcM.intern TcM.runIntern + generalize hpair : internExprM e s.env.intern = pair + rcases pair with ⟨result, intern⟩ + refine ⟨result, { s with env := { s.env with intern } }, ?_, rfl⟩ + rfl + +/-- The extracted character fold has a definitional empty case. -/ +theorem strLitListToConstructor_empty + (methods : Methods .anon) (s : TcState .anon) + (charOfNat cons nil : KExpr .anon) : + (strLitListToConstructor charOfNat cons [] nil).run methods s = + .ok nil s := by + rfl + +/-- Every character-fold step is total and changes only the intern table. +The result remains abstract because collision freedom is what identifies an +intern request with the requested expression; totality and framing do not +need that stronger assumption. -/ +theorem strLitListToConstructor_success_frame + (methods : Methods .anon) (chars : List Char) + (charOfNat cons list : KExpr .anon) (s : TcState .anon) : + ∃ result s', + (strLitListToConstructor charOfNat cons chars list).run methods s = + .ok result s' ∧ + InternUpdateFrame s s' := by + induction chars generalizing list s with + | nil => + exact ⟨list, s, rfl, InternUpdateFrame.refl s⟩ + | cons c chars ih => + obtain ⟨natLit, s₁, hnatLit, hframe₁⟩ := intern_success_frame + (natExprFromValue c.toNat) s + obtain ⟨charVal, s₂, hcharVal, hframe₂⟩ := intern_success_frame + (KExpr.mkApp charOfNat natLit) s₁ + obtain ⟨partialApp, s₃, hpartial, hframe₃⟩ := intern_success_frame + (KExpr.mkApp cons charVal) s₂ + obtain ⟨nextList, s₄, hnextList, hframe₄⟩ := intern_success_frame + (KExpr.mkApp partialApp list) s₃ + obtain ⟨result, s₅, htail, htailFrame⟩ := ih nextList s₄ + refine ⟨result, s₅, ?_, + (((hframe₁.trans hframe₂).trans hframe₃).trans hframe₄).trans + htailFrame⟩ + unfold strLitListToConstructor + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (natExprFromValue c.toNat)) _ s = _ + unfold EStateM.bind + rw [hnatLit] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkApp charOfNat natLit)) _ s₁ = _ + unfold EStateM.bind + rw [hcharVal] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkApp cons charVal)) _ s₂ = _ + unfold EStateM.bind + rw [hpartial] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkApp partialApp list)) _ s₃ = _ + unfold EStateM.bind + rw [hnextList] + exact htail + +/-- Full String constructor expansion is total and intern-framed for every +literal. Canonical-result identity remains deliberately separate: it needs +run-scoped collision freedom and support for every generated node. -/ +theorem strLitToConstructor_success_frame + (methods : Methods .anon) (value : String) (s : TcState .anon) : + ∃ result s', + (strLitToConstructor value).run methods s = .ok result s' ∧ + InternUpdateFrame s s' := by + let p := s.prims + obtain ⟨charConst, s₁, hcharConst, hframe₁⟩ := intern_success_frame + (KExpr.mkConst p.charType #[]) s + obtain ⟨charOfNat, s₂, hcharOfNat, hframe₂⟩ := intern_success_frame + (KExpr.mkConst p.charOfNat #[]) s₁ + obtain ⟨stringMk, s₃, hstringMk, hframe₃⟩ := intern_success_frame + (KExpr.mkConst p.stringOfList #[]) s₂ + obtain ⟨listNilZ, s₄, hlistNilZ, hframe₄⟩ := intern_success_frame + (KExpr.mkConst p.listNil #[KUniv.mkZero]) s₃ + obtain ⟨nil, s₅, hnil, hframe₅⟩ := intern_success_frame + (KExpr.mkApp listNilZ charConst) s₄ + obtain ⟨listConsZ, s₆, hlistConsZ, hframe₆⟩ := intern_success_frame + (KExpr.mkConst p.listCons #[KUniv.mkZero]) s₅ + obtain ⟨cons, s₇, hcons, hframe₇⟩ := intern_success_frame + (KExpr.mkApp listConsZ charConst) s₆ + obtain ⟨list, s₈, hlist, hlistFrame⟩ := + strLitListToConstructor_success_frame methods value.toList.reverse + charOfNat cons nil s₇ + obtain ⟨result, s₉, hresult, hframe₉⟩ := intern_success_frame + (KExpr.mkApp stringMk list) s₈ + refine ⟨result, s₉, ?_, + (((((((hframe₁.trans hframe₂).trans hframe₃).trans hframe₄).trans + hframe₅).trans hframe₆).trans hframe₇).trans hlistFrame).trans + hframe₉⟩ + unfold strLitToConstructor + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run prims methods) _ s = _ + unfold EStateM.bind + rw [show ReaderT.run prims methods s = .ok p s from rfl] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkConst p.charType #[])) _ s = _ + unfold EStateM.bind + rw [hcharConst] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkConst p.charOfNat #[])) _ s₁ = _ + unfold EStateM.bind + rw [hcharOfNat] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkConst p.stringOfList #[])) _ s₂ = _ + unfold EStateM.bind + rw [hstringMk] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind + (TcM.intern (KExpr.mkConst p.listNil #[KUniv.mkZero])) _ s₃ = _ + unfold EStateM.bind + rw [hlistNilZ] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkApp listNilZ charConst)) _ s₄ = _ + unfold EStateM.bind + rw [hnil] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind + (TcM.intern (KExpr.mkConst p.listCons #[KUniv.mkZero])) _ s₅ = _ + unfold EStateM.bind + rw [hlistConsZ] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkApp listConsZ charConst)) _ s₆ = _ + unfold EStateM.bind + rw [hcons] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (strLitListToConstructor charOfNat cons value.toList.reverse nil) + methods) _ s₇ = _ + unfold EStateM.bind + rw [hlist] + simp only + rw [ReaderT.run_monadLift] + exact hresult + +theorem evalNatOffsetLiteral_str + (methods : Methods .anon) (s : TcState .anon) + (value : String) (blob : Address) (info : ExprInfo .anon) : + (evalNatOffsetLiteral (.str value blob info) 0).run methods s = + .ok none s := by + unfold evalNatOffsetLiteral evalNatOffsetLiteralFuel + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run prims methods) _ s = _ + unfold EStateM.bind + rw [show ReaderT.run prims methods s = .ok s.prims s from rfl] + rfl + +theorem natOffset_str + (methods : Methods .anon) (s : TcState .anon) + (value : String) (blob : Address) (info : ExprInfo .anon) : + (natOffset (.str value blob info) 0).run methods s = .ok none s := by + unfold natOffset natOffsetFuel + rfl + +/-- The Nat-offset cleanup preceding String expansion is an exact, +state-preserving miss for every literal. -/ +theorem cleanupNatOffsetMajor_str + (methods : Methods .anon) (s : TcState .anon) + (value : String) (blob : Address) (info : ExprInfo .anon) : + (cleanupNatOffsetMajor (.str value blob info)).run methods s = + .ok none s := by + unfold cleanupNatOffsetMajor + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (evalNatOffsetLiteral (.str value blob info) 0) methods) _ + s = _ + unfold EStateM.bind + rw [evalNatOffsetLiteral_str] + simp only [Option.isSome, Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (natOffset (.str value blob info) 0) methods) _ s = _ + unfold EStateM.bind + rw [natOffset_str] + rfl + +/-- Exact String-literal path through post-WHNF preprocessing. Unlike Nat +literals, String expansion runs a policy-selected recursive WHNF callback and +does not enable transient rule application. -/ +theorem tryIotaAfterMajorWhnf_str + {methods : Methods .anon} {flags : WhnfFlags} + {s sCleanup sStr sWhnf sf : TcState .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {value : String} {blob : Address} {info : ExprInfo .anon} + {strCtor ctorMajor result : KExpr .anon} + (hcleanup : (cleanupNatOffsetMajor (.str value blob info)).run methods s = + .ok none sCleanup) + (hstr : (strLitToConstructor value).run methods sCleanup = + .ok strCtor sStr) + (hwhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec strCtor flags).run methods sStr + else (whnfRec strCtor).run methods sStr) = + .ok ctorMajor sWhnf) + (hdispatch : + (tryIotaCtorOrStructEta recId recr recUs spine ctorMajor false).run + methods sWhnf = .ok (some result) sf) : + (tryIotaAfterMajorWhnf flags recId recr recUs spine + (.str value blob info)).run methods s = .ok (some result) sf := by + unfold tryIotaAfterMajorWhnf + simp only [pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (cleanupNatOffsetMajor (.str value blob info)) methods) _ s = _ + unfold EStateM.bind + rw [hcleanup] + simp only + unfold tryIotaAfterCleanup + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (strLitToConstructor value) methods) _ + sCleanup = _ + unfold EStateM.bind + rw [hstr] + cases hcheap : flags.cheapRec + · simp only [hcheap, Bool.false_eq_true, ↓reduceIte] at hwhnf ⊢ + change EStateM.bind _ _ sStr = _ + unfold EStateM.bind + change whnfRec strCtor methods sStr = .ok ctorMajor sWhnf at hwhnf + rw [hwhnf] + exact hdispatch + · simp only [hcheap, ↓reduceIte] at hwhnf ⊢ + change EStateM.bind _ _ sStr = _ + unfold EStateM.bind + change whnfCoreFlagsRec strCtor flags methods sStr = + .ok ctorMajor sWhnf at hwhnf + rw [hwhnf] + exact hdispatch + +/-- Complete non-K String-literal branch of `tryIotaWithFlags`. -/ +theorem tryIotaWithFlags_strCtor + {methods : Methods .anon} {source : KExpr .anon} {flags : WhnfFlags} + {s sLookup sCleanup sWhnf sCleanupWhnf sStr sStrWhnf sCtor sf : + TcState .anon} + {recId : KId .anon} {recUs : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {spine : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {major : KExpr .anon} {value : String} {blob : Address} + {strInfo : ExprInfo .anon} {strCtor ctorMajor : KExpr .anon} + {ctorId : KId .anon} {ctorUs : Array (KUniv .anon)} + {ctorHeadInfo : ExprInfo .anon} {ctorArgs : Array (KExpr .anon)} + {ctor : KConst .anon} {cidx ctorFields : Nat} + {result : KExpr .anon} + (hsource : source.collectSpine = (.const recId recUs headInfo, spine)) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sLookup) + (hinfo : recursor.iotaInfo? = some recr) + (hmajorBound : recr.majorIdx < spine.size) + (hmajor : spine[recr.majorIdx]! = major) + (hk : recr.k = false) + (hcleanup : (cleanupNatOffsetMajor major).run methods sLookup = + .ok none sCleanup) + (hmajorWhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec major flags).run methods sCleanup + else (whnfRec major).run methods sCleanup) = + .ok (.str value blob strInfo) sWhnf) + (hcleanupWhnf : + (cleanupNatOffsetMajor (.str value blob strInfo)).run methods sWhnf = + .ok none sCleanupWhnf) + (hstr : (strLitToConstructor value).run methods sCleanupWhnf = + .ok strCtor sStr) + (hstrWhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec strCtor flags).run methods sStr + else (whnfRec strCtor).run methods sStr) = + .ok ctorMajor sStrWhnf) + (hctorSpine : ctorMajor.collectSpine = + (.const ctorId ctorUs ctorHeadInfo, ctorArgs)) + (hctorLookup : TcM.tryGetConst ctorId sStrWhnf = + .ok (some ctor) sCtor) + (hctorInfo : ctor.iotaCtorInfo? = some (cidx, ctorFields)) + (hdispatch : + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields false).run + methods sCtor = .ok (some result) sf) : + (tryIotaWithFlags source flags).run methods s = .ok (some result) sf := by + have hctor := tryIotaCtorOrStructEta_regular (recId := recId) + (transient := false) hctorSpine hctorLookup hctorInfo hdispatch + have hafter := tryIotaAfterMajorWhnf_str (flags := flags) + hcleanupWhnf hstr hstrWhnf hctor + exact tryIotaWithFlags_nonKPrefix hsource hlookup hinfo hmajorBound hmajor + hk hcleanup hmajorWhnf hafter + +/-- Headline StringLiteral contract: an actual String-literal recursor run executes the +checked ordinary-constructor rule selected after constructor expansion and +recursive normalization. -/ +theorem tryIotaWithFlags_strCtor_checkedAcceptance_empty + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {methods : Methods .anon} {source : KExpr .anon} {flags : WhnfFlags} + {s sLookup sCleanup sWhnf sCleanupWhnf sStr sStrWhnf sCtor sf : + TcState .anon} + {recId : KId .anon} {recUs : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {spine : Array (KExpr .anon)} + {recursor : KConst .anon} {recr : IotaInfo .anon} + {major : KExpr .anon} {value : String} {blob : Address} + {strInfo : ExprInfo .anon} {strCtor ctorMajor : KExpr .anon} + {ctorId : KId .anon} {ctorUs : Array (KUniv .anon)} + {ctorHeadInfo : ExprInfo .anon} {ctorArgs : Array (KExpr .anon)} + {ctor : KConst .anon} {cidx ctorFields : Nat} + {rule : RecRule .anon} {defeq : VDefEq} {startV : VExpr} + {final : KExpr .anon} {finalV : VExpr} + (h : ApplyIotaCtorTrace layer semantics trProj world support 0 [] + methods recr recUs spine ctorArgs cidx ctorFields false rule startV + sCtor final finalV sf) + (hcollect : source.collectSpine = (.const recId recUs headInfo, spine)) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sLookup) + (hinfo : recursor.iotaInfo? = some recr) + (hmajorBound : recr.majorIdx < spine.size) + (hmajor : spine[recr.majorIdx]! = major) + (hk : recr.k = false) + (hcleanup : (cleanupNatOffsetMajor major).run methods sLookup = + .ok none sCleanup) + (hmajorWhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec major flags).run methods sCleanup + else (whnfRec major).run methods sCleanup) = + .ok (.str value blob strInfo) sWhnf) + (hcleanupWhnf : + (cleanupNatOffsetMajor (.str value blob strInfo)).run methods sWhnf = + .ok none sCleanupWhnf) + (hstr : (strLitToConstructor value).run methods sCleanupWhnf = + .ok strCtor sStr) + (hstrWhnf : + (if flags.cheapRec then + (whnfCoreFlagsRec strCtor flags).run methods sStr + else (whnfRec strCtor).run methods sStr) = + .ok ctorMajor sStrWhnf) + (hctorSpine : ctorMajor.collectSpine = + (.const ctorId ctorUs ctorHeadInfo, ctorArgs)) + (hctorLookup : TcM.tryGetConst ctorId sStrWhnf = + .ok (some ctor) sCtor) + (hctorInfo : ctor.iotaCtorInfo? = some (cidx, ctorFields)) + (hprefixFrame : InternUpdateFrame s sCtor) + (hdispatchI : WhnfStateInv layer semantics trProj world support 0 [] + sCtor) + (hregistered : RegisteredRecursorRuleRhsRel world.venv world.nameOf + trProj recId recursor rule defeq) + (theory : WhnfTheory trProj world 0) + (hempty : recUs.isEmpty = true) + (harity : defeq.uvars = 0) + (hruleSupport : support rule.rhs) + (hstartV : startV = defeq.rhs) + {pattern : RecursorRulePattern} + (hpattern : RawRecursorRulePatternRel world.venv world.catalog + world.nameOf recId recursor rule pattern) + (hdispatchAligned : IotaCtorDispatchAligned cidx ctorFields pattern) + {sourceV sourceType : VExpr} + (hsourceTr : TrKExprS world.venv 0 world.nameOf trProj [] source + sourceV) + (hsourceType : world.venv.HasType 0 [] sourceV sourceType) + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)).Path → VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern pattern.recursorName pattern.majorIdx + pattern.constructorName + (pattern.constructorParams.toNat + + pattern.constructorFields.toNat)) + sourceV levels captures) + (hchecks : pattern.checks.OK + (world.venv.IsDefEqU 0 []) levels captures) + (hrhsAligned : IotaRhsApplicationAligned pattern levels captures + finalV) : + (tryIotaWithFlags source flags).run methods s = .ok (some final) sf ∧ + WhnfStateInv layer semantics trProj world support 0 [] sf ∧ + InternUpdateFrame s sf ∧ + support final ∧ + WhnfMeaning trProj world 0 [] source final := by + have hpatternDispatch : + ApplyIotaCtorTrace layer semantics trProj world support 0 [] methods + recr recUs spine ctorArgs pattern.ruleIndex + pattern.constructorFields.toNat false rule startV sCtor final finalV + sf := by + simpa only [hdispatchAligned.ruleIndex, hdispatchAligned.fields] using h + have hchecked := hpatternDispatch.checkedAcceptance_empty hregistered + theory hempty harity hdispatchI hruleSupport hstartV hpattern hsourceTr + hsourceType hmatch hchecks hrhsAligned + obtain ⟨_, hfinalI, hdispatchFrame, hfinalSupport, hmeaning⟩ := hchecked + have hrun := tryIotaWithFlags_strCtor hcollect hlookup hinfo + hmajorBound hmajor hk hcleanup hmajorWhnf hcleanupWhnf hstr hstrWhnf + hctorSpine hctorLookup hctorInfo h.eval + exact ⟨hrun, hfinalI, hprefixFrame.trans hdispatchFrame, + hfinalSupport, hmeaning⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/StructEtaControl.lean b/Ix/Tc/Verify/Whnf/Iota/StructEtaControl.lean new file mode 100644 index 000000000..eed06f43d --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/StructEtaControl.lean @@ -0,0 +1,1044 @@ +import Ix.Tc.Verify.Whnf.Iota.ConstructorSynthesisFallback + +/-! +# Struct-eta iota control-flow closure + +The ordinary-constructor, Nat/String-literal, and K-synthesis routes all +enter `tryIotaCtorOrStructEta` through a constructor hit. This slice covers +the complementary fallthrough into `tryStructEtaIota`. It names the exact +post-scan probe trace, proves every caught probe miss/error with its retained +state, exposes the H3 Prop guard, and records ordinary error propagation from +universe instantiation and rebuilding. + +Semantic justification of a successful rebuilt rule remains indexed by an +explicit `WhnfMeaning` premise: the operational fact that an inductive looks +structure-like does not itself manufacture the registered Theory recursor +equation or projection interpretation. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Sorts in `Prop` are the sole rejected post-probe shape. -/ +def StructEtaSortAdmissible (e : KExpr .anon) : Prop := + structEtaSortRejected e = false + +/-- The defensive classifier lookup did not return an inductive declaration. -/ +def StructEtaNonInductive : KConst .anon → Prop + | .indc .. => False + | _ => True + +/-- Heads that bypass constructor catalog lookup and fall directly into the +struct-eta dispatcher. -/ +def StructEtaDispatchNonConst : KExpr .anon → Prop + | .const .. => False + | _ => True + +/-- An absent classifier entry is state-retaining failure, not an error. -/ +theorem isStructLike_missing + {methods : Methods .anon} {id : KId .anon} {s sf : TcState .anon} + (hlookup : TcM.tryGetConst id s = .ok none sf) : + (isStructLike id).run methods s = .ok false sf := by + unfold isStructLike + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst id) _ s = _ + unfold EStateM.bind + rw [hlookup] + rfl + +/-- A loaded non-inductive entry is rejected before the recursion probe. -/ +theorem isStructLike_nonInductive + {methods : Methods .anon} {id : KId .anon} {s sf : TcState .anon} + {entry : KConst .anon} + (hlookup : TcM.tryGetConst id s = .ok (some entry) sf) + (hshape : StructEtaNonInductive entry) : + (isStructLike id).run methods s = .ok false sf := by + unfold isStructLike + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst id) _ s = _ + unfold EStateM.bind + rw [hlookup] + cases entry <;> simp [StructEtaNonInductive] at hshape ⊢ + +/-- Lookup errors are not swallowed by structure classification. -/ +theorem isStructLike_lookupError + {methods : Methods .anon} {id : KId .anon} {s sf : TcState .anon} + {err : TcError .anon} + (hlookup : TcM.tryGetConst id s = .error err sf) : + (isStructLike id).run methods s = .error err sf := by + unfold isStructLike + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst id) _ s = _ + unfold EStateM.bind + rw [hlookup] + +/-- Nonzero indices or a constructor count other than one reject the +inductive without consulting `computedIsRec`. -/ +theorem isStructLike_badShape + {methods : Methods .anon} {id block : KId .anon} + {s sf : TcState .anon} {lvls params indices : UInt64} + {isUnsafe : Bool} {memberIdx : UInt64} {ty : KExpr .anon} + {ctors : Array (KId .anon)} + (hlookup : TcM.tryGetConst id s = + .ok (some (.indc () () lvls params indices isUnsafe block memberIdx ty + ctors ())) sf) + (hbad : (indices != 0 || ctors.size != 1) = true) : + (isStructLike id).run methods s = .ok false sf := by + unfold isStructLike + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst id) _ s = _ + unfold EStateM.bind + rw [hlookup] + simp only + rw [hbad] + rfl + +/-- A shape-qualified inductive forwards the exact recursion result and its +post-state, negating only the returned Boolean. -/ +theorem isStructLike_shapeQualified + {methods : Methods .anon} {id block : KId .anon} + {s sLookup sf : TcState .anon} {lvls params indices : UInt64} + {isUnsafe recursive : Bool} {memberIdx : UInt64} {ty : KExpr .anon} + {ctors : Array (KId .anon)} + (hlookup : TcM.tryGetConst id s = + .ok (some (.indc () () lvls params indices isUnsafe block memberIdx ty + ctors ())) sLookup) + (hshape : (indices != 0 || ctors.size != 1) = false) + (hrec : (computedIsRec id).run methods sLookup = .ok recursive sf) : + (isStructLike id).run methods s = .ok (!recursive) sf := by + unfold isStructLike + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst id) _ s = _ + unfold EStateM.bind + rw [hlookup] + simp only + rw [hshape] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (computedIsRec id) methods) _ sLookup = _ + unfold EStateM.bind + rw [hrec] + rfl + +/-- Recursion-computation errors propagate after the qualified lookup. -/ +theorem isStructLike_recError + {methods : Methods .anon} {id block : KId .anon} + {s sLookup sf : TcState .anon} {lvls params indices : UInt64} + {isUnsafe : Bool} {memberIdx : UInt64} {ty : KExpr .anon} + {ctors : Array (KId .anon)} {err : TcError .anon} + (hlookup : TcM.tryGetConst id s = + .ok (some (.indc () () lvls params indices isUnsafe block memberIdx ty + ctors ())) sLookup) + (hshape : (indices != 0 || ctors.size != 1) = false) + (hrec : (computedIsRec id).run methods sLookup = .error err sf) : + (isStructLike id).run methods s = .error err sf := by + unfold isStructLike + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst id) _ s = _ + unfold EStateM.bind + rw [hlookup] + simp only + rw [hshape] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (computedIsRec id) methods) _ sLookup = _ + unfold EStateM.bind + rw [hrec] + +/-- Zero prefix, fields, and trailing arguments leave the instantiated rule +unchanged and do not touch checker state. -/ +theorem finishStructEtaResult_empty + (methods : Methods .anon) (s : TcState .anon) + (indId : KId .anon) (major rhs : KExpr .anon) : + (finishStructEtaResult indId major rhs 0 #[] #[]).run methods s = + .ok rhs s := by + simp [finishStructEtaResult, finishAppResult, finishStructEtaFields] + +/-- Direct expression interning cannot raise a checker error, independently +of collision behavior. -/ +theorem structEtaIntern_total (e : KExpr .anon) (s : TcState .anon) : + ∃ result sf, TcM.intern e s = .ok result sf := by + let pair := internExprM e s.env.intern + exact ⟨pair.1, { s with env := { s.env with intern := pair.2 } }, rfl⟩ + +/-- Every field segment terminates successfully. This is deliberately only +an operational theorem: collision freedom is still required to identify the +returned nodes with the requested projections and applications. -/ +theorem finishStructEtaFields_total + (methods : Methods .anon) (s : TcState .anon) + (indId : KId .anon) (major result : KExpr .anon) + (fuel field : Nat) : + ∃ final sf, + (finishStructEtaFields indId major fuel field result).run methods s = + .ok final sf := by + induction fuel generalizing field result s with + | zero => exact ⟨result, s, rfl⟩ + | succ fuel ih => + obtain ⟨proj, sProj, hproj⟩ := structEtaIntern_total + (KExpr.mkPrj indId field.toUInt64 major) s + obtain ⟨applied, sApp, happ⟩ := structEtaIntern_total + (KExpr.mkApp result proj) sProj + obtain ⟨final, sf, htail⟩ := + ih (s := sApp) (field := field + 1) (result := applied) + refine ⟨final, sf, ?_⟩ + unfold finishStructEtaFields + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind + (TcM.intern (KExpr.mkPrj indId field.toUInt64 major)) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (KExpr.mkApp result proj)) _ sProj = _ + unfold EStateM.bind + rw [happ] + exact htail + +/-- Exact composition equation for the prefix, field, and trailing rebuild +segments. -/ +theorem finishStructEtaResult_of_segments + {methods : Methods .anon} {s sPrefix sFields sf : TcState .anon} + {indId : KId .anon} {major rhs prefixResult fieldsResult final : + KExpr .anon} + {fields : UInt64} + {prefixArgs trailingArgs : Array (KExpr .anon)} + (hprefix : (finishAppResult rhs prefixArgs 0).run methods s = + .ok prefixResult sPrefix) + (hfields : + (finishStructEtaFields indId major fields.toNat 0 prefixResult).run + methods sPrefix = .ok fieldsResult sFields) + (htrailing : (finishAppResult fieldsResult trailingArgs 0).run methods + sFields = .ok final sf) : + (finishStructEtaResult indId major rhs fields prefixArgs trailingArgs).run + methods s = .ok final sf := by + unfold finishStructEtaResult + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (finishAppResult rhs prefixArgs 0) methods) + _ s = _ + unfold EStateM.bind + rw [hprefix] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (finishStructEtaFields indId major fields.toNat 0 prefixResult) methods) + _ sPrefix = _ + unfold EStateM.bind + rw [hfields] + exact htrailing + +/-- The complete three-segment rebuild cannot fail. -/ +theorem finishStructEtaResult_total + (methods : Methods .anon) (s : TcState .anon) + (indId : KId .anon) (major rhs : KExpr .anon) (fields : UInt64) + (prefixArgs trailingArgs : Array (KExpr .anon)) : + ∃ final sf, + (finishStructEtaResult indId major rhs fields prefixArgs trailingArgs).run + methods s = .ok final sf := by + obtain ⟨prefixResult, sPrefix, hprefix⟩ := + finishAppResult_total (methods := methods) (s := s) rhs prefixArgs 0 + obtain ⟨fieldsResult, sFields, hfields⟩ := + finishStructEtaFields_total methods sPrefix indId major prefixResult + fields.toNat 0 + obtain ⟨final, sf, htrailing⟩ := + finishAppResult_total (methods := methods) (s := sFields) fieldsResult + trailingArgs 0 + exact ⟨final, sf, + finishStructEtaResult_of_segments hprefix hfields htrailing⟩ + +/-- Consequently, no projection/application rebuilding error is reachable. +Any struct-eta error after the H3 guard must have arisen during universe +instantiation. -/ +theorem finishStructEtaResult_ne_error + (methods : Methods .anon) (s : TcState .anon) + (indId : KId .anon) (major rhs : KExpr .anon) (fields : UInt64) + (prefixArgs trailingArgs : Array (KExpr .anon)) + (err : TcError .anon) (sf : TcState .anon) : + (finishStructEtaResult indId major rhs fields prefixArgs trailingArgs).run + methods s ≠ .error err sf := by + intro herror + obtain ⟨final, sFinal, hsuccess⟩ := + finishStructEtaResult_total methods s indId major rhs fields prefixArgs + trailingArgs + rw [hsuccess] at herror + contradiction + +/-- The H3 guard rejects a Prop-valued major before universe instantiation or +any result interning. -/ +theorem finishStructEtaAfterSort_prop + {methods : Methods .anon} {s : TcState .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + {major : KExpr .anon} {u : KUniv .anon} {info : ExprInfo .anon} + (hzero : u.isZero = true) : + (finishStructEtaAfterSort recUs spine recr rule indId major + (.sort u info)).run methods s = .ok none s := by + simp [finishStructEtaAfterSort, structEtaSortRejected, hzero] + +/-- Any admissible sort/non-sort shape forwards successful universe +instantiation and rebuilding with their exact intermediate states. -/ +theorem finishStructEtaAfterSort_success + {methods : Methods .anon} {s sInst sf : TcState .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + {major majorSortW rhs result : KExpr .anon} + (hadmissible : StructEtaSortAdmissible majorSortW) + (hinst : TcM.instantiateUnivParams rule.rhs recUs s = .ok rhs sInst) + (hfinish : + (finishStructEtaResult indId major rhs rule.fields + (spine.extract 0 + (min (recr.params + recr.motives + recr.minors) spine.size)) + (spine.extract (recr.majorIdx + 1) spine.size)).run methods sInst = + .ok result sf) : + (finishStructEtaAfterSort recUs spine recr rule indId major + majorSortW).run methods s = .ok (some result) sf := by + unfold StructEtaSortAdmissible at hadmissible + unfold finishStructEtaAfterSort + rw [hadmissible] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.instantiateUnivParams rule.rhs recUs) _ s = _ + unfold EStateM.bind + rw [hinst] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (finishStructEtaResult indId major rhs rule.fields + (spine.extract 0 + (min (recr.params + recr.motives + recr.minors) spine.size)) + (spine.extract (recr.majorIdx + 1) spine.size)) methods) _ sInst = _ + unfold EStateM.bind + rw [hfinish] + rfl + +/-- Universe-instantiation errors are not caught by struct eta. -/ +theorem finishStructEtaAfterSort_instantiateError + {methods : Methods .anon} {s sf : TcState .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + {major majorSortW : KExpr .anon} {err : TcError .anon} + (hadmissible : StructEtaSortAdmissible majorSortW) + (hinst : TcM.instantiateUnivParams rule.rhs recUs s = .error err sf) : + (finishStructEtaAfterSort recUs spine recr rule indId major + majorSortW).run methods s = .error err sf := by + unfold StructEtaSortAdmissible at hadmissible + unfold finishStructEtaAfterSort + rw [hadmissible] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.instantiateUnivParams rule.rhs recUs) _ s = _ + unfold EStateM.bind + rw [hinst] + +/-- Generic forwarding equation for a hypothetical rebuilding error. The +premise is eliminated by `finishStructEtaResult_ne_error`; the theorem is +retained only as a compositional equation for clients that case-split before +using totality. -/ +theorem finishStructEtaAfterSort_finishError + {methods : Methods .anon} {s sInst sf : TcState .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + {major majorSortW rhs : KExpr .anon} {err : TcError .anon} + (hadmissible : StructEtaSortAdmissible majorSortW) + (hinst : TcM.instantiateUnivParams rule.rhs recUs s = .ok rhs sInst) + (hfinish : + (finishStructEtaResult indId major rhs rule.fields + (spine.extract 0 + (min (recr.params + recr.motives + recr.minors) spine.size)) + (spine.extract (recr.majorIdx + 1) spine.size)).run methods sInst = + .error err sf) : + (finishStructEtaAfterSort recUs spine recr rule indId major + majorSortW).run methods s = .error err sf := by + unfold StructEtaSortAdmissible at hadmissible + unfold finishStructEtaAfterSort + rw [hadmissible] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.instantiateUnivParams rule.rhs recUs) _ s = _ + unfold EStateM.bind + rw [hinst] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (finishStructEtaResult indId major rhs rule.fields + (spine.extract 0 + (min (recr.params + recr.motives + recr.minors) spine.size)) + (spine.extract (recr.majorIdx + 1) spine.size)) methods) _ sInst = _ + unfold EStateM.bind + rw [hfinish] + +/-- A failed structure classification is a silent miss with the classifier's +post-state. -/ +theorem tryStructEtaAfterInductive_notStruct + {methods : Methods .anon} {s sf : TcState .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + (hstruct : (isStructLike indId).run methods s = .ok false sf) : + (tryStructEtaAfterInductive recUs spine recr rule indId).run methods s = + .ok none sf := by + unfold tryStructEtaAfterInductive + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (isStructLike indId) methods) _ s = _ + unfold EStateM.bind + rw [hstruct] + rfl + +/-- Classification errors are not among struct eta's caught probes. -/ +theorem tryStructEtaAfterInductive_structError + {methods : Methods .anon} {s sf : TcState .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + {err : TcError .anon} + (hstruct : (isStructLike indId).run methods s = .error err sf) : + (tryStructEtaAfterInductive recUs spine recr rule indId).run methods s = + .error err sf := by + unfold tryStructEtaAfterInductive + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (isStructLike indId) methods) _ s = _ + unfold EStateM.bind + rw [hstruct] + +/-- The first inference probe can silently miss after a successful structure +classification. -/ +theorem tryStructEtaAfterInductive_majorInferMiss + {methods : Methods .anon} {s sStruct sf : TcState .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + (hstruct : (isStructLike indId).run methods s = .ok true sStruct) + (hinfer : (tryOptional (inferOnlyRec spine[recr.majorIdx]!)).run + methods sStruct = .ok none sf) : + (tryStructEtaAfterInductive recUs spine recr rule indId).run methods s = + .ok none sf := by + unfold tryStructEtaAfterInductive + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (isStructLike indId) methods) _ s = _ + unfold EStateM.bind + rw [hstruct] + simp only [Bool.not_true, Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec spine[recr.majorIdx]!)) methods) _ + sStruct = _ + unfold EStateM.bind + rw [hinfer] + rfl + +theorem tryStructEtaAfterInductive_majorInferError + {methods : Methods .anon} {s sStruct sf : TcState .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + {err : TcError .anon} + (hstruct : (isStructLike indId).run methods s = .ok true sStruct) + (hinfer : (inferOnlyRec spine[recr.majorIdx]!).run methods sStruct = + .error err sf) : + (tryStructEtaAfterInductive recUs spine recr rule indId).run methods s = + .ok none sf := + tryStructEtaAfterInductive_majorInferMiss hstruct + (tryOptional_error hinfer) + +/-- The second inference probe can silently miss after retaining both prior +post-states. -/ +theorem tryStructEtaAfterInductive_sortInferMiss + {methods : Methods .anon} {s sStruct sMajorTy sf : TcState .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + {majorTy : KExpr .anon} + (hstruct : (isStructLike indId).run methods s = .ok true sStruct) + (hmajor : (tryOptional (inferOnlyRec spine[recr.majorIdx]!)).run + methods sStruct = .ok (some majorTy) sMajorTy) + (hsort : (tryOptional (inferOnlyRec majorTy)).run methods sMajorTy = + .ok none sf) : + (tryStructEtaAfterInductive recUs spine recr rule indId).run methods s = + .ok none sf := by + unfold tryStructEtaAfterInductive + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (isStructLike indId) methods) _ s = _ + unfold EStateM.bind + rw [hstruct] + simp only [Bool.not_true, Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec spine[recr.majorIdx]!)) methods) _ + sStruct = _ + unfold EStateM.bind + rw [hmajor] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec majorTy)) methods) _ sMajorTy = _ + unfold EStateM.bind + rw [hsort] + rfl + +theorem tryStructEtaAfterInductive_sortInferError + {methods : Methods .anon} {s sStruct sMajorTy sf : TcState .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + {majorTy : KExpr .anon} {err : TcError .anon} + (hstruct : (isStructLike indId).run methods s = .ok true sStruct) + (hmajor : (tryOptional (inferOnlyRec spine[recr.majorIdx]!)).run + methods sStruct = .ok (some majorTy) sMajorTy) + (hsort : (inferOnlyRec majorTy).run methods sMajorTy = .error err sf) : + (tryStructEtaAfterInductive recUs spine recr rule indId).run methods s = + .ok none sf := + tryStructEtaAfterInductive_sortInferMiss hstruct hmajor + (tryOptional_error hsort) + +/-- The final WHNF probe can silently miss after both successful inference +callbacks. -/ +theorem tryStructEtaAfterInductive_sortWhnfMiss + {methods : Methods .anon} + {s sStruct sMajorTy sMajorSort sf : TcState .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + {majorTy majorSort : KExpr .anon} + (hstruct : (isStructLike indId).run methods s = .ok true sStruct) + (hmajor : (tryOptional (inferOnlyRec spine[recr.majorIdx]!)).run + methods sStruct = .ok (some majorTy) sMajorTy) + (hsort : (tryOptional (inferOnlyRec majorTy)).run methods sMajorTy = + .ok (some majorSort) sMajorSort) + (hwhnf : (tryOptional (whnfRec majorSort)).run methods sMajorSort = + .ok none sf) : + (tryStructEtaAfterInductive recUs spine recr rule indId).run methods s = + .ok none sf := by + unfold tryStructEtaAfterInductive + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (isStructLike indId) methods) _ s = _ + unfold EStateM.bind + rw [hstruct] + simp only [Bool.not_true, Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec spine[recr.majorIdx]!)) methods) _ + sStruct = _ + unfold EStateM.bind + rw [hmajor] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec majorTy)) methods) _ sMajorTy = _ + unfold EStateM.bind + rw [hsort] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (whnfRec majorSort)) methods) _ sMajorSort = _ + unfold EStateM.bind + rw [hwhnf] + rfl + +theorem tryStructEtaAfterInductive_sortWhnfError + {methods : Methods .anon} + {s sStruct sMajorTy sMajorSort sf : TcState .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + {majorTy majorSort : KExpr .anon} {err : TcError .anon} + (hstruct : (isStructLike indId).run methods s = .ok true sStruct) + (hmajor : (tryOptional (inferOnlyRec spine[recr.majorIdx]!)).run + methods sStruct = .ok (some majorTy) sMajorTy) + (hsort : (tryOptional (inferOnlyRec majorTy)).run methods sMajorTy = + .ok (some majorSort) sMajorSort) + (hwhnf : (whnfRec majorSort).run methods sMajorSort = .error err sf) : + (tryStructEtaAfterInductive recUs spine recr rule indId).run methods s = + .ok none sf := + tryStructEtaAfterInductive_sortWhnfMiss hstruct hmajor hsort + (tryOptional_error hwhnf) + +/-- Exact successful probe prefix through classification, both inference +callbacks, and sort WHNF. -/ +structure StructEtaProbeTrace + (methods : Methods .anon) (recUs : Array (KUniv .anon)) + (spine : Array (KExpr .anon)) (recr : IotaInfo .anon) + (rule : RecRule .anon) (indId : KId .anon) (s : TcState .anon) : Type where + majorTy : KExpr .anon + majorSort : KExpr .anon + majorSortW : KExpr .anon + sStruct : TcState .anon + sMajorTy : TcState .anon + sMajorSort : TcState .anon + sMajorSortW : TcState .anon + structLike : (isStructLike indId).run methods s = .ok true sStruct + majorInfer : + (tryOptional (inferOnlyRec spine[recr.majorIdx]!)).run methods sStruct = + .ok (some majorTy) sMajorTy + sortInfer : (tryOptional (inferOnlyRec majorTy)).run methods sMajorTy = + .ok (some majorSort) sMajorSort + sortWhnf : (tryOptional (whnfRec majorSort)).run methods sMajorSort = + .ok (some majorSortW) sMajorSortW + +namespace StructEtaProbeTrace + +/-- Any post-probe outcome is forwarded exactly. -/ +theorem eval + (h : StructEtaProbeTrace methods recUs spine recr rule indId s) + {outcome : EStateM.Result (TcError .anon) (TcState .anon) + (Option (KExpr .anon))} + (hfinish : + (finishStructEtaAfterSort recUs spine recr rule indId + spine[recr.majorIdx]! h.majorSortW).run methods h.sMajorSortW = + outcome) : + (tryStructEtaAfterInductive recUs spine recr rule indId).run methods s = + outcome := by + unfold tryStructEtaAfterInductive + rw [ReaderT.run_bind] + change EStateM.bind (ReaderT.run (isStructLike indId) methods) _ s = _ + unfold EStateM.bind + rw [h.structLike] + simp only [Bool.not_true, Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec spine[recr.majorIdx]!)) methods) _ + h.sStruct = _ + unfold EStateM.bind + rw [h.majorInfer] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (inferOnlyRec h.majorTy)) methods) _ + h.sMajorTy = _ + unfold EStateM.bind + rw [h.sortInfer] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryOptional (whnfRec h.majorSort)) methods) _ + h.sMajorSort = _ + unfold EStateM.bind + rw [h.sortWhnf] + exact hfinish + +theorem prop + (h : StructEtaProbeTrace methods recUs spine recr rule indId s) + {u : KUniv .anon} {info : ExprInfo .anon} + (hsort : h.majorSortW = .sort u info) (hzero : u.isZero = true) : + (tryStructEtaAfterInductive recUs spine recr rule indId).run methods s = + .ok none h.sMajorSortW := by + apply h.eval + rw [hsort] + exact finishStructEtaAfterSort_prop hzero + +theorem success + (h : StructEtaProbeTrace methods recUs spine recr rule indId s) + {sInst sf : TcState .anon} {rhs result : KExpr .anon} + (hadmissible : StructEtaSortAdmissible h.majorSortW) + (hinst : TcM.instantiateUnivParams rule.rhs recUs h.sMajorSortW = + .ok rhs sInst) + (hbuild : + (finishStructEtaResult indId spine[recr.majorIdx]! rhs rule.fields + (spine.extract 0 + (min (recr.params + recr.motives + recr.minors) spine.size)) + (spine.extract (recr.majorIdx + 1) spine.size)).run methods sInst = + .ok result sf) : + (tryStructEtaAfterInductive recUs spine recr rule indId).run methods s = + .ok (some result) sf := + h.eval (finishStructEtaAfterSort_success hadmissible hinst hbuild) + +theorem finishError + (h : StructEtaProbeTrace methods recUs spine recr rule indId s) + {sInst sf : TcState .anon} {rhs : KExpr .anon} {err : TcError .anon} + (hadmissible : StructEtaSortAdmissible h.majorSortW) + (hinst : TcM.instantiateUnivParams rule.rhs recUs h.sMajorSortW = + .ok rhs sInst) + (hbuild : + (finishStructEtaResult indId spine[recr.majorIdx]! rhs rule.fields + (spine.extract 0 + (min (recr.params + recr.motives + recr.minors) spine.size)) + (spine.extract (recr.majorIdx + 1) spine.size)).run methods sInst = + .error err sf) : + (tryStructEtaAfterInductive recUs spine recr rule indId).run methods s = + .error err sf := + h.eval (finishStructEtaAfterSort_finishError hadmissible hinst hbuild) + +end StructEtaProbeTrace + +/-- Rule-count rejection happens before any catalog access. -/ +theorem tryStructEtaIota_ruleCount + {methods : Methods .anon} {s : TcState .anon} {recId : KId .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {spine : Array (KExpr .anon)} + (hcount : (recr.rules.size != 1) = true) : + (tryStructEtaIota recId recr recUs spine).run methods s = .ok none s := by + unfold tryStructEtaIota + rw [hcount] + rfl + +/-- With one selected rule, a malformed recursor universe application is +rejected before the repeated catalog lookup or type scan. -/ +theorem tryStructEtaIota_levelMismatch + {methods : Methods .anon} {s : TcState .anon} {recId : KId .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {spine : Array (KExpr .anon)} + (hcount : (recr.rules.size != 1) = false) + (hlevels : (recUs.size.toUInt64 != recr.lvls) = true) : + (tryStructEtaIota recId recr recUs spine).run methods s = .ok none s := by + unfold tryStructEtaIota + rw [hcount] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [hlevels] + rfl + +/-- An absent recursor during the defensive repeated lookup is a silent miss. -/ +theorem tryStructEtaIota_recursorMissing + {methods : Methods .anon} {s sf : TcState .anon} {recId : KId .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {spine : Array (KExpr .anon)} + (hcount : (recr.rules.size != 1) = false) + (hlevels : recUs.size.toUInt64 = recr.lvls) + (hlookup : TcM.tryGetConst recId s = .ok none sf) : + (tryStructEtaIota recId recr recUs spine).run methods s = .ok none sf := by + unfold tryStructEtaIota + rw [hcount] + simp only [Bool.false_eq_true, if_false, pure_bind] + have hlevelsNe : (recUs.size.toUInt64 != recr.lvls) = false := by + simp [hlevels] + rw [hlevelsNe] + simp only [Bool.false_eq_true, if_false, pure_bind] + change EStateM.bind (TcM.tryGetConst recId) _ s = _ + unfold EStateM.bind + rw [hlookup] + rfl + +/-- Recursor lookup errors remain errors. -/ +theorem tryStructEtaIota_recursorError + {methods : Methods .anon} {s sf : TcState .anon} {recId : KId .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {spine : Array (KExpr .anon)} {err : TcError .anon} + (hcount : (recr.rules.size != 1) = false) + (hlevels : recUs.size.toUInt64 = recr.lvls) + (hlookup : TcM.tryGetConst recId s = .error err sf) : + (tryStructEtaIota recId recr recUs spine).run methods s = + .error err sf := by + unfold tryStructEtaIota + rw [hcount] + simp only [Bool.false_eq_true, if_false, pure_bind] + have hlevelsNe : (recUs.size.toUInt64 != recr.lvls) = false := by + simp [hlevels] + rw [hlevelsNe] + simp only [Bool.false_eq_true, if_false, pure_bind] + change EStateM.bind (TcM.tryGetConst recId) _ s = _ + unfold EStateM.bind + rw [hlookup] + +/-- Failure of the bounded major-inductive scan is caught after the repeated +recursor lookup, retaining the scan's post-state. -/ +theorem tryStructEtaIota_majorInductiveMiss + {methods : Methods .anon} {s sRec sf : TcState .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {rule : RecRule .anon} {recursor : KConst .anon} + {recTy : KExpr .anon} + (hcount : (recr.rules.size != 1) = false) + (hlevels : recUs.size.toUInt64 = recr.lvls) + (hrule : recr.rules[0]! = rule) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sRec) + (hrecTy : recursor.ty = recTy) + (hscan : + (tryOptional (do + let recTy ← liftM (TcM.instantiateUnivParams recTy recUs) + getMajorInductiveId recTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64)).run methods sRec = .ok none sf) : + (tryStructEtaIota recId recr recUs spine).run methods s = .ok none sf := by + unfold tryStructEtaIota + rw [hcount] + simp only [Bool.false_eq_true, if_false, pure_bind] + have hlevelsNe : (recUs.size.toUInt64 != recr.lvls) = false := by + simp [hlevels] + rw [hlevelsNe] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [hrule] + change EStateM.bind (TcM.tryGetConst recId) _ s = _ + unfold EStateM.bind + rw [hlookup] + simp only + rw [hrecTy] + change EStateM.bind + (ReaderT.run + (tryOptional (do + let recTy ← liftM (TcM.instantiateUnivParams recTy recUs) + getMajorInductiveId recTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64)) + methods) _ sRec = _ + unfold EStateM.bind + rw [hscan] + rfl + +theorem tryStructEtaIota_majorInductiveError + {methods : Methods .anon} {s sRec sf : TcState .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {rule : RecRule .anon} {recursor : KConst .anon} + {recTy : KExpr .anon} {err : TcError .anon} + (hcount : (recr.rules.size != 1) = false) + (hlevels : recUs.size.toUInt64 = recr.lvls) + (hrule : recr.rules[0]! = rule) + (hlookup : TcM.tryGetConst recId s = .ok (some recursor) sRec) + (hrecTy : recursor.ty = recTy) + (hscan : + (do + let recTy ← liftM (TcM.instantiateUnivParams recTy recUs) + getMajorInductiveId recTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64).run methods sRec = .error err sf) : + (tryStructEtaIota recId recr recUs spine).run methods s = .ok none sf := + tryStructEtaIota_majorInductiveMiss hcount hlevels hrule hlookup hrecTy + (tryOptional_error hscan) + +/-- Exact selected prefix through the single rule, repeated recursor lookup, +and caught inductive scan. -/ +structure StructEtaSelectionTrace + (methods : Methods .anon) (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) + (s : TcState .anon) : Type where + rule : RecRule .anon + recursor : KConst .anon + recTy : KExpr .anon + indId : KId .anon + sRec : TcState .anon + sScan : TcState .anon + ruleCount : (recr.rules.size != 1) = false + levelArity : recUs.size.toUInt64 = recr.lvls + selectedRule : recr.rules[0]! = rule + recursorLookup : TcM.tryGetConst recId s = .ok (some recursor) sRec + recursorType : recursor.ty = recTy + majorInductive : + (tryOptional (do + let recTy ← liftM (TcM.instantiateUnivParams recTy recUs) + getMajorInductiveId recTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64)).run methods sRec = .ok (some indId) sScan + +namespace StructEtaSelectionTrace + +theorem eval + (h : StructEtaSelectionTrace methods recId recr recUs spine s) + {outcome : EStateM.Result (TcError .anon) (TcState .anon) + (Option (KExpr .anon))} + (hafter : + (tryStructEtaAfterInductive recUs spine recr h.rule h.indId).run + methods h.sScan = outcome) : + (tryStructEtaIota recId recr recUs spine).run methods s = outcome := by + unfold tryStructEtaIota + rw [h.ruleCount] + simp only [Bool.false_eq_true, if_false, pure_bind] + have hlevelsNe : (recUs.size.toUInt64 != recr.lvls) = false := by + simp [h.levelArity] + rw [hlevelsNe] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [h.selectedRule] + change EStateM.bind (TcM.tryGetConst recId) _ s = _ + unfold EStateM.bind + rw [h.recursorLookup] + simp only + rw [h.recursorType] + change EStateM.bind + (ReaderT.run + (tryOptional (do + let recTy ← liftM (TcM.instantiateUnivParams h.recTy recUs) + getMajorInductiveId recTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64)) + methods) _ h.sRec = _ + unfold EStateM.bind + rw [h.majorInductive] + exact hafter + +end StructEtaSelectionTrace + +/-- Complete successful path through single-rule selection, the bounded +inductive scan, all three caught probes, universe instantiation, and the +three rebuilding segments. -/ +structure StructEtaIotaSuccessTrace + (methods : Methods .anon) (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) + (s : TcState .anon) (result : KExpr .anon) (sf : TcState .anon) : Type where + selection : StructEtaSelectionTrace methods recId recr recUs spine s + probes : StructEtaProbeTrace methods recUs spine recr selection.rule + selection.indId selection.sScan + rhs : KExpr .anon + sInst : TcState .anon + admissible : StructEtaSortAdmissible probes.majorSortW + instantiation : + TcM.instantiateUnivParams selection.rule.rhs recUs probes.sMajorSortW = + .ok rhs sInst + rebuild : + (finishStructEtaResult selection.indId spine[recr.majorIdx]! rhs + selection.rule.fields + (spine.extract 0 + (min (recr.params + recr.motives + recr.minors) spine.size)) + (spine.extract (recr.majorIdx + 1) spine.size)).run methods sInst = + .ok result sf + +namespace StructEtaIotaSuccessTrace + +/-- The complete trace is an exact execution of production +`tryStructEtaIota`. -/ +theorem eval + (h : StructEtaIotaSuccessTrace methods recId recr recUs spine s result + sf) : + (tryStructEtaIota recId recr recUs spine).run methods s = + .ok (some result) sf := + h.selection.eval + (h.probes.success h.admissible h.instantiation h.rebuild) + +/-- K1 acceptance at the honest semantic boundary. The operational trace is +constructed here; state preservation, finite support, and Theory meaning are +explicit premises because structure-likeness alone does not supply the +registered struct-eta equation or projection interpretation. -/ +theorem acceptance + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + (h : StructEtaIotaSuccessTrace methods recId recr recUs spine s result + sf) + {source : KExpr .anon} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta sf) + (hframe : InternUpdateFrame s sf) + (hsupport : support result) + (hmeaning : WhnfMeaning trProj world uvars Delta source result) : + (tryStructEtaIota recId recr recUs spine).run methods s = + .ok (some result) sf ∧ + WhnfStateInv layer semantics trProj world support uvars Delta sf ∧ + InternUpdateFrame s sf ∧ + support result ∧ + WhnfMeaning trProj world uvars Delta source result := + ⟨h.eval, hI, hframe, hsupport, hmeaning⟩ + +end StructEtaIotaSuccessTrace + +/-! ### Final constructor/struct-eta dispatch -/ + +/-- A non-constant normalized head reaches struct eta without touching the +constant catalog. -/ +theorem tryIotaCtorOrStructEta_nonConst + {methods : Methods .anon} {s : TcState .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {majorWhnf ctorHead : KExpr .anon} {ctorArgs : Array (KExpr .anon)} + {transient : Bool} + {outcome : EStateM.Result (TcError .anon) (TcState .anon) + (Option (KExpr .anon))} + (hspine : majorWhnf.collectSpine = (ctorHead, ctorArgs)) + (hshape : StructEtaDispatchNonConst ctorHead) + (heta : (tryStructEtaIota recId recr recUs spine).run methods s = + outcome) : + (tryIotaCtorOrStructEta recId recr recUs spine majorWhnf transient).run + methods s = outcome := by + unfold tryIotaCtorOrStructEta + rw [hspine] + cases ctorHead <;> simp [StructEtaDispatchNonConst] at hshape ⊢ + all_goals exact heta + +/-- An absent constant-head entry retains the lookup state and falls through +to struct eta. -/ +theorem tryIotaCtorOrStructEta_missing + {methods : Methods .anon} {s sLookup : TcState .anon} + {recId ctorId : KId .anon} {recr : IotaInfo .anon} + {recUs ctorUs : Array (KUniv .anon)} + {spine ctorArgs : Array (KExpr .anon)} + {majorWhnf : KExpr .anon} {ctorInfo : ExprInfo .anon} + {transient : Bool} + {outcome : EStateM.Result (TcError .anon) (TcState .anon) + (Option (KExpr .anon))} + (hspine : majorWhnf.collectSpine = + (.const ctorId ctorUs ctorInfo, ctorArgs)) + (hlookup : TcM.tryGetConst ctorId s = .ok none sLookup) + (heta : (tryStructEtaIota recId recr recUs spine).run methods sLookup = + outcome) : + (tryIotaCtorOrStructEta recId recr recUs spine majorWhnf transient).run + methods s = outcome := by + unfold tryIotaCtorOrStructEta + rw [hspine, ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst ctorId) _ s = _ + unfold EStateM.bind + rw [hlookup] + simpa only [pure_bind] using heta + +/-- A loaded constant without constructor iota metadata takes the same +fallthrough, starting from the lookup's exact post-state. -/ +theorem tryIotaCtorOrStructEta_notConstructor + {methods : Methods .anon} {s sLookup : TcState .anon} + {recId ctorId : KId .anon} {recr : IotaInfo .anon} + {recUs ctorUs : Array (KUniv .anon)} + {spine ctorArgs : Array (KExpr .anon)} + {majorWhnf : KExpr .anon} {ctorInfo : ExprInfo .anon} + {entry : KConst .anon} {transient : Bool} + {outcome : EStateM.Result (TcError .anon) (TcState .anon) + (Option (KExpr .anon))} + (hspine : majorWhnf.collectSpine = + (.const ctorId ctorUs ctorInfo, ctorArgs)) + (hlookup : TcM.tryGetConst ctorId s = .ok (some entry) sLookup) + (hinfo : entry.iotaCtorInfo? = none) + (heta : (tryStructEtaIota recId recr recUs spine).run methods sLookup = + outcome) : + (tryIotaCtorOrStructEta recId recr recUs spine majorWhnf transient).run + methods s = outcome := by + unfold tryIotaCtorOrStructEta + rw [hspine, ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst ctorId) _ s = _ + unfold EStateM.bind + rw [hlookup] + simp only [hinfo, pure_bind] + exact heta + +/-- Constant-head lookup errors propagate before either dispatcher runs. -/ +theorem tryIotaCtorOrStructEta_lookupError + {methods : Methods .anon} {s sf : TcState .anon} + {recId ctorId : KId .anon} {recr : IotaInfo .anon} + {recUs ctorUs : Array (KUniv .anon)} + {spine ctorArgs : Array (KExpr .anon)} + {majorWhnf : KExpr .anon} {ctorInfo : ExprInfo .anon} + {transient : Bool} {err : TcError .anon} + (hspine : majorWhnf.collectSpine = + (.const ctorId ctorUs ctorInfo, ctorArgs)) + (hlookup : TcM.tryGetConst ctorId s = .error err sf) : + (tryIotaCtorOrStructEta recId recr recUs spine majorWhnf transient).run + methods s = .error err sf := by + unfold tryIotaCtorOrStructEta + rw [hspine, ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst ctorId) _ s = _ + unfold EStateM.bind + rw [hlookup] + +/-- A constructor metadata hit forwards either success or error from ordinary +iota, and never enters struct eta. -/ +theorem tryIotaCtorOrStructEta_constructor + {methods : Methods .anon} {s sLookup : TcState .anon} + {recId ctorId : KId .anon} {recr : IotaInfo .anon} + {recUs ctorUs : Array (KUniv .anon)} + {spine ctorArgs : Array (KExpr .anon)} + {majorWhnf : KExpr .anon} {ctorInfo : ExprInfo .anon} + {entry : KConst .anon} {transient : Bool} {cidx ctorFields : Nat} + {outcome : EStateM.Result (TcError .anon) (TcState .anon) + (Option (KExpr .anon))} + (hspine : majorWhnf.collectSpine = + (.const ctorId ctorUs ctorInfo, ctorArgs)) + (hlookup : TcM.tryGetConst ctorId s = .ok (some entry) sLookup) + (hinfo : entry.iotaCtorInfo? = some (cidx, ctorFields)) + (hdispatch : + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields transient).run + methods sLookup = outcome) : + (tryIotaCtorOrStructEta recId recr recUs spine majorWhnf transient).run + methods s = outcome := by + unfold tryIotaCtorOrStructEta + rw [hspine, ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.tryGetConst ctorId) _ s = _ + unfold EStateM.bind + rw [hlookup] + simp only [hinfo, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields transient) + methods) _ sLookup = _ + unfold EStateM.bind + rw [hdispatch] + cases outcome <;> rfl + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/Substitution.lean b/Ix/Tc/Verify/Whnf/Iota/Substitution.lean new file mode 100644 index 000000000..269191c79 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/Substitution.lean @@ -0,0 +1,313 @@ +import Ix.Tc.Verify.Whnf.Iota.RuleSuffixTransport +import Ix.Tc.Verify.Totalization + +/-! +# Transient iota substitution agrees with the verified spec + +Production's Nat-literal iota path sets `transient = true` and beta-reduces +lambda intermediates with `substNoIntern`. The existing semantic beta theorem +is phrased over `KExpr.substSpec`, because that is also the specification of +the ordinary memoized substitution walker. The two implementations have the +same rebuilding arms, but `substNoIntern` adds `lbr` fast paths and uses its own +non-interning lift helper. + +This slice proves those optimizations exact for constructed anonymous terms +under the same UInt64 bounds already required by the walker proofs. It then +uses the equality to expose the production `applyIotaArg` transient-lambda +branch as the verified substitution spec and as a semantic beta reduction. +-/ + +namespace Ix.Tc + +namespace KExpr + +/-- The local non-interning lift used by `substNoIntern` computes the same +anonymous term as `liftSpec`. `Constructed` makes the stored `lbr` metadata +coherent, and the cutoff/size premise prevents binder-depth wraparound in the +fast-path justification. -/ +theorem Constructed.liftNoIntern_eq_liftSpec + {e : KExpr .anon} {shift cutoff : UInt64} + (hcon : Constructed e) + (hcut : cutoff.toNat + e.size < UInt64.size) : + substNoIntern.liftNoIntern e shift cutoff = + KExpr.liftSpec e shift cutoff := by + induction hcon generalizing cutoff with + | @var idx name md hidx => + rw [mkVar_shape] + rw [substNoIntern.liftNoIntern] + split + · rename_i hfast + rcases Bool.or_eq_true_iff.mp hfast with hzero | hlbr + · rw [eq_of_beq hzero] + exact (liftSpec_zero (.var hidx) cutoff).symm + · exact (liftSpec_id (.var hidx) hcut + (of_decide_eq_true hlbr)).symm + · rw [KExpr.liftSpec] + | @fvar id name md => + rw [mkFVar_shape] + simp only [substNoIntern.liftNoIntern, KExpr.liftSpec, KExpr.lbr, + ite_self] + | @sort u md => + rw [mkSort_shape] + simp only [substNoIntern.liftNoIntern, KExpr.liftSpec, KExpr.lbr, + ite_self] + | @const id us md => + rw [mkConst_shape] + simp only [substNoIntern.liftNoIntern, KExpr.liftSpec, KExpr.lbr, + ite_self] + | @app f a md hf ha ihf iha => + rw [mkApp_shape, size] at hcut + rw [mkApp_shape] + rw [substNoIntern.liftNoIntern] + split + · rename_i hfast + rcases Bool.or_eq_true_iff.mp hfast with hzero | hlbr + · rw [eq_of_beq hzero] + exact (liftSpec_zero (.app hf ha) cutoff).symm + · exact (liftSpec_id (.app hf ha) hcut + (of_decide_eq_true hlbr)).symm + · rw [KExpr.liftSpec, + ihf (cutoff := cutoff) (Nat.lt_of_le_of_lt (by omega) hcut), + iha (cutoff := cutoff) (Nat.lt_of_le_of_lt (by omega) hcut)] + | @lam n bi ty body md hty hbody ihty ihbody => + rw [mkLam_shape, size] at hcut + have hc1 : (cutoff + 1).toNat = cutoff.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hcut) + rw [mkLam_shape] + rw [substNoIntern.liftNoIntern] + split + · rename_i hfast + rcases Bool.or_eq_true_iff.mp hfast with hzero | hlbr + · rw [eq_of_beq hzero] + exact (liftSpec_zero (.lam hty hbody) cutoff).symm + · exact (liftSpec_id (.lam hty hbody) hcut + (of_decide_eq_true hlbr)).symm + · rw [KExpr.liftSpec, + ihty (cutoff := cutoff) (Nat.lt_of_le_of_lt (by omega) hcut), + ihbody (cutoff := cutoff + 1) + (by rw [hc1]; exact Nat.lt_of_le_of_lt (by omega) hcut)] + | @all n bi ty body md hty hbody ihty ihbody => + rw [mkAll_shape, size] at hcut + have hc1 : (cutoff + 1).toNat = cutoff.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hcut) + rw [mkAll_shape] + rw [substNoIntern.liftNoIntern] + split + · rename_i hfast + rcases Bool.or_eq_true_iff.mp hfast with hzero | hlbr + · rw [eq_of_beq hzero] + exact (liftSpec_zero (.all hty hbody) cutoff).symm + · exact (liftSpec_id (.all hty hbody) hcut + (of_decide_eq_true hlbr)).symm + · rw [KExpr.liftSpec, + ihty (cutoff := cutoff) (Nat.lt_of_le_of_lt (by omega) hcut), + ihbody (cutoff := cutoff + 1) + (by rw [hc1]; exact Nat.lt_of_le_of_lt (by omega) hcut)] + | @letE n ty val body nd md hty hval hbody ihty ihval ihbody => + rw [mkLet_shape, size] at hcut + have hc1 : (cutoff + 1).toNat = cutoff.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hcut) + rw [mkLet_shape] + rw [substNoIntern.liftNoIntern] + split + · rename_i hfast + rcases Bool.or_eq_true_iff.mp hfast with hzero | hlbr + · rw [eq_of_beq hzero] + exact (liftSpec_zero (.letE hty hval hbody) cutoff).symm + · exact (liftSpec_id (.letE hty hval hbody) hcut + (of_decide_eq_true hlbr)).symm + · rw [KExpr.liftSpec, + ihty (cutoff := cutoff) (Nat.lt_of_le_of_lt (by omega) hcut), + ihval (cutoff := cutoff) (Nat.lt_of_le_of_lt (by omega) hcut), + ihbody (cutoff := cutoff + 1) + (by rw [hc1]; exact Nat.lt_of_le_of_lt (by omega) hcut)] + | @prj id field val md hval ihval => + rw [mkPrj_shape, size] at hcut + rw [mkPrj_shape] + rw [substNoIntern.liftNoIntern] + split + · rename_i hfast + rcases Bool.or_eq_true_iff.mp hfast with hzero | hlbr + · rw [eq_of_beq hzero] + exact (liftSpec_zero (.prj hval) cutoff).symm + · exact (liftSpec_id (.prj hval) hcut + (of_decide_eq_true hlbr)).symm + · rw [KExpr.liftSpec, + ihval (cutoff := cutoff) (Nat.lt_of_le_of_lt (by omega) hcut)] + | @nat v blob md => + rw [mkNat_shape] + simp only [substNoIntern.liftNoIntern, KExpr.liftSpec, KExpr.lbr, + ite_self] + | @str v blob md => + rw [mkStr_shape] + simp only [substNoIntern.liftNoIntern, KExpr.liftSpec, KExpr.lbr, + ite_self] + +/-- The complete non-interning substitution computes `substSpec`. Its body +bound is the memoized walker's `depth + size` premise; its argument bound is +the same premise needed when a variable hit invokes the local lift above. -/ +theorem Constructed.substNoIntern_eq_substSpec + {body arg : KExpr .anon} + (hbody : Constructed body) (harg : Constructed arg) + {depth : UInt64} + (hcut : depth.toNat + body.size < UInt64.size) + (hargsz : arg.size < UInt64.size) : + substNoIntern body arg depth = + KExpr.substSpec body arg depth := by + induction hbody generalizing depth with + | @var idx name md hidx => + rw [mkVar_shape] + rw [substNoIntern] + split + · rename_i hfast + exact (substSpec_id (.var hidx) hcut hfast).symm + · rw [KExpr.substSpec, + harg.liftNoIntern_eq_liftSpec (shift := depth) (cutoff := 0) + (by simpa using hargsz)] + | @fvar id name md => + rw [mkFVar_shape] + simp only [substNoIntern, KExpr.substSpec, KExpr.lbr, ite_self] + | @sort u md => + rw [mkSort_shape] + simp only [substNoIntern, KExpr.substSpec, KExpr.lbr, ite_self] + | @const id us md => + rw [mkConst_shape] + simp only [substNoIntern, KExpr.substSpec, KExpr.lbr, ite_self] + | @app f a md hf ha ihf iha => + rw [mkApp_shape, size] at hcut + rw [mkApp_shape] + rw [substNoIntern] + split + · rename_i hfast + exact (substSpec_id (.app hf ha) hcut hfast).symm + · rw [KExpr.substSpec, + ihf (depth := depth) (Nat.lt_of_le_of_lt (by omega) hcut), + iha (depth := depth) (Nat.lt_of_le_of_lt (by omega) hcut)] + | @lam n bi ty inner md hty hinner ihty ihinner => + rw [mkLam_shape, size] at hcut + have hd1 : (depth + 1).toNat = depth.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hcut) + rw [mkLam_shape] + rw [substNoIntern] + split + · rename_i hfast + exact (substSpec_id (.lam hty hinner) hcut hfast).symm + · rw [KExpr.substSpec, + ihty (depth := depth) (Nat.lt_of_le_of_lt (by omega) hcut), + ihinner (depth := depth + 1) + (by rw [hd1]; exact Nat.lt_of_le_of_lt (by omega) hcut)] + | @all n bi ty inner md hty hinner ihty ihinner => + rw [mkAll_shape, size] at hcut + have hd1 : (depth + 1).toNat = depth.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hcut) + rw [mkAll_shape] + rw [substNoIntern] + split + · rename_i hfast + exact (substSpec_id (.all hty hinner) hcut hfast).symm + · rw [KExpr.substSpec, + ihty (depth := depth) (Nat.lt_of_le_of_lt (by omega) hcut), + ihinner (depth := depth + 1) + (by rw [hd1]; exact Nat.lt_of_le_of_lt (by omega) hcut)] + | @letE n ty val inner nd md hty hval hinner ihty ihval ihinner => + rw [mkLet_shape, size] at hcut + have hd1 : (depth + 1).toNat = depth.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (by omega) hcut) + rw [mkLet_shape] + rw [substNoIntern] + split + · rename_i hfast + exact (substSpec_id (.letE hty hval hinner) hcut hfast).symm + · rw [KExpr.substSpec, + ihty (depth := depth) (Nat.lt_of_le_of_lt (by omega) hcut), + ihval (depth := depth) (Nat.lt_of_le_of_lt (by omega) hcut), + ihinner (depth := depth + 1) + (by rw [hd1]; exact Nat.lt_of_le_of_lt (by omega) hcut)] + | @prj id field val md hval ihval => + rw [mkPrj_shape, size] at hcut + rw [mkPrj_shape] + rw [substNoIntern] + split + · rename_i hfast + exact (substSpec_id (.prj hval) hcut hfast).symm + · rw [KExpr.substSpec, + ihval (depth := depth) (Nat.lt_of_le_of_lt (by omega) hcut)] + | @nat v blob md => + rw [mkNat_shape] + simp only [substNoIntern, KExpr.substSpec, KExpr.lbr, ite_self] + | @str v blob md => + rw [mkStr_shape] + simp only [substNoIntern, KExpr.substSpec, KExpr.lbr, ite_self] + +end KExpr + +namespace RecM + +/-- Exact production equation for the transient lambda branch, normalized to +the already verified pure substitution specification. -/ +theorem applyIotaArg_true_lam_spec + (name : Mode.anon.F Name) (bi : Mode.anon.F Lean.BinderInfo) + (dom body arg : KExpr .anon) (info : ExprInfo .anon) + (hbody : KExpr.Constructed body) (harg : KExpr.Constructed arg) + (hbig : body.size + arg.size < UInt64.size) : + RecM.applyIotaArg (.lam name bi dom body info) arg true = + pure (KExpr.substSpec body arg 0) := by + rw [Ix.Tc.RecM.applyIotaArg_true_lam, + hbody.substNoIntern_eq_substSpec harg + (depth := 0) + (by rw [show (0 : UInt64).toNat = 0 from rfl]; omega) (by omega)] + +/-- Executable form of `applyIotaArg_true_lam_spec`: transient beta neither +reads nor changes the typechecker state. -/ +theorem applyIotaArg_true_lam_run + (methods : Methods .anon) (s : TcState .anon) + (name : Mode.anon.F Name) (bi : Mode.anon.F Lean.BinderInfo) + (dom body arg : KExpr .anon) (info : ExprInfo .anon) + (hbody : KExpr.Constructed body) (harg : KExpr.Constructed arg) + (hbig : body.size + arg.size < UInt64.size) : + (RecM.applyIotaArg (.lam name bi dom body info) arg true).run methods s = + .ok (KExpr.substSpec body arg 0) s := by + rw [applyIotaArg_true_lam_spec name bi dom body arg info hbody harg hbig] + rfl + +end RecM + +namespace WhnfMeaning + +/-- Semantic beta theorem for the exact non-interning term returned by +production's transient iota branch. The equality above is the only new +bridge; the typing and Theory beta argument remain those of `beta`. -/ +theorem betaNoIntern + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + (projections : TrProjOK world.venv uvars trProj) + {Delta : KVLCtx} {nm : Mode.anon.F Name} + {bi : Mode.anon.F Lean.BinderInfo} + {ty body arg : KExpr .anon} {lamMd appMd : ExprInfo .anon} + {A bodyV argV B : Lean4Lean.VExpr} {u : Lean4Lean.VLevel} + (hty : TrKExprS world.venv uvars world.nameOf trProj Delta ty A) + (hbody : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam A) :: Delta) body bodyV) + (harg : TrKExprS world.venv uvars world.nameOf trProj Delta arg argV) + (hA : world.venv.HasType uvars Delta.toCtx A (.sort u)) + (hbodyTy : world.venv.HasType uvars (A :: Delta.toCtx) bodyV B) + (hargTy : world.venv.HasType uvars Delta.toCtx argV A) + (hbodyCon : KExpr.Constructed body) + (hargCon : KExpr.Constructed arg) + (hbig : Delta.bvars + body.size + arg.size < UInt64.size) : + WhnfMeaning trProj world uvars Delta + (.app (.lam nm bi ty body lamMd) arg appMd) + (substNoIntern body arg 0) := by + rw [hbodyCon.substNoIntern_eq_substSpec hargCon + (depth := 0) + (by rw [show (0 : UInt64).toNat = 0 from rfl]; omega) (by omega)] + exact WhnfMeaning.beta projections hty hbody harg hA hbodyTy hargTy hbig + +end WhnfMeaning + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Iota/SynthesisRequests.lean b/Ix/Tc/Verify/Whnf/Iota/SynthesisRequests.lean new file mode 100644 index 000000000..0b9a97708 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Iota/SynthesisRequests.lean @@ -0,0 +1,748 @@ +import Ix.Tc.Verify.Whnf.StructEta.RebuildRequests + +/-! +# Finite request closure for K-synthesis + +The positive K branch builds a constructor application before ordinary iota +processing. Its generated syntax is finite and completely determined by the +selected constructor, normalized major-type spine, and parameter count. This +slice packages those exact intern requests and composes the remaining +stateful prefix: + +* optional infer-only and WHNF callbacks; +* lazy recursor/inductive catalog reads; +* the bounded major-inductive scan; +* both K-synthesis statistics updates; and +* the final, uncaught DefEq callback. + +The last item remains an explicit callback authority because its inputs need +finite support and structural translations before `Methods.WF.isDefEq` can +instantiate it. No catalog, walker, or generated-expression effect remains +abstract. +-/ + +namespace Ix.Tc +namespace RecM + +/-- State-only contract for the actual DefEq back-edge, including production's +dispatch-depth entry and balanced exit on both success and error. -/ +def IsDefEqCallbackPreserves (I : TcState .anon → Prop) + (methods : Methods .anon) : Prop := + ∀ a b s, + TcM.WF I s ((callIsDefEq a b).run methods) (fun _ _ => True) + +/-- Entering an instrumented predecessor-table dispatch changes only the +operational depth counter. Exhaustion throws before the write, so both +outcomes preserve the complete fixed-world invariant. -/ +theorem enterDispatch_whnf_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (enterDispatch (m := .anon)) (fun _ _ => True) := by + unfold enterDispatch + apply TcM.WF.bind + (Q₁ := fun observed after => observed = s ∧ after = s) + (TcM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨rfl, rfl⟩ + simp only + split + · exact TcM.WF.throw (fun _ => trivial) + · apply TcM.WF.set + · intro hI + exact hI.of_semantic_fields_eq rfl rfl rfl rfl rfl rfl rfl rfl + · exact fun _ => trivial + +/-- The balanced dispatch exit is likewise pure operational bookkeeping. -/ +theorem exitDispatch_whnf_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (exitDispatch (m := .anon)) (fun _ _ => True) := by + unfold exitDispatch modify + exact TcM.WF.modifyGet + (fun hI => hI.of_semantic_fields_eq rfl rfl rfl rfl rfl rfl rfl rfl) + (fun _ => trivial) + +/-- At certified inputs, the production `callIsDefEq` wrapper is constructed +directly from the predecessor table's semantic field. The `finally` exit +runs after both callback outcomes and cannot erase partial callback state. -/ +theorem callIsDefEq_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + {a b : KExpr .anon} {va vb : Lean4Lean.VExpr} + (haSupport : support a) (hbSupport : support b) + (ha : TrKExprS world.venv uvars world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv uvars world.nameOf trProj Delta b vb) + {s : TcState .anon} : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((callIsDefEq a b).run methods) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx va vb) := by + unfold callIsDefEq + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind enterDispatch_whnf_wf + intro _ afterEnter _ + change TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) + afterEnter + (tryFinally (methods.isDefEq a b) (exitDispatch (m := .anon))) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx va vb) + apply TcM.WF.tryFinally_const + · exact hmethods.isDefEq haSupport hbSupport ha hb + · intro after + exact exitDispatch_whnf_wf + +/-- Exact finite requests made while constructing one K-synthesis candidate. +The nested extract is the literal input observed by `FinishAppRequests.eval` +for production's `finishAppResult ... 0` call. -/ +structure KSynthCandidateRequests (requests : List WalkerRequest) + (ctorId : KId .anon) (tyUs : Array (KUniv .anon)) + (tyArgs : Array (KExpr .anon)) (params : Nat) : Type where + ctorHead : + WalkerRequest.internExpr (KExpr.mkConst ctorId tyUs) ∈ requests + ctorApp : KExpr .anon + ctorApps : + FinishAppRequests requests + ((tyArgs.extract 0 (min params tyArgs.size)).extract 0 + (tyArgs.extract 0 (min params tyArgs.size)).size).toList + (KExpr.mkConst ctorId tyUs) ctorApp + +/-- Run-wide census for every candidate that a loaded inductive may select. -/ +structure KSynthCandidateRequestCensus + (requests : List WalkerRequest) : Type where + plan : ∀ (ctorId : KId .anon) (tyUs : Array (KUniv .anon)) + (tyArgs : Array (KExpr .anon)) (params : Nat), + KSynthCandidateRequests requests ctorId tyUs tyArgs params + +/-- Exact semantic input retained for one generated K-synthesis candidate. + +The finite request plan determines the raw constructor application. This +record adds only the structural translations needed to instantiate the +predecessor table's `infer` and `isDefEq` fields at that concrete candidate; +it is deliberately indexed by the selected plan rather than quantifying over +arbitrary callback inputs. -/ +def KSynthCandidateInputs + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) + {requests : List WalkerRequest} {ctorId : KId .anon} + {tyUs : Array (KUniv .anon)} {tyArgs : Array (KExpr .anon)} + {params : Nat} + (plan : KSynthCandidateRequests requests ctorId tyUs tyArgs params) + (majorTyW : KExpr .anon) : Prop := + ∃ majorTyWV ctorAppV : Lean4Lean.VExpr, + support majorTyW ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta + majorTyW majorTyWV ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta + plan.ctorApp ctorAppV + +/-- Admission-owned structural translation for the one constructor candidate +actually selected by a successful K-synthesis catalog transaction. + +Every premise is tied to production's observed spine, trusted scan result, +address guard, lazy lookup equation, first-constructor selection, and finite +request plan. This is strictly narrower than an arbitrary inference callback +oracle: it provides no state fact and can be used only to instantiate +`Methods.WF` at the generated expression that production really built. -/ +structure KSynthCandidateInputOracle + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Prop where + candidate : + ∀ {uvars : Nat} {Delta : KVLCtx} + {majorTyW : KExpr .anon} {majorTyWV : Lean4Lean.VExpr} + {tyHeadId indId ctorId : KId .anon} + {tyUs : Array (KUniv .anon)} {tyInfo : ExprInfo .anon} + {tyArgs : Array (KExpr .anon)} {params : Nat} + {requests : List WalkerRequest} + {before after : TcState .anon} {entry : KConst .anon} + (plan : KSynthCandidateRequests requests ctorId tyUs tyArgs params), + support majorTyW → + TrKExprS world.venv uvars world.nameOf trProj Delta + majorTyW majorTyWV → + majorTyW.collectSpine = (.const tyHeadId tyUs tyInfo, tyArgs) → + world.trusted indId → + (tyHeadId.addr != indId.addr) = false → + TcM.tryGetConst indId before = .ok (some entry) after → + (match entry with + | .indc (ctors := ctors) .. => ctors[0]? = some ctorId + | _ => False) → + KSynthCandidateInputs trProj world support uvars Delta plan majorTyW + +/-- Retain the concrete execution equation selected by either outcome of a +verified `TcM` computation. -/ +private theorem wf_with_run_eq + {I : TcState .anon → Prop} {s : TcState .anon} {x : TcM .anon α} + {Q : α → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (hx : TcM.WF I s x Q E) : + TcM.WF I s x + (fun value after => Q value after ∧ x s = .ok value after) + (fun err after => E err after ∧ x s = .error err after) := by + intro hI + have hpost := hx hI + cases hrun : x s with + | ok value after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, rfl⟩ + | error err after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, rfl⟩ + +namespace FinishAppRequests + +/-- Hoare wrapper around the exact finite evaluator. -/ +theorem state_wf + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + {args : Array (KExpr .anon)} {consumed : Nat} + {start final : KExpr .anon} + (h : FinishAppRequests requests + (args.extract consumed args.size).toList start final) + (s : TcState .anon) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((finishAppResult start args consumed).run methods) + (fun result _ => result = final) := by + intro hI + obtain ⟨sf, heval, hIf, _⟩ := h.eval hrun hI + rw [heval] + exact ⟨hIf, rfl⟩ + +end FinishAppRequests + +/-- Candidate construction preserves the complete K1 invariant from the +finite intern plan plus the two exact callback authorities. -/ +theorem verifyKSynthCandidate_state_wf_of_requests + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + (hinfer : InferOnlyCallbackPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods) + (hdefeq : IsDefEqCallbackPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods) + {majorTyW : KExpr .anon} {ctorId : KId .anon} + {tyUs : Array (KUniv .anon)} {tyArgs : Array (KExpr .anon)} + {params : Nat} + (plan : KSynthCandidateRequests requests ctorId tyUs tyArgs params) + (s : TcState .anon) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((verifyKSynthCandidate majorTyW ctorId tyUs tyArgs params).run methods) + (fun _ _ => True) := by + unfold verifyKSynthCandidate + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (Q₁ := fun result _ => result = KExpr.mkConst ctorId tyUs) + · exact TcM.WF.mono + (TcM.intern_whnf_wf hrun.collisionFree + (hrun.coverage.internExpr plan.ctorHead)) + (fun _ _ hpost => hpost.1) + (fun _ _ _ => trivial) + · intro ctorHead afterHead hhead + subst ctorHead + rw [ReaderT.run_bind] + apply TcM.WF.bind (plan.ctorApps.state_wf hrun afterHead) + intro actualApp afterApps hactual + subst actualApp + rw [ReaderT.run_bind] + apply TcM.WF.bind + (tryOptional_state_wf (hinfer plan.ctorApp afterApps)) + intro foundTy afterInfer _ + cases foundTy with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some ctorTy => + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (TcM.bumpStats_whnf_wf + (fun st : TcState .anon => + { st with kSynthAttempts := st.kSynthAttempts + 1 }) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) afterInfer) + intro _ afterAttempt _ + rw [ReaderT.run_bind] + apply TcM.WF.bind (hdefeq majorTyW ctorTy afterAttempt) + intro equal afterDefEq _ + cases equal with + | false => + simp only [Bool.not_false, if_true] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (TcM.bumpStats_whnf_wf + (fun st : TcState .anon => + { st with kSynthRejects := st.kSynthRejects + 1 }) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) afterDefEq) + intro _ afterReject _ + exact TcM.WF.pure (fun _ => trivial) + | true => + exact TcM.WF.pure (fun _ => trivial) + +/-- Candidate construction with both predecessor-table callbacks derived at +their exact certified inputs. + +Unlike `verifyKSynthCandidate_state_wf_of_requests`, this theorem accepts no +state-only inference or DefEq callback oracle. The generated constructor +application is covered by the finite request plan, its translation is +supplied by `KSynthCandidateInputs`, successful inference exposes a +structural translation of the returned type, and `callIsDefEq_wf` then +instantiates `Methods.WF.isDefEq` directly. -/ +theorem verifyKSynthCandidate_state_wf_of_inputs + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + {majorTyW : KExpr .anon} {ctorId : KId .anon} + {tyUs : Array (KUniv .anon)} {tyArgs : Array (KExpr .anon)} + {params : Nat} + (plan : KSynthCandidateRequests requests ctorId tyUs tyArgs params) + (inputs : KSynthCandidateInputs trProj world support uvars Delta plan + majorTyW) + (s : TcState .anon) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((verifyKSynthCandidate majorTyW ctorId tyUs tyArgs params).run methods) + (fun result _ => + OptionalGeneratedInput trProj world support uvars Delta result) := by + rcases inputs with + ⟨majorTyWV, ctorAppV, hmajorTyWSupport, hmajorTyWTr, hctorAppTr⟩ + have hctorHeadSupport : + support (KExpr.mkConst ctorId tyUs) := + hrun.coverage.internExpr plan.ctorHead + have hctorAppSupport : support plan.ctorApp := + plan.ctorApps.support hrun hctorHeadSupport + unfold verifyKSynthCandidate + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (Q₁ := fun result _ => result = KExpr.mkConst ctorId tyUs) + · exact TcM.WF.mono + (TcM.intern_whnf_wf hrun.collisionFree + (hrun.coverage.internExpr plan.ctorHead)) + (fun _ _ hpost => hpost.1) + (fun _ _ _ => trivial) + · intro ctorHead afterHead hhead + subst ctorHead + rw [ReaderT.run_bind] + apply TcM.WF.bind (plan.ctorApps.state_wf hrun afterHead) + intro actualApp afterApps hactual + subst actualApp + rw [ReaderT.run_bind] + apply TcM.WF.bind + ((tryOptionalInferOnlyRec_wf + (s := afterApps) hctorAppSupport hctorAppTr) methods hmethods) + intro foundTy afterInfer hfound + cases foundTy with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some ctorTy => + obtain ⟨hctorTySupport, ctorTyV, hctorTy, _⟩ := hfound + obtain ⟨ctorTyStructuralV, hctorTyTr, _⟩ := hctorTy + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (TcM.bumpStats_whnf_wf + (fun st : TcState .anon => + { st with kSynthAttempts := st.kSynthAttempts + 1 }) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) afterInfer) + intro _ afterAttempt _ + rw [ReaderT.run_bind] + apply TcM.WF.bind + (callIsDefEq_wf hmethods hmajorTyWSupport hctorTySupport + hmajorTyWTr hctorTyTr) + intro equal afterDefEq _ + cases equal with + | false => + simp only [Bool.not_false, if_true] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (TcM.bumpStats_whnf_wf + (fun st : TcState .anon => + { st with kSynthRejects := st.kSynthRejects + 1 }) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) (fun _ => rfl) + (fun _ => rfl) (fun _ => rfl) afterDefEq) + intro _ afterReject _ + exact TcM.WF.pure (fun _ => trivial) + | true => + exact TcM.WF.pure (fun _ => + ⟨ctorAppV, hctorAppSupport, hctorAppTr⟩) + +/-- Defensive catalog selection preserves state on mismatch, every lazy +lookup outcome, malformed inductives, and the selected candidate transaction. +-/ +theorem selectKSynthCandidate_state_wf_of_requests + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (census : KSynthCandidateRequestCensus requests) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hinfer : InferOnlyCallbackPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods) + (hdefeq : IsDefEqCallbackPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods) + (majorTyW : KExpr .anon) (tyHeadId : KId .anon) + (tyUs : Array (KUniv .anon)) (tyArgs : Array (KExpr .anon)) + (indId : KId .anon) (params : Nat) (s : TcState .anon) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((selectKSynthCandidate majorTyW tyHeadId tyUs tyArgs indId params).run + methods) + (fun _ _ => True) := by + unfold selectKSynthCandidate + split + · exact TcM.WF.pure (fun _ => trivial) + · simp only [pure_bind] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind (TcM.tryGetConst_wf hfault indId s) + intro found afterLookup _ + cases found with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some entry => + cases entry <;> simp only + all_goals try + exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + case indc name levelParams lvls indParams indices isUnsafe block + memberIdx indTy ctors leanAll => + cases hfirst : ctors[0]? with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some ctorId => + simp only + exact verifyKSynthCandidate_state_wf_of_requests hrun hinfer + hdefeq (census.plan ctorId tyUs tyArgs params) afterLookup + +/-- Defensive catalog selection with the candidate inference and DefEq +callbacks instantiated from `Methods.WF` at the exact selected input. -/ +theorem selectKSynthCandidate_state_wf_of_inputs + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (census : KSynthCandidateRequestCensus requests) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (candidateInputs : KSynthCandidateInputOracle trProj world support) + {majorTyW : KExpr .anon} {majorTyWV : Lean4Lean.VExpr} + {tyHeadId : KId .anon} {tyUs : Array (KUniv .anon)} + {tyInfo : ExprInfo .anon} {tyArgs : Array (KExpr .anon)} + {indId : KId .anon} {params : Nat} + (hmajorSupport : support majorTyW) + (hmajorTr : TrKExprS world.venv uvars world.nameOf trProj Delta + majorTyW majorTyWV) + (hspine : + majorTyW.collectSpine = (.const tyHeadId tyUs tyInfo, tyArgs)) + (htrusted : world.trusted indId) + (s : TcState .anon) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((selectKSynthCandidate majorTyW tyHeadId tyUs tyArgs indId params).run + methods) + (fun result _ => + OptionalGeneratedInput trProj world support uvars Delta result) := by + unfold selectKSynthCandidate + split + · exact TcM.WF.pure (fun _ => trivial) + · rename_i hsame + simp only [pure_bind] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (Q₁ := fun found after => + TcM.tryGetConst indId s = .ok found after) + (TcM.WF.mono + (wf_with_run_eq (TcM.tryGetConst_wf hfault indId s)) + (fun _ _ hpost => hpost.2) + (fun _ _ _ => trivial)) + intro found afterLookup hlookup + cases found with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some entry => + cases entry <;> simp only + all_goals try + exact TcM.WF.pure (fun _ => by + simp [OptionalGeneratedInput]) + case indc name levelParams lvls indParams indices isUnsafe block + memberIdx indTy ctors leanAll => + cases hfirst : ctors[0]? with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some ctorId => + simp only + let plan := census.plan ctorId tyUs tyArgs params + have hselected : + (match + KConst.indc name levelParams lvls indParams indices + isUnsafe block memberIdx indTy ctors leanAll with + | .indc (ctors := selected) .. => + selected[0]? = some ctorId + | _ => False) := by + exact hfirst + have hinputs := + candidateInputs.candidate plan hmajorSupport hmajorTr hspine + htrusted (by + cases hguard : + (tyHeadId.addr != indId.addr) with + | false => rfl + | true => exact False.elim (hsame hguard)) + hlookup hselected + exact verifyKSynthCandidate_state_wf_of_inputs hrun hmethods + plan hinputs afterLookup + +/-- The complete K-synthesis helper preserves state through its three caught +probes and the selected finite candidate transaction. -/ +theorem synthCtorWhenK_state_wf_of_requests + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (census : KSynthCandidateRequestCensus requests) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : MajorTelescopeInputSupport support) + (hrecInputs : StructEtaRecursorInputOracle trProj world support) + (hfault : ∀ {current : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars current)) + (hreferences : TrustedReferences world support) + (hinfer : InferOnlyCallbackPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods) + (hwhnf : WhnfCallbackPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods) + (hdefeq : IsDefEqCallbackPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods) + (major : KExpr .anon) (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) + (s : TcState .anon) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((synthCtorWhenK major recId recr recUs).run methods) + (fun _ _ => True) := by + unfold synthCtorWhenK + by_cases hlevels : (recUs.size.toUInt64 != recr.lvls) = true + · simp only [hlevels, if_true] + exact TcM.WF.pure fun _ => trivial + · simp only [hlevels, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + apply TcM.WF.bind (tryOptional_state_wf (hinfer major s)) + intro foundTy afterInfer _ + cases foundTy with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some majorTy => + simp only + change TcM.WF _ afterInfer + (EStateM.bind ((tryOptional (whnfRec majorTy)).run methods) _) _ + apply TcM.WF.bind (tryOptional_state_wf (hwhnf majorTy afterInfer)) + intro foundWhnf afterWhnf _ + cases foundWhnf with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some majorTyW => + rcases hspine : majorTyW.collectSpine with ⟨tyHead, tyArgs⟩ + simp only [hspine] + cases tyHead <;> + try exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + next tyHeadId tyUs info => + simp only + change TcM.WF _ afterWhnf + (EStateM.bind (TcM.tryGetConst recId) _) _ + apply TcM.WF.bind + (Q₁ := fun found after => + TcM.tryGetConst recId afterWhnf = .ok found after) + (TcM.WF.mono + (TcM.WF.with_run_eq + (TcM.tryGetConst_wf (hfault (current := Delta)) recId + afterWhnf)) + (fun _ _ h => h.2) (fun _ _ _ => trivial)) + intro foundRecursor afterRecursor hlookup + cases foundRecursor with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some recursor => + simp only [pure_bind] + change TcM.WF _ afterRecursor + (EStateM.bind + ((tryOptional (do + let recTy ← liftM + (TcM.instantiateUnivParams recursor.ty recUs) + getMajorInductiveId recTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64)).run methods) _) _ + apply TcM.WF.bind (tryOptional_state_wf (by + rw [ReaderT.run_bind, ReaderT.run_monadLift, monadLift_self] + apply TcM.WF.bind (hrecInputs.instantiate hlookup) + intro recTy afterInst hrecTy + obtain ⟨hrecSupport, recTyV, hrecTr⟩ := hrecTy + exact TcM.WF.mono + (getMajorInductiveId_wf hmethods hinputs hfault + hreferences + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64 + hrecSupport hrecTr) + (fun _ _ _ => trivial) (fun _ _ _ => trivial))) + intro foundInd afterScan _ + cases foundInd with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some indId => + exact selectKSynthCandidate_state_wf_of_requests + hrun census (hfault (current := Delta)) hinfer hdefeq + majorTyW tyHeadId tyUs tyArgs indId recr.params afterScan + +/-- Complete K-synthesis state closure with its ordinary inference, WHNF, and +final DefEq back-edges derived from the predecessor method table. + +Only the bounded recursor-type scan still uses the dedicated support-retaining +WHNF frame; that scan traverses open declaration telescope bodies rather than +an expression structurally translated in the caller's `Delta`. -/ +theorem synthCtorWhenK_state_wf_of_inputs + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (census : KSynthCandidateRequestCensus requests) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : MajorTelescopeInputSupport support) + (hrecInputs : StructEtaRecursorInputOracle trProj world support) + (hfault : ∀ {current : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars current)) + (hreferences : TrustedReferences world support) + (candidateInputs : KSynthCandidateInputOracle trProj world support) + {major : KExpr .anon} {majorV : Lean4Lean.VExpr} + (hmajorSupport : support major) + (hmajorTr : TrKExprS world.venv uvars world.nameOf trProj Delta + major majorV) + (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) + (s : TcState .anon) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((synthCtorWhenK major recId recr recUs).run methods) + (fun result _ => + OptionalGeneratedInput trProj world support uvars Delta result) := by + unfold synthCtorWhenK + by_cases hlevels : (recUs.size.toUInt64 != recr.lvls) = true + · simp only [hlevels, if_true] + exact TcM.WF.pure fun _ => trivial + · simp only [hlevels, Bool.false_eq_true, if_false] + rw [ReaderT.run_bind] + apply TcM.WF.bind + ((tryOptionalInferOnlyRec_wf + (s := s) hmajorSupport hmajorTr) methods hmethods) + intro foundTy afterInfer hfoundTy + cases foundTy with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some majorTy => + simp only + obtain ⟨hmajorTySupport, majorTyV, hmajorTy, _⟩ := hfoundTy + obtain ⟨majorTyStructuralV, hmajorTyTr, _⟩ := hmajorTy + change TcM.WF _ afterInfer + (EStateM.bind ((tryOptional (whnfRec majorTy)).run methods) _) _ + apply TcM.WF.bind + ((tryOptionalWhnfRec_wf + (s := afterInfer) hmajorTySupport hmajorTyTr) methods hmethods) + intro foundWhnf afterWhnf hfoundWhnf + cases foundWhnf with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some majorTyW => + obtain ⟨hmajorTyWSupport, majorTyWPost⟩ := hfoundWhnf + obtain ⟨majorTyWV, hmajorTyWTr, _⟩ := majorTyWPost + rcases hspine : majorTyW.collectSpine with ⟨tyHead, tyArgs⟩ + simp only [hspine] + cases tyHead <;> + try exact TcM.WF.pure (fun _ => by + simp [OptionalGeneratedInput]) + next tyHeadId tyUs tyInfo => + simp only + change TcM.WF _ afterWhnf + (EStateM.bind (TcM.tryGetConst recId) _) _ + apply TcM.WF.bind + (Q₁ := fun found after => + TcM.tryGetConst recId afterWhnf = .ok found after) + (TcM.WF.mono + (TcM.WF.with_run_eq + (TcM.tryGetConst_wf (hfault (current := Delta)) recId + afterWhnf)) + (fun _ _ h => h.2) (fun _ _ _ => trivial)) + intro foundRecursor afterRecursor hlookup + cases foundRecursor with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some recursor => + simp only [pure_bind] + change TcM.WF _ afterRecursor + (EStateM.bind + ((tryOptional (do + let recTy ← liftM + (TcM.instantiateUnivParams recursor.ty recUs) + getMajorInductiveId recTy + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64)).run methods) _) _ + apply TcM.WF.bind (tryOptional_fixed_wf (by + rw [ReaderT.run_bind, ReaderT.run_monadLift, monadLift_self] + apply TcM.WF.bind (hrecInputs.instantiate hlookup) + intro recTy afterInst hrecTy + obtain ⟨hrecSupport, recTyV, hrecTr⟩ := hrecTy + exact getMajorInductiveId_trusted_wf hmethods hinputs hfault + hreferences + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64 + hrecSupport hrecTr)) + intro foundInd afterScan htrusted + cases foundInd with + | none => + exact TcM.WF.pure (fun _ => trivial) + | some indId => + exact selectKSynthCandidate_state_wf_of_inputs + hrun census hmethods (hfault (current := Delta)) + candidateInputs + hmajorTyWSupport hmajorTyWTr hspine htrusted + afterScan + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/NoDelta/BaseReductions.lean b/Ix/Tc/Verify/Whnf/NoDelta/BaseReductions.lean new file mode 100644 index 000000000..f0368bf8a --- /dev/null +++ b/Ix/Tc/Verify/Whnf/NoDelta/BaseReductions.lean @@ -0,0 +1,94 @@ +import Ix.Tc.Verify.Whnf.NoDelta.Quotient + +/-! +# Assemble the active no-delta base oracle + +The five reducers active under `.noAccel` are now independently closed: +projection application, Nat, String, projection-wrapper definitions, and +quotients. This slice packages their exact finite and semantic inputs and +constructs the `NoDeltaBaseOracle` consumed by the already-proved ordered +no-delta step. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Complete input package for the five active no-delta reducers. + +The fields remain separated by ownership. In particular, generated String, +projection-wrapper, and quotient nodes have their own finite plans; the +generic primitive context's final-result support cannot stand in for those +intermediate intern obligations. -/ +structure NoDeltaBaseContext + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (flags : WhnfFlags) : Type where + run : RunAssumptions initial program requests support + theory : ∀ uvars, WhnfTheory trProj world uvars + applicationCensus : ApplicationFinishRequestCensus requests support + coreInputs : WhnfCoreInputSupport support + projectionHelper : + ProjectionHelper.WF .noAccel semantics trProj world support + inductiveReduction : + InductiveReductionOracle .noAccel semantics trProj world support + primitive : ∀ mode, + NoDeltaPrimitiveContext world support flags mode + natWrites : NatSuccStuckWriteOracle semantics world support + natParts : NatRecLiteralPartsPreserves .noAccel semantics trProj world + support + natReflection : + NatSuccLinearReflection .noAccel semantics trProj world support + natShape : NatCollapseRequestCensus.NatBoolResultShapeSeparation world + stringSupport : StringReductionSupport support + stringReflection : + StringReductionReflection semantics trProj world support + projectionCensus : + ProjectionDefinitionRequestCensus requests support + projectionReflection : + ProjectionDefinitionReflection semantics trProj world support + quotientCensus : QuotientReductionRequestCensus requests support + quotientReflection : + QuotientReductionReflection semantics trProj world support + ingress : + AnonLazyIngressContext .noAccel semantics trProj world support + +namespace NoDeltaBaseContext + +/-- Construct all five active fields in production order for either Nat +successor policy. -/ +theorem oracle + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {flags : WhnfFlags} + (context : NoDeltaBaseContext initial program requests semantics trProj + world support flags) + (mode : NatSuccMode) : + NoDeltaBaseOracle semantics trProj world support flags mode where + projApp := + tryProjAppReduceFinished_optional_wf_of_contexts + context.run context.applicationCensus context.theory + context.coreInputs context.projectionHelper + context.inductiveReduction flags + nat := + tryReduceNatWithSuccMode_optional_wf_of_boundaries + context.primitive context.run context.theory context.natWrites + context.natParts context.natReflection context.natShape mode + string := + tryReduceString_optional_wf_of_reflection + (context.primitive mode).collisionFree context.stringSupport + context.stringReflection + projectionDef := + tryReduceProjectionDefinition_optional_wf_of_contexts + context.run context.projectionCensus + (fun {_ _} => context.ingress.preserves) + context.projectionReflection + quot := + tryQuotReduce_optional_wf_of_contexts + context.run context.quotientCensus (context.primitive mode).inputs + context.quotientReflection + +end NoDeltaBaseContext +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/NoDelta/ProjectionApplication.lean b/Ix/Tc/Verify/Whnf/NoDelta/ProjectionApplication.lean new file mode 100644 index 000000000..43f8afa8f --- /dev/null +++ b/Ix/Tc/Verify/Whnf/NoDelta/ProjectionApplication.lean @@ -0,0 +1,347 @@ +import Ix.Tc.Verify.Whnf.Structural.Reducer + +/-! +# Projection-application no-delta field + +The first reducer after structural WHNF recognizes an application whose +collected head is a projection. It normalizes the projected value, runs the +ordinary projection helper, and then rebuilds the complete trailing +application spine. + +This slice keeps those three effects separate. The recursive callback and +projection helper preserve every partial state; the inductive projection +boundary supplies meaning for the changed head; and the finite application +census certifies the exact left-to-right suffix rebuilt by production. +-/ + +namespace Ix.Tc +namespace RecM + +/-! ## Exact raw-helper equations -/ + +theorem tryProjAppReduce_empty + {methods : Methods .anon} {s : TcState .anon} + {source head : KExpr .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} + (hspine : source.collectSpine = (head, args)) + (hempty : args.isEmpty = true) : + (tryProjAppReduce source flags).run methods s = .ok none s := by + unfold tryProjAppReduce + simp only [hspine, hempty, if_true] + rfl + +theorem tryProjAppReduce_notProjection + {methods : Methods .anon} {s : TcState .anon} + {source head : KExpr .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} + (hspine : source.collectSpine = (head, args)) + (hnonempty : args.isEmpty = false) + (hnonprojection : ∀ id field value info, + head ≠ KExpr.prj id field value info) : + (tryProjAppReduce source flags).run methods s = .ok none s := by + unfold tryProjAppReduce + simp only [hspine, hnonempty, Bool.false_eq_true, if_false] + cases head <;> simp_all + +theorem tryProjAppReduce_projectionWhnfError + {methods : Methods .anon} {s s₁ : TcState .anon} + {source : KExpr .anon} {args : Array (KExpr .anon)} + {id : KId .anon} {field : UInt64} {value : KExpr .anon} + {info : ExprInfo .anon} {flags : WhnfFlags} {err : TcError .anon} + (hspine : source.collectSpine = (.prj id field value info, args)) + (hnonempty : args.isEmpty = false) + (hwhnf : + (if flags.cheapProj then + (whnfCoreFlagsRec value flags).run methods s + else (whnfRec value).run methods s) = .error err s₁) : + (tryProjAppReduce source flags).run methods s = .error err s₁ := by + unfold tryProjAppReduce + simp only [hspine, hnonempty, Bool.false_eq_true, if_false] + cases hcheap : flags.cheapProj <;> + simp only [hcheap, Bool.false_eq_true, ↓reduceIte] at hwhnf ⊢ + all_goals + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind _ _ s = _ + unfold EStateM.bind + rw [hwhnf] + +theorem tryProjAppReduce_projectionReduceError + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {source : KExpr .anon} {args : Array (KExpr .anon)} + {id : KId .anon} {field : UInt64} {value wvalue : KExpr .anon} + {info : ExprInfo .anon} {flags : WhnfFlags} {err : TcError .anon} + (hspine : source.collectSpine = (.prj id field value info, args)) + (hnonempty : args.isEmpty = false) + (hwhnf : + (if flags.cheapProj then + (whnfCoreFlagsRec value flags).run methods s + else (whnfRec value).run methods s) = .ok wvalue s₁) + (hreduce : (tryProjReduce id field wvalue).run methods s₁ = + .error err s₂) : + (tryProjAppReduce source flags).run methods s = .error err s₂ := by + unfold tryProjAppReduce + simp only [hspine, hnonempty, Bool.false_eq_true, if_false] + cases hcheap : flags.cheapProj <;> + simp only [hcheap, Bool.false_eq_true, ↓reduceIte] at hwhnf ⊢ + all_goals + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind _ _ s = _ + unfold EStateM.bind + rw [hwhnf] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjReduce id field wvalue) methods) _ s₁ = _ + unfold EStateM.bind + rw [hreduce] + +theorem tryProjAppReduce_projectionNone + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {source : KExpr .anon} {args : Array (KExpr .anon)} + {id : KId .anon} {field : UInt64} {value wvalue : KExpr .anon} + {info : ExprInfo .anon} {flags : WhnfFlags} + (hspine : source.collectSpine = (.prj id field value info, args)) + (hnonempty : args.isEmpty = false) + (hwhnf : + (if flags.cheapProj then + (whnfCoreFlagsRec value flags).run methods s + else (whnfRec value).run methods s) = .ok wvalue s₁) + (hreduce : (tryProjReduce id field wvalue).run methods s₁ = + .ok none s₂) : + (tryProjAppReduce source flags).run methods s = .ok none s₂ := by + unfold tryProjAppReduce + simp only [hspine, hnonempty, Bool.false_eq_true, if_false] + cases hcheap : flags.cheapProj <;> + simp only [hcheap, Bool.false_eq_true, ↓reduceIte] at hwhnf ⊢ + all_goals + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind _ _ s = _ + unfold EStateM.bind + rw [hwhnf] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjReduce id field wvalue) methods) _ s₁ = _ + unfold EStateM.bind + rw [hreduce] + rfl + +theorem tryProjAppReduce_projectionSome + {methods : Methods .anon} {s s₁ s₂ : TcState .anon} + {source : KExpr .anon} {args : Array (KExpr .anon)} + {id : KId .anon} {field : UInt64} + {value wvalue result : KExpr .anon} + {info : ExprInfo .anon} {flags : WhnfFlags} + (hspine : source.collectSpine = (.prj id field value info, args)) + (hnonempty : args.isEmpty = false) + (hwhnf : + (if flags.cheapProj then + (whnfCoreFlagsRec value flags).run methods s + else (whnfRec value).run methods s) = .ok wvalue s₁) + (hreduce : (tryProjReduce id field wvalue).run methods s₁ = + .ok (some result) s₂) : + (tryProjAppReduce source flags).run methods s = + .ok (some (result, args)) s₂ := by + unfold tryProjAppReduce + simp only [hspine, hnonempty, Bool.false_eq_true, if_false] + cases hcheap : flags.cheapProj <;> + simp only [hcheap, Bool.false_eq_true, ↓reduceIte] at hwhnf ⊢ + all_goals + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + rw [ReaderT.run_bind] + change EStateM.bind _ _ s = _ + unfold EStateM.bind + rw [hwhnf] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run (tryProjReduce id field wvalue) methods) _ s₁ = _ + unfold EStateM.bind + rw [hreduce] + rfl + +/-! ## Semantic assembly -/ + +/-- Empty collected spines make the helper a state-transparent miss. -/ +theorem tryProjAppReduceFinished_empty_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {source head : KExpr .anon} + {args : Array (KExpr .anon)} + {flags : WhnfFlags} {s : TcState .anon} + (hspine : source.collectSpine = (head, args)) + (hempty : args.isEmpty = true) : + RecM.WF layer semantics trProj world support uvars Delta s + (tryProjAppReduceFinished source flags) + (fun result _ => match result with + | none => True + | some reduced => + support reduced ∧ + WhnfMeaning trProj world uvars Delta source reduced) := by + intro methods hmethods hI + have hproj := + tryProjAppReduce_empty (methods := methods) (s := s) (flags := flags) + hspine hempty + rw [tryProjAppReduceFinished_none hproj] + exact ⟨hI, trivial⟩ + +/-- Complete no-delta contract for application-headed projection reduction. + +The Theory premise is uniform in the universe count because +`OptionalReduction.WF` itself is uniform; no cache entry or callback meaning +is replayed across universe counts. -/ +theorem tryProjAppReduceFinished_app_optional_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (hfinish : ApplicationFinishRequestCensus requests support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} + (theory : ∀ uvars, WhnfTheory trProj world uvars) + (hinputs : WhnfCoreInputSupport support) + (hhelper : ProjectionHelper.WF .noAccel semantics trProj world support) + (horacle : InductiveReductionOracle .noAccel semantics trProj world + support) + {f arg : KExpr .anon} {info : ExprInfo .anon} {flags : WhnfFlags} + {uvars : Nat} {Delta : KVLCtx} {sourceV : Lean4Lean.VExpr} + {s : TcState .anon} + (hsourceSupport : support (.app f arg info)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.app f arg info) sourceV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryProjAppReduceFinished (.app f arg info) flags) + (fun result _ => match result with + | none => True + | some reduced => + support reduced ∧ + WhnfMeaning trProj world uvars Delta + (.app f arg info) reduced) := by + intro methods hmethods hI + generalize hspine : + (.app f arg info : KExpr .anon).collectSpine = spine + rcases spine with ⟨head, args⟩ + cases hempty : args.isEmpty with + | true => + have hproj := tryProjAppReduce_empty + (methods := methods) (s := s) (flags := flags) hspine hempty + rw [tryProjAppReduceFinished_none hproj] + exact ⟨hI, trivial⟩ + | false => + cases head with + | prj id field value headInfo => + have htyped := trAppSpine_of_collectSpine hsource hspine + obtain ⟨headV, hheadTr, hsuffix⟩ := htyped.toSuffix + have hheadSupport := + (hinputs.app hsourceSupport hspine).1 + obtain ⟨valueV, hvalueTr, hcallbackWF⟩ := + projectionValueCallback_wf + (s := s) (flags := flags) hinputs hheadSupport hheadTr + have hcallbackPost := hcallbackWF methods hmethods hI + match hcallbackRun : + (if flags.cheapProj then + (whnfCoreFlagsRec value flags).run methods s + else (whnfRec value).run methods s) with + | .error err s₁ => + have hcallbackRunReader : + (if flags.cheapProj then whnfCoreFlagsRec value flags + else whnfRec value).run methods s = + .error err s₁ := by + cases hcheap : flags.cheapProj <;> + simp only [hcheap, Bool.false_eq_true, if_false, if_true] + at hcallbackRun ⊢ <;> + exact hcallbackRun + rw [hcallbackRunReader] at hcallbackPost + have hproj := + tryProjAppReduce_projectionWhnfError hspine hempty + hcallbackRun + rw [tryProjAppReduceFinished_projError hproj] + exact ⟨hcallbackPost.1, trivial⟩ + | .ok wvalue s₁ => + have hcallbackRunReader : + (if flags.cheapProj then whnfCoreFlagsRec value flags + else whnfRec value).run methods s = + .ok wvalue s₁ := by + cases hcheap : flags.cheapProj <;> + simp only [hcheap, Bool.false_eq_true, if_false, if_true] + at hcallbackRun ⊢ <;> + exact hcallbackRun + rw [hcallbackRunReader] at hcallbackPost + have hhelperPost := + hhelper (id := id) (field := field) hmethods + hcallbackPost.2.1 hcallbackPost.1 + match hreduce : + (tryProjReduce id field wvalue).run methods s₁ with + | .error err s₂ => + rw [hreduce] at hhelperPost + have hproj := + tryProjAppReduce_projectionReduceError hspine hempty + hcallbackRun hreduce + rw [tryProjAppReduceFinished_projError hproj] + exact ⟨hhelperPost.1, trivial⟩ + | .ok none s₂ => + rw [hreduce] at hhelperPost + have hproj := + tryProjAppReduce_projectionNone hspine hempty + hcallbackRun hreduce + rw [tryProjAppReduceFinished_none hproj] + exact ⟨hhelperPost.1, trivial⟩ + | .ok (some projResult) s₂ => + rw [hreduce] at hhelperPost + have hsemantic := + horacle.projection hmethods hheadTr hI hcallbackRun + hreduce + have hheadPost : + WhnfPost trProj world uvars Delta headV projResult := + WhnfPost.transMeaning (theory uvars) hI.2.1.wf + (WhnfPost.refl hheadTr + ((theory uvars).exprWF hI.2.1 hheadTr)) + hsemantic.2 + obtain ⟨rebuilt, s₃, hrequest, hfinishRun, hI₃, hframe, + hrebuiltSupport, hmeaning⟩ := + changedHeadFinish_acceptance hrun hfinish + (methods := methods) hsourceSupport hsource hspine + hsuffix hhelperPost.2 hheadPost hsemantic.1 + have hproj := + tryProjAppReduce_projectionSome hspine hempty + hcallbackRun hreduce + rw [tryProjAppReduceFinished_some hproj hfinishRun] + exact ⟨hI₃, hrebuiltSupport, hmeaning⟩ + | var | fvar | sort | const | app | lam | all | letE | nat | str => + have hproj := tryProjAppReduce_notProjection + (methods := methods) (s := s) (flags := flags) + hspine hempty (by simp) + rw [tryProjAppReduceFinished_none hproj] + exact ⟨hI, trivial⟩ + +/-- The application theorem plus the definitional empty-spine behavior of +all ten non-application constructors yields the uniform optional-reducer +field consumed by `NoDeltaBaseOracle`. -/ +theorem tryProjAppReduceFinished_optional_wf_of_contexts + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (hfinish : ApplicationFinishRequestCensus requests support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} + (theory : ∀ uvars, WhnfTheory trProj world uvars) + (hinputs : WhnfCoreInputSupport support) + (hhelper : ProjectionHelper.WF .noAccel semantics trProj world support) + (horacle : InductiveReductionOracle .noAccel semantics trProj world + support) + (flags : WhnfFlags) : + OptionalReduction.WF .noAccel semantics trProj world support + (fun source => tryProjAppReduceFinished source flags) := by + intro uvars Delta source sourceV s hsourceSupport hsource + cases source with + | app => + exact tryProjAppReduceFinished_app_optional_wf hrun hfinish theory + hinputs hhelper horacle hsourceSupport hsource + | var | fvar | sort | const | lam | all | letE | prj | nat | str => + exact tryProjAppReduceFinished_empty_wf (hspine := rfl) + (hempty := rfl) + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/NoDelta/ProjectionDefinition.lean b/Ix/Tc/Verify/Whnf/NoDelta/ProjectionDefinition.lean new file mode 100644 index 000000000..3b0c84de1 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/NoDelta/ProjectionDefinition.lean @@ -0,0 +1,214 @@ +import Ix.Tc.Verify.Whnf.NoDelta.StringPrimitive + +/-! +# Projection-definition no-delta field + +`tryReduceProjectionDefinition` recognizes a loaded reducible definition whose +body is exactly a lambda telescope ending in a projection. A hit constructs +the projection node and then rebuilds every application after the wrapper's +arity. + +This slice keeps those two generated-node obligations finite and explicit. +The initial projection and every intermediate suffix application must be in +the run support; support for only the final expression is not enough to make +the intern-table collision argument sound. +-/ + +namespace Ix.Tc + +/-- Finite request plan for a recognized projection-wrapper definition. + +The indices are the exact values returned by `collectSpine` and +`projectionDefinitionInfo`, so the plan covers production's initial `prj` +intern and precisely the suffix beginning at `arity`. -/ +structure ProjectionDefinitionRequestCensus + (requests : List WalkerRequest) (support : RunSupport) : Prop where + reduce : ∀ {source head : KExpr .anon} + {args : Array (KExpr .anon)} {id : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {val : KExpr .anon} {arity : Nat} {structId : KId .anon} + {field : UInt64} {structArgIdx : Nat}, + support source → + source.collectSpine = (head, args) → + head = .const id us headInfo → + projectionDefinitionInfo val = + some (arity, structId, field, structArgIdx) → + ¬ args.size < arity → + let base := KExpr.mkPrj structId field args[structArgIdx]! + support base ∧ + ∃ final, RecM.FinishAppRequests requests + (args.extract arity args.size).toList base final + +/-- Semantic authority for an observed successful projection-wrapper +rewrite. It owns no state or support claim: ProjectionDefinition proves those from the actual +lazy lookup and finite intern plan. A later admission refinement constructs +this boundary from the loaded definition translation and projection rule. -/ +structure ProjectionDefinitionReflection (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Prop where + success : ∀ {uvars : Nat} {Delta : KVLCtx} + {methods : Methods .anon} {source result : KExpr .anon} + {sourceV : Lean4Lean.VExpr} {s sf : TcState .anon}, + Methods.WFAt .noAccel semantics trProj world support uvars methods → + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + WhnfStateInv .noAccel semantics trProj world support uvars Delta s → + (RecM.tryReduceProjectionDefinition source).run methods s = + .ok (some result) sf → + WhnfMeaning trProj world uvars Delta source result + +namespace RecM + +set_option maxHeartbeats 800000 + +/-- The suffix loop embedded in the projection-definition helper is exactly +the shared production application finisher. -/ +theorem projectionDefinitionFinish_eq (base : KExpr m) + (args : Array (KExpr m)) (arity : Nat) : + (forIn (args.extract arity args.size) base fun arg result => do + let result ← TcM.intern (KExpr.mkApp result arg) + pure (.yield result) : RecM m (KExpr m)) = + finishAppResult base args arity := by + rw [finishAppResult_eq_foldlM] + simp [Array.forIn_yield_eq_foldlM] + +/-- Execute a finite suffix plan as a `RecM.WF` contract. -/ +theorem FinishAppRequests.finishAppResult_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {uvars : Nat} {Delta : KVLCtx} + {args : Array (KExpr .anon)} {consumed : Nat} + {base final : KExpr .anon} {s : TcState .anon} + (plan : FinishAppRequests requests + (args.extract consumed args.size).toList base final) + (hbase : support base) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (finishAppResult base args consumed) + (fun actual _ => actual = final ∧ support actual) := by + intro methods hmethods hI + obtain ⟨sf, hrunFinish, hIf, _⟩ := plan.eval hrun hI + rw [hrunFinish] + exact ⟨hIf, rfl, plan.support hrun hbase⟩ + +/-- State and generated-result closure of the production projection-wrapper +helper, including lazy-ingress errors and every intern in the suffix fold. -/ +theorem tryReduceProjectionDefinition_inv_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (census : ProjectionDefinitionRequestCensus requests support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {uvars : Nat} {Delta : KVLCtx} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + {source : KExpr .anon} {s : TcState .anon} + (hsourceSupport : support source) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryReduceProjectionDefinition source) + (fun result _ => match result with + | none => True + | some reduced => support reduced) := by + unfold tryReduceProjectionDefinition + generalize hspine : source.collectSpine = spine + rcases spine with ⟨head, args⟩ + cases head with + | const id us headInfo => + simp only [pure_bind] + apply RecM.WF.bind <| RecM.WF.withInv <| RecM.WF.liftTcM <| + TcM.tryGetConst_wf hfault id s + intro entry afterLookup hlookup + rcases hlookup with ⟨hILookup, _⟩ + cases entry with + | none => + simp only + exact RecM.WF.pure fun _ => trivial + | some entry => + cases entry with + | defn name levelParams kind safety hints lvls ty val leanAll block => + cases kind with + | defn => + simp only + cases hinfo : projectionDefinitionInfo val with + | none => + simp only + exact RecM.WF.pure fun _ => trivial + | some info => + rcases info with + ⟨arity, structId, field, structArgIdx⟩ + simp only + by_cases hsmall : args.size < arity + · simp only [hsmall, if_pos] + exact RecM.WF.pure fun _ => trivial + · simp only [hsmall, if_false] + let base : KExpr .anon := + KExpr.mkPrj structId field args[structArgIdx]! + obtain ⟨hbase, final, plan⟩ := + census.reduce hsourceSupport hspine rfl hinfo + hsmall + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf hrun.collisionFree hbase + intro actualBase afterBase hactualBase + have hactualBaseEq : actualBase = base := + hactualBase.1 + subst actualBase + rw [projectionDefinitionFinish_eq] + apply RecM.WF.bind + (plan.finishAppResult_wf hrun hbase) + intro actualFinal afterFinal hactualFinal + rcases hactualFinal with + ⟨hactualFinalEq, hfinalSupport⟩ + subst actualFinal + exact RecM.WF.pure fun _ => hfinalSupport + | opaq | thm => + simp only + exact RecM.WF.pure fun _ => trivial + | recr | axio | quot | indc | ctor => + simp only + exact RecM.WF.pure fun _ => trivial + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + simp only + exact RecM.WF.pure fun _ => trivial + +/-- Complete optional-reducer field: all operational state and support facts +come from the finite plan; only a successful hit consults semantic +reflection. -/ +theorem tryReduceProjectionDefinition_optional_wf_of_contexts + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (census : ProjectionDefinitionRequestCensus requests support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} + (hfault : ∀ {uvars : Nat} {Delta : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (reflection : ProjectionDefinitionReflection semantics trProj world + support) : + OptionalReduction.WF .noAccel semantics trProj world support + tryReduceProjectionDefinition := by + intro uvars Delta source sourceV s hsourceSupport hsource + have hstate := + tryReduceProjectionDefinition_inv_wf hrun census + (hfault (uvars := uvars) (Delta := Delta)) + (semantics := semantics) (trProj := trProj) (world := world) + (s := s) hsourceSupport + intro methods hmethods hI + have hpost := hstate methods hmethods hI + match hrunProjection : + (tryReduceProjectionDefinition source).run methods s with + | .error err sf => + rw [hrunProjection] at hpost + exact ⟨hpost.1, trivial⟩ + | .ok none sf => + rw [hrunProjection] at hpost + exact ⟨hpost.1, trivial⟩ + | .ok (some result) sf => + rw [hrunProjection] at hpost + exact ⟨hpost.1, hpost.2, + reflection.success hmethods hsourceSupport hsource hI + hrunProjection⟩ + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/NoDelta/Quotient.lean b/Ix/Tc/Verify/Whnf/NoDelta/Quotient.lean new file mode 100644 index 000000000..c7bd758c9 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/NoDelta/Quotient.lean @@ -0,0 +1,256 @@ +import Ix.Tc.Verify.Whnf.NoDelta.ProjectionDefinition + +/-! +# Quotient no-delta field + +The quotient helper normalizes the major through the predecessor WHNF table, +recognizes `Quot.mk`, interns the first reduced application, and rebuilds the +trailing suffix. This slice proves that complete operational path, including +callback errors and every generated intern, from finite input and request +coverage. +-/ + +namespace Ix.Tc + +/-- Finite generated-node plan for one selected quotient reduction. + +The plan is indexed by both production spine decompositions and the exact +selected function/major indices. Consequently it covers the initial +`f representative` application and every application after the quotient +major, without requiring global closure of the finite run support. -/ +structure QuotientReductionRequestCensus + (requests : List WalkerRequest) (support : RunSupport) : Prop where + reduce : ∀ {source head majorWhnf mkHead : KExpr .anon} + {args mkArgs : Array (KExpr .anon)} {prims : Primitives .anon} + {fIdx majorIdx : Nat} {mkId : KId .anon} + {mkUs : Array (KUniv .anon)} {mkInfo : ExprInfo .anon}, + support source → + source.collectSpine = (head, args) → + majorWhnf.collectSpine = (mkHead, mkArgs) → + mkHead = .const mkId mkUs mkInfo → + (mkId.addr != prims.quotCtor.addr) = false → + (mkArgs.size != 3) = false → + let base := KExpr.mkApp args[fIdx]! mkArgs[2]! + support base ∧ + ∃ final, RecM.FinishAppRequests requests + (args.extract (majorIdx + 1) args.size).toList base final + +/-- Semantic authority for an observed successful quotient reduction. +Operational state and support are excluded: Quotient proves them directly. The +eventual Theory refinement splits the `Quot.lift` registered equation from +the proof-irrelevant `Quot.ind` result. -/ +structure QuotientReductionReflection (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Prop where + success : ∀ {uvars : Nat} {Delta : KVLCtx} + {methods : Methods .anon} {source result : KExpr .anon} + {sourceV : Lean4Lean.VExpr} {s sf : TcState .anon}, + Methods.WFAt .noAccel semantics trProj world support uvars methods → + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + WhnfStateInv .noAccel semantics trProj world support uvars Delta s → + (RecM.tryQuotReduce source).run methods s = + .ok (some result) sf → + WhnfMeaning trProj world uvars Delta source result + +namespace RecM + +set_option maxHeartbeats 800000 + +/-- The common body reached after selecting the `Quot.lift` or `Quot.ind` +function and major indices. -/ +def tryQuotReduceSelected (prims : Primitives m) + (args : Array (KExpr m)) (fIdx majorIdx : Nat) : + RecM m (Option (KExpr m)) := do + let majorWhnf ← whnfRec args[majorIdx]! + let (mkHead, mkArgs) := majorWhnf.collectSpine + let .const mkId _ _ := mkHead | return none + if mkId.addr != prims.quotCtor.addr then + return none + if mkArgs.size != 3 then + return none + let mut result ← TcM.intern (KExpr.mkApp args[fIdx]! mkArgs[2]!) + for arg in args.extract (majorIdx + 1) args.size do + result ← TcM.intern (KExpr.mkApp result arg) + return some result + +/-- State and generated-result closure of the selected common quotient body. +The major callback is justified from its actual spine position; no arbitrary +child-support assumption is inferred from support for the parent. -/ +theorem tryQuotReduceSelected_inv_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (census : QuotientReductionRequestCensus requests support) + (inputs : NoDeltaInputSupport support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {uvars : Nat} {Delta : KVLCtx} + {source head : KExpr .anon} {sourceV : Lean4Lean.VExpr} + {args : Array (KExpr .anon)} {prims : Primitives .anon} + {fIdx majorIdx : Nat} {s : TcState .anon} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hspine : source.collectSpine = (head, args)) + (hfIdx : fIdx < args.size) (hmajorIdx : majorIdx < args.size) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryQuotReduceSelected prims args fIdx majorIdx) + (fun result _ => match result with + | none => True + | some reduced => support reduced) := by + have hmajorSupport : support args[majorIdx]! := by + have hsupported := + (inputs.spine hsourceSupport hspine).2 majorIdx hmajorIdx + simpa only [getElem!_pos args majorIdx hmajorIdx] using hsupported + have _hfunctionSupport : support args[fIdx]! := by + have hsupported := (inputs.spine hsourceSupport hspine).2 fIdx hfIdx + simpa only [getElem!_pos args fIdx hfIdx] using hsupported + have hmajorGet : + args[majorIdx]? = some args[majorIdx]! := by + rw [getElem?_pos args majorIdx hmajorIdx, + getElem!_pos args majorIdx hmajorIdx] + have hspineTr := trAppSpine_of_collectSpine hsource hspine + obtain ⟨majorV, majorType, hmajorType, hmajorTr⟩ := + hspineTr.argument (arg := args[majorIdx]!) <| + Array.mem_toList_iff.mpr (Array.mem_of_getElem? hmajorGet) + unfold tryQuotReduceSelected + apply RecM.WF.bind (whnfRec_wf hmajorSupport hmajorTr) + intro majorWhnf afterWhnf hmajorPost + generalize hmkSpine : majorWhnf.collectSpine = mkSpine + rcases mkSpine with ⟨mkHead, mkArgs⟩ + cases mkHead with + | const mkId mkUs mkInfo => + cases hctor : (mkId.addr != prims.quotCtor.addr) with + | true => + simp only [hctor, if_true] + exact RecM.WF.pure fun _ => trivial + | false => + simp only [hctor, Bool.false_eq_true, if_false] + cases hsize : (mkArgs.size != 3) with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ => trivial + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + let base : KExpr .anon := + KExpr.mkApp args[fIdx]! mkArgs[2]! + obtain ⟨hbase, final, plan⟩ := + census.reduce (prims := prims) (fIdx := fIdx) + (majorIdx := majorIdx) hsourceSupport hspine hmkSpine rfl + hctor hsize + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf hrun.collisionFree hbase + intro actualBase afterBase hactualBase + have hactualBaseEq : actualBase = base := hactualBase.1 + subst actualBase + rw [projectionDefinitionFinish_eq] + apply RecM.WF.bind (plan.finishAppResult_wf hrun hbase) + intro actualFinal afterFinal hactualFinal + rcases hactualFinal with + ⟨hactualFinalEq, hfinalSupport⟩ + subst actualFinal + exact RecM.WF.pure fun _ => hfinalSupport + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + simp only + exact RecM.WF.pure fun _ => trivial + +/-- State and generated-result closure of the complete production quotient +helper, including both arity policies and every miss. -/ +theorem tryQuotReduce_inv_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (census : QuotientReductionRequestCensus requests support) + (inputs : NoDeltaInputSupport support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {uvars : Nat} {Delta : KVLCtx} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + {s : TcState .anon} + (hsourceSupport : support source) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryQuotReduce source) + (fun result _ => match result with + | none => True + | some reduced => support reduced) := by + unfold tryQuotReduce + generalize hspine : source.collectSpine = spine + rcases spine with ⟨head, args⟩ + cases head with + | const id us headInfo => + simp only [pure_bind] + apply RecM.WF.bind (prims_wf (s := s)) + intro prims afterRead hread + rcases hread with ⟨hprims, hafterRead⟩ + subst afterRead + cases hlift : (id.addr == prims.quotLift.addr) with + | true => + simp only [if_true] + by_cases hsize : args.size < 6 + · simp only [hsize, if_pos] + exact RecM.WF.pure fun _ => trivial + · simp only [hsize, if_false] + have hfIdx : 3 < args.size := by omega + have hmajorIdx : 5 < args.size := by omega + simpa only [tryQuotReduceSelected] using + tryQuotReduceSelected_inv_wf hrun census inputs + (semantics := semantics) (trProj := trProj) (world := world) + hsourceSupport hsource hspine hfIdx hmajorIdx + | false => + simp only [Bool.false_eq_true, if_false] + cases hind : (id.addr == prims.quotInd.addr) with + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + | true => + simp only [if_true] + by_cases hsize : args.size < 5 + · simp only [hsize, if_pos] + exact RecM.WF.pure fun _ => trivial + · simp only [hsize, if_false] + have hfIdx : 3 < args.size := by omega + have hmajorIdx : 4 < args.size := by omega + simpa only [tryQuotReduceSelected] using + tryQuotReduceSelected_inv_wf hrun census inputs + (semantics := semantics) (trProj := trProj) + (world := world) hsourceSupport hsource hspine + hfIdx hmajorIdx + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + simp only + exact RecM.WF.pure fun _ => trivial + +/-- Complete quotient optional-reducer field. -/ +theorem tryQuotReduce_optional_wf_of_contexts + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (census : QuotientReductionRequestCensus requests support) + (inputs : NoDeltaInputSupport support) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} + (reflection : QuotientReductionReflection semantics trProj world + support) : + OptionalReduction.WF .noAccel semantics trProj world support + tryQuotReduce := by + intro uvars Delta source sourceV s hsourceSupport hsource + have hstate := + tryQuotReduce_inv_wf hrun census inputs + (semantics := semantics) (trProj := trProj) (world := world) + (s := s) hsourceSupport hsource + intro methods hmethods hI + have hpost := hstate methods hmethods hI + match hrunQuot : (tryQuotReduce source).run methods s with + | .error err sf => + rw [hrunQuot] at hpost + exact ⟨hpost.1, trivial⟩ + | .ok none sf => + rw [hrunQuot] at hpost + exact ⟨hpost.1, trivial⟩ + | .ok (some result) sf => + rw [hrunQuot] at hpost + exact ⟨hpost.1, hpost.2, + reflection.success hmethods hsourceSupport hsource hI hrunQuot⟩ + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/NoDelta/Reducer.lean b/Ix/Tc/Verify/Whnf/NoDelta/Reducer.lean new file mode 100644 index 000000000..5e09646ac --- /dev/null +++ b/Ix/Tc/Verify/Whnf/NoDelta/Reducer.lean @@ -0,0 +1,68 @@ +import Ix.Tc.Verify.Whnf.NoDelta.BaseReductions + +/-! +# Public no-delta reducer + +Reducer constructs the structural reducer and BaseReductions constructs the five active +tail fields. The generic no-delta driver theorem already proves reducer +ordering, bounded iteration, cache hits, transient bypass, partial errors, +and collision-robust cache writes. This slice supplies those two concrete +components to that shell. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Complete fixed-context input for the public no-delta reducer. -/ +structure NoDeltaDriverContext + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) (keys : WhnfContextKeys) + (fallback : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) + (Delta : KVLCtx) (flags : WhnfFlags) : Type where + structural : + StructuralCoreContext initial program requests keys fallback trProj world + support Delta flags + base : + NoDeltaBaseContext initial program requests + (whnfCacheSemantics keys trProj fallback) trProj world support flags + cacheWrites : WhnfCacheWriteOracle keys trProj fallback world support + +namespace NoDeltaDriverContext + +/-- The actual public no-delta reducer satisfies its semantic Hoare contract +for either successor policy. -/ +theorem wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {keys : WhnfContextKeys} + {fallback : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {Delta : KVLCtx} {flags : WhnfFlags} + (context : NoDeltaDriverContext initial program requests keys fallback + trProj world support Delta flags) + (mode : NatSuccMode) {source : KExpr .anon} + (hsourceSupport : support source) + {sourceV : Lean4Lean.VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF .noAccel (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s + (whnfNoDeltaImpl source flags mode) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + intro methods hmethods hI + exact + (whnfNoDeltaImpl_noAccel_wf_of_base + context.structural.theory hI.2.1.wf + context.structural.wf (context.base.oracle mode) + (context.structural.keyRep source hsourceSupport) + (TransientNatWork.preserving + (context.structural.iotaIngress.preserves + (uvars := keys.uvars) (Delta := Delta)) + source) + context.cacheWrites hsourceSupport hsource) + methods hmethods hI + +end NoDeltaDriverContext +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/NoDelta/StringPrimitive.lean b/Ix/Tc/Verify/Whnf/NoDelta/StringPrimitive.lean new file mode 100644 index 000000000..53b1098c2 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/NoDelta/StringPrimitive.lean @@ -0,0 +1,283 @@ +import Ix.Tc.Verify.Whnf.NoDelta.ProjectionApplication + +/-! +# String primitive no-delta field + +`tryReduceString` has three successful forms: an interned UTF-8 byte count, +the canonical empty byte array, or an interned `Char.ofNat` application for +`String.back`. The helper has no recursive method-table edge and no lazy +environment lookup. + +This slice proves its complete state behavior from finite support for those +exact generated nodes. Theory computation remains a deliberately narrow +reflection boundary indexed by an observed successful production run. +-/ + +namespace Ix.Tc + +/-- Finite generated-node support for the String reducer. + +Every premise is scoped to a supported source and the exact production +classifier equations. Thus the obligation remains finite even though +String and Nat are infinite datatypes. -/ +structure StringReductionSupport (support : RunSupport) : Prop where + utf8 : ∀ {source head : KExpr .anon} {args : Array (KExpr .anon)} + {id : KId .anon} {us : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {value : String} {blob : Address} + {stringInfo : ExprInfo .anon} {prims : Primitives .anon}, + support source → + source.collectSpine = (head, args) → + head = .const id us headInfo → + (args.size != 1) = false → + args[0]! = .str value blob stringInfo → + prims.CanonicalAnon → + (id.addr == prims.stringUtf8ByteSize.addr) = true → + support (RecM.natExprFromValue value.utf8ByteSize) + emptyByteArray : ∀ {source head : KExpr .anon} + {args : Array (KExpr .anon)} {id : KId .anon} + {us : Array (KUniv .anon)} {headInfo : ExprInfo .anon} + {value : String} {blob : Address} {stringInfo : ExprInfo .anon} + {prims : Primitives .anon}, + support source → + source.collectSpine = (head, args) → + head = .const id us headInfo → + (args.size != 1) = false → + args[0]! = .str value blob stringInfo → + prims.CanonicalAnon → + (id.addr == prims.stringToByteArray.addr) = true → + value.isEmpty = true → + support (KExpr.mkConst prims.byteArrayEmpty #[]) + back : ∀ {source head : KExpr .anon} {args : Array (KExpr .anon)} + {id : KId .anon} {us : Array (KUniv .anon)} + {headInfo : ExprInfo .anon} {value : String} {blob : Address} + {stringInfo : ExprInfo .anon} {prims : Primitives .anon}, + support source → + source.collectSpine = (head, args) → + head = .const id us headInfo → + (args.size != 1) = false → + args[0]! = .str value blob stringInfo → + prims.CanonicalAnon → + (id.addr == prims.stringBack.addr || + id.addr == prims.stringLegacyBack.addr) = true → + (id.addr == prims.stringUtf8ByteSize.addr) = false → + (id.addr == prims.stringToByteArray.addr) = false → + let codepoint := (value.toList.getLast?.map (·.toNat)).getD 65 + let charHead := KExpr.mkConst prims.charOfNat #[] + let natLit := RecM.natExprFromValue codepoint + support charHead ∧ support natLit ∧ + support (KExpr.mkApp charHead natLit) + +/-- Semantic authority for an observed successful String primitive +reduction. It contributes no state claim; StringPrimitive proves state preservation +for hits, misses, and all intermediate intern operations directly. -/ +structure StringReductionReflection (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Prop where + success : ∀ {uvars : Nat} {Delta : KVLCtx} + {methods : Methods .anon} {source result : KExpr .anon} + {sourceV : Lean4Lean.VExpr} {s sf : TcState .anon}, + Methods.WFAt .noAccel semantics trProj world support uvars methods → + support source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + WhnfStateInv .noAccel semantics trProj world support uvars Delta s → + (RecM.tryReduceString source).run methods s = + .ok (some result) sf → + WhnfMeaning trProj world uvars Delta source result + +namespace RecM + +set_option maxHeartbeats 800000 + +/-- State and generated-result closure of the production String helper. -/ +theorem tryReduceString_inv_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (collision : support.CollisionFree) + (generated : StringReductionSupport support) + {uvars : Nat} {Delta : KVLCtx} {source : KExpr .anon} + {s : TcState .anon} + (hsourceSupport : support source) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryReduceString source) + (fun result _ => match result with + | none => True + | some reduced => support reduced) := by + unfold tryReduceString + generalize hspine : source.collectSpine = spine + rcases spine with ⟨head, args⟩ + cases hsize : args.size != 1 with + | true => + simp only [hsize, if_true] + exact RecM.WF.pure fun _ => trivial + | false => + simp only [hsize, Bool.false_eq_true, if_false] + cases head with + | const id us headInfo => + simp only [pure_bind] + apply RecM.WF.bind (RecM.WF.withInv (prims_wf (s := s))) + intro prims afterRead hread + rcases hread with ⟨hIRead, hprims, hafterRead⟩ + subst afterRead + have hcanonical : prims.CanonicalAnon := by + rw [hprims] + exact hIRead.noAccel_primitives + cases hguard : + (!(id.addr == prims.stringBack.addr || + id.addr == prims.stringLegacyBack.addr) && + !(id.addr == prims.stringUtf8ByteSize.addr) && + !(id.addr == prims.stringToByteArray.addr)) with + | true => + simp only [if_true] + exact RecM.WF.pure fun _ => trivial + | false => + simp only [Bool.false_eq_true, if_false] + cases harg : args[0]! with + | str value blob stringInfo => + simp only + cases hutf8 : + (id.addr == prims.stringUtf8ByteSize.addr) with + | true => + simp only [if_true] + let requested : KExpr .anon := + natExprFromValue value.utf8ByteSize + have hrequested : support requested := by + apply generated.utf8 hsourceSupport hspine rfl hsize + harg + · exact hcanonical + · exact hutf8 + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf collision hrequested + intro interned afterIntern hintern + have hinterned : interned = requested := hintern.1 + subst interned + exact RecM.WF.pure fun _ => hrequested + | false => + simp only [Bool.false_eq_true, if_false] + cases hbytes : + (id.addr == prims.stringToByteArray.addr) with + | true => + simp only [if_true] + cases hempty : value.isEmpty with + | true => + simp only [if_true] + let requested : KExpr .anon := + KExpr.mkConst prims.byteArrayEmpty #[] + have hrequested : support requested := by + apply generated.emptyByteArray hsourceSupport + hspine rfl hsize harg + · exact hcanonical + · exact hbytes + · exact hempty + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf collision hrequested + intro interned afterIntern hintern + have hinterned : interned = requested := + hintern.1 + subst interned + exact RecM.WF.pure fun _ => hrequested + | false => + simp only [Bool.false_eq_true, if_false] + exact RecM.WF.pure fun _ => trivial + | false => + simp only [Bool.false_eq_true, if_false] + have hback : + (id.addr == prims.stringBack.addr || + id.addr == + prims.stringLegacyBack.addr) = true := by + cases hb : + (id.addr == prims.stringBack.addr || + id.addr == + prims.stringLegacyBack.addr) with + | false => + simp [hb, hutf8, hbytes] at hguard + | true => rfl + let codepoint := + (value.toList.getLast?.map (·.toNat)).getD 65 + let charHead : KExpr .anon := + KExpr.mkConst prims.charOfNat #[] + let natLit : KExpr .anon := + natExprFromValue codepoint + let result : KExpr .anon := + KExpr.mkApp charHead natLit + have hgenerated := + generated.back hsourceSupport hspine rfl hsize + harg hcanonical + hback hutf8 hbytes + have hcharHead : support charHead := by + simpa [codepoint, charHead, natLit, result] using + hgenerated.1 + have hnatLit : support natLit := by + simpa [codepoint, charHead, natLit, result] using + hgenerated.2.1 + have hresult : support result := by + simpa [codepoint, charHead, natLit, result] using + hgenerated.2.2 + unfold charOfNatExpr + apply RecM.WF.bind (prims_wf (s := s)) + intro innerPrims afterInnerRead hinnerRead + rcases hinnerRead with + ⟨hinnerPrims, hafterInnerRead⟩ + subst afterInnerRead + have hinnerEq : innerPrims = prims := + hinnerPrims.trans hprims.symm + subst innerPrims + rw [hinnerEq] + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf collision hcharHead + intro actualHead afterHead hactualHead + have hactualHeadEq : actualHead = charHead := + hactualHead.1 + subst actualHead + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf collision hnatLit + intro actualNat afterNat hactualNat + have hactualNatEq : actualNat = natLit := + hactualNat.1 + subst actualNat + apply RecM.WF.bind <| RecM.WF.liftTcM <| + TcM.intern_whnf_wf collision hresult + intro actualResult afterResult hactualResult + have hactualResultEq : actualResult = result := + hactualResult.1 + subst actualResult + exact RecM.WF.pure fun _ => hresult + | var | fvar | sort | const | app | lam | all | letE | prj | + nat => + simp only + exact RecM.WF.pure fun _ => trivial + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + simp only [pure_bind] + exact RecM.WF.pure fun _ => trivial + +/-- Complete optional-reducer field: operational closure comes from the +finite generated-node support, while only a successful hit consults the +String Theory reflection boundary. -/ +theorem tryReduceString_optional_wf_of_reflection + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (collision : support.CollisionFree) + (generated : StringReductionSupport support) + (reflection : StringReductionReflection semantics trProj world support) : + OptionalReduction.WF .noAccel semantics trProj world support + tryReduceString := by + intro uvars Delta source sourceV s hsourceSupport hsource + have hstate := + tryReduceString_inv_wf (semantics := semantics) (trProj := trProj) + (world := world) collision generated + (uvars := uvars) (Delta := Delta) (s := s) hsourceSupport + intro methods hmethods hI + have hpost := hstate methods hmethods hI + match hrun : (tryReduceString source).run methods s with + | .error err sf => + rw [hrun] at hpost + exact ⟨hpost.1, trivial⟩ + | .ok none sf => + rw [hrun] at hpost + exact ⟨hpost.1, trivial⟩ + | .ok (some result) sf => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, + reflection.success hmethods hsourceSupport hsource hI hrun⟩ + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Projection/NoAccelTail.lean b/Ix/Tc/Verify/Whnf/Projection/NoAccelTail.lean new file mode 100644 index 000000000..31ecac194 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Projection/NoAccelTail.lean @@ -0,0 +1,270 @@ +import Ix.Tc.Verify.Whnf.Structural.VerifiedStep + +/-! +# Concrete no-acceleration projection tail + +`VerifiedStep` still exposes the whole production projection helper as one boundary. +This slice removes its non-String core: after preprocessing, `.noAccel` +forces the `Fin.val`/`Decidable.rec` acceleration probe to miss, lazy lookup +is handled by the actual `tryGetConst` state theorem, and a selected field is +proved supported from the finite spine-input closure. + +Only String-literal construction/normalization and the installed lazy-ingress +hook remain as explicit premises when the tail is composed below. +-/ + +namespace Ix.Tc +namespace RecM + +namespace WhnfCoreInputSupport + +/-- Every element returned by `collectSpine` is covered by the finite input +support. Non-applications have an empty spine; the application case is +exactly the `WhnfCoreInputSupport.app` field. -/ +theorem spineArg {support : RunSupport} + (hinputs : WhnfCoreInputSupport support) + {value head arg : KExpr .anon} {args : Array (KExpr .anon)} + (hvalue : support value) + (hspine : value.collectSpine = (head, args)) + (harg : arg ∈ args.toList) : + support arg := by + cases value with + | app f a info => + exact (hinputs.app hvalue hspine).2 arg harg + | var idx name info => simp [KExpr.collectSpine, KExpr.collectSpine.go] at hspine; rw [hspine.2] at harg; simp at harg + | fvar id name info => simp [KExpr.collectSpine, KExpr.collectSpine.go] at hspine; rw [hspine.2] at harg; simp at harg + | sort u info => simp [KExpr.collectSpine, KExpr.collectSpine.go] at hspine; rw [hspine.2] at harg; simp at harg + | const id us info => simp [KExpr.collectSpine, KExpr.collectSpine.go] at hspine; rw [hspine.2] at harg; simp at harg + | lam name bi ty body info => simp [KExpr.collectSpine, KExpr.collectSpine.go] at hspine; rw [hspine.2] at harg; simp at harg + | all name bi ty body info => simp [KExpr.collectSpine, KExpr.collectSpine.go] at hspine; rw [hspine.2] at harg; simp at harg + | letE name ty value body nondep info => simp [KExpr.collectSpine, KExpr.collectSpine.go] at hspine; rw [hspine.2] at harg; simp at harg + | prj id field value info => simp [KExpr.collectSpine, KExpr.collectSpine.go] at hspine; rw [hspine.2] at harg; simp at harg + | nat value blob info => simp [KExpr.collectSpine, KExpr.collectSpine.go] at hspine; rw [hspine.2] at harg; simp at harg + | str value blob info => simp [KExpr.collectSpine, KExpr.collectSpine.go] at hspine; rw [hspine.2] at harg; simp at harg + +end WhnfCoreInputSupport + +/-- State and finite-result closure of the exact projection tail in the +production no-acceleration layer. -/ +theorem tryProjReduceTail_noAccel_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hinputs : WhnfCoreInputSupport support) + (hfault : ∀ uvars Delta, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {id : KId .anon} {field : UInt64} {value : KExpr .anon} + (hvalue : support value) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryProjReduceTail id field value) + (fun result _ => match result with + | none => True + | some reduced => support reduced) := by + intro methods hmethods + rcases hspine : value.collectSpine with ⟨head, args⟩ + unfold tryProjReduceTail + simp only [hspine] + rw [ReaderT.run_bind] + apply TcM.WF.bind (Q₁ := fun result _ => result = none) + · intro hI + rw [tryReduceFinValDecidableRec_noAccel hI.2.2.1] + exact ⟨hI, rfl⟩ + · intro result after hresult + subst result + simp only [ReaderT.run, pure_bind] + cases head with + | const ctorId us info => + simp only + change TcM.WF _ after (TcM.tryGetConst ctorId >>= _) _ + apply TcM.WF.bind + (TcM.tryGetConst_wf (hfault uvars Delta) ctorId after) + intro found afterLookup _ + cases found with + | none => exact TcM.WF.pure fun _ => trivial + | some decl => + cases decl <;> try exact TcM.WF.pure (fun _ => trivial) + case ctor name levelParams isUnsafe lvls induct cidx params fields ty => + cases hfield : args[params.toNat + field.toNat]? with + | none => + simp only [hfield] + exact TcM.WF.pure fun _ => trivial + | some selected => + simp only [hfield] + exact TcM.WF.pure fun _ => + hinputs.spineArg hvalue hspine + (Array.mem_toList_iff.mpr + (Array.mem_of_getElem? hfield)) + | _ => + simp only + exact TcM.WF.pure fun _ => trivial + +namespace ProjectionStringPrelude + +/-- The only projection prelude that is not state-pure. Its scope is +strictly smaller than `ProjectionHelper.WF`: it owns constructor expansion +and the one recursive WHNF callback, but no projection lookup or field +selection. -/ +structure WF (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Prop where + run : ∀ {uvars Delta s value blob info}, + support (.str value blob info) → + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryProjPrepare (.str value blob info)) + (fun result _ => support result) + +end ProjectionStringPrelude + +namespace ProjectionPrelude + +/-- State and finite-support closure of the named production preprocessing +seam. -/ +def WF (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Prop := + ∀ {uvars Delta s value}, + support value → + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryProjPrepare value) (fun prepared _ => support prepared) + +/-- Every non-String branch of the production prelude is definitionally +state-pure and returns its supported input unchanged. -/ +theorem nonString + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {value : KExpr .anon} + (hshape : match value with | .str .. => False | _ => True) + (hvalue : support value) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryProjPrepare value) (fun prepared _ => support prepared) := by + cases value with + | str value blob info => simp at hshape + | var idx name info => + rw [tryProjPrepare_eq] + exact RecM.WF.pure fun _ => hvalue + | fvar id name info => + rw [tryProjPrepare_eq] + exact RecM.WF.pure fun _ => hvalue + | sort u info => + rw [tryProjPrepare_eq] + exact RecM.WF.pure fun _ => hvalue + | const id us info => + rw [tryProjPrepare_eq] + exact RecM.WF.pure fun _ => hvalue + | app f arg info => + rw [tryProjPrepare_eq] + exact RecM.WF.pure fun _ => hvalue + | lam name bi ty body info => + rw [tryProjPrepare_eq] + exact RecM.WF.pure fun _ => hvalue + | all name bi ty body info => + rw [tryProjPrepare_eq] + exact RecM.WF.pure fun _ => hvalue + | letE name ty value body nondep info => + rw [tryProjPrepare_eq] + exact RecM.WF.pure fun _ => hvalue + | prj id field value info => + rw [tryProjPrepare_eq] + exact RecM.WF.pure fun _ => hvalue + | nat value blob info => + rw [tryProjPrepare_eq] + exact RecM.WF.pure fun _ => hvalue + +/-- The String case of the uniform prelude is exactly the separately named +effectful boundary. -/ +theorem string + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hstring : ProjectionStringPrelude.WF semantics trProj world support) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {value : String} {blob : Address} {info : ExprInfo .anon} + (hvalue : support (.str value blob info)) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryProjPrepare (.str value blob info)) + (fun prepared _ => support prepared) := + hstring.run hvalue + +/-- Assemble the uniform prelude from its only effectful String case. -/ +theorem ofString + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hstring : ProjectionStringPrelude.WF semantics trProj world support) : + ProjectionPrelude.WF semantics trProj world support := by + intro uvars Delta s value hvalue + cases value with + | str value blob info => exact string hstring hvalue + | var idx name info => exact nonString trivial hvalue + | fvar id name info => exact nonString trivial hvalue + | sort u info => exact nonString trivial hvalue + | const id us info => exact nonString trivial hvalue + | app f arg info => exact nonString trivial hvalue + | lam name bi ty body info => exact nonString trivial hvalue + | all name bi ty body info => exact nonString trivial hvalue + | letE name ty value body nondep info => exact nonString trivial hvalue + | prj id field value info => exact nonString trivial hvalue + | nat value blob info => exact nonString trivial hvalue + +end ProjectionPrelude + +/-- Compose the proved production tail with the named preprocessing seam in +`tryProjReduce`. -/ +theorem tryProjReduce_noAccel_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hinputs : WhnfCoreInputSupport support) + (hfault : ∀ uvars Delta, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (hprepare : ProjectionPrelude.WF semantics trProj world support) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {projId : KId .anon} {projField : UInt64} {value : KExpr .anon} + (hvalue : support value) : + RecM.WF .noAccel semantics trProj world support uvars Delta s + (tryProjReduce projId projField value) + (fun result _ => match result with + | none => True + | some reduced => support reduced) := by + rw [tryProjReduce_eq] + apply RecM.WF.bind (Q₁ := fun prepared _ => support prepared) + · exact hprepare hvalue + · intro prepared after hprepared + exact tryProjReduceTail_noAccel_wf hinputs hfault + (uvars := uvars) (Delta := Delta) (s := after) + (id := projId) (field := projField) hprepared + +namespace ProjectionHelper + +/- Concrete `.noAccel` projection-helper closure. The former monolithic +helper premise is reduced to String preprocessing plus the installed lazy +ingress contract. -/ +theorem noAccelOfPrelude + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hinputs : WhnfCoreInputSupport support) + (hfault : ∀ uvars Delta, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (hprepare : ProjectionPrelude.WF semantics trProj world support) : + ProjectionHelper.WF .noAccel semantics trProj world support := by + intro uvars Delta methods s id field value hmethods hvalue + exact tryProjReduce_noAccel_wf hinputs hfault hprepare + (uvars := uvars) (Delta := Delta) (s := s) (projId := id) + (projField := field) hvalue methods hmethods + +/-- Public concrete projection-helper constructor: all non-String control +flow is proved, so only String preprocessing and lazy ingress are supplied. -/ +theorem noAccel + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hinputs : WhnfCoreInputSupport support) + (hfault : ∀ uvars Delta, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (hstring : ProjectionStringPrelude.WF semantics trProj world support) : + ProjectionHelper.WF .noAccel semantics trProj world support := + noAccelOfPrelude hinputs hfault (ProjectionPrelude.ofString hstring) + +end ProjectionHelper + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Projection/StringCallback.lean b/Ix/Tc/Verify/Whnf/Projection/StringCallback.lean new file mode 100644 index 000000000..eab362128 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Projection/StringCallback.lean @@ -0,0 +1,85 @@ +import Ix.Tc.Verify.Whnf.Projection.NoAccelTail + +/-! +# Projection String callback closure + +NoAccelTail proves every projection-helper operation after preprocessing. This +slice discharges the recursive callback inside String preprocessing from the +predecessor method table. The remaining String premise now owns only the +interned constructor expansion itself: finite support and structural +translation of the exact generated term. +-/ + +namespace Ix.Tc +namespace RecM + +attribute [local irreducible] whnfRec strLitToConstructor + +namespace ProjectionStringExpansion + +/-- Exact state/support/translation contract for production's generated +String constructor term, before the recursive WHNF callback. -/ +structure WF (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Prop where + run : ∀ {uvars Delta s value blob info}, + support (.str value blob info) → + RecM.WF .noAccel semantics trProj world support uvars Delta s + (strLitToConstructor value) + (fun expanded _ => + support expanded ∧ + ∃ expandedV, + TrKExprS world.venv uvars world.nameOf trProj Delta expanded + expandedV) + +end ProjectionStringExpansion + +namespace ProjectionStringPrelude + +/-- String expansion followed by the actual recursive full-WHNF callback +satisfies NoAccelTail's complete preprocessing contract. -/ +theorem ofExpansion + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hexpansion : ProjectionStringExpansion.WF semantics trProj world + support) : + ProjectionStringPrelude.WF semantics trProj world support where + run := by + intro uvars Delta s value blob info hvalue + rw [tryProjPrepare_eq] + apply RecM.WF.bind + (Q₁ := fun expanded _ => + support expanded ∧ + ∃ expandedV, + TrKExprS world.venv uvars world.nameOf trProj Delta expanded + expandedV) + (hexpansion.run hvalue) + intro expanded after hExpanded + obtain ⟨hSupport, expandedV, hTr⟩ := hExpanded + exact RecM.WF.mono + (whnfRec_wf (s := after) hSupport hTr) + (fun _ _ hPost => hPost.1) + (fun _ _ _ => trivial) + +end ProjectionStringPrelude + +namespace ProjectionHelper + +/-- Concrete `.noAccel` projection helper with only the exact String +constructor expansion and lazy-ingress refinements left as premises. -/ +theorem noAccelOfExpansion + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hinputs : WhnfCoreInputSupport support) + (hfault : ∀ uvars Delta, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (hexpansion : ProjectionStringExpansion.WF semantics trProj world + support) : + ProjectionHelper.WF .noAccel semantics trProj world support := + ProjectionHelper.noAccel hinputs hfault + (ProjectionStringPrelude.ofExpansion hexpansion) + +end ProjectionHelper + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Projection/StringExpansion.lean b/Ix/Tc/Verify/Whnf/Projection/StringExpansion.lean new file mode 100644 index 000000000..1cc3a1b50 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Projection/StringExpansion.lean @@ -0,0 +1,379 @@ +import Ix.Tc.Verify.Whnf.Projection.StringCallback + +/-! +# Finite String-constructor expansion plan + +StringCallback leaves only the interned String constructor expansion as a projection +premise. This slice proves that concrete effectful expansion from a pure, +finite plan: every exact intern request is supported, expression-address +collisions are excluded on the run domain, and the final generated term has +a structural Theory translation. +-/ + +namespace Ix.Tc +namespace RecM + +def stringCharConst (p : Primitives .anon) : KExpr .anon := + KExpr.mkConst p.charType #[] + +def stringCharOfNat (p : Primitives .anon) : KExpr .anon := + KExpr.mkConst p.charOfNat #[] + +def stringMkConst (p : Primitives .anon) : KExpr .anon := + KExpr.mkConst p.stringOfList #[] + +def stringListNilZero (p : Primitives .anon) : KExpr .anon := + KExpr.mkConst p.listNil #[KUniv.mkZero] + +def stringListNil (p : Primitives .anon) : KExpr .anon := + KExpr.mkApp (stringListNilZero p) (stringCharConst p) + +def stringListConsZero (p : Primitives .anon) : KExpr .anon := + KExpr.mkConst p.listCons #[KUniv.mkZero] + +def stringListCons (p : Primitives .anon) : KExpr .anon := + KExpr.mkApp (stringListConsZero p) (stringCharConst p) + +def stringCharNat (c : Char) : KExpr .anon := + natExprFromValue c.toNat + +def stringCharValue (charOfNat : KExpr .anon) (c : Char) : KExpr .anon := + KExpr.mkApp charOfNat (stringCharNat c) + +def stringConsPartial (cons charOfNat : KExpr .anon) + (c : Char) : KExpr .anon := + KExpr.mkApp cons (stringCharValue charOfNat c) + +def stringConsValue (cons charOfNat list : KExpr .anon) + (c : Char) : KExpr .anon := + KExpr.mkApp (stringConsPartial cons charOfNat c) list + +/-- The portion of String expansion determined by an already-read primitive +table. This is definitionally the body of production's +`strLitToConstructor`; naming it keeps the primitive-table read and the +finite intern transaction as separate proof layers. -/ +def strLitToConstructorWithPrimitives (p : Primitives .anon) + (value : String) : RecM .anon (KExpr .anon) := do + let charConst ← TcM.intern (stringCharConst p) + let charOfNat ← TcM.intern (stringCharOfNat p) + let stringMk ← TcM.intern (stringMkConst p) + let listNilZero ← TcM.intern (stringListNilZero p) + let nil ← TcM.intern (KExpr.mkApp listNilZero charConst) + let listConsZero ← TcM.intern (stringListConsZero p) + let cons ← TcM.intern (KExpr.mkApp listConsZero charConst) + let list ← strLitListToConstructor charOfNat cons value.toList.reverse nil + TcM.intern (KExpr.mkApp stringMk list) + +/-- One-layer equation used when verifying the named primitive-table +transaction. -/ +theorem strLitToConstructorWithPrimitives_eq + (p : Primitives .anon) (value : String) : + strLitToConstructorWithPrimitives p value = (do + let charConst ← TcM.intern (stringCharConst p) + let charOfNat ← TcM.intern (stringCharOfNat p) + let stringMk ← TcM.intern (stringMkConst p) + let listNilZero ← TcM.intern (stringListNilZero p) + let nil ← TcM.intern (KExpr.mkApp listNilZero charConst) + let listConsZero ← TcM.intern (stringListConsZero p) + let cons ← TcM.intern (KExpr.mkApp listConsZero charConst) + let list ← strLitListToConstructor charOfNat cons + value.toList.reverse nil + TcM.intern (KExpr.mkApp stringMk list)) := by + rfl + +/-- Stable one-layer equation for the production String expander. Keeping +this equation explicit lets the proof unfold exactly this transaction without +asking the elaborator to reduce `strLitToConstructor` through every later +WHNF contract that mentions it. -/ +theorem strLitToConstructor_eq (value : String) : + strLitToConstructor value = (do + let p ← prims + strLitToConstructorWithPrimitives p value) := by + rfl + +attribute [local irreducible] strLitToConstructor + strLitToConstructorWithPrimitives + +/-- Pure finite certificate for the recursive character fold. The result +index is the exact list term returned after all characters are consumed. -/ +inductive StringListPlan (support : RunSupport) + (charOfNat cons : KExpr .anon) : + List Char → KExpr .anon → KExpr .anon → Prop + | nil {list} (hlist : support list) : + StringListPlan support charOfNat cons [] list list + | cons {c chars list result} + (hnat : support (stringCharNat c)) + (hchar : support (stringCharValue charOfNat c)) + (hpartial : support (stringConsPartial cons charOfNat c)) + (hnext : support (stringConsValue cons charOfNat list c)) + (tail : StringListPlan support charOfNat cons chars + (stringConsValue cons charOfNat list c) result) : + StringListPlan support charOfNat cons (c :: chars) list result + +/-- The actual recursive String-list builder executes any finite pure plan, +returning its exact result and preserving the complete K1 invariant. -/ +theorem strLitListToConstructor_plan_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hcollision : support.CollisionFree) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {charOfNat cons list result : KExpr .anon} {chars : List Char} + (plan : StringListPlan support charOfNat cons chars list result) : + RecM.WF layer semantics trProj world support uvars Delta s + (strLitListToConstructor charOfNat cons chars list) + (fun actual _ => actual = result ∧ support actual) := by + induction plan generalizing s with + | nil hlist => + rw [strLitListToConstructor] + exact RecM.WF.pure fun _ => ⟨rfl, hlist⟩ + | cons hnat hchar hpartial hnext tail ih => + rw [strLitListToConstructor] + refine RecM.WF.bind + (RecM.WF.liftTcM <| TcM.intern_whnf_wf hcollision hnat) ?_ + intro natLit s1 hNat + rcases hNat with ⟨rfl, _⟩ + refine RecM.WF.bind + (RecM.WF.liftTcM <| TcM.intern_whnf_wf hcollision hchar) ?_ + intro charValue s2 hChar + rcases hChar with ⟨rfl, _⟩ + refine RecM.WF.bind + (RecM.WF.liftTcM <| TcM.intern_whnf_wf hcollision hpartial) ?_ + intro partialApp s3 hPartial + rcases hPartial with ⟨rfl, _⟩ + refine RecM.WF.bind + (RecM.WF.liftTcM <| TcM.intern_whnf_wf hcollision hnext) ?_ + intro next s4 hNext + rcases hNext with ⟨rfl, _⟩ + exact ih (s := s4) + +/-- Complete finite plan for one String literal under one primitive table. -/ +structure StringExpansionPlan (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (p : Primitives .anon) (value : String) where + list : KExpr .anon + charConst : support (stringCharConst p) + charOfNat : support (stringCharOfNat p) + stringMk : support (stringMkConst p) + listNilZero : support (stringListNilZero p) + nil : support (stringListNil p) + listConsZero : support (stringListConsZero p) + cons : support (stringListCons p) + chars : StringListPlan support (stringCharOfNat p) (stringListCons p) + value.toList.reverse (stringListNil p) list + final : support (KExpr.mkApp (stringMkConst p) list) + translation : ∀ uvars Delta, + ∃ expandedV, + TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.mkApp (stringMkConst p) list) expandedV + +/-- The already-read primitive-table transaction executes the exact finite +plan, including all seven prefix interns, the recursive character fold, and +the final `String.ofList` application. This stronger form retains the exact +concrete result so semantic clients can attach a specific translation rather +than merely an existential one. -/ +theorem strLitToConstructorWithPrimitives_plan_exact_wf + {layer : WhnfLayer} {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hcollision : support.CollisionFree) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {p : Primitives .anon} {value : String} + (plan : StringExpansionPlan trProj world support p value) : + RecM.WF layer semantics trProj world support uvars Delta s + (strLitToConstructorWithPrimitives p value) + (fun expanded _ => + expanded = KExpr.mkApp (stringMkConst p) plan.list ∧ + support expanded ∧ + ∃ expandedV, + TrKExprS world.venv uvars world.nameOf trProj Delta expanded + expandedV) := by + intro methods hmethods hI + obtain ⟨s1, hCharConst, hI1, _⟩ := + TcM.intern_whnf_eval hcollision plan.charConst hI + obtain ⟨s2, hCharOfNat, hI2, _⟩ := + TcM.intern_whnf_eval hcollision plan.charOfNat hI1 + obtain ⟨s3, hStringMk, hI3, _⟩ := + TcM.intern_whnf_eval hcollision plan.stringMk hI2 + obtain ⟨s4, hListNilZero, hI4, _⟩ := + TcM.intern_whnf_eval hcollision plan.listNilZero hI3 + obtain ⟨s5, hNil, hI5, _⟩ := + TcM.intern_whnf_eval hcollision plan.nil hI4 + obtain ⟨s6, hListConsZero, hI6, _⟩ := + TcM.intern_whnf_eval hcollision plan.listConsZero hI5 + obtain ⟨s7, hCons, hI7, _⟩ := + TcM.intern_whnf_eval hcollision plan.cons hI6 + obtain ⟨actualList, s8, hList, _⟩ := + strLitListToConstructor_success_frame methods value.toList.reverse + (stringCharOfNat p) (stringListCons p) (stringListNil p) s7 + have hListPost := + strLitListToConstructor_plan_wf hcollision (s := s7) plan.chars + methods hmethods hI7 + rw [hList] at hListPost + rcases hListPost with ⟨hI8, hActualList, _⟩ + subst actualList + obtain ⟨s9, hFinal, hI9, _⟩ := + TcM.intern_whnf_eval hcollision plan.final hI8 + have hrun : + (strLitToConstructorWithPrimitives p value).run methods s = + .ok (KExpr.mkApp (stringMkConst p) plan.list) s9 := by + rw [strLitToConstructorWithPrimitives_eq] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (stringCharConst p)) _ s = _ + unfold EStateM.bind + rw [hCharConst] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (stringCharOfNat p)) _ s1 = _ + unfold EStateM.bind + rw [hCharOfNat] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (stringMkConst p)) _ s2 = _ + unfold EStateM.bind + rw [hStringMk] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (stringListNilZero p)) _ s3 = _ + unfold EStateM.bind + rw [hListNilZero] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (stringListNil p)) _ s4 = _ + unfold EStateM.bind + rw [hNil] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (stringListConsZero p)) _ s5 = _ + unfold EStateM.bind + rw [hListConsZero] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.intern (stringListCons p)) _ s6 = _ + unfold EStateM.bind + rw [hCons] + simp only + rw [ReaderT.run_bind] + change EStateM.bind + (ReaderT.run + (strLitListToConstructor (stringCharOfNat p) (stringListCons p) + value.toList.reverse (stringListNil p)) methods) _ s7 = _ + unfold EStateM.bind + rw [hList] + simp only + rw [ReaderT.run_monadLift] + exact hFinal + rw [hrun] + exact ⟨hI9, rfl, plan.final, plan.translation uvars Delta⟩ + +/-- Compatibility form used by K1 callers that need only support and some +structural translation of the generated constructor term. -/ +theorem strLitToConstructorWithPrimitives_plan_wf + {layer : WhnfLayer} {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hcollision : support.CollisionFree) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {p : Primitives .anon} {value : String} + (plan : StringExpansionPlan trProj world support p value) : + RecM.WF layer semantics trProj world support uvars Delta s + (strLitToConstructorWithPrimitives p value) + (fun expanded _ => + support expanded ∧ + ∃ expandedV, + TrKExprS world.venv uvars world.nameOf trProj Delta expanded + expandedV) := by + apply RecM.WF.mono + (strLitToConstructorWithPrimitives_plan_exact_wf hcollision plan) + · intro expanded after hpost + exact ⟨hpost.2.1, hpost.2.2⟩ + · intro _ _ _ + trivial + +/-- Exact production String expansion, including the primitive-table read. -/ +theorem strLitToConstructor_plan_exact_wf + {layer : WhnfLayer} {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hcollision : support.CollisionFree) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} {value : String} + (plan : StringExpansionPlan trProj world support s.prims value) : + RecM.WF layer semantics trProj world support uvars Delta s + (strLitToConstructor value) + (fun expanded _ => + expanded = KExpr.mkApp (stringMkConst s.prims) plan.list ∧ + support expanded ∧ + ∃ expandedV, + TrKExprS world.venv uvars world.nameOf trProj Delta expanded + expandedV) := by + rw [strLitToConstructor_eq] + apply RecM.WF.bind + (Q₁ := fun p after => p = s.prims ∧ after = s) + (prims_wf (s := s)) + intro p after hread + rcases hread with ⟨rfl, rfl⟩ + exact strLitToConstructorWithPrimitives_plan_exact_wf hcollision plan + +/-- Production's full `strLitToConstructor` transaction first reads the +primitive table without changing state and then executes the certified finite +intern transaction above. -/ +theorem strLitToConstructor_plan_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hcollision : support.CollisionFree) + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} {value : String} + (plan : StringExpansionPlan trProj world support s.prims value) : + RecM.WF layer semantics trProj world support uvars Delta s + (strLitToConstructor value) + (fun expanded _ => + support expanded ∧ + ∃ expandedV, + TrKExprS world.venv uvars world.nameOf trProj Delta expanded + expandedV) := by + rw [strLitToConstructor_eq] + refine RecM.WF.bind + (Q₁ := fun p after => p = s.prims ∧ after = s) + (prims_wf (s := s)) ?_ + rintro p after ⟨rfl, rfl⟩ + exact strLitToConstructorWithPrimitives_plan_wf hcollision plan + +/-- Run-scoped pure inputs for every canonical production primitive table. -/ +structure ProjectionStringPlanContext (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) where + collisionFree : support.CollisionFree + plan : ∀ p, p.CanonicalAnon → ∀ value, + StringExpansionPlan trProj world support p value + +namespace ProjectionStringExpansion + +/-- Pure finite plans construct StringCallback's exact effectful expansion contract. -/ +theorem ofPlans + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : ProjectionStringPlanContext trProj world support) : + ProjectionStringExpansion.WF semantics trProj world support where + run := by + intro uvars Delta s value blob info hvalue methods hmethods hI + have plan := context.plan s.prims hI.noAccel_primitives value + exact strLitToConstructor_plan_wf context.collisionFree plan methods + hmethods hI + +end ProjectionStringExpansion + +namespace ProjectionHelper + +/-- Projection-helper closure from pure String generation data plus the +remaining concrete lazy-ingress refinement. -/ +theorem noAccelOfStringPlans + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hinputs : WhnfCoreInputSupport support) + (hfault : ∀ uvars Delta, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (context : ProjectionStringPlanContext trProj world support) : + ProjectionHelper.WF .noAccel semantics trProj world support := + ProjectionHelper.noAccelOfExpansion hinputs hfault + (ProjectionStringExpansion.ofPlans context) + +end ProjectionHelper + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/README.md b/Ix/Tc/Verify/Whnf/README.md new file mode 100644 index 000000000..5a8806528 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/README.md @@ -0,0 +1,33 @@ +# WHNF verification modules + +The WHNF formalization is organized by proof responsibility rather than by +project milestone. The directories are conceptual layers; imports retain the +precise proof-dependency order needed by Lean. + +- `RuntimeContracts.lean` defines the common state, callback, and result + contracts used by the reducer proofs. +- `Iota/` verifies rule recognition and selection, literal preprocessing, + substitution, constructor synthesis, request closure, and optional iota + reduction. +- `StructEta/` verifies scoped recursion classification and structure-eta + rebuilding. +- `Structural/` verifies the cache shell and the structural reducer's variable, + projection, application, and beta-dispatch branches. +- `Beta/` gives the constructive semantics of general multi-argument beta + reduction. +- `Projection/` verifies projection and string-expansion callbacks used by the + no-acceleration path. +- `Runtime/` connects the generic callback contracts to anonymous lazy + ingress. +- `NoDelta/` assembles all active outer reductions that do not unfold + definitions. +- `Driver/` verifies the full-WHNF step and public reducer entry points, + including the explicit contract boundary for the compact symbolic-Nat + guard. +- `Delta/` verifies trusted unfolding, cache semantics, spine rebuilding, and + optional delta reduction. +- `Closure.lean` assembles the four fixed-universe WHNF contracts and records + the boundary with the later `infer`/`isDefEq` closure work. + +The foundational semantic definitions remain in the sibling module +`Ix.Tc.Verify.Whnf` (`../Whnf.lean`). diff --git a/Ix/Tc/Verify/Whnf/Runtime/LazyIngress.lean b/Ix/Tc/Verify/Whnf/Runtime/LazyIngress.lean new file mode 100644 index 000000000..568254423 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Runtime/LazyIngress.lean @@ -0,0 +1,327 @@ +import Ix.Tc.Verify.Whnf.Projection.StringExpansion +import Ix.Tc.Ingress + +/-! +# Concrete anonymous lazy-ingress refinement + +`RuntimeContracts` proves the generic state-on-error plumbing for an arbitrary callback +stored in `TcState.lazyFault`. Its type cannot establish that the callback +agrees with the immutable catalog, preserves finite intern support, or leaves +semantic caches untouched. + +This slice names that missing driver boundary for the actual +`ingressAnonAddrShallow` function. The refinement is deliberately +outcome-exhaustive: `ok false` (absent input), `ok true` (successful ingress), +and `error` (with its partial environment) all carry the same environment +frame. A separate installed-hook premise identifies the otherwise arbitrary +function stored in `TcState`. +-/ + +namespace Ix.Tc + +/-- Exact environment facts needed after one lazy-ingress callback. + +Constants and blocks may grow and the intern table may grow. The new loaded +map must still agree with the immutable catalog; intern coherence and the +run's finite support must be re-established. Semantic caches may not acquire +new entries, and the fvar mint counter must remain fixed so the current local +context stays reconciled. -/ +structure LazyIngressEnvFrame (world : VerifyWorld) (support : RunSupport) + (before after : KEnv .anon) : Prop where + loaded : LoadedAgrees world.catalog after + intern : after.intern.WF + internSupport : support.CoversIntern after.intern + cacheBack : ∀ {entry}, after.HasCacheEntry entry → + before.HasCacheEntry entry + nextFVarId : after.nextFVarId = before.nextFVarId + +namespace LazyIngressEnvFrame + +/-- No environment change is a valid ingress frame. -/ +theorem refl + {world : VerifyWorld} {support : RunSupport} {env : KEnv .anon} + (hloaded : LoadedAgrees world.catalog env) + (hintern : env.intern.WF) + (hcover : support.CoversIntern env.intern) : + LazyIngressEnvFrame world support env env where + loaded := hloaded + intern := hintern + internSupport := hcover + cacheBack := fun h => h + nextFVarId := rfl + +/-- The environment frame preserves the complete fixed-world kernel +invariant. In particular, cache validity is inherited only after proving +that every post-ingress physical entry was already present before ingress. -/ +theorem kernelStateWF + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {before after : KEnv .anon} + (frame : LazyIngressEnvFrame world support before after) + {s : TcState .anon} + (h : KernelStateWF semantics trProj world support s) + (hbefore : s.env = before) : + KernelStateWF semantics trProj world support {s with env := after} := by + subst before + exact { + core := { + trustedCatalog := h.core.trustedCatalog + loaded := frame.loaded + intern := frame.intern + } + internSupport := frame.internSupport + caches := fun {_} hentry => h.caches (frame.cacheBack hentry) + equivalences := h.equivalences + } + +/-- Changing the ingress-owned environment fields leaves the dual concrete +context reconciled. Only `nextFVarId` is observed by `CtxRecon`. -/ +theorem ctxRecon + {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {trProj : RawProjRel} {Delta : KVLCtx} + {s : TcState .anon} {after : KEnv .anon} {addr : Address} + (frame : LazyIngressEnvFrame world support s.env after) + (h : CtxRecon world.venv uvars world.nameOf trProj s Delta) : + CtxRecon world.venv uvars world.nameOf trProj + (TcM.lazyIngressPost s addr after) Delta := by + refine { + size_eq := ?_ + recon := ?_ + lwf := ?_ + incr := ?_ + fresh := ?_ + lets := ?_ + } + · simpa [TcM.lazyIngressPost] using h.size_eq + · simpa [TcM.lazyIngressPost] using h.recon + · simpa [TcM.lazyIngressPost] using h.lwf + · simpa [TcM.lazyIngressPost] using h.incr + · intro p hp + have hold := h.fresh p (by + simpa [TcM.lazyIngressPost] using hp) + simpa [TcM.lazyIngressPost, frame.nextFVarId] using hold + · simpa [TcM.lazyIngressPost] using h.lets + +/-- One callback outcome preserves the entire K1 invariant, including the +address mark retained by production on both success and failure. -/ +theorem whnfStateInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + {s : TcState .anon} {after : KEnv .anon} {addr : Address} + (frame : LazyIngressEnvFrame world support s.env after) + (h : WhnfStateInv layer semantics trProj world support uvars Delta s) : + WhnfStateInv layer semantics trProj world support uvars Delta + (TcM.lazyIngressPost s addr after) := by + refine ⟨?_, frame.ctxRecon h.2.1, ?_⟩ + · exact { + core := { + trustedCatalog := h.1.core.trustedCatalog + loaded := frame.loaded + intern := frame.intern + } + internSupport := frame.internSupport + caches := fun {_} hentry => h.1.caches (frame.cacheBack hentry) + equivalences := by + simpa [TcM.lazyIngressPost] using h.1.equivalences + } + · cases layer <;> + simpa [TcM.lazyIngressPost, WhnfLayer.StateOK] using h.2.2 + +end LazyIngressEnvFrame + +/-- A verified top-level miss is production's exact absent-address outcome: +no conversion, interning, block registration, or partial mutation occurs. -/ +theorem ingressAnonAddrShallow_absent + (ixonEnv : Ixon.Env) (addr : Address) (verify : Bool) + (before : KEnv .anon) + (hget : getConstVerified ixonEnv addr verify = .ok none) : + ingressAnonAddrShallow ixonEnv addr verify before = .ok false before := by + unfold ingressAnonAddrShallow + simp [IngressM.liftExcept, hget] + rfl + +/-- Driver-facing refinement of the actual anonymous shallow-ingress +transaction. + +This is an input/environment relation, not an axiom and not a consequence of +the callback's function type. A proof may be constructed from Ixon +materialization/catalog agreement and a finite support census for every node +interned while converting the selected constant or mutual block. -/ +structure AnonIngressRefinement (ixonEnv : Ixon.Env) (verify : Bool) + (world : VerifyWorld) (support : RunSupport) : Prop where + outcome : ∀ {before : KEnv .anon} {addr : Address}, + LoadedAgrees world.catalog before → + before.intern.WF → + support.CoversIntern before.intern → + match ingressAnonAddrShallow ixonEnv addr verify before with + | .ok _ after => LazyIngressEnvFrame world support before after + | .error _ after => LazyIngressEnvFrame world support before after + +namespace AnonIngressRefinement + +theorem ok + {ixonEnv : Ixon.Env} {verify : Bool} + {world : VerifyWorld} {support : RunSupport} + (refinement : AnonIngressRefinement ixonEnv verify world support) + {before after : KEnv .anon} {addr : Address} {found : Bool} + (hloaded : LoadedAgrees world.catalog before) + (hintern : before.intern.WF) + (hcover : support.CoversIntern before.intern) + (hrun : ingressAnonAddrShallow ixonEnv addr verify before = + .ok found after) : + LazyIngressEnvFrame world support before after := by + have h := refinement.outcome (addr := addr) hloaded hintern hcover + rw [hrun] at h + exact h + +/-- The absent-address result is an explicit specialization of the successful +outcome, rather than being conflated with an ingress error. -/ +theorem absent + {ixonEnv : Ixon.Env} {verify : Bool} + {world : VerifyWorld} {support : RunSupport} + (refinement : AnonIngressRefinement ixonEnv verify world support) + {before after : KEnv .anon} {addr : Address} + (hloaded : LoadedAgrees world.catalog before) + (hintern : before.intern.WF) + (hcover : support.CoversIntern before.intern) + (hrun : ingressAnonAddrShallow ixonEnv addr verify before = + .ok false after) : + LazyIngressEnvFrame world support before after := + refinement.ok hloaded hintern hcover hrun + +/-- Construct the absent-address frame directly from the verified Ixon miss, +without appealing to the general ingress refinement. -/ +theorem absentOfVerifiedMiss + {ixonEnv : Ixon.Env} {verify : Bool} + {world : VerifyWorld} {support : RunSupport} + {before : KEnv .anon} {addr : Address} + (hloaded : LoadedAgrees world.catalog before) + (hintern : before.intern.WF) + (hcover : support.CoversIntern before.intern) + (hget : getConstVerified ixonEnv addr verify = .ok none) : + ingressAnonAddrShallow ixonEnv addr verify before = .ok false before ∧ + LazyIngressEnvFrame world support before before := + ⟨ingressAnonAddrShallow_absent ixonEnv addr verify before hget, + LazyIngressEnvFrame.refl hloaded hintern hcover⟩ + +/-- An ingress error carries the callback's partial post-environment. The +same frame is required there; no rollback is assumed. -/ +theorem error + {ixonEnv : Ixon.Env} {verify : Bool} + {world : VerifyWorld} {support : RunSupport} + (refinement : AnonIngressRefinement ixonEnv verify world support) + {before after : KEnv .anon} {addr : Address} {err : IngressErr} + (hloaded : LoadedAgrees world.catalog before) + (hintern : before.intern.WF) + (hcover : support.CoversIntern before.intern) + (hrun : ingressAnonAddrShallow ixonEnv addr verify before = + .error err after) : + LazyIngressEnvFrame world support before after := by + have h := refinement.outcome (addr := addr) hloaded hintern hcover + rw [hrun] at h + exact h + +/-- Instantiate the generic hook contract from `RuntimeContracts` with the +actual anonymous shallow-ingress function. `hinstalled` is essential: +`WhnfStateInv` does not otherwise constrain the arbitrary function stored in +`lazyFault`. -/ +theorem lazyFaultPreserves + {ixonEnv : Ixon.Env} {verify : Bool} + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + (refinement : AnonIngressRefinement ixonEnv verify world support) + (hinstalled : ∀ {s : TcState .anon} + {fault : Address → EStateM String (KEnv .anon) Bool}, + WhnfStateInv layer semantics trProj world support uvars Delta s → + s.lazyFault = some fault → + fault = fun addr => ingressAnonAddrShallow ixonEnv addr verify) : + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) := by + intro s fault addr hlazy hI + have hfault := hinstalled hI hlazy + subst fault + change + match ingressAnonAddrShallow ixonEnv addr verify s.env with + | .ok _ after => + WhnfStateInv layer semantics trProj world support uvars Delta + (TcM.lazyIngressPost s addr after) + | .error _ after => + WhnfStateInv layer semantics trProj world support uvars Delta + (TcM.lazyIngressPost s addr after) + cases hrun : + ingressAnonAddrShallow ixonEnv addr verify s.env with + | ok found after => + have frame := refinement.ok hI.1.core.loaded hI.1.core.intern + hI.1.internSupport hrun + simpa using frame.whnfStateInv hI + | error err after => + have frame := refinement.error hI.1.core.loaded hI.1.core.intern + hI.1.internSupport hrun + simpa using frame.whnfStateInv hI + +end AnonIngressRefinement + +/-- A driver-owned installation of the concrete anonymous shallow-ingress +hook. Packaging the Ixon environment and verification mode existentially +keeps reducer contexts independent of those runtime parameters while ruling +out an arbitrary function of the same `lazyFault` type. -/ +structure AnonLazyIngressContext (layer : WhnfLayer) + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : Type where + ixonEnv : Ixon.Env + verify : Bool + refinement : AnonIngressRefinement ixonEnv verify world support + installed : ∀ {uvars : Nat} {Delta : KVLCtx} + {s : TcState .anon} + {fault : Address → EStateM String (KEnv .anon) Bool}, + WhnfStateInv layer semantics trProj world support uvars Delta s → + s.lazyFault = some fault → + fault = fun addr => ingressAnonAddrShallow ixonEnv addr verify + +namespace AnonLazyIngressContext + +/-- The installed production hook preserves the complete fixed-world +invariant for every universe count and local context used by the driver. -/ +theorem preserves + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (context : AnonLazyIngressContext layer semantics trProj world support) + {uvars : Nat} {Delta : KVLCtx} : + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) := + context.refinement.lazyFaultPreserves + (context.installed (uvars := uvars) (Delta := Delta)) + +end AnonLazyIngressContext + +namespace RecM.ProjectionHelper + +/-- The concrete `.noAccel` projection helper for an anonymous driver hook. +The String-constructor transaction is supplied by StringExpansion's finite plans; this +slice supplies the exact shallow-ingress callback on every state where a hook +is installed. -/ +theorem noAccelOfAnonIngress + {ixonEnv : Ixon.Env} {verify : Bool} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (hinputs : WhnfCoreInputSupport support) + (refinement : AnonIngressRefinement ixonEnv verify world support) + (hinstalled : ∀ {uvars : Nat} {Delta : KVLCtx} + {s : TcState .anon} + {fault : Address → EStateM String (KEnv .anon) Bool}, + WhnfStateInv .noAccel semantics trProj world support uvars Delta s → + s.lazyFault = some fault → + fault = fun addr => ingressAnonAddrShallow ixonEnv addr verify) + (strings : ProjectionStringPlanContext trProj world support) : + ProjectionHelper.WF .noAccel semantics trProj world support := + ProjectionHelper.noAccelOfStringPlans hinputs + (fun uvars Delta => + refinement.lazyFaultPreserves + (hinstalled (uvars := uvars) (Delta := Delta))) + strings + +end RecM.ProjectionHelper + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/RuntimeContracts.lean b/Ix/Tc/Verify/Whnf/RuntimeContracts.lean new file mode 100644 index 000000000..40c989a67 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/RuntimeContracts.lean @@ -0,0 +1,437 @@ +import Ix.Tc.Verify.Whnf + +/-! +# Closing the remaining WHNF runtime contracts + +This module discharges the state-safety side of the transient-Nat cache probe +for eagerly ingressed states and exposes the strictly smaller lazy-ingress +obligation needed by the same proof in driver-backed states. +-/ + +namespace Ix.Tc + +namespace TcM + +@[simp] theorem pure_apply (a : α) (s : TcState m) : + (pure a : TcM m α) s = .ok a s := rfl + +/-- The exact post-state installed after invoking a lazy-ingress hook. The +address is marked before the hook runs, and the hook's returned environment +is retained on both success and error, matching `TcM.lazyIngressAddr`. -/ +def lazyIngressPost (s : TcState .anon) (addr : Address) + (env : KEnv .anon) : TcState .anon := + { { s with faultedAddrs := s.faultedAddrs.insert addr } with env } + +/-- Semantic contract for the driver-owned lazy-ingress hook. + +The hook is an arbitrary function stored in `TcState`; its type alone says +nothing about catalog agreement, intern support, cache provenance, or context +reconciliation. This contract therefore requires the caller's invariant in +the exact environment-carrying post-state on both hook outcomes. It is a +named implementation-refinement obligation, not an assumption derived from +the presence of the hook. -/ +def LazyFaultPreserves (I : TcState .anon → Prop) : Prop := + ∀ {s : TcState .anon} + {fault : Address → EStateM String (KEnv .anon) Bool} {addr : Address}, + s.lazyFault = some fault → I s → + match fault addr s.env with + | .ok _ env' => I (lazyIngressPost s addr env') + | .error _ env' => I (lazyIngressPost s addr env') + +/-- The production deduplication/error behavior preserves any invariant whose +installed hook satisfies `LazyFaultPreserves`. In particular, the address +mark and the hook's partial environment survive an ingress error. -/ +theorem lazyIngressAddr_wf {I : TcState .anon → Prop} + (hfault : LazyFaultPreserves I) (addr : Address) (s : TcState .anon) : + TcM.WF I s (TcM.lazyIngressAddr addr) (fun _ _ => True) := by + intro hI + unfold TcM.lazyIngressAddr + cases hlazy : s.lazyFault with + | none => exact ⟨hI, trivial⟩ + | some fault => + cases hcontains : s.faultedAddrs.contains addr with + | true => simpa [hlazy, hcontains] using And.intro hI trivial + | false => + have hpost := hfault (addr := addr) hlazy hI + cases hrun : fault addr s.env with + | ok found env' => + rw [hrun] at hpost + simpa [hlazy, hcontains, lazyIngressPost, hrun] using + And.intro hpost trivial + | error err env' => + rw [hrun] at hpost + simpa [hlazy, hcontains, lazyIngressPost, hrun] using + And.intro hpost trivial + +/-- Constant lookup preserves the invariant through the real fast hit, +lazy-fault, retry, post-fault miss, and hook-error paths. -/ +theorem tryGetConst_wf {I : TcState .anon → Prop} + (hfault : LazyFaultPreserves I) (id : KId .anon) (s : TcState .anon) : + TcM.WF I s (TcM.tryGetConst id) (fun _ _ => True) := by + unfold TcM.tryGetConst + apply TcM.WF.bind + (Q₁ := fun read after => read = after) + (TcM.WF.get fun _ => rfl) + intro read before hread + subst read + split + · exact TcM.WF.pure fun _ => trivial + · apply TcM.WF.bind + (Q₁ := fun read after => read = after) + (TcM.WF.get fun _ => rfl) + intro read beforeFault hread + subst read + apply TcM.WF.bind + (Q₁ := fun _ _ => True) + (lazyIngressAddr_wf hfault id.addr beforeFault) + intro _ afterFault _ + apply TcM.WF.bind + (Q₁ := fun read after => read = after) + (TcM.WF.get fun _ => rfl) + intro read after hread + subst read + split + · exact TcM.WF.pure fun _ => trivial + · split + · exact TcM.WF.throw fun _ => trivial + · exact TcM.WF.pure fun _ => trivial + +/-- An invariant-indexed proof that lazy ingress is absent is a vacuous +instance of the general hook contract. -/ +theorem LazyFaultPreserves.of_none {I : TcState .anon → Prop} + (hnoLazy : ∀ {s}, I s → s.lazyFault = none) : + LazyFaultPreserves I := by + intro s fault addr hlazy hI + rw [hnoLazy hI] at hlazy + contradiction + +/-- Without a lazy ingress hook, constant lookup is a state-pure optional +read, including the miss case. -/ +theorem tryGetConst_noLazy {id : KId .anon} {s : TcState .anon} + (hlazy : s.lazyFault = none) : + TcM.tryGetConst id s = .ok (s.env.get? id) s := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only + cases hget : s.env.get? id with + | some c => rfl + | none => + simp only [pure_bind] + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only [hlazy, Option.isSome_none, Bool.false_eq_true, ↓reduceIte] + change EStateM.bind (TcM.lazyIngressAddr id.addr) _ s = _ + unfold EStateM.bind TcM.lazyIngressAddr + rw [hlazy] + simp only + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp [hget] + +end TcM + +namespace RecM + +@[simp] theorem prims_run (methods : Methods m) (s : TcState m) : + (RecM.prims : RecM m (Primitives m)).run methods s = .ok s.prims s := rfl + +/-! ### Linear Nat descriptor ingress -/ + +/-- The concrete descriptor lookup used by the linear Nat recognizer +preserves an arbitrary invariant through fast lookup, lazy ingress success, +lazy ingress error, and post-ingress miss. On a hit it also retains the +exact application spine stored in the returned descriptor view. -/ +theorem natRecLiteralParts_wf {I : TcState .anon → Prop} + (hfault : TcM.LazyFaultPreserves I) (methods : Methods .anon) + (source : KExpr .anon) (s : TcState .anon) : + TcM.WF I s ((natRecLiteralParts source).run methods) + (fun result _ => NatRecLiteralPartsPost source result) := by + unfold natRecLiteralParts + rcases hcollect : source.collectSpine with ⟨head, spine⟩ + cases head <;> simp only + all_goals try exact TcM.WF.pure fun _ => trivial + case const id us info => + rw [ReaderT.run_bind] + apply TcM.WF.bind + (Q₁ := fun p after => p = after.prims) + · exact fun hI => ⟨hI, rfl⟩ + · intro p after hp + subst p + split + · exact TcM.WF.pure fun _ => trivial + · rw [ReaderT.run_bind] + apply TcM.WF.bind + (Q₁ := fun _ _ => True) + (TcM.tryGetConst_wf hfault id after) + intro found afterLookup _ + cases found with + | none => exact TcM.WF.pure fun _ => trivial + | some c => + cases c <;> simp only + all_goals try exact TcM.WF.pure fun _ => trivial + case recr name levelParams k isUnsafe lvls params indices motives + minors block memberIdx ty rules leanAll => + split + · exact TcM.WF.pure fun _ => trivial + · cases hmajor : + spine[(params.toNat + motives.toNat + minors.toNat + + indices.toNat)]? with + | none => exact TcM.WF.pure fun _ => trivial + | some majorExpr => + cases majorExpr <;> + try exact TcM.WF.pure fun _ => trivial + case nat major blob majorInfo => + apply TcM.WF.pure + intro _ + change source.collectSpine.2 = spine + exact congrArg Prod.snd hcollect + +namespace NatRecLiteralPartsPreserves + +/-- Package the generic lazy-hook theorem as the exact operational premise +consumed by `NatSuccLinearOracle.of_reflection`. -/ +theorem of_lazy + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (hfault : ∀ {uvars : Nat} {Delta : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) : + NatRecLiteralPartsPreserves layer semantics trProj world support := by + intro uvars Delta source s methods hmethods + exact natRecLiteralParts_wf (hfault (uvars := uvars) (Delta := Delta)) + methods source s + +/-- Eagerly ingressed states are the no-hook specialization of `of_lazy`. -/ +theorem eager + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + (hnoLazy : ∀ {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon}, + WhnfStateInv layer semantics trProj world support uvars Delta s → + s.lazyFault = none) : + NatRecLiteralPartsPreserves layer semantics trProj world support := + of_lazy fun {_ _} => TcM.LazyFaultPreserves.of_none hnoLazy + +end NatRecLiteralPartsPreserves + +/-- Driver-facing form of the uniform Nat field. The descriptor lookup's +whole-computation preservation premise is constructed from the exact lazy +hook contract, so callers state only the hook refinement plus the two honest +semantic boundaries: linear Nat.rec reflection and canonical Nat/Bool +result-shape separation. -/ +theorem tryReduceNatWithSuccMode_optional_wf_of_lazy_boundaries + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {flags : WhnfFlags} + (context : ∀ mode, + NoDeltaPrimitiveContext world support flags mode) + (hrun : RunAssumptions initial program requests support) + (theory : ∀ uvars, WhnfTheory trProj world uvars) + (writes : NatSuccStuckWriteOracle semantics world support) + (hfault : ∀ {uvars : Nat} {Delta : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars Delta)) + (reflection : NatSuccLinearReflection .noAccel semantics trProj world + support) + (shape : NatCollapseRequestCensus.NatBoolResultShapeSeparation world) + (mode : NatSuccMode) : + OptionalReduction.WF .noAccel semantics trProj world support + (fun source => tryReduceNatWithSuccMode source mode) := + tryReduceNatWithSuccMode_optional_wf_of_boundaries context hrun theory + writes (NatRecLiteralPartsPreserves.of_lazy hfault) reflection shape + mode + +/-- The inner recursor classifier preserves an arbitrary invariant through +its sole effectful operation, `tryGetConst`, provided the installed lazy hook +preserves that invariant. -/ +theorem isNatLiteralRecursorApp_wf {I : TcState .anon → Prop} + (hfault : TcM.LazyFaultPreserves I) (methods : Methods .anon) + (source : KExpr .anon) (s : TcState .anon) : + TcM.WF I s ((isNatLiteralRecursorApp source).run methods) + (fun _ _ => True) := by + unfold isNatLiteralRecursorApp + rcases hcollect : source.collectSpine with ⟨head, spine⟩ + cases head <;> simp only + all_goals try exact TcM.WF.pure fun _ => trivial + case const id us info => + rw [ReaderT.run_bind] + apply TcM.WF.bind + (Q₁ := fun p after => p = after.prims) + · exact fun hI => ⟨hI, rfl⟩ + · intro p after hp + subst p + split + · exact TcM.WF.pure fun _ => trivial + · rw [ReaderT.run_bind] + apply TcM.WF.bind + (Q₁ := fun _ _ => True) + (TcM.tryGetConst_wf hfault id after) + intro found after _ + cases found with + | none => exact TcM.WF.pure fun _ => trivial + | some c => + cases c <;> simp only + all_goals try exact TcM.WF.pure fun _ => trivial + case recr name levelParams k isUnsafe lvls params indices motives + minors block memberIdx ty rules leanAll => + cases spine[(params + motives + minors + indices).toNat]? + · exact TcM.WF.pure fun _ => trivial + · next major => + cases major <;> exact TcM.WF.pure fun _ => trivial + +/-- The complete transient-work classifier preserves the invariant across +both of its possible recursor lookups. The second lookup is reached only +through the production `Nat.succ` shape test, but uses the same lazy hook +contract as the first. -/ +theorem isTransientNatLiteralWork_wf {I : TcState .anon → Prop} + (hfault : TcM.LazyFaultPreserves I) (methods : Methods .anon) + (source : KExpr .anon) (s : TcState .anon) : + TcM.WF I s ((isTransientNatLiteralWork source).run methods) + (fun _ _ => True) := by + unfold isTransientNatLiteralWork + rw [ReaderT.run_bind] + apply TcM.WF.bind + (Q₁ := fun _ _ => True) + (isNatLiteralRecursorApp_wf hfault methods source s) + intro first after _ + cases first with + | true => exact TcM.WF.pure fun _ => trivial + | false => + simp only [Bool.false_eq_true, if_false] + rcases hcollect : source.collectSpine with ⟨head, args⟩ + cases head <;> simp only + all_goals try exact TcM.WF.pure fun _ => trivial + case const id us info => + simp only [pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + (Q₁ := fun p state => p = state.prims) + · exact fun hI => ⟨hI, rfl⟩ + · intro p state hp + subst p + split + · exact isNatLiteralRecursorApp_wf hfault methods args[0]! state + · exact TcM.WF.pure fun _ => trivial + +/-- The inner recursor classifier is likewise state-pure without lazy +ingress. -/ +theorem isNatLiteralRecursorApp_noLazy {methods : Methods .anon} + {source : KExpr .anon} {s : TcState .anon} + (hlazy : s.lazyFault = none) : + ∃ answer, (isNatLiteralRecursorApp source).run methods s = + .ok answer s := by + unfold isNatLiteralRecursorApp + rcases hcollect : source.collectSpine with ⟨head, spine⟩ + cases head <;> simp only + all_goals try exact ⟨false, rfl⟩ + case const id us info => + rw [ReaderT.run_bind] + change ∃ answer, EStateM.bind + ((RecM.prims : RecM .anon (Primitives .anon)).run methods) _ s = + .ok answer s + unfold EStateM.bind + rw [prims_run] + simp only + split + · exact ⟨false, rfl⟩ + · rw [ReaderT.run_bind] + change ∃ answer, EStateM.bind (TcM.tryGetConst id) _ s = + .ok answer s + unfold EStateM.bind + rw [TcM.tryGetConst_noLazy hlazy] + cases hconst : s.env.get? id with + | none => exact ⟨false, rfl⟩ + | some c => + cases c with + | defn => exact ⟨false, rfl⟩ + | axio => exact ⟨false, rfl⟩ + | quot => exact ⟨false, rfl⟩ + | indc => exact ⟨false, rfl⟩ + | ctor => exact ⟨false, rfl⟩ + | recr name levelParams k isUnsafe lvls params indices motives + minors block memberIdx ty rules leanAll => + simp only + cases hmajor : spine[(params + motives + minors + indices).toNat]? + · exact ⟨false, rfl⟩ + · next major => + cases major <;> + first | exact ⟨false, rfl⟩ | exact ⟨true, rfl⟩ + +/-- The transient classifier is state-pure when all constants have already +been ingressed. -/ +theorem isTransientNatLiteralWork_noLazy {methods : Methods .anon} + {source : KExpr .anon} {s : TcState .anon} + (hlazy : s.lazyFault = none) : + ∃ answer, (isTransientNatLiteralWork source).run methods s = + .ok answer s := by + obtain ⟨first, hfirst⟩ := isNatLiteralRecursorApp_noLazy + (methods := methods) (source := source) hlazy + unfold isTransientNatLiteralWork + rw [ReaderT.run_bind] + change ∃ answer, EStateM.bind + ((isNatLiteralRecursorApp source).run methods) _ s = .ok answer s + unfold EStateM.bind + rw [hfirst] + cases first with + | true => exact ⟨true, rfl⟩ + | false => + simp only [Bool.false_eq_true, if_false] + rcases hcollect : source.collectSpine with ⟨head, args⟩ + cases head <;> simp only + all_goals try exact ⟨false, rfl⟩ + case const id us info => + simp only [pure_bind] + rw [ReaderT.run_bind] + change ∃ answer, EStateM.bind + ((RecM.prims : RecM .anon (Primitives .anon)).run methods) _ s = + .ok answer s + unfold EStateM.bind + rw [prims_run] + simp only + split + · exact isNatLiteralRecursorApp_noLazy + (methods := methods) (source := args[0]!) hlazy + · exact ⟨false, rfl⟩ + +namespace TransientNatWork + +/-- General lazy-ingress closure of the transient probe. The formerly +opaque shell premise is reduced to the exact driver hook contract, including +the environment retained by a failing ingress. -/ +theorem preserving {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (source : KExpr .anon) : + TransientNatWork.WF layer semantics trProj world support uvars Delta + source := by + intro s methods hmethods + exact isTransientNatLiteralWork_wf hfault methods source s + +/-- Eagerly ingressed runs discharge the formerly opaque transient-probe +contract. The premise is deliberately invariant-indexed so callers cannot +use one initial `lazyFault = none` fact after an unrelated state mutation. -/ +theorem eager {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + (hnoLazy : ∀ {s}, + WhnfStateInv layer semantics trProj world support uvars Delta s → + s.lazyFault = none) (source : KExpr .anon) : + TransientNatWork.WF layer semantics trProj world support uvars Delta + source := by + intro s methods hmethods hI + obtain ⟨answer, hrun⟩ := isTransientNatLiteralWork_noLazy + (methods := methods) (source := source) (hnoLazy hI) + rw [hrun] + exact ⟨hI, trivial⟩ + +end TransientNatWork + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/StructEta/CallbackPrefix.lean b/Ix/Tc/Verify/Whnf/StructEta/CallbackPrefix.lean new file mode 100644 index 000000000..3283032cd --- /dev/null +++ b/Ix/Tc/Verify/Whnf/StructEta/CallbackPrefix.lean @@ -0,0 +1,223 @@ +import Ix.Tc.Verify.Whnf.StructEta.Rebuild + +/-! +# Struct-eta callback-prefix preservation + +The struct-eta control-flow trace crosses two inference back-edges under +`TcM.withInferOnly` and one WHNF back-edge, with all three errors caught as +optional misses. This slice first proves the reusable state-preservation +adapters for those exact production wrappers. The adapters preserve the +full fixed-world invariant on success and error; they do not claim that a +caught callback is state-pure. +-/ + +namespace Ix.Tc + +namespace TcM + +/-- Exact execution equation for the infer-only scope. The callback sees +`inferOnly = true`; the caller's previous flag is restored on both outcomes, +while every other callback mutation remains visible. -/ +theorem withInferOnly_eq (f : TcM .anon α) (s : TcState .anon) : + TcM.withInferOnly f s = + match f {s with inferOnly := true} with + | .ok a after => .ok a {after with inferOnly := s.inferOnly} + | .error err after => + .error err {after with inferOnly := s.inferOnly} := by + unfold TcM.withInferOnly + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only + change EStateM.bind + (modify (fun st : TcState .anon => {st with inferOnly := true}) : + TcM .anon PUnit) _ s = _ + unfold EStateM.bind + rw [show + (modify (fun st : TcState .anon => {st with inferOnly := true}) : + TcM .anon PUnit) s = .ok ⟨⟩ {s with inferOnly := true} from rfl] + simp only + unfold tryFinally + change EStateM.map (fun x : α × PUnit => x.1) + (tryFinally' f (fun _ => + (modify (fun st : TcState .anon => + {st with inferOnly := s.inferOnly}) : TcM .anon PUnit))) + {s with inferOnly := true} = _ + unfold EStateM.map tryFinally' EStateM.instMonadFinally + simp only + cases hrun : f {s with inferOnly := true} with + | ok a after => + simp only + rw [show + (modify (fun st : TcState .anon => + {st with inferOnly := s.inferOnly}) : TcM .anon PUnit) after = + .ok ⟨⟩ {after with inferOnly := s.inferOnly} from rfl] + | error err after => + simp only + rw [show + (modify (fun st : TcState .anon => + {st with inferOnly := s.inferOnly}) : TcM .anon PUnit) after = + .ok ⟨⟩ {after with inferOnly := s.inferOnly} from rfl] + +/-- Running a verified callback under production's infer-only scope +preserves the complete WHNF invariant. Success and error payloads are kept +state-independent because the wrapper restores one operational flag after +the callback has established its postcondition. -/ +theorem withInferOnly_whnf_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {f : TcM .anon α} {Q : α → Prop} {E : TcError .anon → Prop} + (hf : TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) + {s with inferOnly := true} f (fun a _ => Q a) (fun err _ => E err)) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.withInferOnly f) (fun a _ => Q a) (fun err _ => E err) := by + intro hI + have hEnabled : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with inferOnly := true} := + hI.of_semantic_fields_eq rfl rfl rfl rfl rfl rfl rfl rfl + have hcallback := hf hEnabled + rw [withInferOnly_eq] + cases hrun : f {s with inferOnly := true} with + | ok a after => + rw [hrun] at hcallback + exact ⟨hcallback.1.of_semantic_fields_eq rfl rfl rfl rfl rfl rfl rfl rfl, + hcallback.2⟩ + | error err after => + rw [hrun] at hcallback + exact ⟨hcallback.1.of_semantic_fields_eq rfl rfl rfl rfl rfl rfl rfl rfl, + hcallback.2⟩ + +end TcM + +namespace RecM + +/-- Reader specialization of `inferOnlyRec`: no hidden state exists between +the method-table read and `TcM.withInferOnly`. -/ +@[simp] theorem inferOnlyRec_run (e : KExpr .anon) + (methods : Methods .anon) (s : TcState .anon) : + (inferOnlyRec e).run methods s = + TcM.withInferOnly (methods.infer e) s := by + rfl + +/-- Exact non-backtracking behavior of the optional callback wrapper. -/ +@[simp] theorem tryOptional_run (x : RecM .anon α) + (methods : Methods .anon) (s : TcState .anon) : + (tryOptional x).run methods s = + match x.run methods s with + | .ok a after => .ok (some a) after + | .error _ after => .ok none after := by + cases hrun : x.run methods s with + | ok a after => + rw [tryOptional_success hrun] + | error err after => + rw [tryOptional_error hrun] + +/-- Catching a verified callback preserves its error-side invariant and turns +only the payload into `none`. A successful payload retains the callback's +postcondition. -/ +theorem tryOptional_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {x : RecM .anon α} {Q : α → TcState .anon → Prop} + (hx : RecM.WF layer semantics trProj world support uvars Delta s x Q) : + RecM.WF layer semantics trProj world support uvars Delta s + (tryOptional x) + (fun result after => match result with + | some a => Q a after + | none => True) := by + intro methods hmethods hI + have hrunWF := hx methods hmethods hI + rw [tryOptional_run] + cases hrun : x.run methods s with + | ok a after => + rw [hrun] at hrunWF + exact hrunWF + | error err after => + rw [hrun] at hrunWF + exact ⟨hrunWF.1, trivial⟩ + +/-- The actual inference back-edge, including infer-only flag restoration, +satisfies the predecessor method table's inference contract. -/ +theorem inferOnlyRec_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + {s : TcState .anon} {e : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsource : support e) + (htr : TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((inferOnlyRec e).run methods) + (fun ty _ => support ty ∧ + InferPost trProj world uvars Delta sourceV ty) := by + change TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.withInferOnly (methods.infer e)) _ + apply TcM.withInferOnly_whnf_wf + exact hmethods.infer hsource htr + +/-- Successful caught inference retains both finite support and its Theory +typing postcondition; a caught error retains the invariant and returns +`none`. -/ +theorem tryOptionalInferOnlyRec_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + {s : TcState .anon} {e : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsource : support e) + (htr : TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (tryOptional (inferOnlyRec e)) + (fun result _ => match result with + | some ty => support ty ∧ + InferPost trProj world uvars Delta sourceV ty + | none => True) := by + apply RecM.WF.mono + (tryOptional_wf + (layer := layer) (semantics := semantics) (s := s) + (x := inferOnlyRec e) + (Q := fun ty _ => support ty ∧ + InferPost trProj world uvars Delta sourceV ty) (by + intro methods hmethods + exact inferOnlyRec_wf (s := s) hmethods hsource htr)) + · intro result after hresult + cases result <;> exact hresult + · intro err after herror + exact herror + +/-- Successful caught WHNF retains finite support and the exact predecessor +method-table WHNF postcondition. -/ +theorem tryOptionalWhnfRec_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + {s : TcState .anon} {e : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsource : support e) + (htr : TrKExprS world.venv uvars world.nameOf trProj Delta e sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (tryOptional (whnfRec e)) + (fun result _ => match result with + | some reduced => support reduced ∧ + WhnfPost trProj world uvars Delta sourceV reduced + | none => True) := by + apply RecM.WF.mono + (tryOptional_wf + (layer := layer) (semantics := semantics) (s := s) + (x := whnfRec e) + (Q := fun reduced _ => support reduced ∧ + WhnfPost trProj world uvars Delta sourceV reduced) (by + intro methods hmethods + simpa only [whnfRec_run] using + (hmethods.whnf (s := s) hsource htr))) + · intro result after hresult + cases result <;> exact hresult + · intro err after herror + exact herror + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/StructEta/Classifier.lean b/Ix/Tc/Verify/Whnf/StructEta/Classifier.lean new file mode 100644 index 000000000..250da9a2e --- /dev/null +++ b/Ix/Tc/Verify/Whnf/StructEta/Classifier.lean @@ -0,0 +1,366 @@ +import Ix.Tc.Verify.Whnf.StructEta.RecursionClassifier + +/-! +# Struct-eta classifier state closure + +RecursionClassifier verifies the cached recursion classifier and the recursor-type scan in +isolation. This slice composes the first of those contracts through the +actual `isStructLike` dispatcher. In particular, all defensive rejection +branches retain the state delivered by lazy lookup, while the one qualified +inductive branch inherits the complete cache-transaction proof. + +The result contract is intentionally state-only. Being non-recursive with +one constructor and no indices is not, by itself, a Theory proof of the +struct-eta equation selected later in the reducer. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Exact typed/effect input for the recursor declaration instance scanned by +struct eta. + +Production first observes one concrete declaration through `tryGetConst` and +then instantiates that declaration's polymorphic type at the recursor +application's universe arguments. This boundary is indexed by that lookup +equation and owns the finite walker coverage plus the admission-derived +translation of its successful result. It cannot supply a different +declaration or bypass the actual instantiation computation. -/ +structure StructEtaRecursorInputOracle + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Prop where + instantiate : + ∀ {layer : WhnfLayer} {semantics : CacheSemantics} + {uvars : Nat} {Delta : KVLCtx} + {recId : KId .anon} {before after : TcState .anon} + {entry : KConst .anon} {recUs : Array (KUniv .anon)}, + TcM.tryGetConst recId before = .ok (some entry) after → + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) + after (TcM.instantiateUnivParams entry.ty recUs) + (fun recTy _ => + support recTy ∧ ∃ recTyV, + TrKExprS world.venv uvars world.nameOf trProj Delta recTy recTyV) + +/-- The production structure classifier preserves the complete WHNF +invariant on missing and non-inductive declarations, malformed inductive +shapes, cache hits, lazy-ingress errors, and every recursion-classifier exit. + +The write oracle is indexed by the queried inductive because a provisional +`true` marker and a final computed Boolean have distinct semantic authority. +-/ +theorem isStructLike_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {id : KId .anon} {s : TcState .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ConstructorTelescopeInputSupport support) + (hctorInputs : ConstructorTelescopeInputOracle trProj world support) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hwrites : IsRecCacheWriteOracle semantics world support methods id) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((isStructLike id).run methods) (fun _ _ => True) := by + unfold isStructLike + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind (TcM.tryGetConst_wf hfault id s) + intro found afterLookup _ + cases found with + | none => exact TcM.WF.pure fun _ => trivial + | some entry => + cases entry <;> simp only + all_goals try exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + case indc name levelParams lvls params indices isUnsafe block memberIdx + ty ctors leanAll => + split + · exact TcM.WF.pure fun _ => trivial + · rw [ReaderT.run_bind] + apply TcM.WF.bind + (computedIsRec_wf (s := afterLookup) hmethods hinputs hctorInputs + hfault hwrites) + intro recursive afterRec _ + exact TcM.WF.pure fun _ => trivial + +/-- Fixed-method state rule for production's non-backtracking optional +wrapper. A caught error becomes `none` in the callback's partial post-state, +so the invariant proved by the error arm is the one that must be retained. -/ +theorem tryOptional_state_wf {I : TcState .anon → Prop} + {methods : Methods .anon} {x : RecM .anon α} {s : TcState .anon} + (hx : TcM.WF I s (x.run methods) (fun _ _ => True)) : + TcM.WF I s ((tryOptional x).run methods) (fun _ _ => True) := by + intro hI + have hrunWF := hx hI + rw [tryOptional_run] + cases hrun : x.run methods s with + | ok value after => + rw [hrun] at hrunWF + exact ⟨hrunWF.1, trivial⟩ + | error err after => + rw [hrun] at hrunWF + exact ⟨hrunWF.1, trivial⟩ + +/-- Fixed-method optional wrapper retaining the successful payload's exact +postcondition. This is the form needed when the payload is the trusted +inductive certificate returned by `getMajorInductiveId_trusted_wf`. -/ +theorem tryOptional_fixed_wf + {I : TcState .anon → Prop} {methods : Methods .anon} + {x : RecM .anon α} {s : TcState .anon} + {Q : α → TcState .anon → Prop} + (hx : TcM.WF I s (x.run methods) Q) : + TcM.WF I s ((tryOptional x).run methods) + (fun result after => match result with + | some value => Q value after + | none => True) := by + intro hI + have hrunWF := hx hI + rw [tryOptional_run] + cases hrun : x.run methods s with + | ok value after => + rw [hrun] at hrunWF + exact hrunWF + | error err after => + rw [hrun] at hrunWF + exact ⟨hrunWF.1, trivial⟩ + +/-- Exact remaining callback boundary after the recursor-type prefix has +selected a candidate inductive. Classifier uses this interface to close the +dispatcher without pretending that the inference probes, universe walker, +or generated intern requests are state-free. -/ +def StructEtaAfterInductivePreserves (I : TcState .anon → Prop) + (methods : Methods .anon) : Prop := + ∀ recUs spine recr rule indId s, + TcM.WF I s + ((tryStructEtaAfterInductive recUs spine recr rule indId).run methods) + (fun _ _ => True) + +/-- Legacy state-only contract for an arbitrary infer-only back-edge. The +production struct-eta path below no longer consumes this authority: it +instantiates `Methods.WF` at the exact major and inferred outputs. The +definition remains for the older state-only K-synthesis lemmas. -/ +def InferOnlyCallbackPreserves (I : TcState .anon → Prop) + (methods : Methods .anon) : Prop := + ∀ e s, + TcM.WF I s ((inferOnlyRec e).run methods) (fun _ _ => True) + +/-- Remaining effect boundary after all structure and H3 probes succeed. +It consists precisely of universe instantiation followed by the finite +projection/application rebuild. -/ +def StructEtaFinishPreserves (I : TcState .anon → Prop) + (methods : Methods .anon) : Prop := + ∀ recUs spine recr rule indId major majorSortW s, + TcM.WF I s + ((finishStructEtaAfterSort recUs spine recr rule indId major + majorSortW).run methods) + (fun _ _ => True) + +/-- Compose structure classification with two exact infer-only calls and the +exact WHNF call on the inferred sort. Each predecessor-table call is +instantiated from `Methods.WF` at a supported structural translation; the +resulting post-inductive contract leaves only `finishStructEtaAfterSort` as +an explicit state boundary. -/ +theorem tryStructEtaAfterInductive_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + {s : TcState .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ConstructorTelescopeInputSupport support) + (hctorInputs : ConstructorTelescopeInputOracle trProj world support) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hwrites : IsRecCacheWriteOracle semantics world support methods indId) + {majorV : Lean4Lean.VExpr} + (hmajorSupport : support spine[recr.majorIdx]!) + (hmajorTr : TrKExprS world.venv uvars world.nameOf trProj Delta + spine[recr.majorIdx]! majorV) + (hfinish : StructEtaFinishPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((tryStructEtaAfterInductive recUs spine recr rule indId).run methods) + (fun _ _ => True) := by + unfold tryStructEtaAfterInductive + rw [ReaderT.run_bind] + apply TcM.WF.bind + (isStructLike_wf hmethods hinputs hctorInputs hfault hwrites) + intro structLike afterStruct _ + cases structLike with + | false => exact TcM.WF.pure fun _ => trivial + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind] + apply TcM.WF.bind + ((tryOptionalInferOnlyRec_wf + (s := afterStruct) hmajorSupport hmajorTr) methods hmethods) + intro foundMajorTy afterMajor hfoundMajorTy + cases foundMajorTy with + | none => exact TcM.WF.pure fun _ => trivial + | some majorTy => + obtain ⟨hmajorTySupport, majorTyV, hmajorTy, _⟩ := + hfoundMajorTy + obtain ⟨majorTyStructuralV, hmajorTyTr, _⟩ := hmajorTy + rw [ReaderT.run_bind] + apply TcM.WF.bind + ((tryOptionalInferOnlyRec_wf + (s := afterMajor) hmajorTySupport hmajorTyTr) methods hmethods) + intro foundMajorSort afterSort hfoundMajorSort + cases foundMajorSort with + | none => exact TcM.WF.pure fun _ => trivial + | some majorSort => + obtain ⟨hmajorSortSupport, majorSortV, hmajorSort, _⟩ := + hfoundMajorSort + obtain ⟨majorSortStructuralV, hmajorSortTr, _⟩ := hmajorSort + rw [ReaderT.run_bind] + apply TcM.WF.bind + ((tryOptionalWhnfRec_wf + (s := afterSort) hmajorSortSupport hmajorSortTr) + methods hmethods) + intro foundMajorSortW afterWhnf _hfoundMajorSortW + cases foundMajorSortW with + | none => exact TcM.WF.pure fun _ => trivial + | some majorSortW => + exact hfinish recUs spine recr rule indId + spine[recr.majorIdx]! majorSortW afterWhnf + +/-- Trusted-result refinement of the struct-eta prefix. The successful +optional scan retains its selected-ID trust proof; misses and caught errors +remain state-only. -/ +theorem tryStructEtaIota_trusted_prefix_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {s : TcState .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : MajorTelescopeInputSupport support) + (hrecInputs : StructEtaRecursorInputOracle trProj world support) + (hfault : ∀ {current : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars current)) + (hreferences : TrustedReferences world support) + (hafter : ∀ indId afterScan, + world.trusted indId → + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) + afterScan + ((tryStructEtaAfterInductive recUs spine recr recr.rules[0]! + indId).run methods) + (fun _ _ => True)) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((tryStructEtaIota recId recr recUs spine).run methods) + (fun _ _ => True) := by + unfold tryStructEtaIota + by_cases hrules : (recr.rules.size != 1) = true + · simp only [hrules, if_true] + exact TcM.WF.pure fun _ => trivial + · simp only [hrules, Bool.false_eq_true, if_false] + by_cases hlevels : (recUs.size.toUInt64 != recr.lvls) = true + · simp only [hlevels, if_true] + exact TcM.WF.pure fun _ => trivial + · simp only [hlevels, Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (Q₁ := fun found after => + TcM.tryGetConst recId s = .ok found after) + (TcM.WF.mono + (TcM.WF.with_run_eq + (TcM.tryGetConst_wf (hfault (current := Delta)) recId s)) + (fun _ _ h => h.2) (fun _ _ _ => trivial)) + intro found afterLookup hlookup + cases found with + | none => exact TcM.WF.pure fun _ => trivial + | some entry => + simp only + rw [ReaderT.run_bind] + apply TcM.WF.bind (tryOptional_fixed_wf (by + rw [ReaderT.run_bind, ReaderT.run_monadLift, monadLift_self] + apply TcM.WF.bind (hrecInputs.instantiate hlookup) + intro recTy afterInst hrecTy + obtain ⟨hrecSupport, recTyV, hrecTr⟩ := hrecTy + exact getMajorInductiveId_trusted_wf hmethods hinputs hfault + hreferences + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64 + hrecSupport hrecTr)) + intro foundInd afterScan htrusted + cases foundInd with + | none => exact TcM.WF.pure fun _ => trivial + | some indId => + exact hafter indId afterScan htrusted + +/-- State-only compatibility form of the complete struct-eta prefix. Its +successful branch is implemented through the trusted refinement above, so it +cannot accidentally regress to an untyped raw recursor scan. -/ +theorem tryStructEtaIota_prefix_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {s : TcState .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : MajorTelescopeInputSupport support) + (hrecInputs : StructEtaRecursorInputOracle trProj world support) + (hfault : ∀ {current : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars current)) + (hreferences : TrustedReferences world support) + (hafter : StructEtaAfterInductivePreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((tryStructEtaIota recId recr recUs spine).run methods) + (fun _ _ => True) := + tryStructEtaIota_trusted_prefix_wf hmethods hinputs hrecInputs hfault + hreferences (fun indId afterScan _ => + hafter recUs spine recr recr.rules[0]! indId afterScan) + +/-- Full state-preservation contract for the struct-eta dispatcher. It is +exhaustive over concrete control flow; the remaining premises are narrowly +scoped semantic/effect authorities for recursion-cache writes, callbacks, +and the successful finite rebuild tail. -/ +theorem tryStructEtaIota_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {s : TcState .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ConstructorTelescopeInputSupport support) + (hctorInputs : ConstructorTelescopeInputOracle trProj world support) + (hrecInputs : StructEtaRecursorInputOracle trProj world support) + (hfault : ∀ {current : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars current)) + (hreferences : TrustedReferences world support) + (hwrites : ∀ id, world.trusted id → + IsRecCacheWriteOracle semantics world support methods id) + {majorV : Lean4Lean.VExpr} + (hmajorSupport : support spine[recr.majorIdx]!) + (hmajorTr : TrKExprS world.venv uvars world.nameOf trProj Delta + spine[recr.majorIdx]! majorV) + (hfinish : StructEtaFinishPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((tryStructEtaIota recId recr recUs spine).run methods) + (fun _ _ => True) := by + apply tryStructEtaIota_trusted_prefix_wf hmethods hinputs hrecInputs hfault + hreferences + intro indId afterScan htrusted + exact tryStructEtaAfterInductive_wf hmethods hinputs hctorInputs + (hfault (current := Delta)) + (hwrites indId htrusted) hmajorSupport hmajorTr hfinish + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/StructEta/Rebuild.lean b/Ix/Tc/Verify/Whnf/StructEta/Rebuild.lean new file mode 100644 index 000000000..dce3929fb --- /dev/null +++ b/Ix/Tc/Verify/Whnf/StructEta/Rebuild.lean @@ -0,0 +1,216 @@ +import Ix.Tc.Verify.Whnf.Iota.StructEtaControl + +/-! +# Finite struct-eta rebuild closure + +StructEtaControl identifies the exact successful path through `tryStructEtaIota`, but +its final acceptance theorem still accepts the post-state invariant, the +intern-only frame, and finite result support as premises. This slice derives +those three facts from the concrete projection/application requests made by +`finishStructEtaResult`. + +The remaining `WhnfMeaning` premise is intentional. Collision-safe +execution shows that production built the requested syntax; it does not prove +that the selected recursor rule is a registered Theory equation or that raw +projections have the required interpretation. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Finite request certificate for the projection/application pairs generated +by a contiguous struct-field range. The indices expose the exact field +number, accumulator, request order, and final expression. -/ +inductive StructEtaFieldRequests (requests : List WalkerRequest) + (indId : KId .anon) (major : KExpr .anon) : + Nat → Nat → KExpr .anon → KExpr .anon → Prop + | nil (field result) : + StructEtaFieldRequests requests indId major 0 field result result + | cons {fuel field result final} + (proj : WalkerRequest.internExpr + (KExpr.mkPrj indId field.toUInt64 major) ∈ requests) + (app : WalkerRequest.internExpr + (KExpr.mkApp result + (KExpr.mkPrj indId field.toUInt64 major)) ∈ requests) + (tail : StructEtaFieldRequests requests indId major fuel (field + 1) + (KExpr.mkApp result + (KExpr.mkPrj indId field.toUInt64 major)) final) : + StructEtaFieldRequests requests indId major (fuel + 1) field result + final + +namespace StructEtaFieldRequests + +/-- The final accumulator of a certified field segment belongs to the finite +run support. -/ +theorem support {α : Type} {initial : TcState .anon} + {program : TcM .anon α} {requests : List WalkerRequest} + {runSupport : RunSupport} + (hrun : RunAssumptions initial program requests runSupport) + {indId : KId .anon} {major : KExpr .anon} + {fuel field : Nat} {result final : KExpr .anon} + (h : StructEtaFieldRequests requests indId major fuel field result final) + (hresult : runSupport result) : runSupport final := by + induction h with + | nil => exact hresult + | cons proj app tail ih => + exact ih (hrun.coverage.internExpr app) + +/-- Execute the production field helper from its exact finite request +certificate. Collision freedom makes each returned projection/application +syntactically exact, and the intern-only frames compose across the loop. -/ +theorem eval {α : Type} {initial : TcState .anon} + {program : TcM .anon α} {requests : List WalkerRequest} + {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {indId : KId .anon} {major : KExpr .anon} + {fuel field : Nat} {result final : KExpr .anon} + (h : StructEtaFieldRequests requests indId major fuel field result final) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) : + ∃ sf, + (finishStructEtaFields indId major fuel field result).run methods s = + .ok final sf ∧ + WhnfStateInv layer semantics trProj world support uvars Delta sf ∧ + InternUpdateFrame s sf := by + induction h generalizing s with + | nil => + exact ⟨s, rfl, hI, InternUpdateFrame.refl s⟩ + | @cons fuel field result final proj app tail ih => + obtain ⟨sProj, hproj, hIProj, hframeProj⟩ := + hrun.internExpr_whnf_eval proj hI + obtain ⟨sApp, happ, hIApp, hframeApp⟩ := + hrun.internExpr_whnf_eval app hIProj + obtain ⟨sf, htail, hIf, hframeTail⟩ := ih hIApp + refine ⟨sf, ?_, hIf, + hframeProj.trans (hframeApp.trans hframeTail)⟩ + unfold finishStructEtaFields + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind + (TcM.intern (KExpr.mkPrj indId field.toUInt64 major)) _ s = _ + unfold EStateM.bind + rw [hproj] + simp only + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind + (TcM.intern + (KExpr.mkApp result + (KExpr.mkPrj indId field.toUInt64 major))) _ sProj = _ + unfold EStateM.bind + rw [happ] + exact htail + +end StructEtaFieldRequests + +/-- One certificate for all three rebuild segments: prefix applications, +field projections/applications, and trailing applications. -/ +structure StructEtaBuildRequests (requests : List WalkerRequest) + (indId : KId .anon) (major rhs : KExpr .anon) (fields : UInt64) + (prefixArgs trailingArgs : Array (KExpr .anon)) + (final : KExpr .anon) : Type where + prefixResult : KExpr .anon + fieldsResult : KExpr .anon + prefixCert : FinishAppRequests requests + (prefixArgs.extract 0 prefixArgs.size).toList rhs prefixResult + fieldCert : StructEtaFieldRequests requests indId major fields.toNat 0 + prefixResult fieldsResult + trailingCert : FinishAppRequests requests + (trailingArgs.extract 0 trailingArgs.size).toList fieldsResult final + +namespace StructEtaBuildRequests + +/-- All three certified segments preserve the invariant and compose to the +exact production rebuild. Result support follows from the same requests. -/ +theorem eval {α : Type} {initial : TcState .anon} + {program : TcM .anon α} {requests : List WalkerRequest} + {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {indId : KId .anon} {major rhs : KExpr .anon} {fields : UInt64} + {prefixArgs trailingArgs : Array (KExpr .anon)} + {final : KExpr .anon} + (h : StructEtaBuildRequests requests indId major rhs fields prefixArgs + trailingArgs final) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hrhs : support rhs) : + ∃ sf, + (finishStructEtaResult indId major rhs fields prefixArgs trailingArgs).run + methods s = .ok final sf ∧ + WhnfStateInv layer semantics trProj world support uvars Delta sf ∧ + InternUpdateFrame s sf ∧ + support final := by + obtain ⟨sPrefix, hprefix, hIPrefix, hframePrefix⟩ := + h.prefixCert.eval hrun hI + obtain ⟨sFields, hfields, hIFields, hframeFields⟩ := + h.fieldCert.eval hrun hIPrefix + obtain ⟨sf, htrailing, hIf, hframeTrailing⟩ := + h.trailingCert.eval hrun hIFields + have hprefixSupport : support h.prefixResult := + h.prefixCert.support hrun hrhs + have hfieldsSupport : support h.fieldsResult := + h.fieldCert.support hrun hprefixSupport + have hfinalSupport : support final := + h.trailingCert.support hrun hfieldsSupport + exact ⟨sf, + finishStructEtaResult_of_segments hprefix hfields htrailing, + hIf, hframePrefix.trans (hframeFields.trans hframeTrailing), + hfinalSupport⟩ + +end StructEtaBuildRequests + +namespace StructEtaIotaSuccessTrace + +/-- Successful struct eta with state/resource facts derived from the exact +finite run. Compared with StructEtaControl's `acceptance`, the final invariant, frame, +and support are conclusions. The frame intentionally starts at the final +probe state: classification and recursive callbacks may update caches or +fuel and therefore do not, in general, form an `InternUpdateFrame`. Later +exhaustive helper composition supplies the one remaining prefix invariant. +The Theory meaning remains the explicit inductive semantic boundary. -/ +theorem acceptance_of_requests + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} + {methods : Methods .anon} {recId : KId .anon} + {recr : IotaInfo .anon} {recUs : Array (KUniv .anon)} + {spine : Array (KExpr .anon)} {s sf : TcState .anon} + {result : KExpr .anon} + (h : StructEtaIotaSuccessTrace methods recId recr recUs spine s result + sf) + {source : KExpr .anon} + (hProbeI : WhnfStateInv layer semantics trProj world support uvars Delta + h.probes.sMajorSortW) + (hreach : ∀ x, + KExpr.InstUnivReach recUs h.selection.rule.rhs x → support x) + (hbuild : StructEtaBuildRequests requests h.selection.indId + spine[recr.majorIdx]! h.rhs h.selection.rule.fields + (spine.extract 0 + (min (recr.params + recr.motives + recr.minors) spine.size)) + (spine.extract (recr.majorIdx + 1) spine.size) result) + (hmeaning : WhnfMeaning trProj world uvars Delta source result) : + (tryStructEtaIota recId recr recUs spine).run methods s = + .ok (some result) sf ∧ + WhnfStateInv layer semantics trProj world support uvars Delta sf ∧ + InternUpdateFrame h.probes.sMajorSortW sf ∧ + support result ∧ + WhnfMeaning trProj world uvars Delta source result := by + obtain ⟨_, hInstI, hInstFrame, hRhsSupport⟩ := + TcM.instantiateUnivParams_whnf_of_run hrun.collisionFree hreach hProbeI + h.instantiation + obtain ⟨sf', hBuildRun, hFinalI, hBuildFrame, hResultSupport⟩ := + hbuild.eval hrun hInstI hRhsSupport + rw [h.rebuild] at hBuildRun + cases hBuildRun + exact ⟨h.eval, hFinalI, + hInstFrame.trans hBuildFrame, + hResultSupport, hmeaning⟩ + +end StructEtaIotaSuccessTrace +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/StructEta/RebuildRequests.lean b/Ix/Tc/Verify/Whnf/StructEta/RebuildRequests.lean new file mode 100644 index 000000000..873c87405 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/StructEta/RebuildRequests.lean @@ -0,0 +1,145 @@ +import Ix.Tc.Verify.Whnf.Iota.ApplicationRequests + +/-! +# Finite request closure for the struct-eta rebuild tail + +Classifier exhausts the struct-eta control flow and RebuildTail proves its successful H3 +tail from finite walker/rebuild requests. This slice packages those exact +requests at every possible selected tail, constructs +`StructEtaFinishPreserves`, and therefore replaces NatOffset's whole +`StructEtaIotaPreserves` premise with a contract indexed by the one selected +recursor and spine. The inference probes are derived from `Methods.WF`; only +the helper-scan and recursion-cache authorities remain. +-/ + +namespace Ix.Tc +namespace RecM + +/-- The exact finite requests for one successful struct-eta H3 tail. -/ +structure StructEtaFinishRequests (requests : List WalkerRequest) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) + (recr : IotaInfo .anon) (rule : RecRule .anon) (indId : KId .anon) + (major : KExpr .anon) where + instantiate : WalkerRequest.instUniv rule.rhs recUs ∈ requests + build : ∀ {rhs}, + KExpr.instantiateUnivParamsSpec rule.rhs recUs = .ok rhs → + Σ final, + StructEtaBuildRequests requests indId major rhs rule.fields + (spine.extract 0 + (min (recr.params + recr.motives + recr.minors) spine.size)) + (spine.extract (recr.majorIdx + 1) spine.size) final + +/-- Run-wide census indexed by production's exact selected recursor rule, +inductive, major, and argument slices. -/ +structure StructEtaFinishRequestCensus (requests : List WalkerRequest) where + plan : ∀ (recUs : Array (KUniv .anon)) + (spine : Array (KExpr .anon)) (recr : IotaInfo .anon) + (rule : RecRule .anon) (indId : KId .anon) + (major : KExpr .anon), + StructEtaFinishRequests requests recUs spine recr rule indId major + +namespace StructEtaFinishPreserves + +/-- Construct Classifier's final-tail contract from the exact finite run census. -/ +theorem of_requests + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (census : StructEtaFinishRequestCensus requests) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} : + StructEtaFinishPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods := by + intro recUs spine recr rule indId major majorSortW s + let plan := census.plan recUs spine recr rule indId major + exact finishStructEtaAfterSort_wf_of_requests hrun + (hrun.coverage.instUniv plan.instantiate) plan.build + +end StructEtaFinishPreserves + +namespace StructEtaIotaPreserves + +/-- NatOffset's selected struct-eta boundary constructed from Classifier's precise +helper/cache authorities, exact major translation, and RebuildTail's finite +final-tail census. -/ +theorem of_components + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (finishCensus : StructEtaFinishRequestCensus requests) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ConstructorTelescopeInputSupport support) + (hctorInputs : ConstructorTelescopeInputOracle trProj world support) + (hrecInputs : StructEtaRecursorInputOracle trProj world support) + (hfault : ∀ {current : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars current)) + (hreferences : TrustedReferences world support) + (hwrites : ∀ id, world.trusted id → + IsRecCacheWriteOracle semantics world support methods id) + {majorV : Lean4Lean.VExpr} + (hmajorSupport : support spine[recr.majorIdx]!) + (hmajorTr : TrKExprS world.venv uvars world.nameOf trProj Delta + spine[recr.majorIdx]! majorV) : + SelectedStructEtaIotaPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta) + methods recId recr recUs spine := by + intro s + exact tryStructEtaIota_wf hmethods hinputs hctorInputs hrecInputs hfault + hreferences hwrites hmajorSupport hmajorTr + (StructEtaFinishPreserves.of_requests hrun finishCensus) + +end StructEtaIotaPreserves + +/-- The complete post-major state path with both NatOffset whole-tail premises +replaced by finite requests and the remaining exact callback/cache +authorities. -/ +theorem tryIotaAfterMajorWhnf_state_wf_of_contexts + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (iotaCensus : IotaRuleRequestCensus requests) + (finishCensus : StructEtaFinishRequestCensus requests) + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} + (strings : ProjectionStringPlanContext trProj world support) + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + (hmethods : + Methods.WFAt .noAccel semantics trProj world support uvars methods) + (hinputs : ConstructorTelescopeInputSupport support) + (hctorInputs : ConstructorTelescopeInputOracle trProj world support) + (hrecInputs : StructEtaRecursorInputOracle trProj world support) + (hfault : ∀ {current : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv .noAccel semantics trProj world support uvars current)) + (hreferences : TrustedReferences world support) + (hwrites : ∀ id, world.trusted id → + IsRecCacheWriteOracle semantics world support methods id) + {flags : WhnfFlags} {recId : KId .anon} {recr : IotaInfo .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {majorV : Lean4Lean.VExpr} + (hmajorSupport : support spine[recr.majorIdx]!) + (hmajorTr : TrKExprS world.venv uvars world.nameOf trProj Delta + spine[recr.majorIdx]! majorV) + {majorWhnf0 : KExpr .anon} {s : TcState .anon} : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((tryIotaAfterMajorWhnf flags recId recr recUs spine majorWhnf0).run + methods) + (fun _ _ => True) := by + exact tryIotaAfterMajorWhnf_state_wf strings hmethods + (hfault (current := Delta)) + (TryApplyIotaCtorPreserves.of_requests hrun iotaCensus) + (StructEtaIotaPreserves.of_components hrun finishCensus hmethods hinputs + hctorInputs hrecInputs hfault hreferences hwrites hmajorSupport hmajorTr) + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/StructEta/RebuildTail.lean b/Ix/Tc/Verify/Whnf/StructEta/RebuildTail.lean new file mode 100644 index 000000000..6eb618e19 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/StructEta/RebuildTail.lean @@ -0,0 +1,151 @@ +import Ix.Tc.Verify.Whnf.StructEta.Classifier + +/-! +# Struct-eta universe and rebuild tail + +Classifier reduces the post-selection state obligation to +`finishStructEtaAfterSort`. This slice discharges that tail from the finite +run certificate: the verified universe walker preserves the complete WHNF +invariant on success and partial-state error, and a successful RHS is rebuilt +only through request-certified projection/application interning. +-/ + +namespace Ix.Tc + +namespace TcM + +/-- Universe instantiation preserves the complete K1 invariant on both +outcomes. On success it additionally returns the pure-spec equation and a +result in finite run support. The error proof is important here: production +uses non-backtracking `EStateM`, so a failed walk may retain intern-table +updates made before the error. -/ +theorem instantiateUnivParams_whnf_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + {us : Array (KUniv .anon)} {e : KExpr .anon} + {s : TcState .anon} + (hcollision : support.CollisionFree) + (hreach : ∀ x, KExpr.InstUnivReach us e x → support x) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + (TcM.instantiateUnivParams e us) + (fun result _ => + KExpr.instantiateUnivParamsSpec e us = .ok result ∧ + support result) := by + intro hI + cases hrun : TcM.instantiateUnivParams e us s with + | ok result after => + obtain ⟨hspec, hIafter, _, hresultSupport⟩ := + TcM.instantiateUnivParams_whnf_of_run hcollision hreach hI hrun + exact ⟨hIafter, hspec, hresultSupport⟩ + | error err after => + have hwalk := TcM.instantiateUnivParams_wf hcollision.expr hreach + ⟨hI.1.core.intern, hI.1.internSupport.expr⟩ + rw [hrun] at hwalk + have hframe : InternUpdateFrame s after := hwalk.2.1 + have hunivs := hwalk.2.2 + have hconsts : after.env.consts = s.env.consts := by + simpa [InternUpdateFrame] using + congrArg (fun state : TcState .anon => state.env.consts) hframe + have henv : after.env = + {s.env with intern := after.env.intern} := by + simpa [InternUpdateFrame] using + congrArg (fun state : TcState .anon => state.env) hframe + have hcover : support.CoversIntern after.env.intern := { + expr := hwalk.1.2 + univ := by + intro u hu + exact hI.1.internSupport.univ u (by + simpa only [InternTable.UnivSupport, hunivs] using hu) + } + have hcaches : + CacheInvariant semantics (.stable world) support after.env := by + rw [henv] + exact hI.1.caches.of_intern_update + have hkernel : KernelStateWF semantics trProj world support after := { + core := hI.1.core.of_consts_eq hconsts hwalk.1.1 + internSupport := hcover + caches := hcaches + equivalences := by + have hequiv := congrArg TcState.equivManager hframe + simpa [InternUpdateFrame] using hequiv ▸ hI.1.equivalences + } + exact ⟨hframe.whnfStateInv hkernel hI, trivial⟩ + +end TcM + +namespace RecM + +namespace StructEtaBuildRequests + +/-- Hoare form of the existing finite rebuild evaluator. A request +certificate makes the intern-only helper operationally total, so its error +arm is vacuous; success returns the certificate's exact final syntax. -/ +theorem wf {α : Type} {initial : TcState .anon} + {program : TcM .anon α} {requests : List WalkerRequest} + {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {indId : KId .anon} {major rhs : KExpr .anon} {fields : UInt64} + {prefixArgs trailingArgs : Array (KExpr .anon)} + {final : KExpr .anon} + (h : StructEtaBuildRequests requests indId major rhs fields prefixArgs + trailingArgs final) + (hrhs : support rhs) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((finishStructEtaResult indId major rhs fields prefixArgs + trailingArgs).run methods) + (fun result _ => result = final ∧ support result) := by + intro hI + obtain ⟨sf, hrunBuild, hIf, _, hfinalSupport⟩ := h.eval hrun hI hrhs + rw [hrunBuild] + exact ⟨hIf, rfl, hfinalSupport⟩ + +end StructEtaBuildRequests + +/-- The actual H3 tail preserves state from an execution-indexed finite +request census. No totality assumption is made for universe instantiation: +if the verified walker errors, its partial intern state is retained; if it +succeeds, `hbuild` must certify exactly that pure-spec RHS and all subsequent +generated intern requests. -/ +theorem finishStructEtaAfterSort_wf_of_requests + {α : Type} {initial : TcState .anon} + {program : TcM .anon α} {requests : List WalkerRequest} + {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + {recUs : Array (KUniv .anon)} {spine : Array (KExpr .anon)} + {recr : IotaInfo .anon} {rule : RecRule .anon} {indId : KId .anon} + {major majorSortW : KExpr .anon} {s : TcState .anon} + (hreach : ∀ x, + KExpr.InstUnivReach recUs rule.rhs x → support x) + (hbuild : ∀ {rhs}, + KExpr.instantiateUnivParamsSpec rule.rhs recUs = .ok rhs → + Σ final, StructEtaBuildRequests requests indId major rhs rule.fields + (spine.extract 0 + (min (recr.params + recr.motives + recr.minors) spine.size)) + (spine.extract (recr.majorIdx + 1) spine.size) final) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((finishStructEtaAfterSort recUs spine recr rule indId major + majorSortW).run methods) + (fun _ _ => True) := by + unfold finishStructEtaAfterSort + split + · exact TcM.WF.pure fun _ => trivial + · simp only [pure_bind] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (TcM.instantiateUnivParams_whnf_wf hrun.collisionFree hreach) + intro rhs afterInst hrhs + obtain ⟨final, hcert⟩ := hbuild hrhs.1 + rw [ReaderT.run_bind] + apply TcM.WF.bind (hcert.wf hrun hrhs.2) + intro result afterBuild _ + exact TcM.WF.pure fun _ => trivial + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/StructEta/RecursionClassifier.lean b/Ix/Tc/Verify/Whnf/StructEta/RecursionClassifier.lean new file mode 100644 index 000000000..223cc5a65 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/StructEta/RecursionClassifier.lean @@ -0,0 +1,781 @@ +import Init.Data.Range.Lemmas +import Ix.Tc.Verify.Whnf.StructEta.ScopedClassifier + +/-! +# Recursion-classifier and major-inductive helper effects + +`computedIsRec` and `getMajorInductiveId` sit on the last effectful prefix of +the struct-eta reducer. This slice verifies their concrete environment reads +and recursion-classification cache transactions before assigning either +helper a semantic result contract. + +The `isRecCache` write rule is intentionally provenance-indexed. A cached +`false` enables struct eta, while the provisional `true` entry suppresses +re-entrant eta. Physical insertion alone is therefore not evidence that +either Boolean is semantically valid. +-/ + +namespace Ix.Tc + +namespace RecM + +namespace IsRecCacheUpdate + +/-- Installing one provenance-certified recursion result changes only the +physical `isRecCache` partition and preserves the complete WHNF invariant. -/ +theorem insert_whnfStateInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {ind : Address} {value : Bool} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (hnew : CacheProvenance semantics (CacheAuthority.stable world) support + (.isRec ind value)) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with env := {s.env with + isRecCache := s.env.isRecCache.insert ind value}} := by + rcases hI with ⟨hkernel, hctx, hlayer⟩ + refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ + · exact hkernel.core.of_consts_eq rfl (by + simpa using hkernel.core.intern) + · simpa using hkernel.internSupport + · exact hkernel.caches.insertIsRec hnew + · exact hkernel.equivalences + · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer + +/-- Removing a recursion result cannot invalidate any retained cache entry; +this is the exact cleanup update used after a caught `computeIsRec` error. -/ +theorem erase_whnfStateInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {ind : Address} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) : + WhnfStateInv layer semantics trProj world support uvars Delta + {s with env := {s.env with + isRecCache := s.env.isRecCache.erase ind}} := by + rcases hI with ⟨hkernel, hctx, hlayer⟩ + refine ⟨?_, ?_, ?_⟩ + · refine ⟨?_, ?_, ?_, ?_⟩ + · exact hkernel.core.of_consts_eq rfl (by + simpa using hkernel.core.intern) + · simpa using hkernel.internSupport + · exact hkernel.caches.eraseIsRec + · exact hkernel.equivalences + · exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) + · cases layer <;> simpa [WhnfLayer.StateOK] using hlayer + +end IsRecCacheUpdate + +end RecM + +namespace TcM + +/-- Required constant lookup preserves an arbitrary invariant whenever the +installed lazy-fault hook does. A no-hook miss is converted to the same +state-preserving `unknownConst` error as production. -/ +theorem getConst_wf {I : TcState .anon → Prop} + (hfault : LazyFaultPreserves I) (id : KId .anon) (s : TcState .anon) : + TcM.WF I s (TcM.getConst id) (fun _ _ => True) := by + unfold TcM.getConst + apply TcM.WF.bind (TcM.tryGetConst_wf hfault id s) + intro found after _ + cases found with + | none => exact TcM.WF.throw fun _ => trivial + | some c => exact TcM.WF.pure fun _ => trivial + +/-- Mutual-block lookup has the same fast-read/fault/retry state contract as +constant lookup, but retains production's optional post-fault miss. -/ +theorem tryGetBlock_wf {I : TcState .anon → Prop} + (hfault : LazyFaultPreserves I) (id : KId .anon) (s : TcState .anon) : + TcM.WF I s (TcM.tryGetBlock id) (fun _ _ => True) := by + unfold TcM.tryGetBlock + apply TcM.WF.bind + (Q₁ := fun read after => read = after) + (TcM.WF.get fun _ => rfl) + intro read before hread + subst read + split + · exact TcM.WF.pure fun _ => trivial + · apply TcM.WF.bind + (Q₁ := fun _ _ => True) + (TcM.lazyIngressAddr_wf hfault id.addr before) + intro _ afterFault _ + apply TcM.WF.bind + (Q₁ := fun read after => read = after) + (TcM.WF.get fun _ => rfl) + intro read after hread + subst read + exact TcM.WF.pure fun _ => trivial + +end TcM + +namespace RecM + +/-- State-only contract for the recursive WHNF calls made by helper scans. + +This is intentionally not inferred for every expression from `Methods.WF`: +that record needs finite support and a structural translation for each input. +Later closure supplies this contract from an execution-indexed census of the +actual constructor and recursor-type intermediates. -/ +def WhnfCallbackPreserves (I : TcState .anon → Prop) + (methods : Methods .anon) : Prop := + ∀ e s, TcM.WF I s (methods.whnf e) (fun _ _ => True) + +/-- Every direct declaration reference reachable in this finite execution +support has already crossed the trusted-world admission boundary. This is a +run-scoped property, not a claim that every entry of the immutable catalog is +trusted. -/ +def TrustedReferences (world : VerifyWorld) (support : RunSupport) : Prop := + ∀ {source : KExpr .anon} {id : KId .anon}, + support source → source.References id → world.trusted id + +/-- Result-support contract for the exact predecessor-table WHNF callbacks +crossed by helper scans. Unlike `WhnfCallbackPreserves`, this retains the +finite result witness needed to authorize declaration references selected +from the callback result. -/ +def WhnfCallbackSupports (support : RunSupport) (I : TcState .anon → Prop) + (methods : Methods .anon) : Prop := + ∀ e s, TcM.WF I s (methods.whnf e) (fun result _ => support result) + +/-- Public name for the finite telescope-body support consumed by the +binder-aware constructor and recursor scans. The implementation theorem +currently lives in `ScopedClassifier`; this alias keeps that staging detail out +of the recursion-classifier interface. -/ +abbrev ConstructorTelescopeInputSupport := + ScratchTelescopeInputSupport + +/-- Admission-owned typed input for a constructor declaration actually +returned by the production lookup. + +The execution equation is essential: an arbitrary catalog entry does not +justify invoking WHNF on an arbitrary expression. Conversely, this boundary +owns no state fact and cannot choose a constructor independently of the +lookup. A later admission refinement derives the field from the checked +constructor declaration after resolving its universe parameters. -/ +structure ConstructorTelescopeInputOracle + (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) : Prop where + found : + ∀ {uvars : Nat} {Delta : KVLCtx} + {ctorId : KId .anon} {before after : TcState .anon} + {name : Mode.anon.F Name} + {levelParams : Mode.anon.F (Array Name)} + {isUnsafe : Bool} {lvls : UInt64} {induct : KId .anon} + {cidx params fields : UInt64} {ty : KExpr .anon}, + TcM.tryGetConst ctorId before = + .ok (some (.ctor name levelParams isUnsafe lvls induct cidx params + fields ty)) after → + support ty ∧ ∃ tyV, + TrKExprS world.venv uvars world.nameOf trProj Delta ty tyV + +namespace WhnfCallbackSupports + +/-- Forgetting finite result support recovers the state-only callback +contract used by the existing helper proofs. -/ +theorem preserves + {support : RunSupport} {I : TcState .anon → Prop} + {methods : Methods .anon} + (h : WhnfCallbackSupports support I methods) : + WhnfCallbackPreserves I methods := by + intro e s + exact TcM.WF.mono (h e s) (fun _ _ _ => trivial) + (fun _ _ _ => trivial) + +end WhnfCallbackSupports + +/-- Explicit authority for the two recursion-classification writes made by +`computedIsRec`. The final certificate is indexed by the exact successful +classifier execution; inserting a Boolean into the physical map is not, by +itself, evidence that the Boolean has the cache semantics chosen by the +caller. + +The classifier inputs are supplied by production's preceding inductive and +mutual-block lookups. This record owns only the semantic cache boundary; +the theorem below proves that those are the values actually passed to the +recorded `computeIsRec` execution. -/ +structure IsRecCacheWriteOracle + (semantics : CacheSemantics) (world : VerifyWorld) + (support : RunSupport) (methods : Methods .anon) + (ind : KId .anon) : Prop where + provisional : + CacheProvenance semantics (CacheAuthority.stable world) support + (.isRec ind.addr true) + computed : ∀ {ctors : Array (KId .anon)} {nParams : Nat} + {blockAddrs : Array Address} {before after : TcState .anon} + {value : Bool}, + (computeIsRec ctors nParams blockAddrs).run methods before = + .ok value after → + CacheProvenance semantics (CacheAuthority.stable world) support + (.isRec ind.addr value) + +namespace IsRecCacheWriteOracle + +/-- Construct both classifier-write certificates from trusted operational +cache ownership. + +The successful `computeIsRec` equation remains in the record so callers can +tie the written Boolean to the value production actually returned. It is not +needed to establish cache validity: the `.isRec` family is deliberately only +an operational gate. Conservative/provisional `true` suppresses struct eta, +and any path enabled by `false` must still pass the independent +`IotaSuccessOracle` semantic proof. -/ +theorem of_trusted + {semantics : CacheSemantics} {world : VerifyWorld} + {support : RunSupport} {methods : Methods .anon} + {ind : KId .anon} + (htrusted : world.trusted ind) + (hvalid : ∀ value, + semantics.Valid (CacheAuthority.stable world) support + (.isRec ind.addr value)) : + IsRecCacheWriteOracle semantics world support methods ind where + provisional := + CacheProvenance.isRec_of_trusted htrusted (hvalid true) + computed := by + intro ctors nParams blockAddrs before after value hrun + exact CacheProvenance.isRec_of_trusted htrusted (hvalid value) + +end IsRecCacheWriteOracle + +/-- Strengthen a concrete `TcM` triple with the execution equation selected +by its actual outcome. This is used at semantic write boundaries where the +certificate must be tied to the value that production really computed. -/ +private theorem wf_with_run_eq + {I : TcState .anon → Prop} {s : TcState .anon} {x : TcM .anon α} + {Q : α → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (hx : TcM.WF I s x Q E) : + TcM.WF I s x + (fun value after => Q value after ∧ x s = .ok value after) + (fun err after => E err after ∧ x s = .error err after) := by + intro hI + have hpost := hx hI + cases hrun : x s with + | ok value after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, rfl⟩ + | error err after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, rfl⟩ + +/-- A finite `RecM` list loop preserves an invariant if each exact body +invocation does. `done` exits immediately; `yield` continues from the body's +partial post-state. -/ +private theorem forIn_list_state_wf + {I : TcState .anon → Prop} {methods : Methods .anon} + {f : α → β → RecM .anon (ForInStep β)} + (hstep : ∀ a b s, + TcM.WF I s ((f a b).run methods) (fun _ _ => True)) : + ∀ (xs : List α) (init : β) (s : TcState .anon), + TcM.WF I s ((forIn (m := RecM .anon) xs init f).run methods) + (fun _ _ => True) + | [], init, s => by + exact TcM.WF.pure fun _ => trivial + | a :: xs, init, s => by + rw [List.forIn_cons, ReaderT.run_bind] + apply TcM.WF.bind (hstep a init s) + intro action after _ + cases action with + | done result => exact TcM.WF.pure fun _ => trivial + | yield next => exact forIn_list_state_wf hstep xs next after + +/-- Fixed-reader composition without exposing the representation of +`ReaderT.run` to every helper proof. -/ +private theorem reader_bind_state_wf + {I : TcState .anon → Prop} {methods : Methods .anon} + {x : RecM .anon α} {f : α → RecM .anon β} + {Q₁ : α → TcState .anon → Prop} + {Q₂ : β → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (hx : TcM.WF I s (x.run methods) Q₁ E) + (hf : ∀ a after, Q₁ a after → + TcM.WF I after ((f a).run methods) Q₂ E) : + TcM.WF I s ((x >>= f).run methods) Q₂ E := by + rw [ReaderT.run_bind] + exact TcM.WF.bind hx hf + +/-- Fixed-reader form of non-backtracking exception handling. The handler +starts in the body's exact partial post-state. -/ +private theorem reader_tryCatch_state_wf + {I : TcState .anon → Prop} {methods : Methods .anon} + {x : RecM .anon α} {handler : TcError .anon → RecM .anon α} + {Q : α → TcState .anon → Prop} + {E₁ E₂ : TcError .anon → TcState .anon → Prop} + (hx : TcM.WF I s (x.run methods) Q E₁) + (hh : ∀ err after, E₁ err after → + TcM.WF I after ((handler err).run methods) Q E₂) : + TcM.WF I s ((tryCatch x handler).run methods) Q E₂ := by + change TcM.WF I s + (EStateM.tryCatch (x.run methods) + (fun err => (handler err).run methods)) Q E₂ + exact TcM.WF.tryCatch hx hh + +/-- Fixed-reader state rule for the total bounded-loop driver. -/ +private theorem runBounded_state_wf + {I : TcState .anon → Prop} {methods : Methods .anon} + {step : σ → RecM .anon (BoundedStep σ α)} + (hstep : ∀ state s, + TcM.WF I s ((step state).run methods) (fun _ _ => True)) : + ∀ fuel state s, + TcM.WF I s ((runBounded step fuel state).run methods) + (fun _ _ => True) + | 0, state, s => by + rw [runBounded] + exact TcM.WF.throw fun _ => trivial + | fuel + 1, state, s => by + rw [runBounded, ReaderT.run_bind] + apply TcM.WF.bind (hstep state s) + intro action after _ + cases action with + | done result => exact TcM.WF.pure fun _ => trivial + | next next => exact runBounded_state_wf hstep fuel next after + +/-- State preservation for the bounded constructor-field scan used by +`computeIsRec`. -/ +private theorem computeIsRecFields_wf + {I : TcState .anon → Prop} + (hwhnf : WhnfCallbackPreserves I methods) + (blockAddrs : Array Address) : + ∀ fuel ty s, + TcM.WF I s + ((runBounded (fun ty => do + let w ← whnfRec ty + match w with + | .all _ _ dom body _ => + if exprMentionsAnyAddr dom blockAddrs = true then + pure (.done true) + else pure (.next body) + | _ => pure (.done false)) fuel ty).run methods) + (fun _ _ => True) + | 0, ty, s => by + rw [runBounded] + exact TcM.WF.throw fun _ => trivial + | fuel + 1, ty, s => by + rw [runBounded, ReaderT.run_bind] + apply TcM.WF.bind (Q₁ := fun _ _ => True) + · rw [ReaderT.run_bind] + apply TcM.WF.bind (Q₁ := fun _ _ => True) + (Q₂ := fun _ _ => True) (hwhnf ty s) + intro reduced after _ + cases reduced <;> + try exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + case all name bi dom body info => + simp only + split <;> + exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + · intro action after _ + cases action with + | done result => exact TcM.WF.pure fun _ => trivial + | next next => + exact computeIsRecFields_wf hwhnf blockAddrs fuel next after + +/-- List form of the parameter-prefix loop exposed after range normalization. -/ +private theorem computeIsRecParamsList_wf + {I : TcState .anon → Prop} + (hwhnf : WhnfCallbackPreserves I methods) + (indices : List Nat) (ty : KExpr .anon) (s : TcState .anon) : + TcM.WF I s + ((forIn (m := RecM .anon) indices ty (fun _ ty => do + let w ← whnfRec ty + match w with + | .all _ _ _ body _ => pure (ForInStep.yield body) + | _ => pure (ForInStep.done ty))).run methods) + (fun _ _ => True) := by + apply forIn_list_state_wf + intro _ current before + rw [ReaderT.run_bind] + apply TcM.WF.bind (Q₁ := fun _ _ => True) (hwhnf current before) + intro reduced after _ + cases reduced <;> + exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + +/-- The parameter-prefix range loop preserves state whether it peels all +requested foralls or breaks early on a non-forall callback result. -/ +private theorem computeIsRecParams_wf + {I : TcState .anon → Prop} + (hwhnf : WhnfCallbackPreserves I methods) + (range : _root_.Std.Legacy.Range) (ty : KExpr .anon) + (s : TcState .anon) : + TcM.WF I s + ((forIn (m := RecM .anon) range ty (fun _ ty => do + let w ← whnfRec ty + match w with + | .all _ _ _ body _ => pure (ForInStep.yield body) + | _ => pure (ForInStep.done ty))).run methods) + (fun _ _ => True) := by + rw [_root_.Std.Legacy.Range.forIn_eq_forIn_range'] + exact computeIsRecParamsList_wf hwhnf _ ty s + +/-- Finite support closure needed when a verified WHNF result exposes the +body of a declaration telescope. This is deliberately narrower than +constructor closure of the whole run support. -/ +abbrev MajorTelescopeInputSupport := + ScratchTelescopeInputSupport + +/-- Binder-correct public major-inductive scan. Recursive WHNF calls are +instantiated from the predecessor method table at the dynamically extended +context, and the `finally` block restores the exact caller context on every +success or error. -/ +theorem getMajorInductiveId_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : MajorTelescopeInputSupport support) + (hfault : ∀ {Delta : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hreferences : TrustedReferences world support) + {Delta : KVLCtx} {recTy : KExpr .anon} {recTyV : Lean4Lean.VExpr} + {s : TcState .anon} (skip : UInt64) + (hrecSupport : support recTy) + (hrecTr : + TrKExprS world.venv uvars world.nameOf trProj Delta recTy recTyV) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((getMajorInductiveId recTy skip).run methods) + (fun id _ => world.trusted id) := + scratch_getMajorInductiveId_wf hmethods hinputs hfault hreferences skip + hrecSupport hrecTr + +/-- A constant spine head is a direct reference of the complete application +spine. The private worker follows `collectSpine.go` so the proof does not +depend on any reconstruction or array-order lemma. -/ +private theorem collectSpineGo_const_references + {id : KId .anon} {us : Array (KUniv .anon)} + {info : ExprInfo .anon} : + ∀ (e : KExpr .anon) (acc args : Array (KExpr .anon)), + KExpr.collectSpine.go e acc = (.const id us info, args) → + e.References id + | .app f a appInfo, acc, args, h => by + simp only [KExpr.collectSpine.go] at h + exact Or.inl (collectSpineGo_const_references f (acc.push a) args h) + | .const actual actualUs actualInfo, acc, args, h => by + simp only [KExpr.collectSpine.go] at h + cases h + rfl + | .var .., _, _, h + | .fvar .., _, _, h + | .sort .., _, _, h + | .lam .., _, _, h + | .all .., _, _, h + | .letE .., _, _, h + | .prj .., _, _, h + | .nat .., _, _, h + | .str .., _, _, h => by + simp only [KExpr.collectSpine.go] at h + cases h + +/-- Public `collectSpine` form of the direct-head reference lemma. -/ +theorem collectSpine_const_references + {e : KExpr .anon} {id : KId .anon} + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} + (h : e.collectSpine = (.const id us info, args)) : + e.References id := + collectSpineGo_const_references e #[] args h + +/-- Compatibility spelling for callers that emphasize the trusted result. +The binder-correct public theorem already carries that result contract. -/ +theorem getMajorInductiveId_trusted_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : MajorTelescopeInputSupport support) + (hfault : ∀ {Delta : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hreferences : TrustedReferences world support) + {Delta : KVLCtx} {recTy : KExpr .anon} {recTyV : Lean4Lean.VExpr} + {s : TcState .anon} (skip : UInt64) + (hrecSupport : support recTy) + (hrecTr : + TrKExprS world.venv uvars world.nameOf trProj Delta recTy recTyV) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((getMajorInductiveId recTy skip).run methods) + (fun id _ => world.trusted id) := + getMajorInductiveId_wf hmethods hinputs hfault hreferences skip hrecSupport + hrecTr + +/-- The production mutual-block census preserves an arbitrary invariant on +hits, misses, and lazy-ingress errors. The returned array deliberately has +no semantic postcondition yet; this theorem owns only concrete state effects. -/ +theorem discoverBlockInductives_wf + {I : TcState .anon → Prop} (hfault : TcM.LazyFaultPreserves I) + (methods : Methods .anon) (blockId : KId .anon) (s : TcState .anon) : + TcM.WF I s ((discoverBlockInductives blockId).run methods) + (fun _ _ => True) := by + rw [discoverBlockInductives_equation, ReaderT.run_bind, + ReaderT.run_monadLift] + apply TcM.WF.bind (TcM.tryGetBlock_wf hfault blockId s) + intro found after _ + cases found with + | none => exact TcM.WF.pure fun _ => trivial + | some members => + simp + rw [← Array.forIn_toList] + generalize members.toList = ids + generalize (#[] : Array (KId .anon)) = acc + induction ids generalizing acc after with + | nil => + simpa using + (TcM.WF.pure (I := I) (s := after) (a := acc) + (fun _ => trivial)) + | cons id ids ih => + rw [List.forIn_cons, ReaderT.run_bind] + apply TcM.WF.bind (Q₁ := fun _ _ => True) + · rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind (TcM.tryGetConst_wf hfault id after) + intro found afterLookup _ + cases found with + | none => exact TcM.WF.pure fun _ => trivial + | some c => + cases c <;> exact TcM.WF.pure fun _ => trivial + · intro step afterStep _ + cases step with + | done next => exact TcM.WF.pure fun _ => trivial + | yield next => exact ih afterStep next + +/-- `computeIsRec` preserves the exact caller context while scanning every +constructor telescope. Each successful constructor lookup is tied to its +finite, typed admission input; the binder-aware inner theorem restores the +caller's context on success and on partial errors. -/ +theorem computeIsRec_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ConstructorTelescopeInputSupport support) + (hctorInputs : ConstructorTelescopeInputOracle trProj world support) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (ctors : Array (KId .anon)) (nParams : Nat) + (blockAddrs : Array Address) (s : TcState .anon) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((computeIsRec ctors nParams blockAddrs).run methods) + (fun _ _ => True) := by + unfold computeIsRec + simp + apply TcM.WF.bind (Q₁ := fun _ _ => True) + · rw [← Array.forIn_toList] + apply forIn_list_state_wf + intro ctorId acc before + rw [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (Q₁ := fun found after => + TcM.tryGetConst ctorId before = .ok found after) + (TcM.WF.mono + (TcM.WF.with_run_eq + (TcM.tryGetConst_wf hfault ctorId before)) + (fun _ _ h => h.2) (fun _ _ _ => trivial)) + intro found afterLookup hlookup + cases found with + | none => exact TcM.WF.pure fun _ => trivial + | some c => + cases c <;> + try exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + case ctor name levelParams isUnsafe lvls induct cidx params fields ty => + simp only + rw [ReaderT.run_bind] + obtain ⟨htySupport, tyV, htyTr⟩ := + hctorInputs.found (uvars := uvars) (Delta := Delta) hlookup + apply TcM.WF.bind + (scratch_computeIsRecCtor_wf hmethods hinputs nParams blockAddrs + htySupport htyTr) + intro found afterCtor _ + cases found <;> simp <;> + exact TcM.WF.pure (Q := fun _ _ => True) (fun _ => trivial) + · intro result after _ + rcases result with ⟨answer, _marker⟩ + cases answer with + | none => + simp only + simpa only [ReaderT.run] using + (TcM.WF.pure + (I := WhnfStateInv layer semantics trProj world support uvars Delta) + (s := after) + (Q := fun _ _ => True) (fun _ => trivial)) + | some value => + simp only + simpa only [ReaderT.run] using + (TcM.WF.pure + (I := WhnfStateInv layer semantics trProj world support uvars Delta) + (s := after) + (Q := fun _ _ => True) (fun _ => trivial)) + +/-- One named recursion-cache write preserves the fixed-world invariant when +its exact value has semantic provenance. -/ +theorem cacheIsRec_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {ind : KId .anon} {value : Bool} {s : TcState .anon} + (hwrite : CacheProvenance semantics (CacheAuthority.stable world) support + (.isRec ind.addr value)) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((cacheIsRec ind value).run methods) (fun _ _ => True) := by + unfold cacheIsRec + exact TcM.WF.modifyGet + (fun hI => IsRecCacheUpdate.insert_whnfStateInv hI hwrite) + (fun _ => trivial) + +/-- The named cleanup seam removes only the selected recursion entry and +therefore needs no replacement certificate. -/ +theorem eraseCachedIsRec_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {ind : KId .anon} {s : TcState .anon} : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((eraseCachedIsRec ind).run methods) (fun _ _ => True) := by + unfold eraseCachedIsRec + exact TcM.WF.modifyGet + (fun hI => IsRecCacheUpdate.erase_whnfStateInv hI) + (fun _ => trivial) + +/-- The classifier transaction commits the value produced by the exact +`computeIsRec` execution. If that execution throws, cleanup starts from its +partial post-state, erases the provisional marker, and rethrows. -/ +theorem computedIsRecClassify_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {ind : KId .anon} {ctors : Array (KId .anon)} {nParams : Nat} + {blockAddrs : Array Address} {s : TcState .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ConstructorTelescopeInputSupport support) + (hctorInputs : ConstructorTelescopeInputOracle trProj world support) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hwrites : IsRecCacheWriteOracle semantics world support methods ind) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((computedIsRecClassify ind ctors nParams blockAddrs).run methods) + (fun _ _ => True) := by + unfold computedIsRecClassify + apply reader_tryCatch_state_wf (E₁ := fun _ _ => True) + · rw [ReaderT.run_bind] + apply TcM.WF.bind + (Q₁ := fun value after => + True ∧ + (computeIsRec ctors nParams blockAddrs).run methods s = + .ok value after) + (TcM.WF.mono + (wf_with_run_eq + (computeIsRec_wf hmethods hinputs hctorInputs hfault + ctors nParams blockAddrs s)) + (fun _ _ h => h) (fun _ _ _ => trivial)) + intro value afterCompute hcompute + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cacheIsRec_wf (methods := methods) (s := afterCompute) + (hwrites.computed hcompute.2)) + intro _ afterWrite _ + exact TcM.WF.pure fun _ => trivial + · intro err afterError _ + rw [ReaderT.run_bind] + apply TcM.WF.bind + (eraseCachedIsRec_wf (methods := methods) (ind := ind) + (s := afterError)) + intro _ afterErase _ + exact TcM.WF.throw (fun _ => trivial) + +/-- Cache-miss state preservation follows production's exact transaction +boundary: the provisional marker precedes block discovery, so discovery +errors retain it; only classifier errors enter `computedIsRecClassify`'s +cleanup handler. -/ +theorem computedIsRecMiss_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {ind : KId .anon} {params : UInt64} {ctors : Array (KId .anon)} + {block : KId .anon} {s : TcState .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ConstructorTelescopeInputSupport support) + (hctorInputs : ConstructorTelescopeInputOracle trProj world support) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hwrites : IsRecCacheWriteOracle semantics world support methods ind) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((computedIsRecMiss ind params ctors block).run methods) + (fun _ _ => True) := by + unfold computedIsRecMiss + rw [ReaderT.run_bind] + apply TcM.WF.bind + (cacheIsRec_wf (methods := methods) (s := s) hwrites.provisional) + intro _ afterProvisional _ + rw [ReaderT.run_bind] + apply TcM.WF.bind + (discoverBlockInductives_wf hfault methods block afterProvisional) + intro blockInds afterDiscovery _ + exact computedIsRecClassify_wf hmethods hinputs hctorInputs hfault hwrites + +/-- The complete cached recursion classifier preserves the fixed-world WHNF +invariant on cache hits, lazy lookup failures, non-inductive errors, +block-discovery failures, successful classification, and caught classifier +errors. -/ +theorem computedIsRec_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {ind : KId .anon} {s : TcState .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ConstructorTelescopeInputSupport support) + (hctorInputs : ConstructorTelescopeInputOracle trProj world support) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hwrites : IsRecCacheWriteOracle semantics world support methods ind) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((computedIsRec ind).run methods) (fun _ _ => True) := by + unfold computedIsRec + rw [ReaderT.run_bind] + apply TcM.WF.bind + (Q₁ := fun observed after => observed = after) + (TcM.WF.get fun _ => rfl) + intro observed afterRead hread + subst observed + cases hcache : afterRead.env.isRecCache[ind.addr]? with + | some value => + simp only + exact TcM.WF.pure fun _ => trivial + | none => + simp only [pure_bind] + rw [ReaderT.run_bind, ReaderT.run_monadLift] + change TcM.WF _ afterRead (TcM.getConst ind >>= _) _ + apply TcM.WF.bind (TcM.getConst_wf hfault ind afterRead) + intro entry afterLookup _ + cases entry with + | defn => + simp only [ReaderT.run] + exact TcM.WF.throw (fun _ => trivial) + | recr => + simp only [ReaderT.run] + exact TcM.WF.throw (fun _ => trivial) + | axio => + simp only [ReaderT.run] + exact TcM.WF.throw (fun _ => trivial) + | quot => + simp only [ReaderT.run] + exact TcM.WF.throw (fun _ => trivial) + | ctor => + simp only [ReaderT.run] + exact TcM.WF.throw (fun _ => trivial) + | indc name levelParams lvls params indices isUnsafe block memberIdx + ty ctors leanAll => + simpa only [ReaderT.run] using + (computedIsRecMiss_wf (s := afterLookup) hmethods hinputs + hctorInputs hfault hwrites) + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/StructEta/ScopedClassifier.lean b/Ix/Tc/Verify/Whnf/StructEta/ScopedClassifier.lean new file mode 100644 index 000000000..1e0a0fc13 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/StructEta/ScopedClassifier.lean @@ -0,0 +1,491 @@ +import Ix.Tc.Verify.Whnf.StructEta.ScopedTelescope + +/-! +# Scoped recursion-classifier steps + +This module lifts the scoped telescope invariant through the individual +classifier callbacks and bounded iteration steps. It records both successful +results and partial-error states before the complete classifier loop is +assembled. +-/ + +namespace Ix.Tc +namespace RecM + +def ScratchScopedForInStep + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (base : KVLCtx) : + ForInStep (KExpr .anon) → TcState .anon → Prop + | .done e, s + | .yield e, s => + ScratchScopedExpr layer semantics trProj world support uvars base e s + +def ScratchScopedBoundedStep + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (base : KVLCtx) : + BoundedStep (KExpr .anon) Bool → TcState .anon → Prop + | .done _, s => + ScratchScopedState layer semantics trProj world support uvars base s + | .next e, s => + ScratchScopedExpr layer semantics trProj world support uvars base e s + +theorem scratch_computeIsRecParamStep_run + (ty : KExpr .anon) (methods : Methods .anon) (s : TcState .anon) : + (computeIsRecParamStep ty).run methods s = + (methods.whnf ty >>= fun reduced => + (computeIsRecParamStepAfterWhnf ty reduced).run methods) s := by + have hwhnf : + (whnfRec ty).run methods = methods.whnf ty := by + funext state + exact whnfRec_run ty methods state + rw [computeIsRecParamStep, ReaderT.run_bind, hwhnf] + +theorem scratch_computeIsRecParamStep_scoped + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ScratchTelescopeInputSupport support) + {base : KVLCtx} {n : Nat} {current : KVLCtx} + {ty : KExpr .anon} {tyV : Lean4Lean.VExpr} {s : TcState .anon} + (hExtension : ScratchLamExtension base n current) + (hsupport : support ty) + (htr : TrKExprS world.venv uvars world.nameOf trProj current ty tyV) + (hI : WhnfStateInv layer semantics trProj world support uvars current s) : + match (computeIsRecParamStep ty).run methods s with + | .ok step after => + ScratchScopedForInStep layer semantics trProj world support uvars base + step after + | .error _ after => + ScratchScopedState layer semantics trProj world support uvars base + after := by + have hcallback := hmethods.whnf hsupport htr hI + cases hrun : methods.whnf ty s with + | error err after => + rw [hrun] at hcallback + have hwhole : + (computeIsRecParamStep ty).run methods s = .error err after := by + rw [scratch_computeIsRecParamStep_run] + exact scratch_bind_error hrun + rw [hwhole] + exact ⟨n, current, hExtension, hcallback.1⟩ + | ok reduced after => + rw [hrun] at hcallback + cases reduced + case all name bi dom body info => + obtain ⟨resultV, hresultTr, _⟩ := hcallback.2.2 + cases hresultTr with + | all hdomType hbodyType hdomTr hbodyTr => + obtain ⟨afterPush, hpush⟩ := scratch_pushLocal_ok dom after + have hPushI := + scratch_pushLocal_inv hcallback.1 hdomTr hdomType hpush + have hwhole : + (computeIsRecParamStep ty).run methods s = + .ok (.yield body) afterPush := by + rw [scratch_computeIsRecParamStep_run, scratch_bind_ok hrun, + computeIsRecParamStepAfterWhnf, ReaderT.run_bind, + ReaderT.run_monadLift, monadLift_self, scratch_bind_ok hpush] + rfl + rw [hwhole] + exact ⟨n + 1, _, _, .succ hExtension, hPushI, + hinputs.body hcallback.2.1, hbodyTr⟩ + all_goals + have hwhole : + (computeIsRecParamStep ty).run methods s = + .ok (.done ty) after := by + rw [scratch_computeIsRecParamStep_run, scratch_bind_ok hrun] + simp [computeIsRecParamStepAfterWhnf] + rw [hwhole] + exact ⟨n, current, tyV, hExtension, hcallback.1, hsupport, htr⟩ + +theorem scratch_computeIsRecFieldStep_run + (blockAddrs : Array Address) (ty : KExpr .anon) + (methods : Methods .anon) (s : TcState .anon) : + (computeIsRecFieldStep blockAddrs ty).run methods s = + (methods.whnf ty >>= fun reduced => + (computeIsRecFieldStepAfterWhnf blockAddrs reduced).run methods) s := by + have hwhnf : + (whnfRec ty).run methods = methods.whnf ty := by + funext state + exact whnfRec_run ty methods state + rw [computeIsRecFieldStep, ReaderT.run_bind, hwhnf] + +theorem scratch_computeIsRecFieldStep_scoped + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ScratchTelescopeInputSupport support) + {base : KVLCtx} {n : Nat} {current : KVLCtx} + {blockAddrs : Array Address} + {ty : KExpr .anon} {tyV : Lean4Lean.VExpr} {s : TcState .anon} + (hExtension : ScratchLamExtension base n current) + (hsupport : support ty) + (htr : TrKExprS world.venv uvars world.nameOf trProj current ty tyV) + (hI : WhnfStateInv layer semantics trProj world support uvars current s) : + match (computeIsRecFieldStep blockAddrs ty).run methods s with + | .ok step after => + ScratchScopedBoundedStep layer semantics trProj world support uvars base + step after + | .error _ after => + ScratchScopedState layer semantics trProj world support uvars base + after := by + have hcallback := hmethods.whnf hsupport htr hI + cases hrun : methods.whnf ty s with + | error err after => + rw [hrun] at hcallback + have hwhole : + (computeIsRecFieldStep blockAddrs ty).run methods s = + .error err after := by + rw [scratch_computeIsRecFieldStep_run] + exact scratch_bind_error hrun + rw [hwhole] + exact ⟨n, current, hExtension, hcallback.1⟩ + | ok reduced after => + rw [hrun] at hcallback + cases reduced + case all name bi dom body info => + obtain ⟨resultV, hresultTr, _⟩ := hcallback.2.2 + cases hresultTr with + | all hdomType hbodyType hdomTr hbodyTr => + cases hmentions : exprMentionsAnyAddr dom blockAddrs with + | false => + obtain ⟨afterPush, hpush⟩ := scratch_pushLocal_ok dom after + have hPushI := + scratch_pushLocal_inv hcallback.1 hdomTr hdomType hpush + have hwhole : + (computeIsRecFieldStep blockAddrs ty).run methods s = + .ok (.next body) afterPush := by + rw [scratch_computeIsRecFieldStep_run, scratch_bind_ok hrun, + computeIsRecFieldStepAfterWhnf, hmentions] + simp only [Bool.false_eq_true, if_false, pure_bind] + rw [ReaderT.run_bind, ReaderT.run_monadLift, monadLift_self, + scratch_bind_ok hpush] + rfl + rw [hwhole] + exact ⟨n + 1, _, _, .succ hExtension, hPushI, + hinputs.body hcallback.2.1, hbodyTr⟩ + | true => + have hwhole : + (computeIsRecFieldStep blockAddrs ty).run methods s = + .ok (.done true) after := by + rw [scratch_computeIsRecFieldStep_run, scratch_bind_ok hrun] + simp [computeIsRecFieldStepAfterWhnf, hmentions] + rw [hwhole] + exact ⟨n, current, hExtension, hcallback.1⟩ + all_goals + have hwhole : + (computeIsRecFieldStep blockAddrs ty).run methods s = + .ok (.done false) after := by + rw [scratch_computeIsRecFieldStep_run, scratch_bind_ok hrun] + simp [computeIsRecFieldStepAfterWhnf] + rw [hwhole] + exact ⟨n, current, hExtension, hcallback.1⟩ + +theorem scratch_computeIsRecParams_scoped + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ScratchTelescopeInputSupport support) + {base : KVLCtx} : + ∀ (indices : List Nat) {n current ty s tyV}, + ScratchLamExtension base n current → + support ty → + TrKExprS world.venv uvars world.nameOf trProj current ty tyV → + WhnfStateInv layer semantics trProj world support uvars current s → + match + (forIn (m := RecM .anon) indices ty + (fun _ ty => computeIsRecParamStep ty)).run methods s + with + | .ok result after => + ScratchScopedExpr layer semantics trProj world support uvars base + result after + | .error _ after => + ScratchScopedState layer semantics trProj world support uvars base + after + | [], n, current, ty, s, tyV, hExtension, hsupport, htr, hI => by + rw [List.forIn_nil] + exact ⟨n, current, tyV, hExtension, hI, hsupport, htr⟩ + | index :: indices, n, current, ty, s, tyV, hExtension, hsupport, htr, hI => by + have hstep := + scratch_computeIsRecParamStep_scoped hmethods hinputs hExtension + hsupport htr hI + cases hrun : (computeIsRecParamStep ty).run methods s with + | error err after => + rw [hrun] at hstep + have hwhole : + (forIn (m := RecM .anon) (index :: indices) ty + (fun _ ty => computeIsRecParamStep ty)).run methods s = + .error err after := by + rw [List.forIn_cons, ReaderT.run_bind] + exact scratch_bind_error hrun + rw [hwhole] + exact hstep + | ok action after => + rw [hrun] at hstep + cases action with + | done result => + have hwhole : + (forIn (m := RecM .anon) (index :: indices) ty + (fun _ ty => computeIsRecParamStep ty)).run methods s = + .ok result after := by + rw [List.forIn_cons, ReaderT.run_bind, + scratch_bind_ok hrun] + rfl + rw [hwhole] + exact hstep + | yield next => + obtain ⟨nextN, nextCurrent, nextV, nextExtension, hAfter, + hnextSupport, hnextTr⟩ := hstep + have htail := + scratch_computeIsRecParams_scoped hmethods hinputs indices + nextExtension hnextSupport hnextTr hAfter + cases htailRun : + (forIn (m := RecM .anon) indices next + (fun _ ty => computeIsRecParamStep ty)).run methods after with + | error tailErr final => + rw [htailRun] at htail + have hwhole : + (forIn (m := RecM .anon) (index :: indices) ty + (fun _ ty => computeIsRecParamStep ty)).run methods s = + .error tailErr final := by + rw [List.forIn_cons, ReaderT.run_bind, + scratch_bind_ok hrun] + exact htailRun + rw [hwhole] + exact htail + | ok result final => + rw [htailRun] at htail + have hwhole : + (forIn (m := RecM .anon) (index :: indices) ty + (fun _ ty => computeIsRecParamStep ty)).run methods s = + .ok result final := by + rw [List.forIn_cons, ReaderT.run_bind, + scratch_bind_ok hrun] + exact htailRun + rw [hwhole] + exact htail + +theorem scratch_computeIsRecFields_scoped + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ScratchTelescopeInputSupport support) + {base : KVLCtx} {blockAddrs : Array Address} : + ∀ fuel {n current ty s tyV}, + ScratchLamExtension base n current → + support ty → + TrKExprS world.venv uvars world.nameOf trProj current ty tyV → + WhnfStateInv layer semantics trProj world support uvars current s → + match + (runBounded (computeIsRecFieldStep blockAddrs) fuel ty).run methods s + with + | .ok _ after => + ScratchScopedState layer semantics trProj world support uvars base + after + | .error _ after => + ScratchScopedState layer semantics trProj world support uvars base + after + | 0, n, current, ty, s, tyV, hExtension, hsupport, htr, hI => by + rw [runBounded] + exact ⟨n, current, hExtension, hI⟩ + | fuel + 1, n, current, ty, s, tyV, hExtension, hsupport, htr, hI => by + have hstep := + scratch_computeIsRecFieldStep_scoped (blockAddrs := blockAddrs) + hmethods hinputs hExtension hsupport htr hI + cases hrun : + (computeIsRecFieldStep blockAddrs ty).run methods s with + | error err after => + rw [hrun] at hstep + have hwhole : + (runBounded (computeIsRecFieldStep blockAddrs) (fuel + 1) ty).run + methods s = + .error err after := by + rw [runBounded, ReaderT.run_bind] + exact scratch_bind_error hrun + rw [hwhole] + exact hstep + | ok action after => + rw [hrun] at hstep + cases action with + | done result => + have hwhole : + (runBounded (computeIsRecFieldStep blockAddrs) (fuel + 1) + ty).run methods s = + .ok result after := by + rw [runBounded, ReaderT.run_bind, scratch_bind_ok hrun] + rfl + rw [hwhole] + exact hstep + | next next => + obtain ⟨nextN, nextCurrent, nextV, nextExtension, hAfter, + hnextSupport, hnextTr⟩ := hstep + have htail := + scratch_computeIsRecFields_scoped (blockAddrs := blockAddrs) + hmethods hinputs fuel nextExtension hnextSupport hnextTr hAfter + cases htailRun : + (runBounded (computeIsRecFieldStep blockAddrs) fuel next).run + methods after with + | error tailErr final => + rw [htailRun] at htail + have hwhole : + (runBounded (computeIsRecFieldStep blockAddrs) (fuel + 1) + ty).run methods s = + .error tailErr final := by + rw [runBounded, ReaderT.run_bind, + scratch_bind_ok hrun] + exact htailRun + rw [hwhole] + exact htail + | ok result final => + rw [htailRun] at htail + have hwhole : + (runBounded (computeIsRecFieldStep blockAddrs) (fuel + 1) + ty).run methods s = + .ok result final := by + rw [runBounded, ReaderT.run_bind, + scratch_bind_ok hrun] + exact htailRun + rw [hwhole] + exact htail + +theorem scratch_computeIsRecCtorBody_scoped + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ScratchTelescopeInputSupport support) + {base : KVLCtx} {ctorTy : KExpr .anon} + {ctorTyV : Lean4Lean.VExpr} {s : TcState .anon} + (nParams : Nat) (blockAddrs : Array Address) + (hctorSupport : support ctorTy) + (hctorTr : + TrKExprS world.venv uvars world.nameOf trProj base ctorTy ctorTyV) + (hI : WhnfStateInv layer semantics trProj world support uvars base s) : + match + ((do + let ty ← forIn [0:nParams] ctorTy fun _ ty => + computeIsRecParamStep ty + runBounded (computeIsRecFieldStep blockAddrs) maxWhnfFuel.toNat ty) : + RecM .anon Bool).run methods s + with + | .ok _ after => + ScratchScopedState layer semantics trProj world support uvars base after + | .error _ after => + ScratchScopedState layer semantics trProj world support uvars base after := by + rw [_root_.Std.Legacy.Range.forIn_eq_forIn_range'] + have hparams := + scratch_computeIsRecParams_scoped hmethods hinputs + (List.range' + ([0:nParams] : _root_.Std.Legacy.Range).start + ([0:nParams] : _root_.Std.Legacy.Range).size + ([0:nParams] : _root_.Std.Legacy.Range).step) + (ScratchLamExtension.zero (base := base)) hctorSupport hctorTr hI + cases hparamsRun : + (forIn (m := RecM .anon) + (List.range' + ([0:nParams] : _root_.Std.Legacy.Range).start + ([0:nParams] : _root_.Std.Legacy.Range).size + ([0:nParams] : _root_.Std.Legacy.Range).step) + ctorTy + (fun _ ty => computeIsRecParamStep ty)).run methods s with + | error err after => + rw [hparamsRun] at hparams + rw [ReaderT.run_bind, scratch_bind_error hparamsRun] + exact hparams + | ok ty after => + rw [hparamsRun] at hparams + obtain ⟨n, current, tyV, hExtension, hAfter, htySupport, htyTr⟩ := + hparams + have hfields := + scratch_computeIsRecFields_scoped (blockAddrs := blockAddrs) + hmethods hinputs maxWhnfFuel.toNat hExtension htySupport htyTr hAfter + cases hfieldsRun : + (runBounded (computeIsRecFieldStep blockAddrs) maxWhnfFuel.toNat + ty).run methods after with + | error err final => + rw [hfieldsRun] at hfields + rw [ReaderT.run_bind, scratch_bind_ok hparamsRun, hfieldsRun] + exact hfields + | ok result final => + rw [hfieldsRun] at hfields + rw [ReaderT.run_bind, scratch_bind_ok hparamsRun, hfieldsRun] + exact hfields + +theorem scratch_computeIsRecCtor_run + (ctorTy : KExpr .anon) (nParams : Nat) + (blockAddrs : Array Address) (methods : Methods .anon) + (s : TcState .anon) : + (computeIsRecCtor ctorTy nParams blockAddrs).run methods s = + tryFinally + (((do + let ty ← forIn [0:nParams] ctorTy fun _ ty => + computeIsRecParamStep ty + runBounded (computeIsRecFieldStep blockAddrs) + maxWhnfFuel.toNat ty) : RecM .anon Bool).run methods) + (TcM.restoreDepth s.ctx.size) s := by + rfl + +theorem scratch_computeIsRecCtor_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ScratchTelescopeInputSupport support) + {Delta : KVLCtx} {ctorTy : KExpr .anon} + {ctorTyV : Lean4Lean.VExpr} {s : TcState .anon} + (nParams : Nat) (blockAddrs : Array Address) + (hctorSupport : support ctorTy) + (hctorTr : + TrKExprS world.venv uvars world.nameOf trProj Delta ctorTy ctorTyV) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((computeIsRecCtor ctorTy nParams blockAddrs).run methods) + (fun _ _ => True) := by + intro hI + have hbody := + scratch_computeIsRecCtorBody_scoped hmethods hinputs nParams blockAddrs + hctorSupport hctorTr hI + cases hbodyRun : + ((do + let ty ← forIn [0:nParams] ctorTy fun _ ty => + computeIsRecParamStep ty + runBounded (computeIsRecFieldStep blockAddrs) + maxWhnfFuel.toNat ty) : RecM .anon Bool).run methods s with + | ok result after => + rw [hbodyRun] at hbody + obtain ⟨n, current, hExtension, hAfter⟩ := hbody + obtain ⟨final, hrestore, hFinal⟩ := + scratch_restoreDepth hI hExtension hAfter + have hrun : + (computeIsRecCtor ctorTy nParams blockAddrs).run methods s = + .ok result final := by + rw [scratch_computeIsRecCtor_run] + exact scratch_tryFinally_ok hbodyRun hrestore + rw [hrun] + exact ⟨hFinal, trivial⟩ + | error err after => + rw [hbodyRun] at hbody + obtain ⟨n, current, hExtension, hAfter⟩ := hbody + obtain ⟨final, hrestore, hFinal⟩ := + scratch_restoreDepth hI hExtension hAfter + have hrun : + (computeIsRecCtor ctorTy nParams blockAddrs).run methods s = + .error err final := by + rw [scratch_computeIsRecCtor_run] + exact scratch_tryFinally_error hbodyRun hrestore + rw [hrun] + exact ⟨hFinal, trivial⟩ + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/StructEta/ScopedTelescope.lean b/Ix/Tc/Verify/Whnf/StructEta/ScopedTelescope.lean new file mode 100644 index 000000000..f79a86159 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/StructEta/ScopedTelescope.lean @@ -0,0 +1,713 @@ +import Ix.Tc.Verify.Whnf.StructEta.CallbackPrefix + +/-! +# Scoped telescope state + +This module verifies the local telescope operations used while classifying +recursive structure parameters. Push, pop, and restoration preserve the +ambient WHNF state invariant while tracking the temporary lambda extension +of the caller's context. +-/ + +namespace Ix.Tc + +theorem scratch_pushLocal_run + {ty : KExpr .anon} {s s' : TcState .anon} + (hrun : TcM.pushLocal ty s = .ok () s') : + s'.env = s.env ∧ + s'.ctx = s.ctx.push ty ∧ + s'.letVals = s.letVals.push none ∧ + s'.numLetBindings = s.numLetBindings ∧ + s'.lctx = s.lctx ∧ + s'.prims = s.prims ∧ + s'.noAccel = s.noAccel ∧ + s'.equivManager = s.equivManager := by + simp only [TcM.pushLocal, EStateM.bind, get, set, pure] at hrun + cases hrun + exact ⟨rfl, rfl, rfl, rfl, rfl, rfl, rfl, rfl⟩ + +theorem scratch_pushLocal_ok (ty : KExpr .anon) (s : TcState .anon) : + ∃ after, TcM.pushLocal ty s = .ok () after := by + unfold TcM.pushLocal + exact ⟨_, rfl⟩ + +theorem scratch_pushLocal_inv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s s' : TcState .anon} + {ty : KExpr .anon} {tyV : Lean4Lean.VExpr} + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) + (htr : TrKExprS world.venv uvars world.nameOf trProj Delta ty tyV) + (htype : world.venv.IsType uvars Delta.toCtx tyV) + (hrun : TcM.pushLocal ty s = .ok () s') : + WhnfStateInv layer semantics trProj world support uvars + ((none, .vlam tyV) :: Delta) s' := by + obtain ⟨henv, hctx, hlet, hnum, hlctx, hprims, hnoAccel, hequiv⟩ := + scratch_pushLocal_run hrun + refine ⟨?_, ?_, ?_⟩ + · exact { + core := hI.1.core.of_env_eq henv + internSupport := by simpa only [henv] using hI.1.internSupport + caches := by simpa only [henv] using hI.1.caches + equivalences := by simpa only [hequiv] using hI.1.equivalences } + · exact hI.2.1.pushLocal htr htype hctx hlet hnum hlctx (by simp [henv]) + · cases layer with + | structuralNoAccel => + simpa only [WhnfLayer.StateOK, hnoAccel] using hI.2.2 + | noAccel => + simpa only [WhnfLayer.StateOK, hprims, hnoAccel] using hI.2.2 + | accelerated => + simpa only [WhnfLayer.StateOK, hprims] using hI.2.2 + +theorem scratch_lam_back + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {s : TcState .anon} {Delta : KVLCtx} {tyV : Lean4Lean.VExpr} + (h : CtxRecon env uvars nameOf trProj s + ((none, .vlam tyV) :: Delta)) : + s.letVals.back? = some none := by + obtain ⟨ty, bs, hbs, _⟩ := h.recon.bvar_lam_inv + have hmap := congrArg (List.map Prod.snd) hbs + rw [List.map_reverse, + List.map_snd_zip (by simpa [h.size_eq])] at hmap + have hhead := congrArg List.head? hmap + simpa only [List.head?_reverse, List.head?_cons, + Array.getLast?_toList] using hhead + +theorem scratch_popLocal_run + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {s s' : TcState .anon} {Delta : KVLCtx} {tyV : Lean4Lean.VExpr} + (hctxRecon : CtxRecon env uvars nameOf trProj s + ((none, .vlam tyV) :: Delta)) + (hrun : TcM.popLocal s = .ok () s') : + s'.env = s.env ∧ + s'.ctx = s.ctx.pop ∧ + s'.letVals = s.letVals.pop ∧ + s'.numLetBindings = s.numLetBindings ∧ + s'.lctx = s.lctx ∧ + s'.prims = s.prims ∧ + s'.noAccel = s.noAccel ∧ + s'.equivManager = s.equivManager := by + have hback := scratch_lam_back hctxRecon + simp only [TcM.popLocal, EStateM.bind, get, set, pure, hback] at hrun + cases hrun + refine ⟨rfl, rfl, rfl, ?_, rfl, rfl, rfl, rfl⟩ + simp only [hback] + +theorem scratch_popLocal_ok (s : TcState .anon) : + ∃ after, TcM.popLocal s = .ok () after := by + unfold TcM.popLocal + exact ⟨_, rfl⟩ + +theorem scratch_popLocal_inv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s s' : TcState .anon} + {tyV : Lean4Lean.VExpr} + (hI : WhnfStateInv layer semantics trProj world support uvars + ((none, .vlam tyV) :: Delta) s) + (hrun : TcM.popLocal s = .ok () s') : + WhnfStateInv layer semantics trProj world support uvars Delta s' := by + obtain ⟨henv, hctx, hlet, hnum, hlctx, hprims, hnoAccel, hequiv⟩ := + scratch_popLocal_run hI.2.1 hrun + refine ⟨?_, ?_, ?_⟩ + · exact { + core := hI.1.core.of_env_eq henv + internSupport := by simpa only [henv] using hI.1.internSupport + caches := by simpa only [henv] using hI.1.caches + equivalences := by simpa only [hequiv] using hI.1.equivalences } + · exact hI.2.1.pop_lam hctx hlet hnum hlctx (by simp [henv]) + · cases layer with + | structuralNoAccel => + simpa only [WhnfLayer.StateOK, hnoAccel] using hI.2.2 + | noAccel => + simpa only [WhnfLayer.StateOK, hprims, hnoAccel] using hI.2.2 + | accelerated => + simpa only [WhnfLayer.StateOK, hprims] using hI.2.2 + +inductive ScratchLamExtension (base : KVLCtx) : Nat → KVLCtx → Prop + | zero : ScratchLamExtension base 0 base + | succ {n : Nat} {current : KVLCtx} {tyV : Lean4Lean.VExpr} : + ScratchLamExtension base n current → + ScratchLamExtension base (n + 1) ((none, .vlam tyV) :: current) + +namespace ScratchLamExtension + +theorem bvars {base : KVLCtx} : + ∀ {n current}, ScratchLamExtension base n current → + current.bvars = base.bvars + n + | _, _, .zero => rfl + | _, _, .succ h => by + simp only [KVLCtx.bvars, bvars h] + omega + +end ScratchLamExtension + +theorem scratch_restoreDepth_go + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars saved : Nat} {base : KVLCtx} + (hbase : base.bvars = saved) + {n current s} + (hExtension : ScratchLamExtension base n current) + (hI : WhnfStateInv layer semantics trProj world support uvars current s) : + ∃ final, + TcM.restoreDepth.go (m := .anon) saved n s = .ok () final ∧ + WhnfStateInv layer semantics trProj world support uvars base final := by + induction hExtension generalizing s with + | zero => exact ⟨_, rfl, hI⟩ + | @succ n current tyV hExtension ih => + have hgt : s.ctx.size > saved := by + rw [← hI.2.1.bvars_eq, ScratchLamExtension.bvars (.succ hExtension), + hbase] + omega + cases hpop : TcM.popLocal s with + | error err after => + obtain ⟨actual, hactual⟩ := scratch_popLocal_ok s + rw [hpop] at hactual + contradiction + | ok value after => + cases value + have hAfter := scratch_popLocal_inv hI hpop + obtain ⟨final, hgo, hFinal⟩ := + ih hAfter + refine ⟨final, ?_, hFinal⟩ + rw [TcM.restoreDepth.go.eq_2] + change EStateM.bind (get : TcM .anon (TcState .anon)) + (fun observed => + if observed.ctx.size > saved then do + TcM.popLocal + TcM.restoreDepth.go saved n + else pure ()) s = .ok () final + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only [hgt, if_true] + change EStateM.bind TcM.popLocal + (fun _ => TcM.restoreDepth.go saved n) s = .ok () final + unfold EStateM.bind + rw [hpop] + simp only + exact hgo + +theorem scratch_restoreDepth + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {base current : KVLCtx} {n : Nat} + {initial s : TcState .anon} + (hInitial : WhnfStateInv layer semantics trProj world support uvars + base initial) + (hExtension : ScratchLamExtension base n current) + (hI : WhnfStateInv layer semantics trProj world support uvars current s) : + ∃ final, + TcM.restoreDepth (m := .anon) initial.ctx.size s = .ok () final ∧ + WhnfStateInv layer semantics trProj world support uvars base final := by + have hbase : base.bvars = initial.ctx.size := hInitial.2.1.bvars_eq + have hcurrent : s.ctx.size - initial.ctx.size = n := by + rw [← hI.2.1.bvars_eq, ScratchLamExtension.bvars hExtension, hbase] + omega + obtain ⟨final, hgo, hFinal⟩ := + scratch_restoreDepth_go hbase hExtension hI + refine ⟨final, ?_, hFinal⟩ + unfold TcM.restoreDepth + change TcM.restoreDepth.go initial.ctx.size + (s.ctx.size - initial.ctx.size) s = .ok () final + rw [hcurrent, hgo] + +theorem scratch_bind_ok + {ε σ α β : Type} {x : EStateM ε σ α} {f : α → EStateM ε σ β} + {s after : σ} {value : α} + (hrun : x s = .ok value after) : + (x >>= f) s = f value after := by + change EStateM.bind x f s = f value after + unfold EStateM.bind + rw [hrun] + +theorem scratch_bind_error + {ε σ α β : Type} {x : EStateM ε σ α} {f : α → EStateM ε σ β} + {s after : σ} {err : ε} + (hrun : x s = .error err after) : + (x >>= f) s = .error err after := by + change EStateM.bind x f s = .error err after + unfold EStateM.bind + rw [hrun] + +namespace RecM + +structure ScratchTelescopeInputSupport (support : RunSupport) : Prop where + body : ∀ {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {dom body : KExpr .anon} {info : ExprInfo .anon}, + support (.all name bi dom body info) → support body + +def ScratchScopedState + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (base : KVLCtx) (s : TcState .anon) : Prop := + ∃ n current, + ScratchLamExtension base n current ∧ + WhnfStateInv layer semantics trProj world support uvars current s + +def ScratchScopedExpr + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (base : KVLCtx) (e : KExpr .anon) + (s : TcState .anon) : Prop := + ∃ n current eV, + ScratchLamExtension base n current ∧ + WhnfStateInv layer semantics trProj world support uvars current s ∧ + support e ∧ + TrKExprS world.venv uvars world.nameOf trProj current e eV + +theorem scratch_peelMajorForalls_succ_run + (fuel : Nat) (ty : KExpr .anon) (methods : Methods .anon) + (s : TcState .anon) : + (peelMajorForalls (fuel + 1) ty).run methods s = + (methods.whnf ty >>= fun reduced => + ((match reduced with + | .all _ _ dom body _ => do + TcM.pushLocal dom + peelMajorForalls fuel body + | _ => throw (TcError.other + "get_major_inductive_id: not enough foralls")) : + RecM .anon (KExpr .anon)).run methods) s := by + have hwhnf : + (whnfRec ty).run methods = methods.whnf ty := by + funext state + exact whnfRec_run ty methods state + rw [peelMajorForalls, ReaderT.run_bind, hwhnf] + apply congrArg + (fun continuation : KExpr .anon → TcM .anon (KExpr .anon) => + (methods.whnf ty >>= continuation) s) + funext reduced + cases reduced <;> rfl + +theorem scratch_peelMajorForalls_scoped + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ScratchTelescopeInputSupport support) + {base : KVLCtx} : + ∀ fuel {n current ty s tyV}, + ScratchLamExtension base n current → + support ty → + TrKExprS world.venv uvars world.nameOf trProj current ty tyV → + WhnfStateInv layer semantics trProj world support uvars current s → + match (peelMajorForalls fuel ty).run methods s with + | .ok result after => + ScratchScopedExpr layer semantics trProj world support uvars base + result after + | .error _ after => + ScratchScopedState layer semantics trProj world support uvars base + after + | 0, _, _, _, _, _, hExtension, hsupport, htr, hI => by + exact ⟨_, _, _, hExtension, hI, hsupport, htr⟩ + | fuel + 1, n, current, source, s, sourceV, hExtension, hsupport, htr, + hI => by + have hcallback := hmethods.whnf hsupport htr hI + cases hrun : methods.whnf source s with + | error err after => + rw [hrun] at hcallback + have hwhole : + (peelMajorForalls (fuel + 1) source).run methods s = + .error err after := by + rw [scratch_peelMajorForalls_succ_run] + exact scratch_bind_error hrun + rw [hwhole] + exact ⟨n, current, hExtension, hcallback.1⟩ + | ok reduced after => + rw [hrun] at hcallback + cases reduced + case all name bi dom body info => + obtain ⟨resultV, hresultTr, _⟩ := hcallback.2.2 + cases hresultTr with + | all hdomType hbodyType hdomTr hbodyTr => + obtain ⟨afterPush, hpush⟩ := + scratch_pushLocal_ok dom after + have hPushI := + scratch_pushLocal_inv hcallback.1 hdomTr hdomType hpush + have hbodySupport := hinputs.body hcallback.2.1 + have hrecursive := + scratch_peelMajorForalls_scoped hmethods hinputs fuel + (.succ hExtension) hbodySupport hbodyTr hPushI + cases hrec : + (peelMajorForalls fuel body).run methods afterPush with + | ok result final => + rw [hrec] at hrecursive + have hwhole : + (peelMajorForalls (fuel + 1) source).run methods s = + .ok result final := by + rw [scratch_peelMajorForalls_succ_run, + scratch_bind_ok hrun] + rw [ReaderT.run_bind, ReaderT.run_monadLift, + monadLift_self, + scratch_bind_ok hpush, hrec] + rw [hwhole] + exact hrecursive + | error recErr final => + rw [hrec] at hrecursive + have hwhole : + (peelMajorForalls (fuel + 1) source).run methods s = + .error recErr final := by + rw [scratch_peelMajorForalls_succ_run, + scratch_bind_ok hrun] + rw [ReaderT.run_bind, ReaderT.run_monadLift, + monadLift_self, + scratch_bind_ok hpush, hrec] + rw [hwhole] + exact hrecursive + all_goals + have hwhole : + (peelMajorForalls (fuel + 1) source).run methods s = + .error (.other + "get_major_inductive_id: not enough foralls") after := by + rw [scratch_peelMajorForalls_succ_run, + scratch_bind_ok hrun] + rfl + rw [hwhole] + exact ⟨n, current, hExtension, hcallback.1⟩ + +private theorem scratch_collectSpineGo_const_references + {id : KId .anon} {us : Array (KUniv .anon)} + {info : ExprInfo .anon} : + ∀ (e : KExpr .anon) (acc args : Array (KExpr .anon)), + KExpr.collectSpine.go e acc = (.const id us info, args) → + e.References id + | .app f a appInfo, acc, args, h => by + simp only [KExpr.collectSpine.go] at h + exact Or.inl + (scratch_collectSpineGo_const_references f (acc.push a) args h) + | .const actual actualUs actualInfo, acc, args, h => by + simp only [KExpr.collectSpine.go] at h + cases h + rfl + | .var .., _, _, h + | .fvar .., _, _, h + | .sort .., _, _, h + | .lam .., _, _, h + | .all .., _, _, h + | .letE .., _, _, h + | .prj .., _, _, h + | .nat .., _, _, h + | .str .., _, _, h => by + simp only [KExpr.collectSpine.go] at h + cases h + +theorem scratch_collectSpine_const_references + {e : KExpr .anon} {id : KId .anon} + {us : Array (KUniv .anon)} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} + (h : e.collectSpine = (.const id us info, args)) : + e.References id := + scratch_collectSpineGo_const_references e #[] args h + +def ScratchScopedId + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (base : KVLCtx) (id : KId .anon) + (s : TcState .anon) : Prop := + ScratchScopedState layer semantics trProj world support uvars base s ∧ + world.trusted id + +def ScratchTrustedReferences (world : VerifyWorld) + (support : RunSupport) : Prop := + ∀ {source : KExpr .anon} {id : KId .anon}, + support source → source.References id → world.trusted id + +theorem scratch_scanMajorInductive_succ_run + (fuel : Nat) (ty : KExpr .anon) (methods : Methods .anon) + (s : TcState .anon) : + (scanMajorInductive (fuel + 1) ty).run methods s = + (methods.whnf ty >>= fun reduced => + (scanMajorInductiveStep (scanMajorInductive fuel) reduced).run + methods) s := by + have hwhnf : + (whnfRec ty).run methods = methods.whnf ty := by + funext state + exact whnfRec_run ty methods state + rw [scanMajorInductive, ReaderT.run_bind, hwhnf] + +theorem scratch_scanMajorInductive_scoped + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ScratchTelescopeInputSupport support) + (hfault : ∀ {Delta : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hreferences : ScratchTrustedReferences world support) + {base : KVLCtx} : + ∀ fuel {n current ty s tyV}, + ScratchLamExtension base n current → + support ty → + TrKExprS world.venv uvars world.nameOf trProj current ty tyV → + WhnfStateInv layer semantics trProj world support uvars current s → + match (scanMajorInductive fuel ty).run methods s with + | .ok id after => + ScratchScopedId layer semantics trProj world support uvars base + id after + | .error _ after => + ScratchScopedState layer semantics trProj world support uvars base + after + | 0, n, current, source, s, sourceV, hExtension, hsupport, htr, hI => by + exact ⟨n, current, hExtension, hI⟩ + | fuel + 1, n, current, source, s, sourceV, hExtension, hsupport, htr, + hI => by + have hcallback := hmethods.whnf hsupport htr hI + cases hrun : methods.whnf source s with + | error err after => + rw [hrun] at hcallback + have hwhole : + (scanMajorInductive (fuel + 1) source).run methods s = + .error err after := by + rw [scratch_scanMajorInductive_succ_run] + exact scratch_bind_error hrun + rw [hwhole] + exact ⟨n, current, hExtension, hcallback.1⟩ + | ok reduced after => + rw [hrun] at hcallback + cases reduced + case all name bi dom body info => + obtain ⟨resultV, hresultTr, _⟩ := hcallback.2.2 + cases hresultTr with + | all hdomType hbodyType hdomTr hbodyTr => + have hbodySupport := hinputs.body hcallback.2.1 + have hcontinue : + ∀ {before : TcState .anon}, + WhnfStateInv layer semantics trProj world support + uvars current before → + match + ((do + TcM.pushLocal dom + scanMajorInductive fuel body) : + RecM .anon (KId .anon)).run methods before with + | .ok id final => + ScratchScopedId layer semantics trProj world + support uvars base id final + | .error _ final => + ScratchScopedState layer semantics trProj world + support uvars base final := by + intro before hBefore + obtain ⟨afterPush, hpush⟩ := + scratch_pushLocal_ok dom before + have hPushI := + scratch_pushLocal_inv hBefore hdomTr hdomType hpush + have hrecursive := + scratch_scanMajorInductive_scoped hmethods hinputs + hfault hreferences fuel (.succ hExtension) + hbodySupport hbodyTr hPushI + cases hrec : + (scanMajorInductive fuel body).run methods afterPush with + | ok id final => + rw [hrec] at hrecursive + have hwhole : + ((do + TcM.pushLocal dom + scanMajorInductive fuel body) : + RecM .anon (KId .anon)).run methods before = + .ok id final := by + rw [ReaderT.run_bind, ReaderT.run_monadLift, + monadLift_self, scratch_bind_ok hpush, hrec] + rw [hwhole] + exact hrecursive + | error recErr final => + rw [hrec] at hrecursive + have hwhole : + ((do + TcM.pushLocal dom + scanMajorInductive fuel body) : + RecM .anon (KId .anon)).run methods before = + .error recErr final := by + rw [ReaderT.run_bind, ReaderT.run_monadLift, + monadLift_self, scratch_bind_ok hpush, hrec] + rw [hwhole] + exact hrecursive + rcases hspine : dom.collectSpine with ⟨head, args⟩ + rw [scratch_scanMajorInductive_succ_run, + scratch_bind_ok hrun] + simp only [scanMajorInductiveStep, hspine] + cases head <;> try exact hcontinue hcallback.1 + case const id us headInfo => + have hlookup := + TcM.tryGetConst_wf (hfault (Delta := current)) id + after hcallback.1 + cases hlookupRun : TcM.tryGetConst id after with + | error lookupErr afterLookup => + rw [hlookupRun] at hlookup + rw [ReaderT.run_bind, ReaderT.run_monadLift, + monadLift_self, + scratch_bind_error hlookupRun] + exact ⟨n, current, hExtension, hlookup.1⟩ + | ok found afterLookup => + rw [hlookupRun] at hlookup + rw [ReaderT.run_bind, ReaderT.run_monadLift, + monadLift_self, scratch_bind_ok hlookupRun] + cases found with + | none => exact hcontinue hlookup.1 + | some entry => + cases entry <;> simp only + case indc => + exact + ⟨⟨n, current, hExtension, hlookup.1⟩, + hreferences hcallback.2.1 <| by + simp only [KExpr.References] + exact Or.inl + (scratch_collectSpine_const_references + hspine)⟩ + all_goals exact hcontinue hlookup.1 + all_goals + have hwhole : + (scanMajorInductive (fuel + 1) source).run methods s = + .error (.other + "get_major_inductive_id: expected forall at major") + after := by + rw [scratch_scanMajorInductive_succ_run, + scratch_bind_ok hrun] + rfl + rw [hwhole] + exact ⟨n, current, hExtension, hcallback.1⟩ + +theorem scratch_majorInductiveBody_scoped + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ScratchTelescopeInputSupport support) + (hfault : ∀ {Delta : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hreferences : ScratchTrustedReferences world support) + {base : KVLCtx} {recTy : KExpr .anon} {recTyV : Lean4Lean.VExpr} + {s : TcState .anon} (skip : UInt64) + (hrecSupport : support recTy) + (hrecTr : TrKExprS world.venv uvars world.nameOf trProj base recTy recTyV) + (hI : WhnfStateInv layer semantics trProj world support uvars base s) : + match + ((do + let ty ← peelMajorForalls skip.toNat recTy + scanMajorInductive 9 ty) : RecM .anon (KId .anon)).run methods s with + | .ok id after => + ScratchScopedId layer semantics trProj world support uvars base id after + | .error _ after => + ScratchScopedState layer semantics trProj world support uvars base + after := by + have hpeel := + scratch_peelMajorForalls_scoped hmethods hinputs skip.toNat + (ScratchLamExtension.zero (base := base)) hrecSupport hrecTr hI + cases hpeelRun : + (peelMajorForalls skip.toNat recTy).run methods s with + | error err after => + rw [hpeelRun] at hpeel + rw [ReaderT.run_bind, scratch_bind_error hpeelRun] + exact hpeel + | ok ty after => + rw [hpeelRun] at hpeel + obtain ⟨n, current, tyV, hExtension, hAfter, htySupport, htyTr⟩ := + hpeel + have hscan := + scratch_scanMajorInductive_scoped hmethods hinputs hfault hreferences 9 + hExtension htySupport htyTr hAfter + cases hscanRun : (scanMajorInductive 9 ty).run methods after with + | error err final => + rw [hscanRun] at hscan + rw [ReaderT.run_bind, scratch_bind_ok hpeelRun, hscanRun] + exact hscan + | ok id final => + rw [hscanRun] at hscan + rw [ReaderT.run_bind, scratch_bind_ok hpeelRun, hscanRun] + exact hscan + +theorem scratch_getMajorInductiveId_run + (recTy : KExpr .anon) (skip : UInt64) (methods : Methods .anon) + (s : TcState .anon) : + (getMajorInductiveId recTy skip).run methods s = + tryFinally + (((do + let ty ← peelMajorForalls skip.toNat recTy + scanMajorInductive 9 ty) : RecM .anon (KId .anon)).run methods) + (TcM.restoreDepth s.ctx.size) s := by + rfl + +theorem scratch_tryFinally_ok + {ε σ α β : Type} {x : EStateM ε σ α} + {finalizer : EStateM ε σ β} {s after final : σ} + {value : α} {cleanup : β} + (hbody : x s = .ok value after) + (hcleanup : finalizer after = .ok cleanup final) : + tryFinally x finalizer s = .ok value final := by + unfold tryFinally + change EStateM.map (fun pair : α × β => pair.1) + (tryFinally' x (fun _ => finalizer)) s = .ok value final + unfold EStateM.map MonadFinally.tryFinally' EStateM.instMonadFinally + simp only [hbody, hcleanup] + +theorem scratch_tryFinally_error + {ε σ α β : Type} {x : EStateM ε σ α} + {finalizer : EStateM ε σ β} {s after final : σ} + {err : ε} {cleanup : β} + (hbody : x s = .error err after) + (hcleanup : finalizer after = .ok cleanup final) : + tryFinally x finalizer s = .error err final := by + unfold tryFinally + change EStateM.map (fun pair : α × β => pair.1) + (tryFinally' x (fun _ => finalizer)) s = .error err final + unfold EStateM.map MonadFinally.tryFinally' EStateM.instMonadFinally + simp only [hbody, hcleanup] + +theorem scratch_getMajorInductiveId_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hinputs : ScratchTelescopeInputSupport support) + (hfault : ∀ {Delta : KVLCtx}, + TcM.LazyFaultPreserves + (WhnfStateInv layer semantics trProj world support uvars Delta)) + (hreferences : ScratchTrustedReferences world support) + {Delta : KVLCtx} {recTy : KExpr .anon} {recTyV : Lean4Lean.VExpr} + {s : TcState .anon} (skip : UInt64) + (hrecSupport : support recTy) + (hrecTr : + TrKExprS world.venv uvars world.nameOf trProj Delta recTy recTyV) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((getMajorInductiveId recTy skip).run methods) + (fun id _ => world.trusted id) := by + intro hI + have hbody := + scratch_majorInductiveBody_scoped hmethods hinputs hfault hreferences + skip hrecSupport hrecTr hI + cases hbodyRun : + ((do + let ty ← peelMajorForalls skip.toNat recTy + scanMajorInductive 9 ty) : RecM .anon (KId .anon)).run methods s with + | ok id after => + rw [hbodyRun] at hbody + obtain ⟨⟨n, current, hExtension, hAfter⟩, htrusted⟩ := hbody + obtain ⟨final, hrestore, hFinal⟩ := + scratch_restoreDepth hI hExtension hAfter + have hrun : + (getMajorInductiveId recTy skip).run methods s = .ok id final := by + rw [scratch_getMajorInductiveId_run] + exact scratch_tryFinally_ok hbodyRun hrestore + rw [hrun] + exact ⟨hFinal, htrusted⟩ + | error err after => + rw [hbodyRun] at hbody + obtain ⟨n, current, hExtension, hAfter⟩ := hbody + obtain ⟨final, hrestore, hFinal⟩ := + scratch_restoreDepth hI hExtension hAfter + have hrun : + (getMajorInductiveId recTy skip).run methods s = .error err final := by + rw [scratch_getMajorInductiveId_run] + exact scratch_tryFinally_error hbodyRun hrestore + rw [hrun] + exact ⟨hFinal, trivial⟩ + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/ApplicationCongruence.lean b/Ix/Tc/Verify/Whnf/Structural/ApplicationCongruence.lean new file mode 100644 index 000000000..1778c5981 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/ApplicationCongruence.lean @@ -0,0 +1,102 @@ +import Ix.Tc.Verify.Whnf.Structural.ProjectionStep + +/-! +# Changed-head application congruence + +The changed-head branch cannot use the callback's head-level equality as if +it were already equality of the complete application. Every original spine +argument must be reattached with its typing derivation, in production order. + +This slice converts `TrAppSpine` into the typed-suffix representation used by +the checked iota proofs, ties the recursive callback to that exact head +translation, and transports its definitional equality across the complete +suffix. A `FinishAppRequests` certificate then identifies the semantic +left fold with the expression actually returned by `finishAppResult`. +-/ + +namespace Ix.Tc +namespace RecM + +namespace TrAppSpine + +/-- View a typed spine as a translated head followed by a typed application +suffix. Unlike `headTr`, this keeps the chosen head translation connected to +all argument typing derivations. -/ +theorem toSuffix + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address -> Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {head : KExpr .anon} + {args : List (KExpr .anon)} {resultV : Lean4Lean.VExpr} + (h : TrAppSpine env uvars nameOf trProj Delta head args resultV) : + exists headV, + TrKExprS env uvars nameOf trProj Delta head headV /\ + TrAppSuffix env uvars nameOf trProj Delta headV args resultV := by + induction h with + | head hhead => exact ⟨_, hhead, .nil⟩ + | app hprefix hfun harg hargTr ih => + obtain ⟨headV, hheadTr, hsuffix⟩ := ih + exact ⟨headV, hheadTr, .app hsuffix hfun harg hargTr⟩ + +end TrAppSpine + +/-- Strong application-head callback adapter. The callback postcondition is +indexed by the same head translation that anchors the full typed suffix. -/ +theorem applicationHeadCallbackWithSuffix_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {f arg head : KExpr .anon} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} {sourceV : Lean4Lean.VExpr} + {flags : WhnfFlags} + (hinputs : WhnfCoreInputSupport support) + (hsupport : support (.app f arg info)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.app f arg info) sourceV) + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) : + exists headV, + TrKExprS world.venv uvars world.nameOf trProj Delta head headV /\ + TrAppSuffix world.venv uvars world.nameOf trProj Delta headV + args.toList sourceV /\ + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreFlagsRec head flags) + (fun result _ => support result /\ + WhnfPost trProj world uvars Delta headV result) := by + have htyped := trAppSpine_of_collectSpine hsource hspine + obtain ⟨headV, hheadTr, hsuffix⟩ := htyped.toSuffix + have hheadSupport := (hinputs.app hsupport hspine).1 + exact ⟨headV, hheadTr, hsuffix, + whnfCoreFlagsRec_wf hheadSupport hheadTr⟩ + +namespace WhnfMeaning + +/-- Replace the translated head of an application by a callback result and +rebuild every original argument. The callback equality is lifted through +the typed suffix using Theory application congruence; the finite request +certificate identifies that pure rebuilt spine with production's concrete +result. -/ +theorem appHeadRebuild + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {source changed rebuilt : KExpr .anon} + {args : Array (KExpr .anon)} {sourceV headV : Lean4Lean.VExpr} + {requests : List WalkerRequest} + (hDelta : KVLCtx.WF world.venv uvars Delta) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hsuffix : TrAppSuffix world.venv uvars world.nameOf trProj Delta headV + args.toList sourceV) + (hhead : WhnfPost trProj world uvars Delta headV changed) + (hfinish : FinishAppRequests requests + (args.extract 0 args.size).toList changed rebuilt) : + WhnfMeaning trProj world uvars Delta source rebuilt := by + obtain ⟨changedV, hchangedTr, hheadEq⟩ := hhead + obtain ⟨rebuiltV, hrebuiltTr, hrebuildEq⟩ := + hsuffix.rebase world.venvWF hDelta hchangedTr hheadEq + have hresult : rebuilt = args.toList.foldl KExpr.mkApp changed := by + simpa using hfinish.result_eq_foldl + rw [← hresult] at hrebuiltTr + exact ⟨sourceV, rebuiltV, hsource, hrebuiltTr, hrebuildEq⟩ + +end WhnfMeaning + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/ApplicationRebuild.lean b/Ix/Tc/Verify/Whnf/Structural/ApplicationRebuild.lean new file mode 100644 index 000000000..92a536dde --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/ApplicationRebuild.lean @@ -0,0 +1,71 @@ +import Ix.Tc.Verify.Whnf.Structural.ApplicationCongruence + +/-! +# Changed-head rebuild execution + +ApplicationCongruence proves the semantic congruence theorem for a certified rebuild. This +slice supplies those certificates uniformly for every supported application +that can enter the structural loop and every supported result returned by its +head callback. The guard keeps the obligation finite while covering the +dynamic callback result rather than one hand-picked expression. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Finite request census for rebuilding the complete argument suffix after +a supported application head changes. -/ +def ApplicationFinishRequestCensus (requests : List WalkerRequest) + (support : RunSupport) : Prop := + forall {f arg head changed : KExpr .anon} {info : ExprInfo .anon} + {args : Array (KExpr .anon)}, + support (.app f arg info) -> + (.app f arg info : KExpr .anon).collectSpine = (head, args) -> + support changed -> + exists rebuilt, + FinishAppRequests requests (args.extract 0 args.size).toList changed + rebuilt + +/-- Execute and justify one complete changed-head rebuild. The result joins +four facts that later branch assembly needs simultaneously: the exact helper +run, invariant preservation, finite result support, and Theory meaning from +the original application to the rebuilt spine. -/ +theorem changedHeadFinish_acceptance + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (hcensus : ApplicationFinishRequestCensus requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {f arg head changed : KExpr .anon} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} {sourceV headV : Lean4Lean.VExpr} + (hsourceSupport : support (.app f arg info)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.app f arg info) sourceV) + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hsuffix : TrAppSuffix world.venv uvars world.nameOf trProj Delta headV + args.toList sourceV) + (hchangedSupport : support changed) + (hhead : WhnfPost trProj world uvars Delta headV changed) + (hI : WhnfStateInv layer semantics trProj world support uvars Delta s) : + exists rebuilt s', + FinishAppRequests requests (args.extract 0 args.size).toList changed + rebuilt /\ + (finishAppResult changed args 0).run methods s = .ok rebuilt s' /\ + WhnfStateInv layer semantics trProj world support uvars Delta s' /\ + InternUpdateFrame s s' /\ + support rebuilt /\ + WhnfMeaning trProj world uvars Delta (.app f arg info) rebuilt := by + obtain ⟨rebuilt, hfinish⟩ := + hcensus hsourceSupport hspine hchangedSupport + obtain ⟨s', hfinishRun, hI', hframe⟩ := hfinish.eval hrun hI + have hrebuiltSupport : support rebuilt := + hfinish.support hrun hchangedSupport + have hmeaning := WhnfMeaning.appHeadRebuild hI.2.1.wf hsource hsuffix + hhead hfinish + exact ⟨rebuilt, s', hfinish, hfinishRun, hI', hframe, + hrebuiltSupport, hmeaning⟩ + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/ApplicationStep.lean b/Ix/Tc/Verify/Whnf/Structural/ApplicationStep.lean new file mode 100644 index 000000000..b7d1f206b --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/ApplicationStep.lean @@ -0,0 +1,121 @@ +import Ix.Tc.Verify.Whnf.Structural.BetaBoundary + +/-! +# Exhaustive application-step closure + +The preceding slices prove each continuation after the recursive head +callback. This slice performs the adversarial assembly: callback errors, +lambda results, every non-lambda syntax constructor (including an application +returned by the callback), physical head changes, and address-equal heads are +all covered by one `WhnfStep.WF` contract. + +The unchanged branch does not trust address equality as expression equality. +It uses the run's collision-freedom certificate over the supported callback +result and original head before rewriting the callback equation. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Every outcome of the production application branch satisfies the local +structural-step contract, conditional only on the separately named finite +request and Theory/helper boundaries. -/ +theorem whnfCoreWithFlagsStep_app_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (hbetaCensus : BetaRequestCensus requests support) + (hfinishCensus : ApplicationFinishRequestCensus requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {f arg : KExpr .anon} {info : ExprInfo .anon} + {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hinputs : WhnfCoreInputSupport support) + (hbetaMeaning : BetaManyMeaningOracle trProj world) + (hiota : OptionalReduction.WF layer semantics trProj world support + (fun source => tryIotaWithFlags source flags)) : + forall s, + WhnfStep.Source trProj world support uvars Delta id + (.app f arg info) -> + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreWithFlagsStep (.app f arg info) flags) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta id + (.app f arg info) action) + (fun _ _ => True) := by + intro s hsource methods hmethods hI + obtain ⟨hsourceSupport, sourceV, hsourceTr⟩ := hsource + rcases hspine : (.app f arg info : KExpr .anon).collectSpine with + ⟨head, args⟩ + obtain ⟨headV, hheadTr, hsuffix, hcallbackWF⟩ := + applicationHeadCallbackWithSuffix_wf (s := s) (flags := flags) + hinputs hsourceSupport hsourceTr hspine + have hcallbackPost := hcallbackWF methods hmethods hI + match hheadRun : methods.whnfCoreFlags head flags s with + | .error err s1 => + have hcallbackRun : + (whnfCoreFlagsRec head flags).run methods s = .error err s1 := by + simpa only [whnfCoreFlagsRec] using hheadRun + rw [hcallbackRun] at hcallbackPost + rw [whnfCoreWithFlagsStep_appHeadError hspine hheadRun] + exact ⟨hcallbackPost.1, trivial⟩ + | .ok changed s1 => + have hcallbackRun : + (whnfCoreFlagsRec head flags).run methods s = .ok changed s1 := by + simpa only [whnfCoreFlagsRec] using hheadRun + rw [hcallbackRun] at hcallbackPost + have hI1 := hcallbackPost.1 + have hchangedSupport := hcallbackPost.2.1 + have hheadPost := hcallbackPost.2.2 + have hnonLambda + (hnonlam : WhnfCoreNonLambda changed) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((whnfCoreWithFlagsStep (.app f arg info) flags).run methods) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta + id (.app f arg info) action) := by + by_cases hdiff : (changed != head) = true + · exact whnfCoreWithFlagsStep_appChanged_wf hrun hfinishCensus + theory hiota hmethods hsourceSupport hsourceTr hspine hsuffix + hchangedSupport hheadPost hnonlam hheadRun hdiff hI1 + · have hsameAddr : (changed != head) = false := by + cases hvalue : (changed != head) with + | false => rfl + | true => exact False.elim (hdiff hvalue) + have haddrEq : changed.addr = head.addr := by + change Bool.not (changed.addr == head.addr) = false at hsameAddr + cases heq : (changed.addr == head.addr) with + | false => simp [heq] at hsameAddr + | true => exact beq_iff_eq.mp heq + have herase := hrun.collisionFree.expr hchangedSupport + (hinputs.app hsourceSupport hspine).1 haddrEq + have hsame : changed = head := by + simpa only [KExpr.eraseMeta_anon] using herase + subst changed + exact whnfCoreWithFlagsStep_appUnchanged_wf theory hiota + hmethods hsourceSupport hsourceTr hspine hnonlam hheadRun hI1 + cases changed with + | lam name bi ty body lamInfo => + let consumedResult := consumeBetaLams + (.lam name bi ty body lamInfo) args + rcases hconsume : consumedResult with ⟨body0, consumed⟩ + have hconsume' : + consumeBetaLams (.lam name bi ty body lamInfo) args = + (body0, consumed) := by + simpa only [consumedResult] using hconsume + exact (whnfCoreWithFlagsStep_appBeta_wf hrun hbetaCensus theory + hbetaMeaning hsourceSupport hsourceTr hspine hsuffix + hchangedSupport hheadPost hheadRun hconsume' hI1) hI + | var => exact hnonLambda .var hI + | fvar => exact hnonLambda .fvar hI + | sort => exact hnonLambda .sort hI + | const => exact hnonLambda .const hI + | app => exact hnonLambda .app hI + | all => exact hnonLambda .all hI + | letE => exact hnonLambda .letE hI + | prj => exact hnonLambda .prj hI + | nat => exact hnonLambda .nat hI + | str => exact hnonLambda .str hI + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/ApplicationTails.lean b/Ix/Tc/Verify/Whnf/Structural/ApplicationTails.lean new file mode 100644 index 000000000..87fe99a5c --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/ApplicationTails.lean @@ -0,0 +1,168 @@ +import Ix.Tc.Verify.Whnf.Structural.ApplicationRebuild + +/-! +# Non-beta application tails + +This slice closes both non-lambda continuations after the recursive head +callback. The unchanged path invokes iota on the original source; the +changed path first consumes ApplicationRebuild's certified complete-spine rebuild and then +invokes iota on that rebuilt source. In both cases the ordinary +`OptionalReduction.WF` contract accounts for iota hits, misses, and partial +error states. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Generic unchanged-head/iota-hit equation. The older specialized theorem +fixed the spine head to a recursor constant for its semantic oracle; the +production control-flow equation only needs a non-lambda head and therefore +admits this stronger operational form. -/ +theorem whnfCoreWithFlagsStep_appUnchangedIota + {methods : Methods .anon} {s s1 s2 : TcState .anon} + {f arg head result : KExpr .anon} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} {flags : WhnfFlags} + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hnonlam : WhnfCoreNonLambda head) + (hhead : methods.whnfCoreFlags head flags s = .ok head s1) + (hself : (head != head) = false) + (hiota : (tryIotaWithFlags (.app f arg info) flags).run methods s1 = + .ok (some result) s2) : + (whnfCoreWithFlagsStep (.app f arg info) flags).run methods s = + .ok (.next result) s2 := by + unfold whnfCoreWithFlagsStep + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + rw [hspine] + change EStateM.bind (methods.whnfCoreFlags head flags) _ s = _ + unfold EStateM.bind + rw [hhead] + simp only + cases hnonlam <;> simp only + all_goals + rw [hself] + change EStateM.bind + (ReaderT.run (tryIotaWithFlags (.app f arg info) flags) methods) _ s1 = _ + unfold EStateM.bind + rw [hiota] + rfl + +/-- Complete unchanged non-lambda tail. A miss is reflexive at the original +source; a hit uses the optional iota contract directly; an error retains the +helper's partial post-state. -/ +theorem whnfCoreWithFlagsStep_appUnchanged_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s s1 : TcState .anon} {f arg head : KExpr .anon} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hiota : OptionalReduction.WF layer semantics trProj world support + (fun source => tryIotaWithFlags source flags)) + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hsourceSupport : support (.app f arg info)) + {sourceV : Lean4Lean.VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.app f arg info) sourceV) + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hnonlam : WhnfCoreNonLambda head) + (hhead : methods.whnfCoreFlags head flags s = .ok head s1) + (hI1 : WhnfStateInv layer semantics trProj world support uvars Delta + s1) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((whnfCoreWithFlagsStep (.app f arg info) flags).run methods) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta id + (.app f arg info) action) := by + intro hI + have hiotaPost := (hiota hsourceSupport hsource) methods hmethods hI1 + have hself : (head != head) = false := by + change Bool.not (head.addr == head.addr) = false + rw [beq_self_eq_true] + rfl + match hiotaRun : + (tryIotaWithFlags (.app f arg info) flags).run methods s1 with + | .error err s2 => + rw [hiotaRun] at hiotaPost + rw [whnfCoreWithFlagsStep_appUnchangedIotaError hspine hnonlam hhead + hself hiotaRun] + exact ⟨hiotaPost.1, trivial⟩ + | .ok none s2 => + rw [hiotaRun] at hiotaPost + rw [whnfCoreWithFlagsStep_appUnchangedDone hspine hnonlam hhead hself + hiotaRun] + exact ⟨hiotaPost.1, hsourceSupport, + WhnfMeaning.refl hsource (theory.exprWF hI1.2.1 hsource)⟩ + | .ok (some result) s2 => + rw [hiotaRun] at hiotaPost + rw [whnfCoreWithFlagsStep_appUnchangedIota hspine hnonlam hhead hself + hiotaRun] + exact ⟨hiotaPost.1, hiotaPost.2.1, hiotaPost.2.2⟩ + +/-- Complete changed non-lambda tail. Head congruence justifies the rebuilt +source; an iota hit is composed transitively with that meaning, while a miss +returns the rebuilt source itself. -/ +theorem whnfCoreWithFlagsStep_appChanged_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (hfinishCensus : ApplicationFinishRequestCensus requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + {s s1 : TcState .anon} {f arg head changed : KExpr .anon} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {sourceV headV : Lean4Lean.VExpr} {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hiota : OptionalReduction.WF layer semantics trProj world support + (fun source => tryIotaWithFlags source flags)) + (hmethods : + Methods.WFAt layer semantics trProj world support uvars methods) + (hsourceSupport : support (.app f arg info)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.app f arg info) sourceV) + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hsuffix : TrAppSuffix world.venv uvars world.nameOf trProj Delta headV + args.toList sourceV) + (hchangedSupport : support changed) + (hheadPost : WhnfPost trProj world uvars Delta headV changed) + (hnonlam : WhnfCoreNonLambda changed) + (hhead : methods.whnfCoreFlags head flags s = .ok changed s1) + (hchanged : (changed != head) = true) + (hI1 : WhnfStateInv layer semantics trProj world support uvars Delta + s1) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((whnfCoreWithFlagsStep (.app f arg info) flags).run methods) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta id + (.app f arg info) action) := by + intro hI + obtain ⟨rebuilt, s2, hfinish, hfinishRun, hI2, hframe, + hrebuiltSupport, happMeaning⟩ := + changedHeadFinish_acceptance hrun hfinishCensus hsourceSupport hsource + hspine hsuffix hchangedSupport hheadPost hI1 + have happMeaningSaved := happMeaning + obtain ⟨sourceV2, rebuiltV, hsourceTr2, hrebuiltTr, hrebuildEq⟩ := + happMeaning + have hiotaPost := + (hiota hrebuiltSupport hrebuiltTr) methods hmethods hI2 + match hiotaRun : (tryIotaWithFlags rebuilt flags).run methods s2 with + | .error err s3 => + rw [hiotaRun] at hiotaPost + rw [whnfCoreWithFlagsStep_appChangedIotaError hspine hnonlam hhead + hchanged hfinishRun hiotaRun] + exact ⟨hiotaPost.1, trivial⟩ + | .ok none s3 => + rw [hiotaRun] at hiotaPost + rw [whnfCoreWithFlagsStep_appChangedDone hspine hnonlam hhead hchanged + hfinishRun hiotaRun] + exact ⟨hiotaPost.1, hrebuiltSupport, happMeaningSaved⟩ + | .ok (some result) s3 => + rw [hiotaRun] at hiotaPost + rw [whnfCoreWithFlagsStep_appChangedIota hspine hnonlam hhead hchanged + hfinishRun hiotaRun] + have hmeaning := theory.transMeaning hI2.2.1.wf happMeaningSaved + hiotaPost.2.2 + exact ⟨hiotaPost.1, hiotaPost.2.1, hmeaning⟩ + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/BasicStep.lean b/Ix/Tc/Verify/Whnf/Structural/BasicStep.lean new file mode 100644 index 000000000..7243dc066 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/BasicStep.lean @@ -0,0 +1,164 @@ +import Ix.Tc.Verify.Whnf.Structural.CacheShell + +/-! +# Basic structural-step closure + +CacheShell verifies the public structural cache shell once one exhaustive local +step contract is available. This slice starts that local assembly with the +state-pure leaves, the complete fvar branch, and explicit-let substitution. + +The fvar premise is intentionally stronger than `CtxRecon`: production +returns an `.ldecl` value without lifting it, so soundness requires that the +stored value be constructed, closed with respect to the legacy de Bruijn +stack, and within the current weakening bound. Naming this state obligation +prevents a translated-but-stale local value from being accepted silently. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Runtime safety needed by production's unchanged let-fvar return. This +property is indexed by every state satisfying the fixed K1 invariant so it +can be consumed by the uniform `WhnfStep.WF` contract rather than by one +hand-picked execution fixture. -/ +def FVarZetaSafety (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) : Prop := + ∀ {s : TcState .anon} {fv : FVarId} {declName : Mode.anon.F Name} + {ty val : KExpr .anon}, + WhnfStateInv layer semantics trProj world support uvars Delta s → + s.lctx.find? fv = some (.ldecl declName ty val) → + support val ∧ KExpr.Constructed val ∧ val.lbr = 0 ∧ + Delta.bvars + val.size < UInt64.size + +/-- Finite request census for every supported explicit let that can become a +current structural-loop state. The support guard keeps the obligation +finite; it does not require global closure under arbitrary let syntax. -/ +def LetSubstRequestCensus (requests : List WalkerRequest) + (support : RunSupport) : Prop := + ∀ {name : Mode.anon.F Name} {ty val body : KExpr .anon} + {nondep : Bool} {info : ExprInfo .anon}, + support (.letE name ty val body nondep info) → + WalkerRequest.subst body val 0 ∈ requests + +/-- Exhaustive fvar step closure. Missing and ordinary local declarations +are reflexive, while an `.ldecl` uses the exact state-safety facts needed by +`WhnfMeaning.zetaFVar`. The branch is state-pure and cannot raise an error. -/ +theorem whnfCoreWithFlagsStep_fvar_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {fv : FVarId} + {name : Mode.anon.F Name} {info : ExprInfo .anon} {flags : WhnfFlags} + {stepError : TcError .anon → TcState .anon → Prop} + (theory : WhnfTheory trProj world uvars) + (hsafe : FVarZetaSafety layer semantics trProj world support uvars + Delta) : + ∀ s, + WhnfStep.Source trProj world support uvars Delta id + (.fvar fv name info) → + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreWithFlagsStep (.fvar fv name info) flags) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta id + (.fvar fv name info) action) + stepError := by + intro s hsource methods hmethods hI + obtain ⟨hsourceSupport, sourceV, hsourceTr⟩ := hsource + cases hfind : s.lctx.find? fv with + | none => + have hnot : ∀ declName ty val, + s.lctx.find? fv ≠ some (.ldecl declName ty val) := by + intro declName ty val hbad + rw [hfind] at hbad + contradiction + rw [whnfCoreWithFlagsStep_fvarDone hnot] + exact ⟨hI, hsourceSupport, + WhnfMeaning.refl hsourceTr (theory.exprWF hI.2.1 hsourceTr)⟩ + | some decl => + cases decl with + | cdecl declName bi ty => + have hnot : ∀ declName' ty' val, + s.lctx.find? fv ≠ some (.ldecl declName' ty' val) := by + intro declName' ty' val hbad + rw [hfind] at hbad + cases hbad + rw [whnfCoreWithFlagsStep_fvarDone hnot] + exact ⟨hI, hsourceSupport, + WhnfMeaning.refl hsourceTr (theory.exprWF hI.2.1 hsourceTr)⟩ + | ldecl declName ty val => + rw [whnfCoreWithFlagsStep_fvarZeta hfind] + obtain ⟨hvalSupport, hconstructed, hclosed, hbound⟩ := + hsafe hI hfind + exact ⟨hI, hvalSupport, + WhnfMeaning.zetaFVar hI.2.1 theory.projections hfind hconstructed + hclosed hbound⟩ + +/-- Every supported explicit-let branch satisfies the local step contract +from its one request-certified substitution. Request bounds supply the +constructedness and no-wrap facts; request coverage supplies finite result +support and the walker preserves the complete invariant. -/ +theorem whnfCoreWithFlagsStep_letE_wf + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (hcensus : LetSubstRequestCensus requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {name : Mode.anon.F Name} + {ty val body : KExpr .anon} {nondep : Bool} {info : ExprInfo .anon} + {flags : WhnfFlags} + {stepError : TcError .anon → TcState .anon → Prop} + (theory : WhnfTheory trProj world uvars) : + ∀ s, + WhnfStep.Source trProj world support uvars Delta id + (.letE name ty val body nondep info) → + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreWithFlagsStep (.letE name ty val body nondep info) flags) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta id + (.letE name ty val body nondep info) action) + stepError := by + intro s hsource methods hmethods hI + have hmem : WalkerRequest.subst body val 0 ∈ requests := + hcensus hsource.1 + obtain ⟨s', hstep, hI', hmeaning⟩ := + whnfCoreWithFlagsStep_letE_acceptance hrun theory hmem hsource hI + rw [hstep] + exact ⟨hI', hmeaning⟩ + +/-- The structural forms closed by this slice. Keeping a proof-relevant +classifier makes later exhaustive assembly a simple constructor case split +and prevents a syntax branch from disappearing behind a Boolean test. -/ +inductive WhnfCoreBasic : KExpr .anon → Prop + | leaf {e} : WhnfCoreLeaf e → WhnfCoreBasic e + | fvar {fv name info} : WhnfCoreBasic (.fvar fv name info) + | letE {name ty val body nondep info} : + WhnfCoreBasic (.letE name ty val body nondep info) + +/-- Uniform local-step contract for all basic forms: immediate leaves, +fvars, and explicit lets. -/ +theorem whnfCoreWithFlagsStep_basic_wf + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (hcensus : LetSubstRequestCensus requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {source : KExpr .anon} {flags : WhnfFlags} + {stepError : TcError .anon → TcState .anon → Prop} + (theory : WhnfTheory trProj world uvars) + (hsafe : FVarZetaSafety layer semantics trProj world support uvars + Delta) + (hbasic : WhnfCoreBasic source) : + ∀ s, + WhnfStep.Source trProj world support uvars Delta id source → + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreWithFlagsStep source flags) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta id + source action) + stepError := by + cases hbasic with + | leaf hleaf => exact whnfCoreWithFlagsStep_leaf_wf theory hleaf + | fvar => exact whnfCoreWithFlagsStep_fvar_wf theory hsafe + | letE => exact whnfCoreWithFlagsStep_letE_wf hrun hcensus theory + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/BetaBoundary.lean b/Ix/Tc/Verify/Whnf/Structural/BetaBoundary.lean new file mode 100644 index 000000000..39c32284a --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/BetaBoundary.lean @@ -0,0 +1,128 @@ +import Ix.Tc.Verify.Whnf.Structural.ApplicationTails + +/-! +# General beta branch boundary and execution + +The production beta branch peels as many lambdas as the application spine +provides, performs one simultaneous substitution with the consumed arguments +in de Bruijn order, and rebuilds only the unconsumed suffix. This slice +closes all of that runtime behavior from the finite request census. + +The one remaining semantic ingredient is named separately as +`BetaManyMeaningOracle`. It is purely a Theory bridge from the typed original +spine, the callback's head equality, the exact `consumeBetaLams` equation, and +the substitution bounds to the final certified rebuild. No state effect, +support fact, or production execution is hidden in that interface. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Finite request census for every dynamic multi-beta branch reachable from +a supported application and supported lambda callback result. -/ +def BetaRequestCensus (requests : List WalkerRequest) + (support : RunSupport) : Prop := + forall {f arg head : KExpr .anon} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body body0 : KExpr .anon} {lamInfo : ExprInfo .anon} + {consumed : Array (KExpr .anon)}, + support (.app f arg info) -> + (.app f arg info : KExpr .anon).collectSpine = (head, args) -> + support (.lam name bi ty body lamInfo) -> + consumeBetaLams (.lam name bi ty body lamInfo) args = + (body0, consumed) -> + (!consumed.isEmpty) = true /\ + WalkerRequest.simulSubst body0 consumed.reverse 0 ∈ requests /\ + exists result, + FinishAppRequests requests + (args.extract consumed.size args.size).toList + (KExpr.simulSubstSpec body0 consumed.reverse 0) result + +/-- Theory-only semantic bridge still required for general multi-beta. The +resource bound is the exact bound already checked for the production walker; +the rebuild certificate fixes the unconsumed suffix and its order. -/ +def BetaManyMeaningOracle (trProj : RawProjRel) (world : VerifyWorld) : Prop := + forall {uvars : Nat}, WhnfTheory trProj world uvars -> + forall {Delta : KVLCtx} {requests : List WalkerRequest} + {f arg : KExpr .anon} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body body0 : KExpr .anon} {lamInfo : ExprInfo .anon} + {consumed : Array (KExpr .anon)} {result : KExpr .anon} + {sourceV headV : Lean4Lean.VExpr}, + KVLCtx.WF world.venv uvars Delta -> + TrKExprS world.venv uvars world.nameOf trProj Delta + (.app f arg info) sourceV -> + TrAppSuffix world.venv uvars world.nameOf trProj Delta headV + args.toList sourceV -> + WhnfPost trProj world uvars Delta headV + (.lam name bi ty body lamInfo) -> + consumeBetaLams (.lam name bi ty body lamInfo) args = + (body0, consumed) -> + (WalkerRequest.simulSubst body0 consumed.reverse 0).Bounds -> + FinishAppRequests requests + (args.extract consumed.size args.size).toList + (KExpr.simulSubstSpec body0 consumed.reverse 0) result -> + WhnfMeaning trProj world uvars Delta (.app f arg info) result + +/-- Complete general beta tail for one successful lambda callback. The +walker and suffix rebuild are both total under their finite certificates, so +the branch has one exact successful result and preserves the invariant +through the composed intern-only frame. -/ +theorem whnfCoreWithFlagsStep_appBeta_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (hcensus : BetaRequestCensus requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} + {s s1 : TcState .anon} {f arg head : KExpr .anon} + {info : ExprInfo .anon} {args : Array (KExpr .anon)} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body body0 : KExpr .anon} {lamInfo : ExprInfo .anon} + {consumed : Array (KExpr .anon)} {sourceV headV : Lean4Lean.VExpr} + {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hmeaning : BetaManyMeaningOracle trProj world) + (hsourceSupport : support (.app f arg info)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.app f arg info) sourceV) + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hsuffix : TrAppSuffix world.venv uvars world.nameOf trProj Delta headV + args.toList sourceV) + (hlamSupport : support (.lam name bi ty body lamInfo)) + (hheadPost : WhnfPost trProj world uvars Delta headV + (.lam name bi ty body lamInfo)) + (hhead : methods.whnfCoreFlags head flags s = + .ok (.lam name bi ty body lamInfo) s1) + (hconsume : consumeBetaLams (.lam name bi ty body lamInfo) args = + (body0, consumed)) + (hI1 : WhnfStateInv layer semantics trProj world support uvars Delta + s1) : + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((whnfCoreWithFlagsStep (.app f arg info) flags).run methods) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta id + (.app f arg info) action) := by + intro hI + obtain ⟨hnonempty, hsubstMem, result, hfinish⟩ := + hcensus hsourceSupport hspine hlamSupport hconsume + obtain ⟨s2, hsubstRun, hI2, hsubstFrame⟩ := + hrun.simulSubst_whnf_eval hsubstMem hI1 + obtain ⟨s3, hfinishRun, hI3, hfinishFrame⟩ := + hfinish.eval hrun hI2 + have hsubSupport : + support (KExpr.simulSubstSpec body0 consumed.reverse 0) := + hrun.coverage.simulSubst hsubstMem _ + (KExpr.SimulSubstReach.spec consumed.reverse body0 0) + have hresultSupport : support result := + hfinish.support hrun hsubSupport + have hresultMeaning := hmeaning theory hI1.2.1.wf hsource hsuffix + hheadPost hconsume (hrun.requestBounds hsubstMem) hfinish + rw [whnfCoreWithFlagsStep_betaMany hspine hhead hconsume hnonempty + hsubstRun hfinishRun] + exact ⟨hI3, hresultSupport, hresultMeaning⟩ + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/CacheShell.lean b/Ix/Tc/Verify/Whnf/Structural/CacheShell.lean new file mode 100644 index 000000000..65e32a6c9 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/CacheShell.lean @@ -0,0 +1,388 @@ +import Ix.Tc.Verify.Whnf.StructEta.RebuildTail +import Ix.Tc.Verify.Suffix + +/-! +# Structural-core cache shell + +RebuildTail closes the deepest successful struct-eta rebuild tail. This slice +returns to the public structural driver and verifies its two cache partitions. +The existing outer-cache oracle deliberately owns only `whnfNoDelta`, +`whnfNoDeltaCheap`, and full `whnf`; structural core therefore gets a separate +collision-robust write interface for `whnfCore` and `whnfCoreCheap`. + +The dispatcher theorem remains conditional on one exhaustive +`WhnfStep.WF` for `whnfCoreWithFlagsStep`. Once that branch proof is +constructed, this file turns it into the complete public +`whnfCoreWithFlags` contract, including full/cheap hits, misses, transient +Nat bypass, and the legacy-variable prefix. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Collision-robust provenance for the two structural-core insertion sites. +An executed reduction at one source/context is not enough to justify a cache +entry: validity quantifies over every supported source sharing the expression +address and every context represented by the suffix digest. -/ +structure WhnfCoreCacheWriteOracle (keys : WhnfContextKeys) + (trProj : RawProjRel) (fallback : CacheSemantics) + (world : VerifyWorld) (support : RunSupport) : Prop where + full : forall {Delta source key result s}, + support source -> + support result -> + keys.Matches trProj world s Delta source key -> + WhnfMeaning trProj world keys.uvars Delta source result -> + CacheProvenance (whnfCacheSemantics keys trProj fallback) + (CacheAuthority.stable world) support + (.expr .whnfCore key result) + cheap : forall {Delta source key result s}, + support source -> + support result -> + keys.Matches trProj world s Delta source key -> + WhnfMeaning trProj world keys.uvars Delta source result -> + CacheProvenance (whnfCacheSemantics keys trProj fallback) + (CacheAuthority.stable world) support + (.expr .whnfCoreCheap key result) + +namespace WhnfCoreCacheWriteOracle + +/-- Closed expressions need no suffix transport. Finite expression-address +collision freedom identifies every supported source at the key, while direct +reference authorization remains explicit for the generated cache entry. -/ +theorem closed + {uvars : Nat} {trProj : RawProjRel} {fallback : CacheSemantics} + {world : VerifyWorld} {support : RunSupport} + (hcollision : support.CollisionFree) + (hreferences : forall {kind key source result}, + (kind = .whnfCore \/ kind = .whnfCoreCheap) -> + support source -> support result -> source.addr = key.1 -> + (CacheEntry.expr kind key result).ReferencesAuthorized + (CacheAuthority.stable world) support) : + WhnfCoreCacheWriteOracle (WhnfContextKeys.closed uvars) trProj fallback + world support := by + have build : forall {kind : ExprCacheKind} {Delta source key result s}, + (kind = .whnfCore \/ kind = .whnfCoreCheap) -> + support source -> + support result -> + (WhnfContextKeys.closed uvars).Matches trProj world s Delta source key -> + WhnfMeaning trProj world uvars Delta source result -> + CacheProvenance + (whnfCacheSemantics (WhnfContextKeys.closed uvars) trProj fallback) + (CacheAuthority.stable world) support (.expr kind key result) := by + intro kind Delta source key result s hkind hsource hresult hmatch hmeaning + have hDelta : Delta = [] := hmatch.2.1.2.2 + subst Delta + refine ⟨⟨⟨source, hsource, hmatch.sourceAddr⟩, hresult⟩, + hreferences hkind hsource hresult hmatch.sourceAddr, ?_⟩ + have his : kind.IsWhnf := by + rcases hkind with hkind | hkind + · subst kind + exact .whnfCore + · subst kind + exact .whnfCoreCheap + have htransport : forall other, support other -> other.addr = key.1 -> + forall Delta, + (WhnfContextKeys.closed uvars).Represents other.lbr key.2 Delta -> + WhnfMeaning trProj world uvars Delta other result := by + intro other hother haddr Delta hrepresented + have heq : source = other := by + have herase := hcollision.expr hsource hother + (hmatch.sourceAddr.trans haddr.symm) + simpa only [KExpr.eraseMeta_anon] using herase + subst other + have hDelta : Delta = [] := hrepresented.2.2 + subst Delta + exact hmeaning + cases his <;> exact htransport + refine ⟨?_, ?_⟩ + · intro Delta source key result s hsource hresult hmatch hmeaning + exact build (.inl rfl) hsource hresult hmatch hmeaning + · intro Delta source key result s hsource hresult hmatch hmeaning + exact build (.inr rfl) hsource hresult hmatch hmeaning + +end WhnfCoreCacheWriteOracle + +/-- Conditional Hoare closure for the keyed structural-core body. The +bounded semantic loop is supplied by `WhnfCoreTrace.uncached_wf`; this theorem +discharges the actual full/cheap cache control flow, including transient Nat +bypass and provenance-certified writes. -/ +theorem whnfCoreWithFlagsNonLeaf_wf + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {Delta : KVLCtx} {flags : WhnfFlags} + {source : KExpr .anon} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world keys.uvars) + (hkeyRep : WhnfKey.Represents keys trProj world source Delta) + (htransient : TransientNatWork.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta source) + (hstep : WhnfStep.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta id (fun cur => whnfCoreWithFlagsStep cur flags) + stepError) + (hwrites : WhnfCoreCacheWriteOracle keys trProj fallback world support) + (hsupport : support source) + {sourceV : Lean4Lean.VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s (whnfCoreWithFlagsNonLeaf source flags) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + have hinner : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 + (whnfCoreWithFlagsUncached source flags) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + fun s0 => RecM.WF.mono + (WhnfCoreTrace.uncached_wf theory hstep (s := s0) hsupport hsource) + (fun _ _ h => h) (fun _ _ _ => trivial) + unfold whnfCoreWithFlagsNonLeaf + apply RecM.WF.bind + (Q₁ := fun key _ => keys.Matches trProj world s Delta source key) + · apply RecM.WF.liftTcM + exact TcM.WF.mono + (TcM.whnfKey_matches_wf + (fun key after hctx hrun => hkeyRep s key after hctx hrun)) + (fun key _ h => h.1) (fun _ _ h => h) + · intro key s1 hmatch + apply RecM.WF.bind (htransient s1) + intro transient s2 _ + cases hfull : flags.isFull with + | true => + simp only [if_true] + cases transient with + | true => + simpa using hinner s2 + | false => + simp only [Bool.not_false, if_true] + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s2 ∧ after = s2) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + let found := s2.env.whnfCoreCache[key]? + cases hfound : found with + | some cached => + have hcache : s2.env.whnfCoreCache[key]? = some cached := by + simpa [found] using hfound + simp only [hcache] + exact RecM.WF.pure fun hI2 => by + have hcached := + (hI2.1.caches.hit (.whnfCore hcache)).supported.2 + have hmeaning := hI2.1.caches.whnfHitOfMatches + (.whnfCore hcache) .whnfCore hsupport hmatch + have hstart := WhnfPost.refl hsource + (theory.exprWF hI2.2.1 hsource) + exact ⟨hcached, + hstart.transMeaning theory hI2.2.1.wf hmeaning⟩ + | none => + have hcache : s2.env.whnfCoreCache[key]? = none := by + simpa [found] using hfound + simp only [hcache] + apply RecM.WF.bind (hinner s2) + intro result s3 hpost + let next := {s3 with env := {s3.env with + whnfCoreCache := s3.env.whnfCoreCache.insert key result}} + apply RecM.WF.bind (Q₁ := fun _ after => after = next) + · refine RecM.WF.modify (f := fun st => + {st with env := {st.env with whnfCoreCache := + st.env.whnfCoreCache.insert key result}}) ?_ + (fun _ => rfl) + intro hI3 + exact WhnfCoreCacheUpdate.full_whnfStateInv hI3 + (hwrites.full hsupport hpost.1 hmatch + (hpost.2.meaning hsource)) + · intro _ s4 hs4 + subst s4 + exact RecM.WF.pure fun _ => hpost + | false => + cases transient with + | true => + simpa using hinner s2 + | false => + simp only [Bool.not_false, if_true] + apply RecM.WF.bind + (Q₁ := fun observed after => observed = s2 ∧ after = s2) + (RecM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + let found := s2.env.whnfCoreCheapCache[key]? + cases hfound : found with + | some cached => + have hcache : s2.env.whnfCoreCheapCache[key]? = some cached := by + simpa [found] using hfound + simp only [hcache] + exact RecM.WF.pure fun hI2 => by + have hcached := + (hI2.1.caches.hit (.whnfCoreCheap hcache)).supported.2 + have hmeaning := hI2.1.caches.whnfHitOfMatches + (.whnfCoreCheap hcache) .whnfCoreCheap hsupport hmatch + have hstart := WhnfPost.refl hsource + (theory.exprWF hI2.2.1 hsource) + exact ⟨hcached, + hstart.transMeaning theory hI2.2.1.wf hmeaning⟩ + | none => + have hcache : s2.env.whnfCoreCheapCache[key]? = none := by + simpa [found] using hfound + simp only [hcache] + apply RecM.WF.bind (hinner s2) + intro result s3 hpost + let next := {s3 with env := {s3.env with + whnfCoreCheapCache := + s3.env.whnfCoreCheapCache.insert key result}} + apply RecM.WF.bind (Q₁ := fun _ after => after = next) + · refine RecM.WF.modify (f := fun st => + {st with env := {st.env with whnfCoreCheapCache := + st.env.whnfCoreCheapCache.insert key result}}) ?_ + (fun _ => rfl) + intro hI3 + exact WhnfCoreCacheUpdate.cheap_whnfStateInv hI3 + (hwrites.cheap hsupport hpost.1 hmatch + (hpost.2.meaning hsource)) + · intro _ s4 hs4 + subst s4 + exact RecM.WF.pure fun _ => hpost + +/-- Conditional closure of the actual public structural dispatcher for every +expression form. Immediate leaves are reflexive; a legacy variable performs +the proved read-only let test and enters the same keyed shell only when it is +actually zeta-reducible. -/ +theorem whnfCoreWithFlags_wf + {keys : WhnfContextKeys} {fallback : CacheSemantics} + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} {Delta : KVLCtx} {flags : WhnfFlags} + {source : KExpr .anon} + {stepError : TcError .anon -> TcState .anon -> Prop} + (theory : WhnfTheory trProj world keys.uvars) + (hkeyRep : WhnfKey.Represents keys trProj world source Delta) + (htransient : TransientNatWork.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta source) + (hstep : WhnfStep.WF layer + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta id (fun cur => whnfCoreWithFlagsStep cur flags) + stepError) + (hwrites : WhnfCoreCacheWriteOracle keys trProj fallback world support) + (hsupport : support source) + {sourceV : Lean4Lean.VExpr} {s : TcState .anon} + (hsource : TrKExprS world.venv keys.uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s (whnfCoreWithFlags source flags) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := by + have hreflexive : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 (pure source) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + fun s0 => RecM.WF.pure fun hI => + ⟨hsupport, WhnfPost.refl hsource (theory.exprWF hI.2.1 hsource)⟩ + have hshell : forall s0, + RecM.WF layer (whnfCacheSemantics keys trProj fallback) trProj world + support keys.uvars Delta s0 (whnfCoreWithFlagsNonLeaf source flags) + (fun result _ => support result ∧ + WhnfPost trProj world keys.uvars Delta sourceV result) := + fun s0 => whnfCoreWithFlagsNonLeaf_wf theory hkeyRep htransient hstep + hwrites hsupport (s := s0) hsource + cases source with + | sort u info => + simpa [whnfCoreWithFlags] using hreflexive s + | all name bi ty body info => + simpa [whnfCoreWithFlags] using hreflexive s + | lam name bi ty body info => + simpa [whnfCoreWithFlags] using hreflexive s + | nat value blob info => + simpa [whnfCoreWithFlags] using hreflexive s + | str value blob info => + simpa [whnfCoreWithFlags] using hreflexive s + | const id us info => + simpa [whnfCoreWithFlags] using hreflexive s + | fvar id name info => + simpa [whnfCoreWithFlags] using hshell s + | app f arg info => + simpa [whnfCoreWithFlags] using hshell s + | letE name ty value body nondep info => + simpa [whnfCoreWithFlags] using hshell s + | prj id field value info => + simpa [whnfCoreWithFlags] using hshell s + | var idx name info => + unfold whnfCoreWithFlags + apply RecM.WF.bind + · apply RecM.WF.liftTcM + exact TcM.isLetVar_wf idx s + · intro isLet s1 hs1 + subst s1 + cases isLet with + | false => + simpa using hreflexive s + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false, + pure_bind] + exact hshell s + +end RecM + +namespace WhnfSuffixModel + +/-- Suffix transport plus finite expression collision freedom constructs the +two structural-core write rules. This is the open-context counterpart of +`WhnfCoreCacheWriteOracle.closed`; it relies on the same operational suffix +model already consumed by the three outer WHNF cache partitions. -/ +theorem coreCacheWriteOracle + {trProj : RawProjRel} {fallback : CacheSemantics} + {world : VerifyWorld} {support : RunSupport} + (model : WhnfSuffixModel trProj world) + (hcollision : support.CollisionFree) + (hreferences : ∀ {kind key source result}, + (kind = .whnfCore ∨ kind = .whnfCoreCheap) → + support source → support result → source.addr = key.1 → + (CacheEntry.expr kind key result).ReferencesAuthorized + (CacheAuthority.stable world) support) : + RecM.WhnfCoreCacheWriteOracle model.keys trProj fallback world support := by + have build : ∀ {kind : ExprCacheKind} {Delta source key result s}, + (kind = .whnfCore ∨ kind = .whnfCoreCheap) → + support source → + support result → + model.keys.Matches trProj world s Delta source key → + WhnfMeaning trProj world model.keys.uvars Delta source result → + CacheProvenance + (whnfCacheSemantics model.keys trProj fallback) + (CacheAuthority.stable world) support (.expr kind key result) := by + intro kind Delta source key result s hkind hsource hresult hmatch hmeaning + refine ⟨⟨⟨source, hsource, hmatch.sourceAddr⟩, hresult⟩, + hreferences hkind hsource hresult hmatch.sourceAddr, ?_⟩ + have his : kind.IsWhnf := by + rcases hkind with hkind | hkind + · subst kind + exact .whnfCore + · subst kind + exact .whnfCoreCheap + have hvalid : ∀ other, support other → other.addr = key.1 → + ∀ Delta', model.keys.Represents other.lbr key.2 Delta' → + WhnfMeaning trProj world model.keys.uvars Delta' other result := by + intro other hother haddr Delta' hrepresented + have heq : source = other := by + have herase := hcollision.expr hsource hother + (hmatch.sourceAddr.trans haddr.symm) + simpa only [KExpr.eraseMeta_anon] using herase + subst other + exact model.transport hmatch.2.1 hrepresented hmeaning + cases his <;> exact hvalid + refine ⟨?_, ?_⟩ + · intro Delta source key result s hsource hresult hmatch hmeaning + exact build (.inl rfl) hsource hresult hmatch hmeaning + · intro Delta source key result s hsource hresult hmatch hmeaning + exact build (.inr rfl) hsource hresult hmatch hmeaning + +end WhnfSuffixModel + +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/ProjectionStep.lean b/Ix/Tc/Verify/Whnf/Structural/ProjectionStep.lean new file mode 100644 index 000000000..c717b7bdb --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/ProjectionStep.lean @@ -0,0 +1,155 @@ +import Ix.Tc.Verify.Whnf.Structural.RecursiveCallbacks + +/-! +# Exhaustive projection-step closure + +RecursiveCallbacks derives the policy-selected projection-value callback from the smaller +method table. The remaining helper has its own effects: String expansion +interns a constructor spine and invokes full WHNF, the accelerated layer may +rewrite `Fin.val` through `Decidable.rec`, and constructor lookup may invoke +lazy ingress. + +`ProjectionHelper.WF` records exactly that remaining implementation boundary: +for a supported callback result, the actual `tryProjReduce` computation +preserves the fixed K1 state invariant on hits, misses, and errors, and any +successful result remains in finite run support. The step theorem below then +proves every concrete projection outcome. Semantic authority for a hit stays +with `InductiveReductionOracle`; a syntax-directed helper execution alone is +not treated as a Theory projection equation. +-/ + +namespace Ix.Tc +namespace RecM + +namespace ProjectionHelper + +/-- State and finite-result closure of the exact production projection +helper. This is intentionally indexed by supported inputs rather than all +raw expressions, so it can be instantiated by a finite execution census. -/ +def WF (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) : Prop := + forall {uvars Delta methods s id field value}, + Methods.WFAt layer semantics trProj world support uvars methods -> + support value -> + TcM.WF (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((tryProjReduce id field value).run methods) + (fun result _ => match result with + | none => True + | some reduced => support reduced) + +end ProjectionHelper + +/-- Exhaustive local `WhnfStep.WF` contract for a projection. Callback and +helper errors preserve the invariant and are admitted by the structural +loop's ordinary error relation; a helper miss returns the original source +with reflexive meaning; a helper hit combines finite result support with the +projection oracle's semantic certificate. -/ +theorem whnfCoreWithFlagsStep_projection_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} + {id : KId .anon} {field : UInt64} {value : KExpr .anon} + {info : ExprInfo .anon} {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hinputs : WhnfCoreInputSupport support) + (hhelper : ProjectionHelper.WF layer semantics trProj world support) + (horacle : InductiveReductionOracle layer semantics trProj world + support) : + forall s, + WhnfStep.Source trProj world support uvars Delta (fun e => e) + (KExpr.prj id field value info) -> + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreWithFlagsStep (.prj id field value info) flags) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta + (fun e => e) (KExpr.prj id field value info) action) + (fun _ _ => True) := by + intro s hsource methods hmethods hI + obtain ⟨hsourceSupport, sourceV, hsourceTr⟩ := hsource + obtain ⟨valueV, hvalueTr, hcallbackWF⟩ := + projectionValueCallback_wf (s := s) (flags := flags) hinputs + hsourceSupport hsourceTr + have hcallbackPost := hcallbackWF methods hmethods hI + match hcallbackRun : + ((if flags.cheapProj then whnfCoreFlagsRec value flags + else whnfRec value).run methods s) with + | .error err s1 => + rw [hcallbackRun] at hcallbackPost + have hwhnf : + (if flags.cheapProj then + (whnfCoreFlagsRec value flags).run methods s + else (whnfRec value).run methods s) = .error err s1 := by + cases hcheap : flags.cheapProj + · simpa only [hcheap, Bool.false_eq_true, if_false] using hcallbackRun + · simpa only [hcheap, if_true] using hcallbackRun + rw [whnfCoreWithFlagsStep_projectionWhnfError hwhnf] + exact ⟨hcallbackPost.1, trivial⟩ + | .ok wvalue s1 => + rw [hcallbackRun] at hcallbackPost + have hwhnf : + (if flags.cheapProj then + (whnfCoreFlagsRec value flags).run methods s + else (whnfRec value).run methods s) = .ok wvalue s1 := by + cases hcheap : flags.cheapProj + · simpa only [hcheap, Bool.false_eq_true, if_false] using hcallbackRun + · simpa only [hcheap, if_true] using hcallbackRun + have hhelperPost := + hhelper (id := id) (field := field) hmethods + hcallbackPost.2.1 hcallbackPost.1 + match hreduce : (tryProjReduce id field wvalue).run methods s1 with + | .error err s2 => + rw [hreduce] at hhelperPost + rw [whnfCoreWithFlagsStep_projectionReduceError hwhnf hreduce] + exact ⟨hhelperPost.1, trivial⟩ + | .ok none s2 => + rw [hreduce] at hhelperPost + rw [whnfCoreWithFlagsStep_projectionDone hwhnf hreduce] + exact ⟨hhelperPost.1, hsourceSupport, + WhnfMeaning.refl hsourceTr + (theory.exprWF hI.2.1 hsourceTr)⟩ + | .ok (some result) s2 => + rw [hreduce] at hhelperPost + have hsemantic := + horacle.projection hmethods hsourceTr hI hwhnf hreduce + rw [whnfCoreWithFlagsStep_projection hwhnf hreduce] + exact ⟨hsemantic.1, hhelperPost.2, hsemantic.2⟩ + +/-- VariableStep's basic/legacy cases extended with the complete projection split. -/ +inductive WhnfCoreBasicVarProjection : KExpr .anon -> Prop + | basicVar {e} : + WhnfCoreBasicVar e -> WhnfCoreBasicVarProjection e + | projection {id field value info} : + WhnfCoreBasicVarProjection (.prj id field value info) + +theorem whnfCoreWithFlagsStep_basicVarProjection_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (hlet : LetSubstRequestCensus requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {source : KExpr .anon} {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hfvar : FVarZetaSafety layer semantics trProj world support uvars Delta) + (hvar : LegacyZetaRequestCensus layer semantics trProj world support + uvars Delta requests) + (hinputs : WhnfCoreInputSupport support) + (hhelper : ProjectionHelper.WF layer semantics trProj world support) + (horacle : InductiveReductionOracle layer semantics trProj world support) + (hcase : WhnfCoreBasicVarProjection source) : + forall s, + WhnfStep.Source trProj world support uvars Delta id source -> + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreWithFlagsStep source flags) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta id + source action) + (fun _ _ => True) := by + cases hcase with + | basicVar hbasic => + exact whnfCoreWithFlagsStep_basicVar_wf hrun hlet theory hfvar hvar + hbasic + | projection => + exact whnfCoreWithFlagsStep_projection_wf theory hinputs hhelper + horacle + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/RecursiveCallbacks.lean b/Ix/Tc/Verify/Whnf/Structural/RecursiveCallbacks.lean new file mode 100644 index 000000000..d9d718205 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/RecursiveCallbacks.lean @@ -0,0 +1,145 @@ +import Ix.Tc.Verify.Whnf.Structural.VariableStep + +/-! +# Structural recursive-callback closure + +The remaining projection and application cases both recurse through the +predecessor method table before their syntax-directed helper runs. A +structural translation already identifies the projected value and the +application-spine head, but `RunSupport` is an arbitrary finite predicate: +support for a parent expression does not silently imply support for either +child. + +This slice names that finite child-coverage obligation and then instantiates +the exact full/cheap callback contracts from `Methods.WF`. It is deliberately +only a support boundary; semantic translation of each child is derived from +the translated parent. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Finite support closure needed by one structural-WHNF iteration. The app +field covers both the head callback and every argument later consumed by beta, +iota, or application rebuilding. -/ +structure WhnfCoreInputSupport (support : RunSupport) : Prop where + projection : forall {id : KId .anon} {field : UInt64} + {value : KExpr .anon} {info : ExprInfo .anon}, + support (.prj id field value info) -> support value + app : forall {f arg : KExpr .anon} {info : ExprInfo .anon} + {head : KExpr .anon} {args : Array (KExpr .anon)}, + support (.app f arg info) -> + (.app f arg info : KExpr .anon).collectSpine = (head, args) -> + support head /\ forall child, child ∈ args.toList -> support child + +/-- The recursive structural-WHNF callback is exactly the corresponding +field of the predecessor method table. -/ +theorem whnfCoreFlagsRec_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + {flags : WhnfFlags} + (hsource : support source) + (htr : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreFlagsRec source flags) + (fun result _ => support result /\ + WhnfPost trProj world uvars Delta sourceV result) := by + intro methods hmethods + simpa only [whnfCoreFlagsRec] using + hmethods.whnfCoreFlags hsource htr + +namespace TrAppSpine + +/-- A typed application spine retains the translation of its raw head. -/ +theorem headTr + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address -> Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {head : KExpr .anon} + {args : List (KExpr .anon)} {resultV : Lean4Lean.VExpr} + (h : TrAppSpine env uvars nameOf trProj Delta head args resultV) : + exists headV, + TrKExprS env uvars nameOf trProj Delta head headV := by + induction h with + | head hhead => exact ⟨_, hhead⟩ + | app hprefix hfun harg hargTr ih => exact ih + +end TrAppSpine + +/-- The projection-value callback inherits either full WHNF or structural +WHNF according to the production `cheapProj` branch. Translation of the +value is obtained by inversion of the translated projection source. -/ +theorem projectionValueCallback_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {id : KId .anon} {field : UInt64} {value : KExpr .anon} + {info : ExprInfo .anon} {sourceV : Lean4Lean.VExpr} + {flags : WhnfFlags} + (hinputs : WhnfCoreInputSupport support) + (hsupport : support (.prj id field value info)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.prj id field value info) sourceV) : + exists valueV, + TrKExprS world.venv uvars world.nameOf trProj Delta value valueV /\ + RecM.WF layer semantics trProj world support uvars Delta s + (if flags.cheapProj then whnfCoreFlagsRec value flags + else whnfRec value) + (fun result _ => support result /\ + WhnfPost trProj world uvars Delta valueV result) := by + cases hsource with + | prj hname hvalueTr hproj => + refine ⟨_, hvalueTr, ?_⟩ + have hvalueSupport := hinputs.projection hsupport + cases hcheap : flags.cheapProj with + | false => + simp only [Bool.false_eq_true, if_false] + exact whnfRec_wf hvalueSupport hvalueTr + | true => + simp only [if_true] + exact whnfCoreFlagsRec_wf hvalueSupport hvalueTr + +/-- The application-head callback is justified by the actual production +spine equation. `TrAppSpine` supplies its translation and the finite input +support boundary supplies its callback admissibility. -/ +theorem applicationHeadCallback_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {s : TcState .anon} + {f arg head : KExpr .anon} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} {sourceV : Lean4Lean.VExpr} + {flags : WhnfFlags} + (hinputs : WhnfCoreInputSupport support) + (hsupport : support (.app f arg info)) + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.app f arg info) sourceV) + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) : + exists headV, + TrKExprS world.venv uvars world.nameOf trProj Delta head headV /\ + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreFlagsRec head flags) + (fun result _ => support result /\ + WhnfPost trProj world uvars Delta headV result) := by + have htyped := trAppSpine_of_collectSpine hsource hspine + obtain ⟨headV, hheadTr⟩ := htyped.headTr + have hheadSupport := (hinputs.app hsupport hspine).1 + exact ⟨headV, hheadTr, + whnfCoreFlagsRec_wf hheadSupport hheadTr⟩ + +/-- Every concrete member of the production argument array is in finite run +support. This projection of `WhnfCoreInputSupport` is the form consumed by +the walker and rebuild request censuses in the remaining app proof. -/ +theorem applicationArgument_support + {support : RunSupport} (hinputs : WhnfCoreInputSupport support) + {f arg head child : KExpr .anon} {info : ExprInfo .anon} + {args : Array (KExpr .anon)} + (hsupport : support (.app f arg info)) + (hspine : (.app f arg info : KExpr .anon).collectSpine = (head, args)) + (hmem : child ∈ args.toList) : + support child := + (hinputs.app hsupport hspine).2 child hmem + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/Reducer.lean b/Ix/Tc/Verify/Whnf/Structural/Reducer.lean new file mode 100644 index 000000000..adc6d8fce --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/Reducer.lean @@ -0,0 +1,118 @@ +import Ix.Tc.Verify.Whnf.Structural.VerifiedStep +import Ix.Tc.Verify.Whnf.Iota.OptionalReduction + +/-! +# Construct the structural reducer + +This slice connects the exhaustive local step to the bounded structural +driver and its real cache shell. The context is indexed by the actual +universe count and local context used by `WhnfContextKeys`; it therefore +cannot replay a cache meaning proved at one universe count as though it held +at every other count. + +`StructuralCoreContext.wf` produces the exact `StructuralReduction.WF` +consumed by the no-delta reducer. In particular, its iota field is OptionalReduction's +state/semantic composition rather than a free `OptionalReduction.WF` +parameter. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Complete fixed-context input for the production structural reducer. + +The remaining fields are owned by distinct parts of the verification model: +finite execution coverage, Theory, local-context safety, projection and +inductive admission, suffix-key interpretation, and collision-robust cache +provenance. -/ +structure StructuralCoreContext {alpha : Type} + (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) (keys : WhnfContextKeys) + (fallback : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) + (Delta : KVLCtx) (flags : WhnfFlags) : Type where + run : RunAssumptions initial program requests support + letCensus : LetSubstRequestCensus requests support + betaCensus : BetaRequestCensus requests support + applicationCensus : ApplicationFinishRequestCensus requests support + kCensus : KSynthCandidateRequestCensus requests + iotaCensus : IotaRuleRequestCensus requests + structEtaCensus : StructEtaFinishRequestCensus requests + theory : WhnfTheory trProj world keys.uvars + fvar : FVarZetaSafety .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta + legacyVar : LegacyZetaRequestCensus .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta requests + inputs : WhnfCoreInputSupport support + telescopeInputs : ConstructorTelescopeInputSupport support + constructorInputs : ConstructorTelescopeInputOracle trProj world support + recursorInputs : StructEtaRecursorInputOracle trProj world support + projectionHelper : ProjectionHelper.WF .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + inductiveReduction : InductiveReductionOracle .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + strings : ProjectionStringPlanContext trProj world support + kSynthInputs : + KSynthCandidateInputOracle trProj world support + natOffsetCleanupInputs : + NatOffsetCleanupInputOracle trProj world support + iotaIngress : AnonLazyIngressContext .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + iotaCallbacks : IotaCallbackFrameOracle + (whnfCacheSemantics keys trProj fallback) trProj world support + iotaSuccess : IotaSuccessOracle + (whnfCacheSemantics keys trProj fallback) trProj world support + keyRep : ∀ source, support source → + WhnfKey.Represents keys trProj world source Delta + cacheWrites : WhnfCoreCacheWriteOracle keys trProj fallback world support + +namespace StructuralCoreContext + +/-- The actual public `whnfCoreWithFlags` satisfies the structural-reduction +contract at the universe/context encoded by the cache model. -/ +theorem wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {keys : WhnfContextKeys} + {fallback : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {Delta : KVLCtx} {flags : WhnfFlags} + (context : StructuralCoreContext initial program requests keys fallback + trProj world support Delta flags) : + StructuralReduction.WF .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + keys.uvars Delta flags := by + intro source sourceV s hsourceSupport hsource + have hiota : OptionalReduction.WF .noAccel + (whnfCacheSemantics keys trProj fallback) trProj world support + (fun source => tryIotaWithFlags source flags) := + tryIotaWithFlags_optional_wf_of_contexts context.run context.kCensus + context.iotaCensus context.structEtaCensus context.strings + context.inputs context.telescopeInputs context.constructorInputs + context.recursorInputs context.kSynthInputs + context.natOffsetCleanupInputs + context.iotaIngress + context.iotaCallbacks context.iotaSuccess flags + have hstep := + whnfCoreWithFlagsStep_constructive_wf + (uvars := keys.uvars) (Delta := Delta) + context.run context.letCensus context.betaCensus + context.applicationCensus context.theory context.fvar + context.legacyVar context.inputs context.projectionHelper + context.inductiveReduction hiota + have hdriver := + whnfCoreWithFlags_wf context.theory + (context.keyRep source hsourceSupport) + (TransientNatWork.preserving + (context.iotaIngress.preserves + (uvars := keys.uvars) (Delta := Delta)) + source) + hstep context.cacheWrites hsourceSupport (s := s) hsource + exact RecM.WF.mono hdriver + (fun _ _ hpost => ⟨hpost.1, hpost.2.meaning hsource⟩) + (fun _ _ herror => herror) + +end StructuralCoreContext +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/StepAssembly.lean b/Ix/Tc/Verify/Whnf/Structural/StepAssembly.lean new file mode 100644 index 000000000..cfdd1b8f5 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/StepAssembly.lean @@ -0,0 +1,85 @@ +import Ix.Tc.Verify.Whnf.Structural.ApplicationStep + +/-! +# Exhaustive structural-step assembly + +All eleven raw expression constructors are dispatched here. The theorem is +the single local `WhnfStep.WF` consumed by the already verified bounded loop +and cache shell; no syntax branch remains implicit in a classifier premise. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Exhaustive contract for one actual `whnfCoreWithFlagsStep` iteration. -/ +theorem whnfCoreWithFlagsStep_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (hlet : LetSubstRequestCensus requests support) + (hbeta : BetaRequestCensus requests support) + (hfinish : ApplicationFinishRequestCensus requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hfvar : FVarZetaSafety layer semantics trProj world support uvars Delta) + (hvar : LegacyZetaRequestCensus layer semantics trProj world support + uvars Delta requests) + (hinputs : WhnfCoreInputSupport support) + (hprojection : ProjectionHelper.WF layer semantics trProj world support) + (hinductive : InductiveReductionOracle layer semantics trProj world + support) + (hbetaMeaning : BetaManyMeaningOracle trProj world) + (hiota : OptionalReduction.WF layer semantics trProj world support + (fun source => tryIotaWithFlags source flags)) : + WhnfStep.WF layer semantics trProj world support uvars Delta id + (fun source => whnfCoreWithFlagsStep source flags) + (fun _ _ => True) := by + intro source s hsource + cases source with + | var => + exact whnfCoreWithFlagsStep_basicVarProjection_wf hrun hlet theory + hfvar hvar hinputs hprojection hinductive + (.basicVar .var) s hsource + | fvar => + exact whnfCoreWithFlagsStep_basicVarProjection_wf hrun hlet theory + hfvar hvar hinputs hprojection hinductive + (.basicVar (.basic .fvar)) s hsource + | sort => + exact whnfCoreWithFlagsStep_basicVarProjection_wf hrun hlet theory + hfvar hvar hinputs hprojection hinductive + (.basicVar (.basic (.leaf .sort))) s hsource + | const => + exact whnfCoreWithFlagsStep_basicVarProjection_wf hrun hlet theory + hfvar hvar hinputs hprojection hinductive + (.basicVar (.basic (.leaf .const))) s hsource + | app => + exact whnfCoreWithFlagsStep_app_wf hrun hbeta hfinish theory hinputs + hbetaMeaning hiota s hsource + | lam => + exact whnfCoreWithFlagsStep_basicVarProjection_wf hrun hlet theory + hfvar hvar hinputs hprojection hinductive + (.basicVar (.basic (.leaf .lam))) s hsource + | all => + exact whnfCoreWithFlagsStep_basicVarProjection_wf hrun hlet theory + hfvar hvar hinputs hprojection hinductive + (.basicVar (.basic (.leaf .all))) s hsource + | letE => + exact whnfCoreWithFlagsStep_basicVarProjection_wf hrun hlet theory + hfvar hvar hinputs hprojection hinductive + (.basicVar (.basic .letE)) s hsource + | prj => + exact whnfCoreWithFlagsStep_basicVarProjection_wf hrun hlet theory + hfvar hvar hinputs hprojection hinductive .projection s hsource + | nat => + exact whnfCoreWithFlagsStep_basicVarProjection_wf hrun hlet theory + hfvar hvar hinputs hprojection hinductive + (.basicVar (.basic (.leaf .nat))) s hsource + | str => + exact whnfCoreWithFlagsStep_basicVarProjection_wf hrun hlet theory + hfvar hvar hinputs hprojection hinductive + (.basicVar (.basic (.leaf .str))) s hsource + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/VariableStep.lean b/Ix/Tc/Verify/Whnf/Structural/VariableStep.lean new file mode 100644 index 000000000..d20727dbd --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/VariableStep.lean @@ -0,0 +1,196 @@ +import Ix.Tc.Verify.Whnf.Structural.BasicStep + +/-! +# Legacy-variable structural-step closure + +The legacy `.var` branch reads a de Bruijn let value and rebases it with the +verified lift walker. BasicStep's fvar branch needed an unchanged-value safety +invariant; legacy zeta instead gets all construction and no-wrap facts from +the exact finite lift request. `CtxRecon.lookupLetVal_liftBounds` connects +those walker-tight bounds to the semantic context without introducing the +older, stronger `Δ.bvars + val.size` assumption. +-/ + +namespace Ix.Tc + +namespace TcM + +/-- An in-range non-let entry makes `lookupLetVal` return `none` without +changing state or invoking the lift walker. -/ +theorem lookupLetVal_noLet + {idx : UInt64} {s : TcState .anon} + (hidx : idx.toNat < s.ctx.size) + (hval : s.letVals[s.ctx.size - 1 - idx.toNat]! = none) : + TcM.lookupLetVal idx s = .ok none s := by + unfold TcM.lookupLetVal + change EStateM.bind (get : TcM .anon (TcState .anon)) _ s = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) s = .ok s s from rfl] + simp only + rw [if_neg (by omega)] + simp only [pure_bind] + rw [hval] + rfl + +end TcM + +namespace WhnfMeaning + +/-- Legacy zeta meaning from the exact lift-walker arithmetic contract. -/ +theorem zetaVar_liftBounds + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {s : TcState .anon} {Delta : KVLCtx} + {idx : UInt64} {name : Mode.anon.F Name} {info : ExprInfo .anon} + {ty val : KExpr .anon} + (hctx : CtxRecon world.venv uvars world.nameOf trProj s Delta) + (htp : TrProjOK world.venv uvars trProj) + (hidx : idx.toNat < s.ctx.size) + (hshift : (idx + 1).toNat = idx.toNat + 1) + (hty : s.ctx[s.ctx.size - 1 - idx.toNat]? = some ty) + (hov : s.letVals[s.ctx.size - 1 - idx.toNat]? = some (some val)) + (hcon : KExpr.Constructed val) + (hcut : (0 : UInt64).toNat + val.size < UInt64.size) + (hlift : val.lbr.toNat + val.size + (idx + 1).toNat < UInt64.size) : + WhnfMeaning trProj world uvars Delta (.var idx name info) + (KExpr.liftSpec val (idx + 1) 0) := by + obtain ⟨e, A, hfind, hresult⟩ := hctx.lookupLetVal_liftBounds + world.venvWF.ordered htp hidx hshift hty hov hcon hcut hlift + have hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.var idx name info) e := .var hfind + have hwf : Lean4Lean.VExpr.WF world.venv uvars Delta.toCtx e := + ⟨A, hctx.wf.find?_wf world.venvWF.ordered hfind⟩ + exact ⟨e, e, hsource, hresult, hwf⟩ + +end WhnfMeaning + +namespace RecM + +/-- Every supported legacy variable that resolves to a concrete let value +must have its exact lift request in the finite run census. Misses need no +request. -/ +def LegacyZetaRequestCensus + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (requests : List WalkerRequest) : Prop := + ∀ {s : TcState .anon} {idx : UInt64} {name : Mode.anon.F Name} + {info : ExprInfo .anon} {val : KExpr .anon}, + WhnfStateInv layer semantics trProj world support uvars Delta s → + support (.var idx name info) → + idx.toNat < s.ctx.size → + s.letVals[s.ctx.size - 1 - idx.toNat]! = some val → + idx.toNat + 1 < UInt64.size ∧ + WalkerRequest.lift val (idx + 1) 0 ∈ requests + +/-- Exhaustive legacy-variable step closure. Source translation proves that +the index is in range; the concrete let-value observation selects either the +state-pure miss or the request-certified zeta step. -/ +theorem whnfCoreWithFlagsStep_var_wf + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {idx : UInt64} {name : Mode.anon.F Name} + {info : ExprInfo .anon} {flags : WhnfFlags} + {stepError : TcError .anon → TcState .anon → Prop} + (theory : WhnfTheory trProj world uvars) + (hcensus : LegacyZetaRequestCensus layer semantics trProj world support + uvars Delta requests) : + ∀ s, + WhnfStep.Source trProj world support uvars Delta id + (.var idx name info) → + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreWithFlagsStep (.var idx name info) flags) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta id + (.var idx name info) action) + stepError := by + intro s hsource methods hmethods hI + obtain ⟨hsourceSupport, sourceV, hsourceTr⟩ := hsource + have hidx : idx.toNat < s.ctx.size := by + rw [← hI.2.1.bvars_eq] + cases hsourceTr with + | var hsourceFind => exact KVLCtx.find?_inl_lt hsourceFind + let level := s.ctx.size - 1 - idx.toNat + have hlevel : level < s.ctx.size := by + dsimp only [level] + omega + have hletLevel : level < s.letVals.size := by + rw [← hI.2.1.size_eq] + exact hlevel + let ty := s.ctx[level] + have hty : s.ctx[level]? = some ty := by + apply getElem?_eq_some_iff.mpr + exact ⟨hlevel, rfl⟩ + cases hbang : s.letVals[level]! with + | none => + have hlookup : TcM.lookupLetVal idx s = .ok none s := by + apply TcM.lookupLetVal_noLet hidx + simpa only [level] using hbang + rw [whnfCoreWithFlagsStep_varDone hlookup] + exact ⟨hI, hsourceSupport, + WhnfMeaning.refl hsourceTr + (theory.exprWF hI.2.1 hsourceTr)⟩ + | some val => + have hov : s.letVals[level]? = some (some val) := by + apply getElem?_eq_some_iff.mpr + refine ⟨hletLevel, ?_⟩ + have hbang' := hbang + rw [getElem!_pos s.letVals level hletLevel] at hbang' + exact hbang' + obtain ⟨hidxNoWrap, hmem⟩ := + hcensus hI hsourceSupport hidx + (by simpa only [level] using hbang) + have hshift : (idx + 1).toNat = idx.toNat + 1 := by + rw [UInt64.toNat_add, show (1 : UInt64).toNat = 1 from rfl] + exact Nat.mod_eq_of_lt hidxNoWrap + obtain ⟨hcon, hcut, hliftBound⟩ := hrun.requestBounds hmem + obtain ⟨s', hliftRun, hI', hframe⟩ := + hrun.lift_whnf_eval hmem hI + have hlookup : TcM.lookupLetVal idx s = + .ok (some (KExpr.liftSpec val (idx + 1) 0)) s' := + TcM.lookupLetVal_eval hidx + (by simpa only [level] using hbang) hliftRun + rw [whnfCoreWithFlagsStep_varZeta hlookup] + have hresultSupport : + support (KExpr.liftSpec val (idx + 1) 0) := + hrun.coverage.lift hmem _ (KExpr.LiftReach.spec (idx + 1) val 0) + have hmeaning := WhnfMeaning.zetaVar_liftBounds + (name := name) (info := info) hI.2.1 + theory.projections hidx hshift (by simpa only [level] using hty) + (by simpa only [level] using hov) hcon hcut hliftBound + exact ⟨hI', hresultSupport, hmeaning⟩ + +/-- Basic structural cases extended with the complete legacy-variable split. -/ +inductive WhnfCoreBasicVar : KExpr .anon → Prop + | basic {e} : WhnfCoreBasic e → WhnfCoreBasicVar e + | var {idx name info} : WhnfCoreBasicVar (.var idx name info) + +theorem whnfCoreWithFlagsStep_basicVar_wf + {α : Type} {initial : TcState .anon} {program : TcM .anon α} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (hlet : LetSubstRequestCensus requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {source : KExpr .anon} {flags : WhnfFlags} + {stepError : TcError .anon → TcState .anon → Prop} + (theory : WhnfTheory trProj world uvars) + (hfvar : FVarZetaSafety layer semantics trProj world support uvars Delta) + (hvar : LegacyZetaRequestCensus layer semantics trProj world support + uvars Delta requests) + (hbasic : WhnfCoreBasicVar source) : + ∀ s, + WhnfStep.Source trProj world support uvars Delta id source → + RecM.WF layer semantics trProj world support uvars Delta s + (whnfCoreWithFlagsStep source flags) + (fun action _ => WhnfStep.Meaning trProj world support uvars Delta id + source action) + stepError := by + cases hbasic with + | basic h => + exact whnfCoreWithFlagsStep_basic_wf hrun hlet theory hfvar h + | var => + exact whnfCoreWithFlagsStep_var_wf hrun theory hvar + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Whnf/Structural/VerifiedStep.lean b/Ix/Tc/Verify/Whnf/Structural/VerifiedStep.lean new file mode 100644 index 000000000..0263c3dd0 --- /dev/null +++ b/Ix/Tc/Verify/Whnf/Structural/VerifiedStep.lean @@ -0,0 +1,44 @@ +import Ix.Tc.Verify.Whnf.Beta.Meaning + +/-! +# Structural step without a beta oracle + +`StepAssembly` assembled every raw-expression constructor but retained the historical +`BetaManyMeaningOracle` parameter. `Meaning` constructs that contract from the +Theory and translation invariants, so the production structural step can now +be exposed with only its genuine helper and finite-run boundaries. +-/ + +namespace Ix.Tc +namespace RecM + +/-- Exhaustive `whnfCoreWithFlagsStep` closure with general multi-beta proved +constructively. -/ +theorem whnfCoreWithFlagsStep_constructive_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {support : RunSupport} + (hrun : RunAssumptions initial program requests support) + (hlet : LetSubstRequestCensus requests support) + (hbeta : BetaRequestCensus requests support) + (hfinish : ApplicationFinishRequestCensus requests support) + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {flags : WhnfFlags} + (theory : WhnfTheory trProj world uvars) + (hfvar : FVarZetaSafety layer semantics trProj world support uvars Delta) + (hvar : LegacyZetaRequestCensus layer semantics trProj world support + uvars Delta requests) + (hinputs : WhnfCoreInputSupport support) + (hprojection : ProjectionHelper.WF layer semantics trProj world support) + (hinductive : InductiveReductionOracle layer semantics trProj world + support) + (hiota : OptionalReduction.WF layer semantics trProj world support + (fun source => tryIotaWithFlags source flags)) : + WhnfStep.WF layer semantics trProj world support uvars Delta id + (fun source => whnfCoreWithFlagsStep source flags) + (fun _ _ => True) := + whnfCoreWithFlagsStep_wf hrun hlet hbeta hfinish theory hfvar hvar + hinputs hprojection hinductive (betaManyMeaning trProj world) hiota + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Whnf.lean b/Ix/Tc/Whnf.lean index 7cc34ee3c..e165d8364 100644 --- a/Ix/Tc/Whnf.lean +++ b/Ix/Tc/Whnf.lean @@ -62,6 +62,33 @@ structure NatRecLiteralParts (m : Mode) where /-! ### Pure helpers -/ +/-- Decode exactly the recursor fields consumed by ordinary iota. Keeping +this pure snapshot separate from `tryIotaWithFlags` gives verification an +exact relation between the loaded `KConst` and the rule array later indexed +by constructor position. -/ +def KConst.iotaInfo? : KConst m → Option (IotaInfo m) + | .recr (k := k) (lvls := lvls) (params := params) + (indices := indices) (motives := motives) (minors := minors) + (rules := rules) .. => + let majorIdx := (params + motives + minors + indices).toNat + some { + k + params := params.toNat + motives := motives.toNat + minors := minors.toNat + indices := indices.toNat + majorIdx + rules + lvls } + | _ => none + +/-- Decode the constructor index and field count used by ordinary iota. +All other loaded constant kinds are constructor misses. -/ +def KConst.iotaCtorInfo? : KConst m → Option (Nat × Nat) + | .ctor (cidx := cidx) (fields := fields) .. => + some (cidx.toNat, fields.toNat) + | _ => none + /-- Nat value from a literal or the `Nat.zero` constructor (C++ `is_nat_lit_ext` / lean4lean `rawNatLitExt?`). -/ def extractNatLit (e : KExpr m) (prims : Primitives m) : Option Nat := @@ -192,6 +219,21 @@ def isNatBinPredAddr (addr : Address) : RecM m Bool := do let p ← prims return addr == p.natBeq.addr || addr == p.natBle.addr +/-- Intern the character-list fold used by String-literal expansion. The +input is already reversed, so each step prepends the current character and +the final list retains source order. Keeping this recursion explicit gives +verification a structural induction point without changing production's +left-to-right intern sequence. -/ +def strLitListToConstructor (charOfNat cons : KExpr m) : + List Char → KExpr m → RecM m (KExpr m) + | [], list => pure list + | c :: chars, list => do + let natLit ← TcM.intern (natExprFromValue c.toNat : KExpr m) + let charVal ← TcM.intern (KExpr.mkApp charOfNat natLit) + let partialApp ← TcM.intern (KExpr.mkApp cons charVal) + let list ← TcM.intern (KExpr.mkApp partialApp list) + strLitListToConstructor charOfNat cons chars list + /-- `"abc" → String.ofList (List.cons (Char.ofNat 97) … List.nil)` — the kernel's string-literal constructor expansion (def_eq.rs `str_lit_to_constructor`; `Char.ofNat` + `String.ofList`, matching @@ -205,12 +247,7 @@ def strLitToConstructor (s : String) : RecM m (KExpr m) := do let nil ← TcM.intern (KExpr.mkApp listNilZ charConst) let listConsZ ← TcM.intern (.mkConst p.listCons #[.mkZero]) let cons ← TcM.intern (KExpr.mkApp listConsZ charConst) - let mut list := nil - for c in s.toList.reverse do - let natLit ← TcM.intern (natExprFromValue c.toNat : KExpr m) - let charVal ← TcM.intern (KExpr.mkApp charOfNat natLit) - let partialApp ← TcM.intern (KExpr.mkApp cons charVal) - list ← TcM.intern (KExpr.mkApp partialApp list) + let list ← strLitListToConstructor charOfNat cons s.toList.reverse nil TcM.intern (KExpr.mkApp stringMk list) /-- `Int.ofNat n` / `Int.negSucc (|v|-1)` canonical literal. -/ @@ -397,6 +434,65 @@ def applyIotaArg (result : KExpr m) (arg : KExpr m) else TcM.intern (KExpr.mkApp result arg) +/-- Apply an iota rule's arguments from left to right. Keeping this loop in + one helper makes the three argument segments in `tryIotaWithFlags` + observationally identical while preserving the transient Nat-literal + policy. -/ +def applyIotaArgs (result : KExpr m) (args : Array (KExpr m)) + (transient : Bool) : RecM m (KExpr m) := do + let mut result := result + for arg in args do + result ← applyIotaArg result arg transient + return result + +/-- Parameters, motives, and minors passed to an ordinary iota rule. The +`min` is production's defensive truncation when a malformed recursor reports +more prefix arguments than the source spine contains. -/ +def iotaPrefixArgs (recr : IotaInfo m) (spine : Array (KExpr m)) : + Array (KExpr m) := + let pmmEnd := recr.params + recr.motives + recr.minors + spine.extract 0 (min pmmEnd spine.size) + +/-- Constructor fields passed to an ordinary iota rule. Production has +already checked `ctorFields ≤ ctorArgs.size` before selecting this slice. -/ +def iotaFieldArgs (ctorArgs : Array (KExpr m)) (ctorFields : Nat) : + Array (KExpr m) := + ctorArgs.extract (ctorArgs.size - ctorFields) ctorArgs.size + +/-- Arguments after the recursor major are retained as an over-application +suffix of the reduced rule. -/ +def iotaTrailingArgs (recr : IotaInfo m) (spine : Array (KExpr m)) : + Array (KExpr m) := + spine.extract (recr.majorIdx + 1) spine.size + +/-- Instantiate one selected iota rule and apply exactly the three argument +segments used by `tryIotaWithFlags`. Isolating this successful constructor +branch gives verification one production term whose indices cannot drift +from the reducer's slice arithmetic. -/ +def applyIotaRule (rule : RecRule m) (recUs : Array (KUniv m)) + (recr : IotaInfo m) (spine ctorArgs : Array (KExpr m)) + (ctorFields : Nat) (transient : Bool) : RecM m (KExpr m) := do + let rhs ← TcM.instantiateUnivParams rule.rhs recUs + let result ← applyIotaArgs rhs (iotaPrefixArgs recr spine) transient + let result ← applyIotaArgs result + (iotaFieldArgs ctorArgs ctorFields) transient + applyIotaArgs result (iotaTrailingArgs recr spine) transient + +/-- Select and execute the constructor-indexed ordinary iota rule. The +three guards are kept in production order: rule existence, universe arity, +then constructor-field availability. -/ +def tryApplyIotaCtor (recr : IotaInfo m) (recUs : Array (KUniv m)) + (spine ctorArgs : Array (KExpr m)) (cidx ctorFields : Nat) + (transient : Bool) : RecM m (Option (KExpr m)) := do + let some rule := recr.rules[cidx]? | return none + -- H6: level arity; H5: fields ≤ ctor args (lean4lean Reduce.lean:75-76). + if recUs.size.toUInt64 != recr.lvls then + return none + if ctorFields > ctorArgs.size then + return none + return some (← applyIotaRule rule recUs recr spine ctorArgs ctorFields + transient) + def isNatLiteralRecursorApp (e : KExpr m) : RecM m Bool := do let (head, spine) := e.collectSpine let .const id _ _ := head | return false @@ -616,6 +712,18 @@ def consumeBetaLams (body : KExpr m) (args : Array (KExpr m)) : RecM m (KExpr m) := do (← read).whnfCoreFlags e flags +/-- Inference back-edge under the validation policy used by K synthesis and +other WHNF probes. Naming this seam exposes the caught callback as one +operation while preserving the original method-table read and state scope. -/ +@[inline] def inferOnlyRec (e : KExpr m) : RecM m (KExpr m) := do + let methods ← read + TcM.withInferOnly (methods.infer e) + +/-- Catch a WHNF probe error as absence while retaining its error-side state, +matching Rust's `&mut` catch-and-continue behavior. -/ +@[inline] def tryOptional (x : RecM m α) : RecM m (Option α) := + try? x + mutual /-- Full WHNF: loop of whnf-no-delta → native/nat/decidable/string → delta. -/ @@ -708,16 +816,22 @@ def whnfWithNatSuccModeNonLeaf (e : KExpr m) def whnfCore (e : KExpr m) : RecM m (KExpr m) := whnfCoreWithFlags e .FULL -/-- Structural WHNF for def-eq's cheap-projection scaffold - (`whnfCore (cheapProj := true)`). Bumps `cheapRecursionDepth` so cheap - false negatives stay out of the full def-eq cache. -/ -def whnfCoreForDefEq (e : KExpr m) : RecM m (KExpr m) := do +/-- Run one cheap recursive reduction scope. Cheap-mode cache routing is +visible only while the body executes; the caller's depth is restored on both +success and error. -/ +def withCheapRecursionDepth (x : RecM m α) : RecM m α := do modify fun s => { s with cheapRecursionDepth := s.cheapRecursionDepth + 1 } try - whnfCoreWithFlags e .DEF_EQ_CORE + x finally modify fun s => { s with cheapRecursionDepth := s.cheapRecursionDepth - 1 } +/-- Structural WHNF for def-eq's cheap-projection scaffold + (`whnfCore (cheapProj := true)`). Bumps `cheapRecursionDepth` so cheap + false negatives stay out of the full def-eq cache. -/ +def whnfCoreForDefEq (e : KExpr m) : RecM m (KExpr m) := + withCheapRecursionDepth (whnfCoreWithFlags e .DEF_EQ_CORE) + /-- Key/cache/uncached body reached after structural-WHNF's syntactic fast paths. Naming this seam leaves runtime behavior unchanged while allowing the outer cache policy to be verified independently of leaf/variable dispatch. -/ @@ -794,14 +908,11 @@ def whnfCoreWithFlagsStep (cur : KExpr m) (flags : WhnfFlags) : let remainingStart := consumedArgs.size if !consumedArgs.isEmpty then body ← TcM.runIntern (simulSubst body consumedArgs.reverse 0) - for arg in args.extract remainingStart args.size do - body ← TcM.intern (KExpr.mkApp body arg) + body ← finishAppResult body args remainingStart return .next body if f != f0 then -- Head reduced: rebuild, try iota once, else done. - let mut rebuilt := f - for arg in args do - rebuilt ← TcM.intern (KExpr.mkApp rebuilt arg) + let rebuilt ← finishAppResult f args 0 match (← tryIotaWithFlags rebuilt flags) with | some reduced => return .next reduced | none => return .done rebuilt @@ -819,28 +930,20 @@ def whnfNoDelta (e : KExpr m) : RecM m (KExpr m) := whnfNoDeltaImpl e .FULL .collapse /-- Def-eq no-delta WHNF (cheap projection policy). -/ -def whnfNoDeltaForDefEq (e : KExpr m) : RecM m (KExpr m) := do - modify fun s => { s with cheapRecursionDepth := s.cheapRecursionDepth + 1 } - try - whnfNoDeltaImpl e .DEF_EQ_CORE .collapse - finally - modify fun s => { s with cheapRecursionDepth := s.cheapRecursionDepth - 1 } - -/-- One no-delta WHNF loop iteration, in the precise production reducer - order. Successful syntax-directed helpers remain visible as `.next`; - a fully stuck structural result terminates the loop. -/ -def whnfNoDeltaImplStep (flags : WhnfFlags) (natSuccMode : NatSuccMode) - (cur : KExpr m) : RecM m (BoundedStep (KExpr m) (KExpr m)) := do - let cur ← whnfCoreWithFlags cur flags +def whnfNoDeltaForDefEq (e : KExpr m) : RecM m (KExpr m) := + withCheapRecursionDepth + (whnfNoDeltaImpl e .DEF_EQ_CORE .collapse) + +/-- Ordered reducer tail of one no-delta iteration, after structural WHNF has + completed. Naming this seam makes the helper precedence and partial + error states independently verifiable without changing the bounded loop. -/ +def whnfNoDeltaReducersStep (flags : WhnfFlags) + (natSuccMode : NatSuccMode) (cur : KExpr m) : + RecM m (BoundedStep (KExpr m) (KExpr m)) := do -- App-of-Prj: whnf_core resolves the outermost Prj only; give the -- head one more attempt under the same projection policy. - match (← tryProjAppReduce cur flags) with - | some (projResult, args) => - let mut result := projResult - for arg in args do - result ← TcM.intern (KExpr.mkApp result arg) + if let some result ← tryProjAppReduceFinished cur flags then return .next result - | none => pure () if let some reduced ← tryReduceBitvec cur then return .next reduced if let some reduced ← tryReduceNatWithSuccMode cur natSuccMode then @@ -859,6 +962,14 @@ def whnfNoDeltaImplStep (flags : WhnfFlags) (natSuccMode : NatSuccMode) return .next reduced return .done cur +/-- One no-delta WHNF loop iteration, in the precise production reducer + order. Successful syntax-directed helpers remain visible as `.next`; + a fully stuck structural result terminates the loop. -/ +def whnfNoDeltaImplStep (flags : WhnfFlags) (natSuccMode : NatSuccMode) + (cur : KExpr m) : RecM m (BoundedStep (KExpr m) (KExpr m)) := do + let cur ← whnfCoreWithFlags cur flags + whnfNoDeltaReducersStep flags natSuccMode cur + /-- No-delta bounded loop without its outer cache policy. -/ def whnfNoDeltaImplUncached (e : KExpr m) (flags : WhnfFlags) (natSuccMode : NatSuccMode) : RecM m (KExpr m) := @@ -896,81 +1007,82 @@ def whnfNoDeltaImpl (e : KExpr m) (flags : WhnfFlags) | _ => pure () whnfNoDeltaImplNonLeaf e flags natSuccMode +/-- Dispatch an already normalized, non-String major either to an ordinary +constructor rule or to struct eta. Literal conversion and cleanup live in +`tryIotaAfterMajorWhnf`, so this seam owns only constructor lookup and the +final fallback. -/ +def tryIotaCtorOrStructEta (recId : KId m) (recr : IotaInfo m) + (recUs : Array (KUniv m)) (spine : Array (KExpr m)) + (majorWhnf : KExpr m) (transient : Bool) : + RecM m (Option (KExpr m)) := do + let (ctorHead, ctorArgs) := majorWhnf.collectSpine + let ctorInfo? ← match ctorHead with + | .const cid _ _ => + match (← TcM.tryGetConst cid) with + | some ctor => pure ctor.iotaCtorInfo? + | _ => pure none + | _ => pure none + if let some (cidx, ctorFields) := ctorInfo? then + return ← tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields + transient + tryStructEtaIota recId recr recUs spine + +/-- Dispatch after Nat-offset cleanup. String literals require constructor +expansion plus one policy-selected recursive WHNF callback; every other +shape proceeds directly to constructor/struct-eta selection. -/ +def tryIotaAfterCleanup (flags : WhnfFlags) (recId : KId m) + (recr : IotaInfo m) (recUs : Array (KUniv m)) + (spine : Array (KExpr m)) (majorWhnf : KExpr m) + (majorWasNatLit : Bool) : RecM m (Option (KExpr m)) := do + let mut majorWhnf := majorWhnf + match majorWhnf with + | .str val _ _ => + let strCtor ← strLitToConstructor val + majorWhnf ← if flags.cheapRec then whnfCoreFlagsRec strCtor flags + else whnfRec strCtor + | _ => pure () + tryIotaCtorOrStructEta recId recr recUs spine majorWhnf majorWasNatLit + +/-- Finish iota preprocessing after the major callback. This seam owns Nat +literal expansion, the second offset cleanup, String expansion, and then the +constructor/struct-eta dispatch above. -/ +def tryIotaAfterMajorWhnf (flags : WhnfFlags) (recId : KId m) + (recr : IotaInfo m) (recUs : Array (KUniv m)) + (spine : Array (KExpr m)) (majorWhnf0 : KExpr m) : + RecM m (Option (KExpr m)) := do + -- Nat literal → constructor form (one layer). + let mut majorWhnf := majorWhnf0 + let mut majorWasNatLit := false + match majorWhnf with + | .nat val _ _ => + majorWasNatLit := true + majorWhnf ← natToConstructor val + | _ => pure () + if let some cleaned ← cleanupNatOffsetMajor majorWhnf then + majorWhnf := cleaned + -- String literal → constructor form, then WHNF (same flag policy). + tryIotaAfterCleanup flags recId recr recUs spine majorWhnf majorWasNatLit + /-- Iota: recursor applied to a constructor (or K-synthesized / struct-eta fallback). `cheapRec` reduces the major structurally only. -/ def tryIotaWithFlags (e : KExpr m) (flags : WhnfFlags) : RecM m (Option (KExpr m)) := do let (head, spine) := e.collectSpine let .const recId recUs _ := head | return none - let recr ← match (← TcM.tryGetConst recId) with - | some (.recr (k := k) (lvls := lvls) (params := params) - (indices := indices) (motives := motives) (minors := minors) - (rules := rules) ..) => - let majorIdx := (params + motives + minors + indices).toNat - if spine.size ≤ majorIdx then - return none - pure { k, params := params.toNat, motives := motives.toNat, - minors := minors.toNat, indices := indices.toNat, - majorIdx, rules, lvls : IotaInfo m } - | _ => return none + let some recursor ← TcM.tryGetConst recId | return none + let some recr := recursor.iotaInfo? | return none + if spine.size ≤ recr.majorIdx then + return none -- K-like: synthesize a nullary ctor from the major's type before WHNF. let major := spine[recr.majorIdx]! let major ← if recr.k then - pure ((← synthCtorWhenK major recId recr).getD major) + pure ((← synthCtorWhenK major recId recr recUs).getD major) else pure major let major := (← cleanupNatOffsetMajor major).getD major -- WHNF the major (cheap mode skips delta on the major itself). let majorWhnf0 ← if flags.cheapRec then whnfCoreFlagsRec major flags else whnfRec major - -- Nat literal → constructor form (one layer). - let mut majorWhnf := majorWhnf0 - let mut majorWasNatLit := false - match majorWhnf with - | .nat val _ _ => - majorWasNatLit := true - majorWhnf ← natToConstructor val - | _ => pure () - if let some cleaned ← cleanupNatOffsetMajor majorWhnf then - majorWhnf := cleaned - -- String literal → constructor form, then WHNF (same flag policy). - match majorWhnf with - | .str val _ _ => - let strCtor ← strLitToConstructor val - majorWhnf ← if flags.cheapRec then whnfCoreFlagsRec strCtor flags - else whnfRec strCtor - | _ => pure () - -- Constructor application? - let (ctorHead, ctorArgs) := majorWhnf.collectSpine - let ctorInfo? ← match ctorHead with - | .const cid _ _ => - match (← TcM.tryGetConst cid) with - | some (.ctor (cidx := cidx) (fields := fields) ..) => - pure (some (cidx.toNat, fields.toNat)) - | _ => pure none - | _ => pure none - if let some (cidx, ctorFields) := ctorInfo? then - if h : cidx < recr.rules.size then - let rule := recr.rules[cidx] - -- H6: level arity; H5: fields ≤ ctor args (lean4lean Reduce.lean:75-76). - if recUs.size.toUInt64 != recr.lvls then - return none - if ctorFields > ctorArgs.size then - return none - let rhs ← TcM.instantiateUnivParams rule.rhs recUs - let pmmEnd := recr.params + recr.motives + recr.minors - let fieldStart := ctorArgs.size - ctorFields - let mut result := rhs - for arg in spine.extract 0 (min pmmEnd spine.size) do - result ← applyIotaArg result arg majorWasNatLit - for arg in ctorArgs.extract fieldStart ctorArgs.size do - result ← applyIotaArg result arg majorWasNatLit - for arg in spine.extract (recr.majorIdx + 1) spine.size do - result ← applyIotaArg result arg majorWasNatLit - return some result - else - return none - -- Struct eta iota fallback. - tryStructEtaIota recId recr recUs spine + tryIotaAfterMajorWhnf flags recId recr recUs spine majorWhnf0 def isStructLike (id : KId m) : RecM m Bool := do match (← TcM.tryGetConst id) with @@ -980,6 +1092,65 @@ def isStructLike (id : KId m) : RecM m Bool := do | _ => return false return !(← computedIsRec id) +/-- Intern the projection/application pairs for a contiguous struct field +range. The explicit remaining-field index makes totality and left-to-right +state threading visible while retaining the old loop's exact request order. -/ +def finishStructEtaFields (indId : KId m) (major : KExpr m) : + Nat → Nat → KExpr m → RecM m (KExpr m) + | 0, _, result => pure result + | fuel + 1, field, result => do + let proj ← TcM.intern (KExpr.mkPrj indId field.toUInt64 major) + let result ← TcM.intern (KExpr.mkApp result proj) + finishStructEtaFields indId major fuel (field + 1) result + +/-- Rebuild the struct-eta recursor result after all semantic guards have +passed. The three named left-to-right segments preserve the generated +expression and intern order of the former imperative loops. -/ +def finishStructEtaResult (indId : KId m) (major rhs : KExpr m) + (fields : UInt64) (prefixArgs trailingArgs : Array (KExpr m)) : + RecM m (KExpr m) := do + let result ← finishAppResult rhs prefixArgs 0 + let result ← finishStructEtaFields indId major fields.toNat 0 result + finishAppResult result trailingArgs 0 + +/-- The H3 post-probe guard rejects exactly `Prop`-valued majors. Keeping +this test pure makes the semantic boundary independently inspectable without +moving any checker effects across it. -/ +def structEtaSortRejected : KExpr m → Bool + | .sort u _ => u.isZero + | _ => false + +/-- Apply the H3 Prop guard and, for an admissible major sort, instantiate +and rebuild the selected struct-eta rule. -/ +def finishStructEtaAfterSort (recUs : Array (KUniv m)) + (spine : Array (KExpr m)) (recr : IotaInfo m) (rule : RecRule m) + (indId : KId m) (major majorSortW : KExpr m) : + RecM m (Option (KExpr m)) := do + if structEtaSortRejected majorSortW then + return none + let rhs ← TcM.instantiateUnivParams rule.rhs recUs + let pmmEnd := recr.params + recr.motives + recr.minors + let result ← finishStructEtaResult indId major rhs rule.fields + (spine.extract 0 (min pmmEnd spine.size)) + (spine.extract (recr.majorIdx + 1) spine.size) + return some result + +/-- Complete struct-eta after the recursor type scan has selected the major +inductive. Optional inference/WHNF probes retain their error-side state; +universe instantiation and rebuilding errors remain ordinary propagated +errors. -/ +def tryStructEtaAfterInductive (recUs : Array (KUniv m)) + (spine : Array (KExpr m)) (recr : IotaInfo m) (rule : RecRule m) + (indId : KId m) : RecM m (Option (KExpr m)) := do + if !(← isStructLike indId) then + return none + -- H3: Prop guard. + let major := spine[recr.majorIdx]! + let some majorTy ← tryOptional (inferOnlyRec major) | return none + let some majorSort ← tryOptional (inferOnlyRec majorTy) | return none + let some majorSortW ← tryOptional (whnfRec majorSort) | return none + finishStructEtaAfterSort recUs spine recr rule indId major majorSortW + /-- Struct-eta iota: single-rule recursor over a non-recursive one-ctor zero-index inductive; rebuild the rule with projections of the major. Prop-typed majors are excluded (lean4lean `toCtorWhenStruct`). -/ @@ -988,62 +1159,32 @@ def tryStructEtaIota (recId : KId m) (recr : IotaInfo m) RecM m (Option (KExpr m)) := do if recr.rules.size != 1 then return none - let rule := recr.rules[0]! - let recTy ← match (← TcM.tryGetConst recId) with - | some c => pure c.ty - | none => return none - let skip := (recr.params + recr.motives + recr.minors + recr.indices).toUInt64 - let some indId ← try? (getMajorInductiveId recTy skip) | return none - if !(← isStructLike indId) then + if recUs.size.toUInt64 != recr.lvls then return none - -- H3: Prop guard. - let major := spine[recr.majorIdx]! - let some majorTy ← try? (TcM.withInferOnly ((← read).infer major)) - | return none - let some majorSort ← try? (TcM.withInferOnly ((← read).infer majorTy)) - | return none - let some majorSortW ← try? (whnfRec majorSort) | return none - if let .sort u _ := majorSortW then - if u.isZero then - return none - let rhs ← TcM.instantiateUnivParams rule.rhs recUs - let pmmEnd := recr.params + recr.motives + recr.minors - let mut result := rhs - for arg in spine.extract 0 (min pmmEnd spine.size) do - result ← TcM.intern (KExpr.mkApp result arg) - for i in [0:rule.fields.toNat] do - let proj ← TcM.intern (KExpr.mkPrj indId i.toUInt64 major) - result ← TcM.intern (KExpr.mkApp result proj) - for arg in spine.extract (recr.majorIdx + 1) spine.size do - result ← TcM.intern (KExpr.mkApp result arg) - return some result - -/-- K-like recursors: when the major isn't a ctor but its type matches the - target inductive, build `ctor₀ params…` and def-eq-verify its type. -/ -def synthCtorWhenK (major : KExpr m) (recId : KId m) - (recr : IotaInfo m) : RecM m (Option (KExpr m)) := do - let some majorTy ← try? (TcM.withInferOnly ((← read).infer major)) - | return none - let some majorTyW ← try? (whnfRec majorTy) | return none - let (tyHead, tyArgs) := majorTyW.collectSpine - let .const tyHeadId tyUs _ := tyHead | return none + let rule := recr.rules[0]! let recTy ← match (← TcM.tryGetConst recId) with | some c => pure c.ty | none => return none let skip := (recr.params + recr.motives + recr.minors + recr.indices).toUInt64 - let some indId ← try? (getMajorInductiveId recTy skip) | return none - if tyHeadId.addr != indId.addr then - return none - let ctorId ← match (← TcM.tryGetConst indId) with - | some (.indc (ctors := ctors) ..) => - match ctors[0]? with - | some c => pure c - | none => return none - | _ => return none - let mut ctorApp ← TcM.intern (KExpr.mkConst ctorId tyUs) - for arg in tyArgs.extract 0 (min recr.params tyArgs.size) do - ctorApp ← TcM.intern (KExpr.mkApp ctorApp arg) - let some ctorTy ← try? (TcM.withInferOnly ((← read).infer ctorApp)) + let some indId ← tryOptional (do + -- The stored declaration type is polymorphic in the recursor's own + -- universe parameters. Scan the instance named by this application, + -- not that raw declaration under the caller's unrelated universe scope. + let recTy ← TcM.instantiateUnivParams recTy recUs + getMajorInductiveId recTy skip) | return none + tryStructEtaAfterInductive recUs spine recr rule indId + +/-- Build one K-synthesis constructor candidate and validate that its inferred +type is definitionally equal to the normalized major type. Catalog selection +stays in `synthCtorWhenK`; this seam owns all intern, stats, and final DefEq +effects, including the counted silent rejection. -/ +def verifyKSynthCandidate (majorTyW : KExpr m) (ctorId : KId m) + (tyUs : Array (KUniv m)) (tyArgs : Array (KExpr m)) (params : Nat) : + RecM m (Option (KExpr m)) := do + let ctorApp ← TcM.intern (KExpr.mkConst ctorId tyUs) + let ctorApp ← finishAppResult ctorApp + (tyArgs.extract 0 (min params tyArgs.size)) 0 + let some ctorTy ← tryOptional (inferOnlyRec ctorApp) | return none TcM.bumpStats (m := m) fun s => { s with kSynthAttempts := s.kSynthAttempts + 1 } @@ -1056,24 +1197,76 @@ def synthCtorWhenK (major : KExpr m) (recId : KId m) return none return some ctorApp -/-- Projection of a ctor application (with string-literal expansion first, - and the `Fin.val`-through-`Decidable.rec` special case). -/ -def tryProjReduce (id : KId m) (field : UInt64) (wval : KExpr m) : +/-- Finish K-synthesis after the recursor scan has selected its major +inductive. Naming this defensive catalog transaction exposes the address +check, repeated inductive lookup, empty-constructor fallback, and candidate +result without changing their order or state scope. -/ +def selectKSynthCandidate (majorTyW : KExpr m) (tyHeadId : KId m) + (tyUs : Array (KUniv m)) (tyArgs : Array (KExpr m)) + (indId : KId m) (params : Nat) : RecM m (Option (KExpr m)) := do + if tyHeadId.addr != indId.addr then + return none + let ctorId ← match (← TcM.tryGetConst indId) with + | some (.indc (ctors := ctors) ..) => + match ctors[0]? with + | some c => pure c + | none => return none + | _ => return none + verifyKSynthCandidate majorTyW ctorId tyUs tyArgs params + +/-- K-like recursors: when the major isn't a ctor but its type matches the + target inductive, build `ctor₀ params…` and def-eq-verify its type. -/ +def synthCtorWhenK (major : KExpr m) (recId : KId m) + (recr : IotaInfo m) (recUs : Array (KUniv m)) : + RecM m (Option (KExpr m)) := do + if recUs.size.toUInt64 != recr.lvls then + return none + let some majorTy ← tryOptional (inferOnlyRec major) + | return none + let some majorTyW ← tryOptional (whnfRec majorTy) | return none + let (tyHead, tyArgs) := majorTyW.collectSpine + let .const tyHeadId tyUs _ := tyHead | return none + let recTy ← match (← TcM.tryGetConst recId) with + | some c => pure c.ty + | none => return none + let skip := (recr.params + recr.motives + recr.minors + recr.indices).toUInt64 + let some indId ← tryOptional (do + let recTy ← TcM.instantiateUnivParams recTy recUs + getMajorInductiveId recTy skip) | return none + selectKSynthCandidate majorTyW tyHeadId tyUs tyArgs indId recr.params + +/- Projection reduction is split at the String-literal preprocessing +boundary. Besides giving verification an induction-free seam, this keeps +the accelerated `Fin.val` probe and lazy constructor lookup in one tail whose +evaluation order is shared by literal and non-literal inputs. -/ + +/-- Projection tail after any String-literal expansion and recursive WHNF. -/ +def tryProjReduceTail (id : KId m) (field : UInt64) (wval : KExpr m) : RecM m (Option (KExpr m)) := do - let wval ← match wval with - | .str s _ _ => do - let expanded ← strLitToConstructor s - whnfRec expanded - | _ => pure wval let (head, args) := wval.collectSpine if let some result ← tryReduceFinValDecidableRec id field head args then return some result let .const ctorId _ _ := head | return none let ctorParams ← match (← TcM.tryGetConst ctorId) with | some (.ctor (params := params) ..) => pure params.toNat - | _ => return none + | _ => return none return args[ctorParams + field.toNat]? +/-- Normalize only the String-literal input form used by projection. -/ +def tryProjPrepare (wval : KExpr m) : RecM m (KExpr m) := + match wval with + | .str s _ _ => do + let expanded ← strLitToConstructor s + whnfRec expanded + | _ => pure wval + +/-- Projection of a ctor application (with string-literal expansion first, + and the `Fin.val`-through-`Decidable.rec` special case). -/ +def tryProjReduce (id : KId m) (field : UInt64) (wval : KExpr m) : + RecM m (Option (KExpr m)) := do + let wval ← tryProjPrepare wval + tryProjReduceTail id field wval + /-- `App(Prj(S, i, v), args…)`: one more projection attempt on the head. -/ def tryProjAppReduce (e : KExpr m) (flags : WhnfFlags) : RecM m (Option (KExpr m × Array (KExpr m))) := do @@ -1087,28 +1280,67 @@ def tryProjAppReduce (e : KExpr m) (flags : WhnfFlags) : | some result => return some (result, args) | none => return none -/-- Major-premise inductive of a recursor type: peel `skip` foralls, then - scan (bounded) for the first forall whose domain head is an inductive. -/ -def getMajorInductiveId (recTy : KExpr m) (skip : UInt64) : - RecM m (KId m) := do - let mut ty := recTy - for _ in [0:skip.toNat] do +/-- Complete the app-of-projection reduction by rebuilding the full trailing + spine through the shared, left-to-right application helper. -/ +def tryProjAppReduceFinished (e : KExpr m) (flags : WhnfFlags) : + RecM m (Option (KExpr m)) := do + match (← tryProjAppReduce e flags) with + | some (projResult, args) => + return some (← finishAppResult projResult args 0) + | none => return none + +/-- Peel the fixed recursor prefix before searching for the major premise. -/ +def peelMajorForalls : Nat → KExpr m → RecM m (KExpr m) + | 0, ty => pure ty + | fuel + 1, ty => do let w ← whnfRec ty match w with - | .all _ _ _ body _ => ty := body + | .all _ _ dom body _ => + -- The body is open. Retain the binder in the legacy context so a + -- recursive WHNF cannot resolve one of its variables through an + -- unrelated caller frame. + TcM.pushLocal dom + peelMajorForalls fuel body | _ => throw (.other "get_major_inductive_id: not enough foralls") - for _ in [0:9] do + +/-- One successful-WHNF step of the bounded major-inductive scan. Naming the +step keeps the callback boundary and the binder-scoped continuation visible to +verification without changing lookup or error order. -/ +def scanMajorInductiveStep + (next : KExpr m → RecM m (KId m)) (w : KExpr m) : RecM m (KId m) := do + match w with + | .all _ _ dom body _ => + let (head, _) := dom.collectSpine + if let .const id _ _ := head then + if let some (.indc ..) ← TcM.tryGetConst id then + return id + -- Continue underneath the forall in the context in which its body is + -- scoped. `getMajorInductiveId` restores the caller depth on every + -- outcome. + TcM.pushLocal dom + next body + | _ => throw (.other "get_major_inductive_id: expected forall at major") + +/-- Bounded search for the first forall whose domain head is a loaded +inductive. The recursive presentation preserves the former loop's exact +left-to-right lookup and error order. -/ +def scanMajorInductive : Nat → KExpr m → RecM m (KId m) + | 0, _ => throw (.other + "get_major_inductive_id: no inductive-headed forall within scan bound") + | fuel + 1, ty => do let w ← whnfRec ty - match w with - | .all _ _ dom body _ => - let (head, _) := dom.collectSpine - if let .const id _ _ := head then - if let some (.indc ..) ← TcM.tryGetConst id then - return id - ty := body - | _ => throw (.other "get_major_inductive_id: expected forall at major") - throw (.other - "get_major_inductive_id: no inductive-headed forall within scan bound") + scanMajorInductiveStep (scanMajorInductive fuel) w + +/-- Major-premise inductive of a recursor type: peel `skip` foralls, then + scan (bounded) for the first forall whose domain head is an inductive. -/ +def getMajorInductiveId (recTy : KExpr m) (skip : UInt64) : + RecM m (KId m) := do + let saved ← liftM (TcM.saveDepth (m := m)) + try + let ty ← peelMajorForalls skip.toNat recTy + scanMajorInductive 9 ty + finally + liftM (TcM.restoreDepth (m := m) saved) /-- Nat primitives: succ-collapse, binary arithmetic, boolean predicates. -/ def tryReduceNat (e : KExpr m) : RecM m (Option (KExpr m)) := @@ -1145,6 +1377,85 @@ def tryReduceNatWithSuccMode (e : KExpr m) TcM.intern (.mkConst (if b then p.boolTrue else p.boolFalse) #[]) finishAppResult resultExpr args 2 +/-- Recognize exactly one `Nat.succ` application after recursive WHNF. The + helper retains the production's second primitive-table read while making + its Boolean branch independently equation-visible. -/ +def isNatSuccSpine (w : KExpr m) : RecM m Bool := do + let (head, args) := w.collectSpine + match head with + | .const id _ _ => + pure (id.addr == (← prims).natSucc.addr && args.size == 1) + | _ => pure false + +/-- Commit the finite set of successor arguments proved stuck by one loop + execution. Both stuck exits share this exact state mutation. -/ +def recordNatSuccStuck (visited : Array (Address × Address)) : RecM m Unit := + modify fun s => { s with env := { s.env with + natSuccStuck := visited.foldl (·.insert ·) s.env.natSuccStuck } } + +/-- Extend the successor-loop trace after the peeled argument is known not to + have a stuck memo entry. -/ +def tryReduceNatSuccPeelMiss (w cur : KExpr m) (offset : Nat) + (visited : Array (Address × Address)) (curKey : Address × Address) : + RecM m (BoundedStep + (KExpr m × Nat × Array (Address × Address)) (Option (KExpr m))) := do + let visited := visited.push curKey + -- succ(cur) can surface later as a succ-iter argument too. + let visited := visited.push (← TcM.whnfKey w) + return .next (cur, offset + 1, visited) + +/-- Decide a resolved peeled argument key: either propagate a known-stuck + suffix to the whole visited prefix, or continue with the second key. -/ +def tryReduceNatSuccPeelAfterKey (w cur : KExpr m) (offset : Nat) + (visited : Array (Address × Address)) (curKey : Address × Address) : + RecM m (BoundedStep + (KExpr m × Nat × Array (Address × Address)) (Option (KExpr m))) := do + if (← get).env.natSuccStuck.contains curKey then + -- Known-stuck suffix ⇒ the whole chain above is stuck too. + recordNatSuccStuck visited + return .done none + tryReduceNatSuccPeelMiss w cur offset visited curKey + +/-- Peel one recognized successor layer, either stopping at a previously + memoized suffix or extending the visited-key trace for the next step. -/ +def tryReduceNatSuccPeel (w cur : KExpr m) (offset : Nat) + (visited : Array (Address × Address)) : + RecM m (BoundedStep + (KExpr m × Nat × Array (Address × Address)) (Option (KExpr m))) := do + let curKey ← TcM.whnfKey cur + tryReduceNatSuccPeelAfterKey w cur offset visited curKey + +/-- Classify the recursively normalized successor argument. This second + successor-loop seam isolates literal success, successor peeling, and both + stuck-memo writes from the two recursive callbacks that precede it. -/ +def tryReduceNatSuccAfterWhnf (w : KExpr m) (offset : Nat) + (visited : Array (Address × Address)) : + RecM m (BoundedStep + (KExpr m × Nat × Array (Address × Address)) (Option (KExpr m))) := do + let p ← prims + if let some n := extractNatLit w p then + return .done (some (natExprFromValue (n + offset))) + let (_, args) := w.collectSpine + let isSucc ← isNatSuccSpine w + if isSucc then + let cur := args[0]! + return (← tryReduceNatSuccPeel w cur offset visited) + recordNatSuccStuck visited + return .done none + +/-- One bounded successor-collapse iteration. Naming this seam exposes the + linear-recognizer, recursive WHNF, literal, successor-peel, and stuck-memo + branches to verification without changing their production order. -/ +def tryReduceNatSuccIterStep + (state : KExpr m × Nat × Array (Address × Address)) : + RecM m (BoundedStep + (KExpr m × Nat × Array (Address × Address)) (Option (KExpr m))) := do + let (cur, offset, visited) := state + if let some result ← tryReduceNatSuccLinearRec cur offset then + return .done (some result) + let w ← whnfModeRec cur .stuck + tryReduceNatSuccAfterWhnf w offset visited + /-- Collapse a `Nat.succ` chain onto a literal (with stuck-chain memo: the inner WHNF runs in `stuck` mode which bypasses caches, so without the memo a stuck `succ^k(x)` re-peels from every depth — O(k²)). -/ @@ -1153,35 +1464,8 @@ def tryReduceNatSuccIter (arg : KExpr m) : let entryKey ← TcM.whnfKey arg if (← get).env.natSuccStuck.contains entryKey then return none - runBounded (fun (cur, offset, visited) => do - if let some result ← tryReduceNatSuccLinearRec cur offset then - return .done (some result) - let w ← whnfModeRec cur .stuck - if let some n := extractNatLit w (← prims) then - return .done (some (natExprFromValue (n + offset))) - let (head, args) := w.collectSpine - let isSucc ← match head with - | .const id _ _ => - pure (id.addr == (← prims).natSucc.addr && args.size == 1) - | _ => pure false - if isSucc then - let offset := offset + 1 - let cur := args[0]! - let curKey ← TcM.whnfKey cur - if (← get).env.natSuccStuck.contains curKey then - -- Known-stuck suffix ⇒ the whole chain above is stuck too. - let vs := visited - modify fun s => { s with env := { s.env with - natSuccStuck := vs.foldl (·.insert ·) s.env.natSuccStuck } } - return .done none - let visited := visited.push curKey - -- succ(cur) can surface later as a succ-iter argument too. - let visited := visited.push (← TcM.whnfKey w) - return .next (cur, offset, visited) - let vs := visited - modify fun s => { s with env := { s.env with - natSuccStuck := vs.foldl (·.insert ·) s.env.natSuccStuck } } - return .done none) maxWhnfFuel.toNat (arg, 1, #[entryKey]) + runBounded tryReduceNatSuccIterStep maxWhnfFuel.toNat + (arg, 1, #[entryKey]) /-- `Nat.rec base step (lit n)` where step = `fun _ ih => Nat.succ ih`: compute `base + n + offset` directly (literal base), or collapse to the @@ -1609,29 +1893,53 @@ def tryReduceNative (e : KExpr m) : RecM m (Option (KExpr m)) := do -- ### `is_rec` verification (inductive.rs `computed_is_rec` — hosted here -- because struct-likeness needs it; `Ix.Tc.Inductive` reuses it) -/-- Constructive `is_rec`: any constructor field (after params) mentioning - any inductive of the mutual block. Provisional-true cache entry guards - re-entrancy through whnf → struct-eta → isStructLike. -/ -def computedIsRec (ind : KId m) : RecM m Bool := do - if let some v := (← get).env.isRecCache[ind.addr]? then - return v - let (params, ctors, block) ← match (← TcM.getConst ind) with - | .indc (params := params) (ctors := ctors) (block := block) .. => - pure (params, ctors, block) - | _ => throw (.other "computed_is_rec: not an inductive") - modify fun s => { s with env := { s.env with - isRecCache := s.env.isRecCache.insert ind.addr true } } - let blockInds ← discoverBlockInductives block - let blockAddrs := blockInds.map (·.addr) +/-- Finish one constructor-parameter peel after the recursive WHNF callback. +Naming the post-callback seam keeps the binder mutation equation stable for +verification without changing the production control flow. -/ +def computeIsRecParamStepAfterWhnf (ty w : KExpr m) : + RecM m (ForInStep (KExpr m)) := do + match w with + | .all _ _ dom body _ => + TcM.pushLocal dom + return .yield body + | _ => return .done ty + +/-- Peel one constructor parameter when its normalized type remains a forall. +The pushed domain scopes the returned body for every later scan step. -/ +def computeIsRecParamStep (ty : KExpr m) : + RecM m (ForInStep (KExpr m)) := do + let w ← whnfRec ty + computeIsRecParamStepAfterWhnf ty w + +/-- Finish one constructor-field scan after the recursive WHNF callback. -/ +def computeIsRecFieldStepAfterWhnf (blockAddrs : Array Address) + (w : KExpr m) : RecM m (BoundedStep (KExpr m) Bool) := do + match w with + | .all _ _ dom body _ => + if exprMentionsAnyAddr dom blockAddrs then + return .done true + TcM.pushLocal dom + return .next body + | _ => return .done false + +/-- Inspect one constructor field and either find a recursive occurrence, +continue under its binder, or finish at the end of the telescope. -/ +def computeIsRecFieldStep (blockAddrs : Array Address) (ty : KExpr m) : + RecM m (BoundedStep (KExpr m) Bool) := do + let w ← whnfRec ty + computeIsRecFieldStepAfterWhnf blockAddrs w + +/-- Classify one constructor telescope while restoring the caller's legacy +context depth on every result and partial error. -/ +def computeIsRecCtor (ctorTy : KExpr m) (nParams : Nat) + (blockAddrs : Array Address) : RecM m Bool := do + let saved ← liftM (TcM.saveDepth (m := m)) try - let v ← computeIsRec ctors params.toNat blockAddrs - modify fun s => { s with env := { s.env with - isRecCache := s.env.isRecCache.insert ind.addr v } } - return v - catch e => - modify fun s => { s with env := { s.env with - isRecCache := s.env.isRecCache.erase ind.addr } } - throw e + let ty ← forIn [0:nParams] ctorTy fun _ ty => + computeIsRecParamStep ty + runBounded (computeIsRecFieldStep blockAddrs) maxWhnfFuel.toNat ty + finally + liftM (TcM.restoreDepth (m := m) saved) def computeIsRec (ctors : Array (KId m)) (nParams : Nat) (blockAddrs : Array Address) : RecM m Bool := do @@ -1639,26 +1947,81 @@ def computeIsRec (ctors : Array (KId m)) (nParams : Nat) let ctorTy ← match (← TcM.tryGetConst ctorId) with | some (.ctor (ty := ty) ..) => pure ty | _ => continue - let mut ty := ctorTy - for _ in [0:nParams] do - let w ← whnfRec ty - match w with - | .all _ _ _ body _ => ty := body - | _ => break - let found ← runBounded (fun ty => do - let w ← whnfRec ty - match w with - | .all _ _ dom body _ => - if exprMentionsAnyAddr dom blockAddrs then - return .done true - return .next body - | _ => return .done false) maxWhnfFuel.toNat ty + let found ← computeIsRecCtor ctorTy nParams blockAddrs if found then return true return false +/-- The single physical write used for both the provisional re-entrancy +marker and the final recursion result. Naming the seam keeps the semantic +cache certificate separate from the classifier's control flow. -/ +def cacheIsRec (ind : KId m) (value : Bool) : RecM m Unit := + modify fun s => { s with env := { s.env with + isRecCache := s.env.isRecCache.insert ind.addr value } } + +/-- Cleanup performed only when the constructor-field classifier throws. +Errors from declaration or mutual-block discovery occur before this scope and +therefore deliberately retain the provisional marker. -/ +def eraseCachedIsRec (ind : KId m) : RecM m Unit := + modify fun s => { s with env := { s.env with + isRecCache := s.env.isRecCache.erase ind.addr } } + +/-- Classify one already-discovered mutual block and commit its exact result. +The non-backtracking handler erases the provisional entry from the partial +error state before rethrowing. -/ +def computedIsRecClassify (ind : KId m) (ctors : Array (KId m)) + (nParams : Nat) (blockAddrs : Array Address) : RecM m Bool := + tryCatch + (do + let value ← computeIsRec ctors nParams blockAddrs + cacheIsRec ind value + return value) + (fun err => do + eraseCachedIsRec ind + throw err) + +/-- Cache-miss transaction after the inductive metadata has been selected. +The provisional marker precedes mutual-block discovery, matching the original +Rust/Lean state-on-error behavior. -/ +def computedIsRecMiss (ind : KId m) (params : UInt64) + (ctors : Array (KId m)) (block : KId m) : RecM m Bool := do + cacheIsRec ind true + let blockInds ← discoverBlockInductives block + computedIsRecClassify ind ctors params.toNat (blockInds.map (·.addr)) + +/-- Constructive `is_rec`: any constructor field (after params) mentioning + any inductive of the mutual block. Provisional-true cache entry guards + re-entrancy through whnf → struct-eta → isStructLike. -/ +def computedIsRec (ind : KId m) : RecM m Bool := do + if let some value := (← get).env.isRecCache[ind.addr]? then + return value + match (← TcM.getConst ind) with + | .indc (params := params) (ctors := ctors) (block := block) .. => + computedIsRecMiss ind params ctors block + | _ => throw (.other "computed_is_rec: not an inductive") + end +/-- Equation theorem exposing only the projection prelude/tail split. Keeping +this outside the large recursive method block prevents downstream proofs from +unfolding unrelated WHNF definitions merely to inspect `tryProjReduce`. -/ +theorem tryProjPrepare_eq (wval : KExpr m) : + tryProjPrepare wval = + match wval with + | .str value _ _ => do + let expanded ← strLitToConstructor value + whnfRec expanded + | _ => pure wval := by + cases wval <;> rfl + +theorem tryProjReduce_eq (id : KId m) (field : UInt64) (wval : KExpr m) : + tryProjReduce id field wval = (do + let prepared ← tryProjPrepare wval + tryProjReduceTail id field prepared) := by + rfl + +attribute [irreducible] tryProjPrepare tryProjReduce + end RecM end Ix.Tc diff --git a/Tests/Ix/Tc/Substrate.lean b/Tests/Ix/Tc/Substrate.lean index 32183b849..c5fadfb1d 100644 --- a/Tests/Ix/Tc/Substrate.lean +++ b/Tests/Ix/Tc/Substrate.lean @@ -107,8 +107,8 @@ def instantiateRevTests : TestSeq := def abstractFVarsTests : TestSeq := test "empty passthrough" (runI (abstractFVars (aVar 0) #[]) == aVar 0) - ++ test "no fvars passthrough" - (runI (abstractFVars (aVar 0) #[⟨0⟩]) == aVar 0) + ++ test "no fvars still shifts loose bvars" + (runI (abstractFVars (aVar 0) #[⟨0⟩]) == aVar 1) ++ test "single replacement" (runI (abstractFVars (aFVar 0) #[⟨0⟩]) == aVar 0) ++ test "position mapping" @@ -187,31 +187,37 @@ def internTests : TestSeq := def eqAddr (n : UInt64) : Address := Address.blake3 ⟨n.toLEBytes.data⟩ +def eqKey (n : UInt64) (ctxAddr : Address) : EqKey where + exprAddr := eqAddr n + ctxAddr := ctxAddr + lbr := 0 + exprLbr := 0 + def equivTests : TestSeq := test "basic equiv" (Id.run do let z := eqAddr 0 let em : EquivManager := {} - let (before, em) := em.isEquiv (eqAddr 100, z) (eqAddr 200, z) - let em := em.addEquiv (eqAddr 100, z) (eqAddr 200, z) - let (after, em) := em.isEquiv (eqAddr 100, z) (eqAddr 200, z) - let (sym, _) := em.isEquiv (eqAddr 200, z) (eqAddr 100, z) + let (before, em) := em.isEquiv (eqKey 100 z) (eqKey 200 z) + let em := em.addEquiv (eqKey 100 z) (eqKey 200 z) + let (after, em) := em.isEquiv (eqKey 100 z) (eqKey 200 z) + let (sym, _) := em.isEquiv (eqKey 200 z) (eqKey 100 z) return !before && after && sym) ++ test "transitivity" (Id.run do let z := eqAddr 0 let em := EquivManager.empty - |>.addEquiv (eqAddr 100, z) (eqAddr 200, z) - |>.addEquiv (eqAddr 200, z) (eqAddr 300, z) - let (r, _) := em.isEquiv (eqAddr 100, z) (eqAddr 300, z) + |>.addEquiv (eqKey 100 z) (eqKey 200 z) + |>.addEquiv (eqKey 200 z) (eqKey 300 z) + let (r, _) := em.isEquiv (eqKey 100 z) (eqKey 300 z) return r) ++ test "context isolation" (Id.run do let c1 := eqAddr 1 let c2 := eqAddr 2 - let em := EquivManager.empty.addEquiv (eqAddr 100, c1) (eqAddr 200, c1) - let (inC1, em) := em.isEquiv (eqAddr 100, c1) (eqAddr 200, c1) - let (inC2, _) := em.isEquiv (eqAddr 100, c2) (eqAddr 200, c2) + let em := EquivManager.empty.addEquiv (eqKey 100 c1) (eqKey 200 c1) + let (inC1, em) := em.isEquiv (eqKey 100 c1) (eqKey 200 c1) + let (inC2, _) := em.isEquiv (eqKey 100 c2) (eqKey 200 c2) return inC1 && !inC2) ++ test "find reaches the root and path-halves within the node bound" ((let em : EquivManager := diff --git a/Tests/Ix/Tc/WhnfTests.lean b/Tests/Ix/Tc/WhnfTests.lean index aa0bf3c9d..ce55b97c4 100644 --- a/Tests/Ix/Tc/WhnfTests.lean +++ b/Tests/Ix/Tc/WhnfTests.lean @@ -120,6 +120,32 @@ def pureHelperTests : TestSeq := | .error .maxRecDepth zeroState, .error .maxRecDepth oneState => zeroState.recFuel == 7 && oneState.recFuel == 6 | _, _ => false) : Bool) + ++ test "major scan keeps peeled binders out of an unrelated caller let" + ((let targetId := aId "major-scan-target" + let target : KConst .anon := + .indc () () 0 0 0 false targetId 0 sort0 #[] () + let env := (KEnv.new (m := .anon)).insert targetId target + let forged := KExpr.mkAll () () (pConst targetId) sort0 + -- After peeling the outer forall, its open body is Var 0. Without + -- retaining that binder, the caller let below fabricates `forged` and + -- the scan incorrectly reports `targetId`. + let recTy := KExpr.mkAll () () sort0 (.mkVar 0 ()) + let initial := TcState.ofEnvAnon env + match TcM.pushLet sort0 forged initial with + | .error _ _ => false + | .ok _ pushed => + match (RecM.getMajorInductiveId recTy 1).run + (whnfOnlyMethodsN maxWhnfFuel.toNat) pushed with + | .ok _ _ => false + | .error _ final => + final.ctx.size == pushed.ctx.size && + final.letVals.size == pushed.letVals.size && + final.numLetBindings == pushed.numLetBindings && + final.ctxId == pushed.ctxId && + final.ctxIdStack.size == pushed.ctxIdStack.size && + match final.letVals[0]? with + | some (some value) => value.addr == forged.addr + | _ => false) : Bool) ++ test "beta-lambda peeling is bounded by the application spine" ((let x := pConst (aId "x") let y := pConst (aId "y") diff --git a/crates/kernel/src/def_eq.rs b/crates/kernel/src/def_eq.rs index 4813b247e..3eea05073 100644 --- a/crates/kernel/src/def_eq.rs +++ b/crates/kernel/src/def_eq.rs @@ -136,9 +136,10 @@ impl TypeChecker<'_, M> { // `src/ix/kernel/equiv.rs`), so no additional key construction is paid // per method call. Any true result moves the originals into `add_equiv` // before returning. + let eq_lbr = a.lbr().max(b.lbr()); let eq_ctx = self.def_eq_ctx_key(a, b); - let a_key: crate::equiv::EqKey = (a.hash_key(), eq_ctx); - let b_key: crate::equiv::EqKey = (b.hash_key(), eq_ctx); + let a_key = crate::equiv::EqKey::new(a.hash_key(), eq_ctx, eq_lbr, a.lbr()); + let b_key = crate::equiv::EqKey::new(b.hash_key(), eq_ctx, eq_lbr, b.lbr()); if self.equiv_manager.is_equiv(&a_key, &b_key) { return Ok(true); @@ -173,8 +174,11 @@ impl TypeChecker<'_, M> { self.equiv_manager.find_root_key(&a_key), self.equiv_manager.find_root_key(&b_key), ) && (a_root != a_key || b_root != b_key) + && crate::equiv::EqKey::root_cache_scope_matches( + &a_root, &b_root, eq_ctx, eq_lbr, + ) { - let (rlo, rhi) = canonical_pair(a_root.0, b_root.0); + let (rlo, rhi) = canonical_pair(a_root.expr_addr, b_root.expr_addr); let root_cache_key = (rlo, rhi, eq_ctx); let mut cached = self.env.def_eq_cache.get(&root_cache_key).map(|v| (*v, false)); @@ -609,26 +613,25 @@ impl TypeChecker<'_, M> { // `instantiate_rev` and lets def-eq compare them structurally. // Mirrors lean4lean `isDefEqBinding` // (refs/lean4lean/Lean4Lean/TypeChecker.lean:546). - let saved = self.lctx.len(); - let fv_id = self.fresh_fvar_id(); - let fv = self.intern(KExpr::fvar(fv_id, name.clone())); - self.lctx.push( - fv_id, - LocalDecl::CDecl { - name: name.clone(), - bi: bi.clone(), - ty: ty1.clone(), - }, - ); - let b1_open = instantiate_rev( - &mut self.env.intern, - body1, - std::slice::from_ref(&fv), - ); - let b2_open = instantiate_rev(&mut self.env.intern, body2, &[fv]); - let r = self.is_def_eq(&b1_open, &b2_open); - self.lctx.truncate(saved); - r + self.with_lctx_scope(|tc| { + let fv_id = tc.fresh_fvar_id(); + let fv = tc.intern(KExpr::fvar(fv_id, name.clone())); + tc.lctx.push( + fv_id, + LocalDecl::CDecl { + name: name.clone(), + bi: bi.clone(), + ty: ty1.clone(), + }, + ); + let b1_open = instantiate_rev( + &mut tc.env.intern, + body1, + std::slice::from_ref(&fv), + ); + let b2_open = instantiate_rev(&mut tc.env.intern, body2, &[fv]); + tc.is_def_eq(&b1_open, &b2_open) + }) }, _ => Ok(false), } @@ -705,25 +708,25 @@ impl TypeChecker<'_, M> { ) => { if self.is_def_eq(ty1, ty2)? { // Open both bodies with the same fresh fvar (see `quick_def_eq`). - let saved = self.lctx.len(); - let fv_id = self.fresh_fvar_id(); - let fv = self.intern(KExpr::fvar(fv_id, name.clone())); - self.lctx.push( - fv_id, - LocalDecl::CDecl { - name: name.clone(), - bi: bi.clone(), - ty: ty1.clone(), - }, - ); - let b1_open = instantiate_rev( - &mut self.env.intern, - body1, - std::slice::from_ref(&fv), - ); - let b2_open = instantiate_rev(&mut self.env.intern, body2, &[fv]); - let r = self.is_def_eq(&b1_open, &b2_open)?; - self.lctx.truncate(saved); + let r = self.with_lctx_scope(|tc| { + let fv_id = tc.fresh_fvar_id(); + let fv = tc.intern(KExpr::fvar(fv_id, name.clone())); + tc.lctx.push( + fv_id, + LocalDecl::CDecl { + name: name.clone(), + bi: bi.clone(), + ty: ty1.clone(), + }, + ); + let b1_open = instantiate_rev( + &mut tc.env.intern, + body1, + std::slice::from_ref(&fv), + ); + let b2_open = instantiate_rev(&mut tc.env.intern, body2, &[fv]); + tc.is_def_eq(&b1_open, &b2_open) + })?; if r { return Ok(true); } @@ -739,25 +742,25 @@ impl TypeChecker<'_, M> { // FVar zeta-reduction in body comparison, in case this branch IS // reached. if self.is_def_eq(ty1, ty2)? && self.is_def_eq(v1, v2)? { - let saved = self.lctx.len(); - let fv_id = self.fresh_fvar_id(); - let fv = self.intern(KExpr::fvar(fv_id, name.clone())); - self.lctx.push( - fv_id, - LocalDecl::LDecl { - name: name.clone(), - ty: ty1.clone(), - val: v1.clone(), - }, - ); - let b1_open = instantiate_rev( - &mut self.env.intern, - body1, - std::slice::from_ref(&fv), - ); - let b2_open = instantiate_rev(&mut self.env.intern, body2, &[fv]); - let r = self.is_def_eq(&b1_open, &b2_open)?; - self.lctx.truncate(saved); + let r = self.with_lctx_scope(|tc| { + let fv_id = tc.fresh_fvar_id(); + let fv = tc.intern(KExpr::fvar(fv_id, name.clone())); + tc.lctx.push( + fv_id, + LocalDecl::LDecl { + name: name.clone(), + ty: ty1.clone(), + val: v1.clone(), + }, + ); + let b1_open = instantiate_rev( + &mut tc.env.intern, + body1, + std::slice::from_ref(&fv), + ); + let b2_open = instantiate_rev(&mut tc.env.intern, body2, &[fv]); + tc.is_def_eq(&b1_open, &b2_open) + })?; if r { return Ok(true); } diff --git a/crates/kernel/src/equiv.rs b/crates/kernel/src/equiv.rs index 2bde4d1c2..e39a1c013 100644 --- a/crates/kernel/src/equiv.rs +++ b/crates/kernel/src/equiv.rs @@ -1,18 +1,59 @@ //! Union-find (disjoint set) for context-aware definitional equality caching. //! //! Provides O(α(n)) amortized equivalence checks via weighted quick-union -//! with path halving. Keys are `(expr_hash, ctx_hash)` pairs using content- -//! addressed blake3 hashes for both components. +//! with path halving. Keys retain the expression hash, context hash, the +//! context-suffix radius used to construct that hash, and the expression's +//! intrinsic local-binder radius. use rustc_hash::FxHashMap; use super::env::{Addr, CtxAddr}; -/// Composite key: (expression content hash, context content hash). -pub type EqKey = (Addr, CtxAddr); +/// One expression in one context-suffix interpretation. +/// +/// The radius is semantically load-bearing even if two suffix calculations +/// emit the same digest: DefEq transport is justified only at a common +/// requested radius. Keeping it in the union-find key prevents transitive +/// components from joining equality results established at different radii. +#[derive(Debug, Clone, Copy, PartialEq, Eq, Hash)] +pub struct EqKey { + pub expr_addr: Addr, + pub ctx_addr: CtxAddr, + /// Radius at which `ctx_addr` was computed for this comparison. + pub lbr: u64, + /// Intrinsic local-binder radius of the expression at `expr_addr`. + pub expr_lbr: u64, +} + +impl EqKey { + pub fn new( + expr_addr: Addr, + ctx_addr: CtxAddr, + lbr: u64, + expr_lbr: u64, + ) -> Self { + Self { expr_addr, ctx_addr, lbr, expr_lbr } + } + + /// Whether two representatives can safely reuse a DefEq cache context. + /// Their intrinsic expression radii must reconstruct the requested radius + /// at which the context digest was computed. + pub fn root_cache_scope_matches( + left: &Self, + right: &Self, + ctx_addr: CtxAddr, + lbr: u64, + ) -> bool { + left.ctx_addr == ctx_addr + && right.ctx_addr == ctx_addr + && left.lbr == lbr + && right.lbr == lbr + && left.expr_lbr.max(right.expr_lbr) == lbr + } +} /// Union-find structure for tracking definitional equality between -/// (expr_hash, ctx_hash) pairs. +/// context-aware expression keys. #[derive(Debug, Clone)] pub struct EquivManager { /// Map from composite key to union-find node index. @@ -152,19 +193,24 @@ mod tests { fn test_basic_equiv() { let mut em = EquivManager::new(); let zero = ctx(0); - assert!(!em.is_equiv(&(addr(100), zero), &(addr(200), zero))); - em.add_equiv((addr(100), zero), (addr(200), zero)); - assert!(em.is_equiv(&(addr(100), zero), &(addr(200), zero))); - assert!(em.is_equiv(&(addr(200), zero), &(addr(100), zero))); + let a = EqKey::new(addr(100), zero, 0, 0); + let b = EqKey::new(addr(200), zero, 0, 0); + assert!(!em.is_equiv(&a, &b)); + em.add_equiv(a, b); + assert!(em.is_equiv(&a, &b)); + assert!(em.is_equiv(&b, &a)); } #[test] fn test_transitivity() { let mut em = EquivManager::new(); let zero = ctx(0); - em.add_equiv((addr(100), zero), (addr(200), zero)); - em.add_equiv((addr(200), zero), (addr(300), zero)); - assert!(em.is_equiv(&(addr(100), zero), &(addr(300), zero))); + let a = EqKey::new(addr(100), zero, 0, 0); + let b = EqKey::new(addr(200), zero, 0, 0); + let c = EqKey::new(addr(300), zero, 0, 0); + em.add_equiv(a, b); + em.add_equiv(b, c); + assert!(em.is_equiv(&a, &c)); } #[test] @@ -172,8 +218,49 @@ mod tests { let mut em = EquivManager::new(); let ctx1 = ctx(1); let ctx2 = ctx(2); - em.add_equiv((addr(100), ctx1), (addr(200), ctx1)); - assert!(em.is_equiv(&(addr(100), ctx1), &(addr(200), ctx1))); - assert!(!em.is_equiv(&(addr(100), ctx2), &(addr(200), ctx2))); + let a1 = EqKey::new(addr(100), ctx1, 1, 1); + let b1 = EqKey::new(addr(200), ctx1, 1, 1); + let a2 = EqKey::new(addr(100), ctx2, 1, 1); + let b2 = EqKey::new(addr(200), ctx2, 1, 1); + em.add_equiv(a1, b1); + assert!(em.is_equiv(&a1, &b1)); + assert!(!em.is_equiv(&a2, &b2)); + } + + #[test] + fn test_radius_isolation() { + let mut em = EquivManager::new(); + let zero = ctx(0); + let a1 = EqKey::new(addr(100), zero, 1, 1); + let b1 = EqKey::new(addr(200), zero, 1, 1); + let a2 = EqKey::new(addr(100), zero, 2, 1); + let b2 = EqKey::new(addr(200), zero, 2, 1); + em.add_equiv(a1, b1); + assert!(em.is_equiv(&a1, &b1)); + assert!(!em.is_equiv(&a2, &b2)); + } + + #[test] + fn test_intrinsic_radius_isolation() { + let mut em = EquivManager::new(); + let zero = ctx(0); + let a1 = EqKey::new(addr(100), zero, 2, 1); + let b1 = EqKey::new(addr(200), zero, 2, 2); + let a2 = EqKey::new(addr(100), zero, 2, 2); + let b2 = EqKey::new(addr(200), zero, 2, 2); + em.add_equiv(a1, b1); + assert!(em.is_equiv(&a1, &b1)); + assert!(!em.is_equiv(&a2, &b2)); + } + + #[test] + fn test_root_cache_scope_requires_intrinsic_radius() { + let scope = ctx(0); + let low_left = EqKey::new(addr(100), scope, 2, 1); + let low_right = EqKey::new(addr(200), scope, 2, 1); + let high_right = EqKey::new(addr(200), scope, 2, 2); + + assert!(!EqKey::root_cache_scope_matches(&low_left, &low_right, scope, 2)); + assert!(EqKey::root_cache_scope_matches(&low_left, &high_right, scope, 2)); } } diff --git a/crates/kernel/src/inductive.rs b/crates/kernel/src/inductive.rs index f6a40ffca..1fa69f648 100644 --- a/crates/kernel/src/inductive.rs +++ b/crates/kernel/src/inductive.rs @@ -474,27 +474,40 @@ impl TypeChecker<'_, M> { Some(KConst::Ctor { ty, .. }) => ty.clone(), _ => continue, }; - // Skip params - let mut ty = ctor_ty; - for _ in 0..n_params { - let w = self.whnf(&ty)?; - match w.data() { - ExprData::All(_, _, _, body, _) => ty = body.clone(), - _ => break, + let saved = self.save_depth(); + let found = (|| -> Result> { + // Skip params, retaining each binder while normalizing the dependent + // constructor remainder. Without these frames an open Var could be + // zeta-reduced through an unrelated caller let-binding. + let mut ty = ctor_ty; + for _ in 0..n_params { + let w = self.whnf(&ty)?; + match w.data() { + ExprData::All(_, _, dom, body, _) => { + self.push_local(dom.clone()); + ty = body.clone(); + }, + _ => break, + } } - } - // Check each remaining field domain for block inductive mentions - loop { - let w = self.whnf(&ty)?; - match w.data() { - ExprData::All(_, _, dom, body, _) => { - if expr_mentions_any_addr(dom, block_addrs) { - return Ok(true); - } - ty = body.clone(); - }, - _ => break, + // Check each remaining field domain for block inductive mentions. + loop { + let w = self.whnf(&ty)?; + match w.data() { + ExprData::All(_, _, dom, body, _) => { + if expr_mentions_any_addr(dom, block_addrs) { + return Ok(true); + } + self.push_local(dom.clone()); + ty = body.clone(); + }, + _ => return Ok(false), + } } + })(); + self.restore_depth(saved); + if found? { + return Ok(true); } } Ok(false) diff --git a/crates/kernel/src/infer.rs b/crates/kernel/src/infer.rs index cbe061c06..1a302fa1e 100644 --- a/crates/kernel/src/infer.rs +++ b/crates/kernel/src/infer.rs @@ -199,71 +199,71 @@ impl TypeChecker<'_, M> { // Open the binder with a fresh fvar. Mirrors lean4lean // `inferLambda` (TypeChecker.lean:122) and the C++ // `infer_lambda` (refs/lean4/src/kernel/type_checker.cpp:116). - let saved = self.lctx.len(); - let fv_id = self.fresh_fvar_id(); - let fv = self.intern(KExpr::fvar(fv_id, name.clone())); - self.lctx.push( - fv_id, - LocalDecl::CDecl { - name: name.clone(), - bi: bi.clone(), - ty: ty.clone(), - }, - ); - let body_open = instantiate_rev(&mut self.env.intern, body, &[fv]); - let body_ty = self.infer(&body_open)?; - // Peephole-reduce App(λ.., ..) shapes inside the inferred type - // before wrapping in the Pi. Idempotent in the Pi case, so - // outer frames pay nothing. - let body_ty = cheap_beta_reduce(&mut self.env.intern, &body_ty); - // Close back: abstract the fvar and wrap in `All` with anonymous - // name + default binder info (matching the pre-fvar legacy shape; - // the Lam's user-facing name does not propagate into the - // inferred Pi type). Recursor coherence relies on this exact - // shape — `lctx.mk_pi` would preserve the Lam's `name`/`bi`, - // diverging from what `inductive.rs::build_recursor_*` produces - // canonically. - let abstracted = - abstract_fvars(&mut self.env.intern, &body_ty, &[fv_id]); - self.lctx.truncate(saved); - self.intern(KExpr::all( - M::meta_field(ix_common::env::Name::anon()), - M::meta_field(ix_common::env::BinderInfo::Default), - ty.clone(), - abstracted, - )) + self.with_lctx_scope(|tc| { + let fv_id = tc.fresh_fvar_id(); + let fv = tc.intern(KExpr::fvar(fv_id, name.clone())); + tc.lctx.push( + fv_id, + LocalDecl::CDecl { + name: name.clone(), + bi: bi.clone(), + ty: ty.clone(), + }, + ); + let body_open = instantiate_rev(&mut tc.env.intern, body, &[fv]); + let body_ty = tc.infer(&body_open)?; + // Peephole-reduce App(λ.., ..) shapes inside the inferred type + // before wrapping in the Pi. Idempotent in the Pi case, so + // outer frames pay nothing. + let body_ty = cheap_beta_reduce(&mut tc.env.intern, &body_ty); + // Close back: abstract the fvar and wrap in `All` with anonymous + // name + default binder info (matching the pre-fvar legacy shape; + // the Lam's user-facing name does not propagate into the + // inferred Pi type). Recursor coherence relies on this exact + // shape — `lctx.mk_pi` would preserve the Lam's `name`/`bi`, + // diverging from what `inductive.rs::build_recursor_*` produces + // canonically. + let abstracted = + abstract_fvars(&mut tc.env.intern, &body_ty, &[fv_id]); + Ok(tc.intern(KExpr::all( + M::meta_field(ix_common::env::Name::anon()), + M::meta_field(ix_common::env::BinderInfo::Default), + ty.clone(), + abstracted, + ))) + })? }, ExprData::All(name, bi, ty, body, _) => { let ty_ty = self.infer(ty)?; let u1 = self.ensure_sort(&ty_ty)?; - let saved = self.lctx.len(); - let fv_id = self.fresh_fvar_id(); - let fv = self.intern(KExpr::fvar(fv_id, name.clone())); - if crate::env_var("IX_FVAR_TRACE").is_ok() { - log::info!( - "[fvar All push] fv={fv_id} ty.addr={:?} ty.lbr={} ctx_len_before_push={} body.lbr={}", - ty.addr(), - ty.lbr(), - self.ctx.len(), - body.lbr(), + self.with_lctx_scope(|tc| { + let fv_id = tc.fresh_fvar_id(); + let fv = tc.intern(KExpr::fvar(fv_id, name.clone())); + if crate::env_var("IX_FVAR_TRACE").is_ok() { + log::info!( + "[fvar All push] fv={fv_id} ty.addr={:?} ty.lbr={} ctx_len_before_push={} body.lbr={}", + ty.addr(), + ty.lbr(), + tc.ctx.len(), + body.lbr(), + ); + log::info!(" ty data: {:?}", ty.data()); + } + tc.lctx.push( + fv_id, + LocalDecl::CDecl { + name: name.clone(), + bi: bi.clone(), + ty: ty.clone(), + }, ); - log::info!(" ty data: {:?}", ty.data()); - } - self.lctx.push( - fv_id, - LocalDecl::CDecl { - name: name.clone(), - bi: bi.clone(), - ty: ty.clone(), - }, - ); - let body_open = instantiate_rev(&mut self.env.intern, body, &[fv]); - let body_ty = self.infer(&body_open)?; - let u2 = self.ensure_sort(&body_ty)?; - self.lctx.truncate(saved); - let u = KUniv::imax(u1, u2); - self.intern(KExpr::sort(u)) + let body_open = instantiate_rev(&mut tc.env.intern, body, &[fv]); + let body_ty = tc.infer(&body_open)?; + let u2 = tc.ensure_sort(&body_ty)?; + let u = KUniv::imax(u1, u2); + Ok(tc.intern(KExpr::sort(u))) + })? }, ExprData::Let(name, ty, val, body, _, _) => { @@ -280,32 +280,31 @@ impl TypeChecker<'_, M> { // WHNF can zeta-reduce on FVar(let) lookup, and so the closing // step below produces a `Let` wrapper whose body is the // abstracted body_ty. - let saved = self.lctx.len(); - let fv_id = self.fresh_fvar_id(); - let fv = self.intern(KExpr::fvar(fv_id, name.clone())); - self.lctx.push( - fv_id, - LocalDecl::LDecl { - name: name.clone(), - ty: ty.clone(), - val: val.clone(), - }, - ); - let body_open = instantiate_rev(&mut self.env.intern, body, &[fv]); - let body_ty = self.infer(&body_open)?; - // Eagerly substitute `val` for the let's fvar in the inferred - // type, then cheap-beta. This matches the pre-fvar behavior of - // `inferLet` (which used a single `subst(body_ty, val, 0)` after - // pop) and avoids leaking a `Let` wrapper into cached infer - // results, which would change cache shapes for downstream - // consumers. Equivalent to `lctx.mk_pi([fv_id], body_ty)` - // followed by zeta — we collapse directly. - let abstracted = - abstract_fvars(&mut self.env.intern, &body_ty, &[fv_id]); - let r = subst(&mut self.env.intern, &abstracted, val, 0); - let r = cheap_beta_reduce(&mut self.env.intern, &r); - self.lctx.truncate(saved); - r + self.with_lctx_scope(|tc| { + let fv_id = tc.fresh_fvar_id(); + let fv = tc.intern(KExpr::fvar(fv_id, name.clone())); + tc.lctx.push( + fv_id, + LocalDecl::LDecl { + name: name.clone(), + ty: ty.clone(), + val: val.clone(), + }, + ); + let body_open = instantiate_rev(&mut tc.env.intern, body, &[fv]); + let body_ty = tc.infer(&body_open)?; + // Eagerly substitute `val` for the let's fvar in the inferred + // type, then cheap-beta. This matches the pre-fvar behavior of + // `inferLet` (which used a single `subst(body_ty, val, 0)` after + // pop) and avoids leaking a `Let` wrapper into cached infer + // results, which would change cache shapes for downstream + // consumers. Equivalent to `lctx.mk_pi([fv_id], body_ty)` + // followed by zeta — we collapse directly. + let abstracted = + abstract_fvars(&mut tc.env.intern, &body_ty, &[fv_id]); + let r = subst(&mut tc.env.intern, &abstracted, val, 0); + Ok(cheap_beta_reduce(&mut tc.env.intern, &r)) + })? }, ExprData::Prj(struct_id, field, val, _) => { @@ -609,6 +608,7 @@ mod tests { use super::super::error::TcError; use super::super::expr::{ExprData, KExpr}; use super::super::id::KId; + use super::super::lctx::LocalDecl; use super::super::level::KUniv; use super::super::mode::Anon; use super::super::tc::TypeChecker; @@ -830,6 +830,36 @@ mod tests { } } + #[test] + fn infer_binder_errors_restore_lctx_scope() { + let bad_body = AE::cnst(mk_id("MissingBinderBody"), Box::new([])); + let cases = [ + ("lambda", AE::lam((), (), sort0(), bad_body.clone())), + ("forall", AE::all((), (), sort0(), bad_body.clone())), + ("let", AE::let_((), sort1(), sort0(), bad_body, false)), + ]; + + for (kind, expr) in cases { + let mut env = test_env(); + let mut tc = TypeChecker::new(&mut env); + let outer_id = tc.fresh_fvar_id(); + tc.lctx + .push(outer_id, LocalDecl::CDecl { name: (), bi: (), ty: sort0() }); + let saved = tc.lctx.len(); + + assert!(tc.infer(&expr).is_err(), "{kind} body must fail"); + assert_eq!( + tc.lctx.len(), + saved, + "{kind} inference leaked a binder local after error" + ); + assert!( + tc.lctx.find(outer_id).is_some(), + "{kind} inference damaged the enclosing local context" + ); + } + } + #[test] fn infer_app_mismatch_errors() { // Applying `id : Sort 0 → Sort 0` to a Nat (which has type Nat, not diff --git a/crates/kernel/src/subst.rs b/crates/kernel/src/subst.rs index 2df800ab5..9779c76ba 100644 --- a/crates/kernel/src/subst.rs +++ b/crates/kernel/src/subst.rs @@ -941,13 +941,15 @@ fn instantiate_rev_cached( /// Used by `LocalContext::mk_lambda` / `mk_pi` to close a body back into /// a chain of de Bruijn binders after binder opening. /// -/// Fast path: returns `body` unchanged when `!body.has_fvars()`. +/// Fast path: returns `body` unchanged when there are no target fvars, or +/// when `body` has neither fvars nor loose bvars. A no-fvar term with loose +/// bvars must still be traversed: wrapping new binders shifts those bvars. pub fn abstract_fvars( env: &mut InternTable, body: &KExpr, fvars: &[FVarId], ) -> KExpr { - if fvars.is_empty() || !body.has_fvars() { + if fvars.is_empty() || (!body.has_fvars() && body.lbr() == 0) { return body.clone(); } // Build a position map for O(1) fvar → position lookup. For typical @@ -1278,11 +1280,11 @@ mod tests { } #[test] - fn abstract_fvars_no_fvars_passthrough() { + fn abstract_fvars_no_fvars_shifts_loose_bvar() { let mut env = InternTable::::new(); let v0 = AE::var(0, ()); let result = abstract_fvars(&mut env, &v0, &[FVarId(0)]); - assert!(result.ptr_eq(&v0)); + assert_eq!(result, AE::var(1, ())); } #[test] diff --git a/crates/kernel/src/tc.rs b/crates/kernel/src/tc.rs index b7fa4308e..81d95f464 100644 --- a/crates/kernel/src/tc.rs +++ b/crates/kernel/src/tc.rs @@ -955,6 +955,19 @@ impl<'a, M: KernelMode> TypeChecker<'a, M> { result } + /// Run a closure in a free-variable local-context scope. Declarations + /// pushed by the closure are discarded on both `Ok` and `Err` returns; + /// mutations to the rest of the checker state are retained. + pub(crate) fn with_lctx_scope( + &mut self, + f: impl FnOnce(&mut Self) -> R, + ) -> R { + let saved = self.lctx.len(); + let result = f(self); + self.lctx.truncate(saved); + result + } + // ----------------------------------------------------------------------- // Interning helper // ----------------------------------------------------------------------- diff --git a/crates/kernel/src/whnf.rs b/crates/kernel/src/whnf.rs index 50bea0824..e7b53ab0c 100644 --- a/crates/kernel/src/whnf.rs +++ b/crates/kernel/src/whnf.rs @@ -1349,7 +1349,7 @@ impl TypeChecker<'_, M> { let major = &spine[recr.major_idx]; let major = if recr.k { self - .synth_ctor_when_k(major, &rec_id, &recr)? + .synth_ctor_when_k(major, &rec_id, &recr, &rec_us)? .unwrap_or_else(|| major.clone()) } else { major.clone() @@ -1845,12 +1845,19 @@ impl TypeChecker<'_, M> { if recr.rules.len() != 1 { return Ok(None); } + if rec_us.len() as u64 != recr.lvls { + return Ok(None); + } let rule = &recr.rules[0]; let rec_ty = match self.try_get_const(rec_id)? { Some(c) => c.ty().clone(), None => return Ok(None), }; + let rec_ty = match self.instantiate_univ_params(&rec_ty, rec_us) { + Ok(ty) => ty, + Err(_) => return Ok(None), + }; let skip = (recr.params + recr.motives + recr.minors + recr.indices) as u64; let ind_id = match self.get_major_inductive_id(&rec_ty, skip) { Ok(id) => id, @@ -1911,7 +1918,11 @@ impl TypeChecker<'_, M> { major: &KExpr, rec_id: &KId, recr: &IotaInfo, + rec_us: &[KUniv], ) -> Result>, TcError> { + if rec_us.len() as u64 != recr.lvls { + return Ok(None); + } // Infer major's type (infer-only: we just need the type, not validation) let major_ty = match self.with_infer_only(|tc| tc.infer(major)) { Ok(ty) => ty, @@ -1934,6 +1945,10 @@ impl TypeChecker<'_, M> { Some(c) => c.ty().clone(), None => return Ok(None), }; + let rec_ty = match self.instantiate_univ_params(&rec_ty, rec_us) { + Ok(ty) => ty, + Err(_) => return Ok(None), + }; let skip = (recr.params + recr.motives + recr.minors + recr.indices) as u64; let ind_id = match self.get_major_inductive_id(&rec_ty, skip) { Ok(id) => id, @@ -2227,47 +2242,57 @@ impl TypeChecker<'_, M> { skip: u64, ) -> Result, TcError> { const MAX_EXTRA_FORALLS: u64 = 8; - - let mut ty = rec_ty.clone(); - for _ in 0..skip { - let w = self.whnf(&ty)?; - match w.data() { - ExprData::All(_, _, _, body, _) => ty = body.clone(), - _ => { - return Err(TcError::Other( - "get_major_inductive_id: not enough foralls".into(), - )); - }, + let saved = self.save_depth(); + let result = (|| -> Result, TcError> { + let mut ty = rec_ty.clone(); + for _ in 0..skip { + let w = self.whnf(&ty)?; + match w.data() { + ExprData::All(_, _, dom, body, _) => { + // Keep the peeled binder in scope. The body is open, and must not + // resolve one of its Vars through an unrelated caller frame. + self.push_local(dom.clone()); + ty = body.clone(); + }, + _ => { + return Err(TcError::Other( + "get_major_inductive_id: not enough foralls".into(), + )); + }, + } } - } - // Scan forward looking for a forall whose domain has a `KConst::Indc` - // head. Accept the first match. Bounded so we can't loop forever. - for _ in 0..=MAX_EXTRA_FORALLS { - let w = self.whnf(&ty)?; - match w.data() { - ExprData::All(_, _, dom, body, _) => { - let (head, _) = collect_app_spine(dom); - if let ExprData::Const(id, _, _) = head.data() { - // Only accept if the head resolves to an inductive. - if matches!(self.try_get_const(id)?, Some(KConst::Indc { .. })) { - return Ok(id.clone()); + // Scan forward looking for a forall whose domain has a `KConst::Indc` + // head. Accept the first match. Bounded so we can't loop forever. + for _ in 0..=MAX_EXTRA_FORALLS { + let w = self.whnf(&ty)?; + match w.data() { + ExprData::All(_, _, dom, body, _) => { + let (head, _) = collect_app_spine(dom); + if let ExprData::Const(id, _, _) = head.data() { + // Only accept if the head resolves to an inductive. + if matches!(self.try_get_const(id)?, Some(KConst::Indc { .. })) { + return Ok(id.clone()); + } } - } - ty = body.clone(); - }, - _ => { - return Err(TcError::Other( - "get_major_inductive_id: expected forall at major".into(), - )); - }, + self.push_local(dom.clone()); + ty = body.clone(); + }, + _ => { + return Err(TcError::Other( + "get_major_inductive_id: expected forall at major".into(), + )); + }, + } } - } - Err(TcError::Other( - "get_major_inductive_id: no inductive-headed forall within scan bound" - .into(), - )) + Err(TcError::Other( + "get_major_inductive_id: no inductive-headed forall within scan bound" + .into(), + )) + })(); + self.restore_depth(saved); + result } /// Convert a Nat literal to constructor form: 0 → Nat.zero, n+1 → Nat.succ(n-1). @@ -4264,6 +4289,47 @@ mod tests { assert_eq!(result, sort1()); } + #[test] + fn major_scan_does_not_capture_an_unrelated_caller_let() { + let target_id = mk_id("major-scan-target"); + let mut env = KEnv::new(); + env.insert( + target_id.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 0, + params: 0, + indices: 0, + is_unsafe: false, + block: target_id.clone(), + member_idx: 0, + ty: sort0(), + ctors: Vec::new(), + lean_all: (), + }, + ); + let mut tc = TypeChecker::new(&mut env); + let forged = AE::all((), (), AE::cnst(target_id, Box::new([])), sort0()); + // Peeling the outer forall exposes Var 0. Without retaining its binder, + // WHNF zeta-reduces that variable through this unrelated caller let and + // fabricates the inductive-headed forall above. + let rec_ty = AE::all((), (), sort0(), AE::var(0, ())); + tc.push_let(sort0(), forged.clone()); + let saved_depth = tc.save_depth(); + let saved_ctx_id = tc.ctx_id; + let saved_let_count = tc.num_let_bindings; + + assert!(tc.get_major_inductive_id(&rec_ty, 1).is_err()); + assert_eq!(tc.save_depth(), saved_depth); + assert_eq!(tc.ctx_id, saved_ctx_id); + assert_eq!(tc.num_let_bindings, saved_let_count); + assert!( + matches!(&tc.let_vals[0], Some(value) if value == &forged), + "the caller let must survive the scoped scan unchanged" + ); + } + #[test] fn whnf_string_legacy_back_empty_literal() { use super::super::testing as kt; diff --git a/docs/tc-context-digest-collision-boundary.md b/docs/tc-context-digest-collision-boundary.md new file mode 100644 index 000000000..f7b4fb1a4 --- /dev/null +++ b/docs/tc-context-digest-collision-boundary.md @@ -0,0 +1,138 @@ +# Ix.Tc context-digest collision boundary + +Snapshot: 2026-07-31. This note records a proof boundary for the K1/K2 cache +soundness argument. + +## Two distinct collision obligations + +Run-scoped expression collision freedom controls addresses of expressions in +the finite `RunSupport`. Schematically, it lets a proof recover the supported +expression represented by an expression-address component: + +```text +e, e' in S and e.addr = e'.addr -> e and e' are the same source +``` + +The context component of an inference, DefEq, or open-WHNF key is different. +`ctxAddrForLbr` emits a composite Blake3 digest for a local-context suffix. +Injectivity of every expression-address ingredient does not establish +injectivity of the digest that combines those ingredients: + +```text +ctxDigest(lbr, Delta) = ctxDigest(lbr, Delta') -/-> Delta = Delta' +``` + +The outer hash can collide on two different sequences even when all of their +individual expression addresses are distinct and collision-free. Moreover, a +fixed-width digest cannot be globally injective over an unbounded context +domain. Cryptographic collision resistance is not mathematical injectivity. + +The requested `lbr` is also a semantic input and must not be erased from the +representation relation. In particular, production `ctxAddrForLbr 0` emits +`emptyCtxAddr` regardless of the surrounding concrete context. If a relation +forgets which `lbr` was requested, that one digest can spuriously represent +arbitrary-radius suffixes without requiring a Blake3 collision at all. The +current `WhnfContextKeys.Represents` relation therefore retains `lbr`: WHNF +and inference use the source expression's `lbr`, and DefEq uses the maximum of +its two operands' `lbr` values. + +## Equivalence-root cache probes + +DefEq's union-find second chance replaces each original expression address by +a component representative and probes the ordinary DefEq cache with those +root addresses. A representative retains the comparison's requested radius, +but the expression named by that representative can have a smaller intrinsic +`lbr`. Consequently, reusing the original context digest for the root pair is +not justified merely because both roots remain in the same union-find scope: + +```text +max(a.lbr, b.lbr) = r does not imply +max(root(a).lbr, root(b).lbr) = r +``` + +`EqKey` therefore stores both values separately: `lbr` is the requested +context-suffix radius and `exprLbr` is the intrinsic radius of the expression +address. `EqKey.rootCacheScopeMatches` permits a root-derived probe only when +both representatives retain the exact context digest and requested radius, +and `max rootA.exprLbr rootB.exprLbr` reconstructs that radius. The Rust +kernel mirrors this as `EqKey::root_cache_scope_matches`. + +The formal acceptance proof does not interpret a root address by itself. +Each verified union-find path supplies a supported endpoint expression and +its intrinsic-radius equality; the guarded cache entry supplies equality of +the two endpoints; the result composes original-left to left-root, root pair, +and right-root back to original-right. A failed guard simply disables the +optimization and continues through the ordinary DefEq path. + +## Consequence for cache soundness + +A cache value written while the ghost context is `Delta` can be read by an +execution represented by `Delta'` when both executions emit the same context +digest. `RunSupport.CollisionFree` alone does not justify transporting the +cached typing, WHNF, or definitional-equality judgment between those contexts. + +The current formalization keeps this obligation visible in +`KernelSuffixModel.whnfTransport`, `inferTransport`, `defEqTransport`, and +`isPropTransport`. +`operationalWhnfContextKeys` proves that represented keys came from real, +reconciled `ctxAddrForLbr` executions with the same requested `lbr`; it +deliberately does not claim that an equal emitted digest makes their contexts +equal. + +The finite construction is now explicit in the proof API: + +- `ContextDigestSpec` names the normalized input and a state-validity + predicate for context-id/memo coherence, exposes concrete current-context + memo validity, requires validity preservation, and requires every real + `ctxAddrForLbr` execution from a valid state to return its digest; +- `ContextDigestScope` stores a constructive finite input list and keeps run + capture separate from composite-digest collision freedom; +- `ContextSuffixSemantics` states that equal normalized inputs preserve the + four semantic judgment families (WHNF, inference, DefEq, and the auxiliary + proposition classifier); and +- `ScopedKernelSuffixModel.finiteOperational` composes those facts into the + joint WHNF/inference/DefEq/proposition-classifier model for captured states. + +The existing `KernelSuffixModel` quantifies over every reconciled checker +state, which is stronger than a finite run claim. Converting the scoped model +to that universal interface therefore requires an explicit proof that every +such state is captured. A finite execution trace cannot discharge that proof +by itself; downstream method closure must retain the state-domain index or +establish a genuinely global specification. + +The `ContextDigestSpec.execution` premise includes memo hits and requires +`ContextDigestSpec.StateValid` for the pre-state. This is +load-bearing: a successful lookup in `ctxAddrCache` is not evidence that the +cached address is the digest of the current normalized suffix. Concrete K2 +must define that validity predicate from execution history or a strengthened +state invariant. The interface now requires both `memoValid` and `preserves`, +so an implementation cannot label an initial state valid while leaving later +memoized calls outside the proof domain. + +Production now exposes the pure calculation as +`TcM.ctxAddrForLbrUncached`. The exact fast-path, cache-hit, and cache-miss +equations prove immediate replay stability and preservation of +`TcM.ContextAddrMemoValid`. This closes the operational memo-mutation part of +K2; it does not yet prove that the pure hash input is the chosen semantic +normalization of the reconciled `KVLCtx`. + +## Required K2 discharge + +Instantiating the finite construction for production must: + +1. define the finite set of `(lbr, serialized relevant suffix)` composite + context-digest inputs reachable during the verified run; +2. connect `ctxAddrForLbrUncached` to that normalized semantic input and prove + the non-memo portion of `ContextDigestSpec.StateValid`; +3. prove that every represented production key execution lies in that set; +4. consume an explicit collision-freedom hypothesis for the composite digest + on that set, yielding the required context or suffix equivalence; and +5. prove declaratively that this equivalence preserves `WhnfMeaning`, + `InferMeaning`, `DefEqMeaning`, and `IsPropMeaning`, thereby constructing + the four `KernelSuffixModel` transports. + +Review rule: a proof that transports semantics across different requested +`lbr` values, or derives same-context-digest semantic transport from +expression-address collision freedom alone, is unsound. The radius index and +both collision layers must remain separately named in theorem statements and +trust reports.